1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
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;
47 with Output; use Output;
48 with Restrict; use Restrict;
49 with Rident; use Rident;
50 with Rtsfind; use Rtsfind;
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
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.
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);
121 Eq_Prim_Op : Entity_Id := Empty;
124 if No_Run_Time_Mode then
125 Error_Msg_CRT ("tagged types", Call_Node);
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)
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))
150 Subp := Alias (Subp);
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))
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));
179 CW_Typ := Class_Wide_Type (Ctrl_Typ);
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);
188 -- Dispatching call to C++ primitive
190 if Is_CPP_Class (Typ) then
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
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
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
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
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))))
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)
244 -- Now we need to generate the Tag check
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,
256 Make_Selected_Component (Loc,
257 Prefix => New_Value (Ctrl_Arg),
260 (First_Tag_Component (Typ), Loc)),
263 Make_Selected_Component (Loc,
265 Unchecked_Convert_To (Typ, New_Value (Param)),
268 (First_Tag_Component (Typ), Loc))),
271 New_List (New_Constraint_Error (Loc))));
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);
288 -- Handle private types
290 if Present (Full_View (Root_Typ)) then
291 Root_Typ := Full_View (Root_Typ);
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);
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);
321 -- Handle private types
323 if Present (Full_View (Typ)) then
324 Full_Typ := Full_View (Typ);
327 if Present (Full_View (Root_Typ)) then
328 Root_Typ := Full_View (Root_Typ);
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)));
339 and then not Is_Interface (Full_Typ)
340 and then Has_Interfaces (Full_Typ)
342 Check_Restriction (Static_Dispatch_Tables, Typ);
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
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))
386 Build_Dispatch_Tables
387 (Declarations (Proper_Body (Unit (Library_Unit (D)))));
389 -- Handle full type declarations and derivations of library level
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))
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))
405 (not Comes_From_Source (Defining_Entity (D))
407 Has_Unknown_Discriminants (Etype (Defining_Entity (D)))
409 not Comes_From_Source
410 (First_Subtype (Defining_Entity (D))))
414 Insert_List_After_And_Analyze (Last (Target_List),
415 Make_DT (Defining_Entity (D)));
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)))
429 E1 : constant Entity_Id := Defining_Entity (D);
430 E2 : constant Entity_Id := Full_View (E1);
433 if Is_Library_Level_Tagged_Type (E2)
434 and then Ekind (E2) /= E_Record_Subtype
435 and then not Is_Concurrent_Type (E2)
437 Exchange_Declarations (E1);
438 Insert_List_After_And_Analyze (Last (Target_List),
440 Exchange_Declarations (E2);
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);
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);
471 end Build_Package_Dispatch_Tables;
473 -- Start of processing for Build_Static_Dispatch_Tables
476 if not Expander_Active
477 or else not Tagged_Type_Expansion
482 if Nkind (N) = N_Package_Declaration then
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);
489 if Present (Priv_Decls)
490 and then Is_Non_Empty_List (Priv_Decls)
492 Target_List := Priv_Decls;
494 elsif not Present (Vis_Decls) then
495 Target_List := New_List;
496 Set_Private_Declarations (Spec, Target_List);
498 Target_List := Vis_Decls;
501 Build_Package_Dispatch_Tables (N);
504 else pragma Assert (Nkind (N) = N_Package_Body);
505 Target_List := Declarations (N);
506 Build_Dispatch_Tables (Target_List);
508 end Build_Static_Dispatch_Tables;
510 ------------------------------
511 -- Convert_Tag_To_Interface --
512 ------------------------------
514 function Convert_Tag_To_Interface
516 Expr : Node_Id) return Node_Id
518 Loc : constant Source_Ptr := Sloc (Expr);
519 Anon_Type : Entity_Id;
523 pragma Assert (Is_Class_Wide_Type (Typ)
524 and then Is_Interface (Typ)
526 ((Nkind (Expr) = N_Selected_Component
527 and then Is_Tag (Entity (Selector_Name (Expr))))
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)))
547 Make_Explicit_Dereference (Loc,
548 Unchecked_Convert_To (Anon_Type,
549 Make_Attribute_Reference (Loc,
551 Attribute_Name => Name_Address)));
554 Make_Explicit_Dereference (Loc,
555 Unchecked_Convert_To (Anon_Type, Expr));
559 end Convert_Tag_To_Interface;
565 function CPP_Num_Prims (Typ : Entity_Id) return Nat is
567 Tag_Comp : Entity_Id;
570 if not Is_Tagged_Type (Typ)
571 or else not Is_CPP_Class (Root_Type (Typ))
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
584 return UI_To_Int (DT_Entry_Count (Tag_Comp));
586 -- Otherwise, count the primitives of the enclosing CPP type
594 Elmt := First_Elmt (Primitive_Operations (CPP_Typ));
595 while Present (Elmt) loop
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;
614 Get_Name_String (Chars (E));
617 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
619 if Chars (E) = Name_uSize then
622 elsif TSS_Name = TSS_Stream_Read then
625 elsif TSS_Name = TSS_Stream_Write then
628 elsif TSS_Name = TSS_Stream_Input then
631 elsif TSS_Name = TSS_Stream_Output then
634 elsif Chars (E) = Name_Op_Eq then
637 elsif Chars (E) = Name_uAssign then
640 elsif TSS_Name = TSS_Deep_Adjust then
643 elsif TSS_Name = TSS_Deep_Finalize then
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
654 elsif Chars (E) = Name_uDisp_Conditional_Select then
657 elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
660 elsif Chars (E) = Name_uDisp_Get_Task_Id then
663 elsif Chars (E) = Name_uDisp_Requeue then
666 elsif Chars (E) = Name_uDisp_Timed_Select then
672 end Default_Prim_Op_Position;
674 ----------------------
675 -- Elab_Flag_Needed --
676 ----------------------
678 function Elab_Flag_Needed (Typ : Entity_Id) return Boolean is
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);
701 New_Call_Name : Node_Id;
702 New_Params : List_Id := No_List;
705 Subp_Ptr_Typ : Entity_Id;
706 Subp_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
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
737 if Is_Entity_Name (N)
738 and then Present (Entity (N))
739 and then Is_Formal (Entity (N))
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
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))
769 Set_Controlling_Argument (Parent (Parent (N)),
785 procedure Update is new Traverse_Proc (Replace_Formals);
789 Str_Loc : constant String := Build_Location_String (Loc);
795 -- Start of processing for Build_Class_Wide_Check
799 -- Locate class-wide precondition, if any
801 if Present (Contract (Subp))
802 and then Present (Pre_Post_Conditions (Contract (Subp)))
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);
812 if No (Prec) or else Is_Ignored (Prec) then
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.
822 (Expression (First (Pragma_Argument_Associations (Prec))));
825 -- Build message indicating the failed precondition and the
826 -- dispatching call that caused it.
828 Msg := Expression (Last (Pragma_Argument_Associations (Prec)));
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,
841 New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
842 Parameter_Associations => New_List (Msg)))));
844 end Build_Class_Wide_Check;
850 function New_Value (From : Node_Id) return Node_Id is
851 Res : constant Node_Id := Duplicate_Subexpr (From);
853 if Is_Access_Type (Etype (From)) then
855 Make_Explicit_Dereference (Sloc (From),
865 SCIL_Node : Node_Id := Empty;
866 SCIL_Related_Node : Node_Id := Call_Node;
868 -- Start of processing for Expand_Dispatching_Call
871 if No_Run_Time_Mode then
872 Error_Msg_CRT ("tagged types", Call_Node);
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))
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))
903 Subp := Alias (Subp);
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))
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));
934 CW_Typ := Class_Wide_Type (Ctrl_Typ);
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);
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));
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))
974 Append_To (New_Params, Relocate_Node (Param));
981 -- Generate the appropriate subprogram pointer type
983 if Etype (Subp) = Typ then
986 Res_Typ := Etype (Subp);
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.
1003 Old_Formal : Entity_Id := First_Formal (Subp);
1004 New_Formal : Entity_Id;
1005 Extra : Entity_Id := Empty;
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);
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));
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 Link_Entities (New_Formal, New_Copy (Old_Formal));
1034 Next_Entity (New_Formal);
1035 Next_Actual (Param);
1038 Unlink_Next_Entity (New_Formal);
1039 Set_Last_Entity (Subp_Typ, Extra);
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);
1049 Create_Extra_Formals (Subp_Typ);
1052 -- Complete description of pointer type, including size information, as
1053 -- must be done with itypes to prevent order-of-elaboration anomalies
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))
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
1079 (Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag)
1081 (RTE_Available (RE_Interface_Tag)
1083 Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag)))
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)
1092 Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
1096 Make_Selected_Component (Loc,
1097 Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
1098 Selector_Name => New_Occurrence_Of (DTC_Entity (Subp), Loc));
1101 -- Handle dispatching calls to predefined primitives
1103 if Is_Predefined_Dispatching_Operation (Subp)
1104 or else Is_Predefined_Dispatching_Alias (Subp)
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
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);
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
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)
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)
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
1179 elsif Nkind (Controlling_Tag) = N_Attribute_Reference
1180 and then Attribute_Name (Controlling_Tag) = Name_Tag
1182 Set_SCIL_Controlling_Tag (SCIL_Node,
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);
1195 pragma Assert (False);
1200 if Nkind (Call_Node) = N_Function_Call then
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);
1216 Make_Selected_Component (Loc,
1217 Prefix => New_Value (Param),
1219 New_Occurrence_Of (First_Tag_Component (Typ),
1223 Make_Selected_Component (Loc,
1225 Unchecked_Convert_To (Typ,
1226 New_Value (Next_Actual (Param))),
1229 (First_Tag_Component (Typ), Loc))),
1230 Right_Opnd => New_Call);
1232 SCIL_Related_Node := Right_Opnd (New_Call);
1237 Make_Procedure_Call_Statement (Loc,
1238 Name => New_Call_Name,
1239 Parameter_Associations => New_Params);
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);
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;
1276 -- Handle access types
1278 if Is_Access_Type (E) then
1279 E := Directly_Designated_Type (E);
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
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);
1296 -- Handle private types
1298 E := Underlying_Type (E);
1302 return Base_Type (E);
1303 end Underlying_Record_Type;
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);
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
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));
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).
1335 Opnd : Entity_Id := Operand_Typ;
1338 if Is_Access_Type (Opnd) then
1339 Opnd := Designated_Type (Opnd);
1342 if not Is_Interface (Opnd)
1343 and then Is_Ancestor (Iface_Typ, Opnd, Use_Full_View => True)
1349 -- Evaluate if we can statically displace the pointer to the object
1352 Opnd_Typ : constant Node_Id := Underlying_Record_Type (Operand_Typ);
1356 not Is_Interface (Opnd_Typ)
1357 and then Interface_Present_In_Ancestor
1360 and then (Etype (Opnd_Typ) = Opnd_Typ
1362 Is_Variable_Size_Record (Etype (Opnd_Typ)));
1365 if not Tagged_Type_Expansion then
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.
1373 and then Is_Interface (Etype (N))
1374 and then not Is_Class_Wide_Type (Etype (N))
1375 and then Comes_From_Source (N)
1377 Rewrite (N, Unchecked_Convert_To (Etype (N), N));
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);
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
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))),
1413 (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
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),
1429 (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
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.
1438 New_Itype : Entity_Id;
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);
1446 Make_Explicit_Dereference (Loc,
1448 Unchecked_Convert_To (New_Itype, Relocate_Node (N))));
1450 Freeze_Itype (New_Itype, N);
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.
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))));
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
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);
1484 -- if O = Null_Address then
1487 -- return Iface_Typ!(Aux.Iface_Tag'Address);
1492 Desig_Typ : Entity_Id;
1494 New_Typ_Decl : Node_Id;
1498 Desig_Typ := Etype (Expression (N));
1500 if Is_Access_Type (Desig_Typ) then
1502 Available_View (Directly_Designated_Type (Desig_Typ));
1505 if Is_Concurrent_Type (Desig_Typ) then
1506 Desig_Typ := Base_Type (Corresponding_Record_Type (Desig_Typ));
1510 Make_Full_Type_Declaration (Loc,
1511 Defining_Identifier => Make_Temporary (Loc, 'T'),
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)));
1521 Make_Simple_Return_Statement (Loc,
1522 Unchecked_Convert_To (Etype (N),
1523 Make_Attribute_Reference (Loc,
1525 Make_Selected_Component (Loc,
1527 Unchecked_Convert_To
1528 (Defining_Identifier (New_Typ_Decl),
1529 Make_Identifier (Loc, Name_uO)),
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
1539 Make_If_Statement (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));
1551 Fent := Make_Temporary (Loc, 'F');
1553 Make_Subprogram_Body (Loc,
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),
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))
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))))));
1594 -- Generate: Func (Operand_Typ!(Expression)'Address)
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))));
1609 end Expand_Interface_Conversion;
1611 ------------------------------
1612 -- Expand_Interface_Actuals --
1613 ------------------------------
1615 procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
1617 Actual_Dup : Node_Id;
1618 Actual_Typ : Entity_Id;
1620 Conversion : Node_Id;
1622 Formal_Typ : Entity_Id;
1624 Formal_DDT : Entity_Id := Empty; -- initialize to prevent warning
1625 Actual_DDT : Entity_Id := Empty; -- initialize to prevent warning
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
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
1648 Subp := Entity (Name (Call_Node));
1651 -- Ada 2005 (AI-251): Look for interface type formals to force "this"
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);
1663 if Is_Access_Type (Formal_Typ) then
1664 Formal_DDT := Directly_Designated_Type (Formal_Typ);
1667 Actual_Typ := Etype (Actual);
1669 if Is_Access_Type (Actual_Typ) then
1670 Actual_DDT := Directly_Designated_Type (Actual_Typ);
1673 if Is_Interface (Formal_Typ)
1674 and then Is_Class_Wide_Type (Formal_Typ)
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
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)
1691 -- Implicit conversion to the class-wide formal type to force the
1692 -- displacement of the pointer.
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);
1706 Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
1707 Rewrite (Actual, Conversion);
1708 Analyze_And_Resolve (Actual, Formal_Typ);
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
1718 Iface => Etype (Formal_DDT))
1720 -- Handle attributes 'Access and 'Unchecked_Access
1722 if Nkind (Actual) = N_Attribute_Reference
1724 (Attribute_Name (Actual) = Name_Access
1725 or else Attribute_Name (Actual) = Name_Unchecked_Access)
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));
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
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)
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);
1767 Set_Directly_Designated_Type
1768 (Anon, Non_Limited_View (Actual_DDT));
1769 Set_Etype (Actual_Dup, Anon);
1773 Conversion := Convert_To (Formal_Typ, Actual_Dup);
1774 Rewrite (Actual, Conversion);
1775 Analyze_And_Resolve (Actual, Formal_Typ);
1779 Next_Actual (Actual);
1780 Next_Formal (Formal);
1782 end Expand_Interface_Actuals;
1784 ----------------------------
1785 -- Expand_Interface_Thunk --
1786 ----------------------------
1788 procedure Expand_Interface_Thunk
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);
1804 Iface_Formal : Node_Id := Empty; -- initialize to prevent warning
1806 Offset_To_Top : Node_Id;
1807 Target_Formal : Entity_Id;
1811 Thunk_Code := Empty;
1813 -- No thunk needed if the primitive has been eliminated
1815 if Is_Eliminated (Ultimate_Alias (Prim)) then
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));
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
1838 if not Is_Predefined_Dispatching_Operation (Prim) then
1839 Iface_Formal := First_Formal (Interface_Alias (Prim));
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
1849 if not Is_Controlling_Formal (Formal)
1850 or else Is_Predefined_Dispatching_Operation (Prim)
1852 Ftyp := Etype (Formal);
1853 Expr := New_Copy_Tree (Expression (Parent (Formal)));
1855 Ftyp := Etype (Iface_Formal);
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);
1873 Next_Formal (Formal);
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
1888 Base_Type (Directly_Designated_Type (Etype (Target_Formal)));
1890 Ftyp := Base_Type (Etype (Target_Formal));
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);
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)
1905 -- type T is access all <<type of the target formal>>
1906 -- S : Storage_Offset := Storage_Offset!(Formal)
1907 -- + Offset_To_Top (address!(Formal))
1910 Make_Full_Type_Declaration (Loc,
1911 Defining_Identifier => Make_Temporary (Loc, 'T'),
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)));
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
1926 Build_Offset_To_Top (Loc, New_Arg);
1929 Make_Function_Call (Loc,
1930 Name => New_Occurrence_Of (RTE (RE_Offset_To_Top), Loc),
1931 Parameter_Associations => New_List (New_Arg));
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),
1943 Unchecked_Convert_To
1944 (RTE (RE_Storage_Offset),
1946 (Defining_Identifier (Formal), Loc)),
1950 Append_To (Decl, Decl_2);
1951 Append_To (Decl, Decl_1);
1953 -- Reference the new actual. Generate:
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
1964 -- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
1965 -- + Offset_To_Top (Formal'Address)
1966 -- S2 : Addr_Ptr := Addr_Ptr!(S1)
1969 Make_Attribute_Reference (Loc,
1971 New_Occurrence_Of (Defining_Identifier (Formal), Loc),
1975 if not RTE_Available (RE_Offset_To_Top) then
1977 Build_Offset_To_Top (Loc, New_Arg);
1980 Make_Function_Call (Loc,
1981 Name => New_Occurrence_Of (RTE (RE_Offset_To_Top), Loc),
1982 Parameter_Associations => New_List (New_Arg));
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),
1994 Unchecked_Convert_To
1995 (RTE (RE_Storage_Offset),
1996 Make_Attribute_Reference (Loc,
1999 (Defining_Identifier (Formal), Loc),
2000 Attribute_Name => Name_Address)),
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),
2011 Unchecked_Convert_To
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)
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
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
2038 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
2041 Next_Formal (Target_Formal);
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);
2053 if Ekind (Target) = E_Procedure then
2055 Make_Subprogram_Body (Loc,
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))));
2070 else pragma Assert (Ekind (Target) = E_Function);
2072 Result_Def : Node_Id;
2073 Call_Node : Node_Id;
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
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;
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.
2115 Make_Type_Conversion (Loc,
2117 New_Occurrence_Of (Class_Wide_Type (Etype (Prim)), Loc),
2118 Expression => Relocate_Node (Call_Node));
2122 Make_Subprogram_Body (Loc,
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))));
2135 end Expand_Interface_Thunk;
2137 --------------------------
2138 -- Has_CPP_Constructors --
2139 --------------------------
2141 function Has_CPP_Constructors (Typ : Entity_Id) return Boolean is
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
2157 end Has_CPP_Constructors;
2163 function Has_DT (Typ : Entity_Id) return Boolean is
2165 return not Is_Interface (Typ)
2166 and then not Restriction_Active (No_Dispatching_Calls);
2169 ----------------------------------
2170 -- Is_Expanded_Dispatching_Call --
2171 ----------------------------------
2173 function Is_Expanded_Dispatching_Call (N : Node_Id) return Boolean is
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_Alias --
2182 -------------------------------------
2184 function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean
2187 return not Is_Predefined_Dispatching_Operation (Prim)
2188 and then Present (Alias (Prim))
2189 and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim));
2190 end Is_Predefined_Dispatching_Alias;
2192 ----------------------------------------
2193 -- Make_Disp_Asynchronous_Select_Body --
2194 ----------------------------------------
2196 -- For interface types, generate:
2198 -- procedure _Disp_Asynchronous_Select
2199 -- (T : in out <Typ>;
2201 -- P : System.Address;
2202 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2207 -- C := Ada.Tags.POK_Function;
2208 -- end _Disp_Asynchronous_Select;
2210 -- For protected types, generate:
2212 -- procedure _Disp_Asynchronous_Select
2213 -- (T : in out <Typ>;
2215 -- P : System.Address;
2216 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2220 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2221 -- Bnn : System.Tasking.Protected_Objects.Operations.
2222 -- Communication_Block;
2224 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2225 -- (T._object'Access,
2226 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2228 -- System.Tasking.Asynchronous_Call,
2230 -- B := System.Storage_Elements.Dummy_Communication_Block (Bnn);
2231 -- end _Disp_Asynchronous_Select;
2233 -- For task types, generate:
2235 -- procedure _Disp_Asynchronous_Select
2236 -- (T : in out <Typ>;
2238 -- P : System.Address;
2239 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2243 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2245 -- System.Tasking.Rendezvous.Task_Entry_Call
2247 -- System.Tasking.Task_Entry_Index (I),
2249 -- System.Tasking.Asynchronous_Call,
2251 -- end _Disp_Asynchronous_Select;
2253 function Make_Disp_Asynchronous_Select_Body
2254 (Typ : Entity_Id) return Node_Id
2256 Com_Block : Entity_Id;
2257 Conc_Typ : Entity_Id := Empty;
2258 Decls : constant List_Id := New_List;
2259 Loc : constant Source_Ptr := Sloc (Typ);
2261 Stmts : constant List_Id := New_List;
2265 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2267 -- Null body is generated for interface types
2269 if Is_Interface (Typ) then
2271 Make_Subprogram_Body (Loc,
2273 Make_Disp_Asynchronous_Select_Spec (Typ),
2274 Declarations => New_List,
2275 Handled_Statement_Sequence =>
2276 Make_Handled_Sequence_Of_Statements (Loc,
2278 Make_Assignment_Statement (Loc,
2279 Name => Make_Identifier (Loc, Name_uF),
2280 Expression => New_Occurrence_Of (Standard_False, Loc)))));
2283 if Is_Concurrent_Record_Type (Typ) then
2284 Conc_Typ := Corresponding_Concurrent_Type (Typ);
2288 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2290 -- where I will be used to capture the entry index of the primitive
2291 -- wrapper at position S.
2293 if Tagged_Type_Expansion then
2295 Unchecked_Convert_To (RTE (RE_Tag),
2297 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2300 Make_Attribute_Reference (Loc,
2301 Prefix => New_Occurrence_Of (Typ, Loc),
2302 Attribute_Name => Name_Tag);
2306 Make_Object_Declaration (Loc,
2307 Defining_Identifier =>
2308 Make_Defining_Identifier (Loc, Name_uI),
2309 Object_Definition =>
2310 New_Occurrence_Of (Standard_Integer, Loc),
2312 Make_Function_Call (Loc,
2314 New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
2315 Parameter_Associations =>
2316 New_List (Tag_Node, Make_Identifier (Loc, Name_uS)))));
2318 if Ekind (Conc_Typ) = E_Protected_Type then
2321 -- Bnn : Communication_Block;
2323 Com_Block := Make_Temporary (Loc, 'B');
2325 Make_Object_Declaration (Loc,
2326 Defining_Identifier => Com_Block,
2327 Object_Definition =>
2328 New_Occurrence_Of (RTE (RE_Communication_Block), Loc)));
2330 -- Build T._object'Access for calls below
2333 Make_Attribute_Reference (Loc,
2334 Attribute_Name => Name_Unchecked_Access,
2336 Make_Selected_Component (Loc,
2337 Prefix => Make_Identifier (Loc, Name_uT),
2338 Selector_Name => Make_Identifier (Loc, Name_uObject)));
2340 case Corresponding_Runtime_Package (Conc_Typ) is
2341 when System_Tasking_Protected_Objects_Entries =>
2344 -- Protected_Entry_Call
2345 -- (T._object'Access, -- Object
2346 -- Protected_Entry_Index! (I), -- E
2347 -- P, -- Uninterpreted_Data
2348 -- Asynchronous_Call, -- Mode
2349 -- Bnn); -- Communication_Block
2351 -- where T is the protected object, I is the entry index, P
2352 -- is the wrapped parameters and B is the name of the
2353 -- communication block.
2356 Make_Procedure_Call_Statement (Loc,
2358 New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc),
2359 Parameter_Associations =>
2363 Make_Unchecked_Type_Conversion (Loc, -- entry index
2366 (RTE (RE_Protected_Entry_Index), Loc),
2367 Expression => Make_Identifier (Loc, Name_uI)),
2369 Make_Identifier (Loc, Name_uP), -- parameter block
2370 New_Occurrence_Of -- Asynchronous_Call
2371 (RTE (RE_Asynchronous_Call), Loc),
2372 New_Occurrence_Of -- comm block
2373 (Com_Block, Loc))));
2376 raise Program_Error;
2380 -- B := Dummy_Communication_Block (Bnn);
2383 Make_Assignment_Statement (Loc,
2384 Name => Make_Identifier (Loc, Name_uB),
2386 Make_Unchecked_Type_Conversion (Loc,
2389 (RTE (RE_Dummy_Communication_Block), Loc),
2390 Expression => New_Occurrence_Of (Com_Block, Loc))));
2396 Make_Assignment_Statement (Loc,
2397 Name => Make_Identifier (Loc, Name_uF),
2398 Expression => New_Occurrence_Of (Standard_False, Loc)));
2401 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2405 -- (T._task_id, -- Acceptor
2406 -- Task_Entry_Index! (I), -- E
2407 -- P, -- Uninterpreted_Data
2408 -- Asynchronous_Call, -- Mode
2409 -- F); -- Rendezvous_Successful
2411 -- where T is the task object, I is the entry index, P is the
2412 -- wrapped parameters and F is the status flag.
2415 Make_Procedure_Call_Statement (Loc,
2417 New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc),
2418 Parameter_Associations =>
2420 Make_Selected_Component (Loc, -- T._task_id
2421 Prefix => Make_Identifier (Loc, Name_uT),
2422 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2424 Make_Unchecked_Type_Conversion (Loc, -- entry index
2426 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
2427 Expression => Make_Identifier (Loc, Name_uI)),
2429 Make_Identifier (Loc, Name_uP), -- parameter block
2430 New_Occurrence_Of -- Asynchronous_Call
2431 (RTE (RE_Asynchronous_Call), Loc),
2432 Make_Identifier (Loc, Name_uF)))); -- status flag
2436 -- Ensure that the statements list is non-empty
2439 Make_Assignment_Statement (Loc,
2440 Name => Make_Identifier (Loc, Name_uF),
2441 Expression => New_Occurrence_Of (Standard_False, Loc)));
2445 Make_Subprogram_Body (Loc,
2447 Make_Disp_Asynchronous_Select_Spec (Typ),
2448 Declarations => Decls,
2449 Handled_Statement_Sequence =>
2450 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2451 end Make_Disp_Asynchronous_Select_Body;
2453 ----------------------------------------
2454 -- Make_Disp_Asynchronous_Select_Spec --
2455 ----------------------------------------
2457 function Make_Disp_Asynchronous_Select_Spec
2458 (Typ : Entity_Id) return Node_Id
2460 Loc : constant Source_Ptr := Sloc (Typ);
2461 Def_Id : constant Node_Id :=
2462 Make_Defining_Identifier (Loc,
2463 Name_uDisp_Asynchronous_Select);
2464 Params : constant List_Id := New_List;
2467 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2469 -- T : in out Typ; -- Object parameter
2470 -- S : Integer; -- Primitive operation slot
2471 -- P : Address; -- Wrapped parameters
2472 -- B : out Dummy_Communication_Block; -- Communication block dummy
2473 -- F : out Boolean; -- Status flag
2475 Append_List_To (Params, New_List (
2477 Make_Parameter_Specification (Loc,
2478 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
2479 Parameter_Type => New_Occurrence_Of (Typ, Loc),
2481 Out_Present => True),
2483 Make_Parameter_Specification (Loc,
2484 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
2485 Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
2487 Make_Parameter_Specification (Loc,
2488 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
2489 Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)),
2491 Make_Parameter_Specification (Loc,
2492 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uB),
2494 New_Occurrence_Of (RTE (RE_Dummy_Communication_Block), Loc),
2495 Out_Present => True),
2497 Make_Parameter_Specification (Loc,
2498 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF),
2499 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
2500 Out_Present => True)));
2503 Make_Procedure_Specification (Loc,
2504 Defining_Unit_Name => Def_Id,
2505 Parameter_Specifications => Params);
2506 end Make_Disp_Asynchronous_Select_Spec;
2508 ---------------------------------------
2509 -- Make_Disp_Conditional_Select_Body --
2510 ---------------------------------------
2512 -- For interface types, generate:
2514 -- procedure _Disp_Conditional_Select
2515 -- (T : in out <Typ>;
2517 -- P : System.Address;
2518 -- C : out Ada.Tags.Prim_Op_Kind;
2523 -- C := Ada.Tags.POK_Function;
2524 -- end _Disp_Conditional_Select;
2526 -- For protected types, generate:
2528 -- procedure _Disp_Conditional_Select
2529 -- (T : in out <Typ>;
2531 -- P : System.Address;
2532 -- C : out Ada.Tags.Prim_Op_Kind;
2536 -- Bnn : System.Tasking.Protected_Objects.Operations.
2537 -- Communication_Block;
2540 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S));
2542 -- if C = Ada.Tags.POK_Procedure
2543 -- or else C = Ada.Tags.POK_Protected_Procedure
2544 -- or else C = Ada.Tags.POK_Task_Procedure
2550 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2551 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2552 -- (T.object'Access,
2553 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2555 -- System.Tasking.Conditional_Call,
2557 -- F := not Cancelled (Bnn);
2558 -- end _Disp_Conditional_Select;
2560 -- For task types, generate:
2562 -- procedure _Disp_Conditional_Select
2563 -- (T : in out <Typ>;
2565 -- P : System.Address;
2566 -- C : out Ada.Tags.Prim_Op_Kind;
2572 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2573 -- System.Tasking.Rendezvous.Task_Entry_Call
2575 -- System.Tasking.Task_Entry_Index (I),
2577 -- System.Tasking.Conditional_Call,
2579 -- end _Disp_Conditional_Select;
2581 function Make_Disp_Conditional_Select_Body
2582 (Typ : Entity_Id) return Node_Id
2584 Loc : constant Source_Ptr := Sloc (Typ);
2585 Blk_Nam : Entity_Id;
2586 Conc_Typ : Entity_Id := Empty;
2587 Decls : constant List_Id := New_List;
2589 Stmts : constant List_Id := New_List;
2593 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2595 -- Null body is generated for interface types
2597 if Is_Interface (Typ) then
2599 Make_Subprogram_Body (Loc,
2601 Make_Disp_Conditional_Select_Spec (Typ),
2602 Declarations => No_List,
2603 Handled_Statement_Sequence =>
2604 Make_Handled_Sequence_Of_Statements (Loc,
2605 New_List (Make_Assignment_Statement (Loc,
2606 Name => Make_Identifier (Loc, Name_uF),
2607 Expression => New_Occurrence_Of (Standard_False, Loc)))));
2610 if Is_Concurrent_Record_Type (Typ) then
2611 Conc_Typ := Corresponding_Concurrent_Type (Typ);
2616 -- where I will be used to capture the entry index of the primitive
2617 -- wrapper at position S.
2620 Make_Object_Declaration (Loc,
2621 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI),
2622 Object_Definition =>
2623 New_Occurrence_Of (Standard_Integer, Loc)));
2626 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S);
2628 -- if C = POK_Procedure
2629 -- or else C = POK_Protected_Procedure
2630 -- or else C = POK_Task_Procedure;
2636 Build_Common_Dispatching_Select_Statements (Typ, Stmts);
2639 -- Bnn : Communication_Block;
2641 -- where Bnn is the name of the communication block used in the
2642 -- call to Protected_Entry_Call.
2644 Blk_Nam := Make_Temporary (Loc, 'B');
2646 Make_Object_Declaration (Loc,
2647 Defining_Identifier => Blk_Nam,
2648 Object_Definition =>
2649 New_Occurrence_Of (RTE (RE_Communication_Block), Loc)));
2652 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2654 -- I is the entry index and S is the dispatch table slot
2656 if Tagged_Type_Expansion then
2658 Unchecked_Convert_To (RTE (RE_Tag),
2660 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2664 Make_Attribute_Reference (Loc,
2665 Prefix => New_Occurrence_Of (Typ, Loc),
2666 Attribute_Name => Name_Tag);
2670 Make_Assignment_Statement (Loc,
2671 Name => Make_Identifier (Loc, Name_uI),
2673 Make_Function_Call (Loc,
2675 New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
2676 Parameter_Associations => New_List (
2678 Make_Identifier (Loc, Name_uS)))));
2680 if Ekind (Conc_Typ) = E_Protected_Type then
2682 Obj_Ref := -- T._object'Access
2683 Make_Attribute_Reference (Loc,
2684 Attribute_Name => Name_Unchecked_Access,
2686 Make_Selected_Component (Loc,
2687 Prefix => Make_Identifier (Loc, Name_uT),
2688 Selector_Name => Make_Identifier (Loc, Name_uObject)));
2690 case Corresponding_Runtime_Package (Conc_Typ) is
2691 when System_Tasking_Protected_Objects_Entries =>
2694 -- Protected_Entry_Call
2695 -- (T._object'Access, -- Object
2696 -- Protected_Entry_Index! (I), -- E
2697 -- P, -- Uninterpreted_Data
2698 -- Conditional_Call, -- Mode
2701 -- where T is the protected object, I is the entry index, P
2702 -- are the wrapped parameters and Bnn is the name of the
2703 -- communication block.
2706 Make_Procedure_Call_Statement (Loc,
2708 New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc),
2709 Parameter_Associations => New_List (
2712 Make_Unchecked_Type_Conversion (Loc, -- entry index
2715 (RTE (RE_Protected_Entry_Index), Loc),
2716 Expression => Make_Identifier (Loc, Name_uI)),
2718 Make_Identifier (Loc, Name_uP), -- parameter block
2720 New_Occurrence_Of -- Conditional_Call
2721 (RTE (RE_Conditional_Call), Loc),
2722 New_Occurrence_Of -- Bnn
2725 when System_Tasking_Protected_Objects_Single_Entry =>
2727 -- If we are compiling for a restricted run-time, the call
2728 -- uses the simpler form.
2731 Make_Procedure_Call_Statement (Loc,
2734 (RTE (RE_Protected_Single_Entry_Call), Loc),
2735 Parameter_Associations => New_List (
2738 Make_Attribute_Reference (Loc,
2739 Prefix => Make_Identifier (Loc, Name_uP),
2740 Attribute_Name => Name_Address),
2743 (RTE (RE_Conditional_Call), Loc))));
2745 raise Program_Error;
2749 -- F := not Cancelled (Bnn);
2751 -- where F is the success flag. The status of Cancelled is negated
2752 -- in order to match the behavior of the version for task types.
2755 Make_Assignment_Statement (Loc,
2756 Name => Make_Identifier (Loc, Name_uF),
2760 Make_Function_Call (Loc,
2762 New_Occurrence_Of (RTE (RE_Cancelled), Loc),
2763 Parameter_Associations => New_List (
2764 New_Occurrence_Of (Blk_Nam, Loc))))));
2766 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2770 -- (T._task_id, -- Acceptor
2771 -- Task_Entry_Index! (I), -- E
2772 -- P, -- Uninterpreted_Data
2773 -- Conditional_Call, -- Mode
2774 -- F); -- Rendezvous_Successful
2776 -- where T is the task object, I is the entry index, P are the
2777 -- wrapped parameters and F is the status flag.
2780 Make_Procedure_Call_Statement (Loc,
2782 New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc),
2783 Parameter_Associations => New_List (
2785 Make_Selected_Component (Loc, -- T._task_id
2786 Prefix => Make_Identifier (Loc, Name_uT),
2787 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2789 Make_Unchecked_Type_Conversion (Loc, -- entry index
2791 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
2792 Expression => Make_Identifier (Loc, Name_uI)),
2794 Make_Identifier (Loc, Name_uP), -- parameter block
2795 New_Occurrence_Of -- Conditional_Call
2796 (RTE (RE_Conditional_Call), Loc),
2797 Make_Identifier (Loc, Name_uF)))); -- status flag
2801 -- Initialize out parameters
2804 Make_Assignment_Statement (Loc,
2805 Name => Make_Identifier (Loc, Name_uF),
2806 Expression => New_Occurrence_Of (Standard_False, Loc)));
2808 Make_Assignment_Statement (Loc,
2809 Name => Make_Identifier (Loc, Name_uC),
2810 Expression => New_Occurrence_Of (RTE (RE_POK_Function), Loc)));
2814 Make_Subprogram_Body (Loc,
2816 Make_Disp_Conditional_Select_Spec (Typ),
2817 Declarations => Decls,
2818 Handled_Statement_Sequence =>
2819 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2820 end Make_Disp_Conditional_Select_Body;
2822 ---------------------------------------
2823 -- Make_Disp_Conditional_Select_Spec --
2824 ---------------------------------------
2826 function Make_Disp_Conditional_Select_Spec
2827 (Typ : Entity_Id) return Node_Id
2829 Loc : constant Source_Ptr := Sloc (Typ);
2830 Def_Id : constant Node_Id :=
2831 Make_Defining_Identifier (Loc,
2832 Name_uDisp_Conditional_Select);
2833 Params : constant List_Id := New_List;
2836 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2838 -- T : in out Typ; -- Object parameter
2839 -- S : Integer; -- Primitive operation slot
2840 -- P : Address; -- Wrapped parameters
2841 -- C : out Prim_Op_Kind; -- Call kind
2842 -- F : out Boolean; -- Status flag
2844 Append_List_To (Params, New_List (
2846 Make_Parameter_Specification (Loc,
2847 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
2848 Parameter_Type => New_Occurrence_Of (Typ, Loc),
2850 Out_Present => True),
2852 Make_Parameter_Specification (Loc,
2853 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
2854 Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
2856 Make_Parameter_Specification (Loc,
2857 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
2858 Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)),
2860 Make_Parameter_Specification (Loc,
2861 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC),
2863 New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc),
2864 Out_Present => True),
2866 Make_Parameter_Specification (Loc,
2867 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF),
2868 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
2869 Out_Present => True)));
2872 Make_Procedure_Specification (Loc,
2873 Defining_Unit_Name => Def_Id,
2874 Parameter_Specifications => Params);
2875 end Make_Disp_Conditional_Select_Spec;
2877 -------------------------------------
2878 -- Make_Disp_Get_Prim_Op_Kind_Body --
2879 -------------------------------------
2881 function Make_Disp_Get_Prim_Op_Kind_Body (Typ : Entity_Id) return Node_Id is
2882 Loc : constant Source_Ptr := Sloc (Typ);
2886 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2888 if Is_Interface (Typ) then
2890 Make_Subprogram_Body (Loc,
2892 Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2893 Declarations => New_List,
2894 Handled_Statement_Sequence =>
2895 Make_Handled_Sequence_Of_Statements (Loc,
2896 New_List (Make_Null_Statement (Loc))));
2900 -- C := get_prim_op_kind (tag! (<type>VP), S);
2902 -- where C is the out parameter capturing the call kind and S is the
2903 -- dispatch table slot number.
2905 if Tagged_Type_Expansion then
2907 Unchecked_Convert_To (RTE (RE_Tag),
2909 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2913 Make_Attribute_Reference (Loc,
2914 Prefix => New_Occurrence_Of (Typ, Loc),
2915 Attribute_Name => Name_Tag);
2919 Make_Subprogram_Body (Loc,
2921 Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2922 Declarations => New_List,
2923 Handled_Statement_Sequence =>
2924 Make_Handled_Sequence_Of_Statements (Loc,
2926 Make_Assignment_Statement (Loc,
2927 Name => Make_Identifier (Loc, Name_uC),
2929 Make_Function_Call (Loc,
2931 New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc),
2932 Parameter_Associations => New_List (
2934 Make_Identifier (Loc, Name_uS)))))));
2935 end Make_Disp_Get_Prim_Op_Kind_Body;
2937 -------------------------------------
2938 -- Make_Disp_Get_Prim_Op_Kind_Spec --
2939 -------------------------------------
2941 function Make_Disp_Get_Prim_Op_Kind_Spec
2942 (Typ : Entity_Id) return Node_Id
2944 Loc : constant Source_Ptr := Sloc (Typ);
2945 Def_Id : constant Node_Id :=
2946 Make_Defining_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind);
2947 Params : constant List_Id := New_List;
2950 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2952 -- T : in out Typ; -- Object parameter
2953 -- S : Integer; -- Primitive operation slot
2954 -- C : out Prim_Op_Kind; -- Call kind
2956 Append_List_To (Params, New_List (
2958 Make_Parameter_Specification (Loc,
2959 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
2960 Parameter_Type => New_Occurrence_Of (Typ, Loc),
2962 Out_Present => True),
2964 Make_Parameter_Specification (Loc,
2965 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
2966 Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
2968 Make_Parameter_Specification (Loc,
2969 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC),
2971 New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc),
2972 Out_Present => True)));
2975 Make_Procedure_Specification (Loc,
2976 Defining_Unit_Name => Def_Id,
2977 Parameter_Specifications => Params);
2978 end Make_Disp_Get_Prim_Op_Kind_Spec;
2980 --------------------------------
2981 -- Make_Disp_Get_Task_Id_Body --
2982 --------------------------------
2984 function Make_Disp_Get_Task_Id_Body
2985 (Typ : Entity_Id) return Node_Id
2987 Loc : constant Source_Ptr := Sloc (Typ);
2991 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2993 if Is_Concurrent_Record_Type (Typ)
2994 and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type
2997 -- return To_Address (_T._task_id);
3000 Make_Simple_Return_Statement (Loc,
3002 Make_Unchecked_Type_Conversion (Loc,
3003 Subtype_Mark => New_Occurrence_Of (RTE (RE_Address), Loc),
3005 Make_Selected_Component (Loc,
3006 Prefix => Make_Identifier (Loc, Name_uT),
3007 Selector_Name => Make_Identifier (Loc, Name_uTask_Id))));
3009 -- A null body is constructed for non-task types
3013 -- return Null_Address;
3016 Make_Simple_Return_Statement (Loc,
3017 Expression => New_Occurrence_Of (RTE (RE_Null_Address), Loc));
3021 Make_Subprogram_Body (Loc,
3022 Specification => Make_Disp_Get_Task_Id_Spec (Typ),
3023 Declarations => New_List,
3024 Handled_Statement_Sequence =>
3025 Make_Handled_Sequence_Of_Statements (Loc, New_List (Ret)));
3026 end Make_Disp_Get_Task_Id_Body;
3028 --------------------------------
3029 -- Make_Disp_Get_Task_Id_Spec --
3030 --------------------------------
3032 function Make_Disp_Get_Task_Id_Spec
3033 (Typ : Entity_Id) return Node_Id
3035 Loc : constant Source_Ptr := Sloc (Typ);
3038 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3041 Make_Function_Specification (Loc,
3042 Defining_Unit_Name =>
3043 Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id),
3044 Parameter_Specifications => New_List (
3045 Make_Parameter_Specification (Loc,
3046 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
3047 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
3048 Result_Definition =>
3049 New_Occurrence_Of (RTE (RE_Address), Loc));
3050 end Make_Disp_Get_Task_Id_Spec;
3052 ----------------------------
3053 -- Make_Disp_Requeue_Body --
3054 ----------------------------
3056 function Make_Disp_Requeue_Body
3057 (Typ : Entity_Id) return Node_Id
3059 Loc : constant Source_Ptr := Sloc (Typ);
3060 Conc_Typ : Entity_Id := Empty;
3061 Stmts : constant List_Id := New_List;
3064 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3066 -- Null body is generated for interface types and non-concurrent
3069 if Is_Interface (Typ)
3070 or else not Is_Concurrent_Record_Type (Typ)
3073 Make_Subprogram_Body (Loc,
3074 Specification => Make_Disp_Requeue_Spec (Typ),
3075 Declarations => No_List,
3076 Handled_Statement_Sequence =>
3077 Make_Handled_Sequence_Of_Statements (Loc,
3078 New_List (Make_Null_Statement (Loc))));
3081 Conc_Typ := Corresponding_Concurrent_Type (Typ);
3083 if Ekind (Conc_Typ) = E_Protected_Type then
3085 -- Generate statements:
3087 -- System.Tasking.Protected_Objects.Operations.
3088 -- Requeue_Protected_Entry
3089 -- (Protection_Entries_Access (P),
3090 -- O._object'Unchecked_Access,
3091 -- Protected_Entry_Index (I),
3094 -- System.Tasking.Protected_Objects.Operations.
3095 -- Requeue_Task_To_Protected_Entry
3096 -- (O._object'Unchecked_Access,
3097 -- Protected_Entry_Index (I),
3101 if Restriction_Active (No_Entry_Queue) then
3102 Append_To (Stmts, Make_Null_Statement (Loc));
3105 Make_If_Statement (Loc,
3106 Condition => Make_Identifier (Loc, Name_uF),
3111 -- Call to Requeue_Protected_Entry
3113 Make_Procedure_Call_Statement (Loc,
3116 (RTE (RE_Requeue_Protected_Entry), Loc),
3117 Parameter_Associations =>
3120 Make_Unchecked_Type_Conversion (Loc, -- PEA (P)
3123 RTE (RE_Protection_Entries_Access), Loc),
3125 Make_Identifier (Loc, Name_uP)),
3127 Make_Attribute_Reference (Loc, -- O._object'Acc
3129 Name_Unchecked_Access,
3131 Make_Selected_Component (Loc,
3133 Make_Identifier (Loc, Name_uO),
3135 Make_Identifier (Loc, Name_uObject))),
3137 Make_Unchecked_Type_Conversion (Loc, -- entry index
3140 (RTE (RE_Protected_Entry_Index), Loc),
3141 Expression => Make_Identifier (Loc, Name_uI)),
3143 Make_Identifier (Loc, Name_uA)))), -- abort status
3148 -- Call to Requeue_Task_To_Protected_Entry
3150 Make_Procedure_Call_Statement (Loc,
3153 (RTE (RE_Requeue_Task_To_Protected_Entry), Loc),
3154 Parameter_Associations =>
3157 Make_Attribute_Reference (Loc, -- O._object'Acc
3158 Attribute_Name => Name_Unchecked_Access,
3160 Make_Selected_Component (Loc,
3162 Make_Identifier (Loc, Name_uO),
3164 Make_Identifier (Loc, Name_uObject))),
3166 Make_Unchecked_Type_Conversion (Loc, -- entry index
3169 (RTE (RE_Protected_Entry_Index), Loc),
3170 Expression => Make_Identifier (Loc, Name_uI)),
3172 Make_Identifier (Loc, Name_uA)))))); -- abort status
3176 pragma Assert (Is_Task_Type (Conc_Typ));
3180 -- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry
3181 -- (Protection_Entries_Access (P),
3183 -- Task_Entry_Index (I),
3186 -- System.Tasking.Rendezvous.Requeue_Task_Entry
3188 -- Task_Entry_Index (I),
3193 Make_If_Statement (Loc,
3194 Condition => Make_Identifier (Loc, Name_uF),
3196 Then_Statements => New_List (
3198 -- Call to Requeue_Protected_To_Task_Entry
3200 Make_Procedure_Call_Statement (Loc,
3203 (RTE (RE_Requeue_Protected_To_Task_Entry), Loc),
3205 Parameter_Associations => New_List (
3207 Make_Unchecked_Type_Conversion (Loc, -- PEA (P)
3210 (RTE (RE_Protection_Entries_Access), Loc),
3211 Expression => Make_Identifier (Loc, Name_uP)),
3213 Make_Selected_Component (Loc, -- O._task_id
3214 Prefix => Make_Identifier (Loc, Name_uO),
3215 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3217 Make_Unchecked_Type_Conversion (Loc, -- entry index
3219 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
3220 Expression => Make_Identifier (Loc, Name_uI)),
3222 Make_Identifier (Loc, Name_uA)))), -- abort status
3224 Else_Statements => New_List (
3226 -- Call to Requeue_Task_Entry
3228 Make_Procedure_Call_Statement (Loc,
3230 New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc),
3232 Parameter_Associations => New_List (
3234 Make_Selected_Component (Loc, -- O._task_id
3235 Prefix => Make_Identifier (Loc, Name_uO),
3236 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3238 Make_Unchecked_Type_Conversion (Loc, -- entry index
3240 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
3241 Expression => Make_Identifier (Loc, Name_uI)),
3243 Make_Identifier (Loc, Name_uA)))))); -- abort status
3246 -- Even though no declarations are needed in both cases, we allocate
3247 -- a list for entities added by Freeze.
3250 Make_Subprogram_Body (Loc,
3251 Specification => Make_Disp_Requeue_Spec (Typ),
3252 Declarations => New_List,
3253 Handled_Statement_Sequence =>
3254 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
3255 end Make_Disp_Requeue_Body;
3257 ----------------------------
3258 -- Make_Disp_Requeue_Spec --
3259 ----------------------------
3261 function Make_Disp_Requeue_Spec
3262 (Typ : Entity_Id) return Node_Id
3264 Loc : constant Source_Ptr := Sloc (Typ);
3267 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3269 -- O : in out Typ; - Object parameter
3270 -- F : Boolean; - Protected (True) / task (False) flag
3271 -- P : Address; - Protection_Entries_Access value
3272 -- I : Entry_Index - Index of entry call
3273 -- A : Boolean - Abort flag
3275 -- Note that the Protection_Entries_Access value is represented as a
3276 -- System.Address in order to avoid dragging in the tasking runtime
3277 -- when compiling sources without tasking constructs.
3280 Make_Procedure_Specification (Loc,
3281 Defining_Unit_Name =>
3282 Make_Defining_Identifier (Loc, Name_uDisp_Requeue),
3284 Parameter_Specifications => New_List (
3286 Make_Parameter_Specification (Loc, -- O
3287 Defining_Identifier =>
3288 Make_Defining_Identifier (Loc, Name_uO),
3290 New_Occurrence_Of (Typ, Loc),
3292 Out_Present => True),
3294 Make_Parameter_Specification (Loc, -- F
3295 Defining_Identifier =>
3296 Make_Defining_Identifier (Loc, Name_uF),
3298 New_Occurrence_Of (Standard_Boolean, Loc)),
3300 Make_Parameter_Specification (Loc, -- P
3301 Defining_Identifier =>
3302 Make_Defining_Identifier (Loc, Name_uP),
3304 New_Occurrence_Of (RTE (RE_Address), Loc)),
3306 Make_Parameter_Specification (Loc, -- I
3307 Defining_Identifier =>
3308 Make_Defining_Identifier (Loc, Name_uI),
3310 New_Occurrence_Of (Standard_Integer, Loc)),
3312 Make_Parameter_Specification (Loc, -- A
3313 Defining_Identifier =>
3314 Make_Defining_Identifier (Loc, Name_uA),
3316 New_Occurrence_Of (Standard_Boolean, Loc))));
3317 end Make_Disp_Requeue_Spec;
3319 ---------------------------------
3320 -- Make_Disp_Timed_Select_Body --
3321 ---------------------------------
3323 -- For interface types, generate:
3325 -- procedure _Disp_Timed_Select
3326 -- (T : in out <Typ>;
3328 -- P : System.Address;
3331 -- C : out Ada.Tags.Prim_Op_Kind;
3336 -- C := Ada.Tags.POK_Function;
3337 -- end _Disp_Timed_Select;
3339 -- For protected types, generate:
3341 -- procedure _Disp_Timed_Select
3342 -- (T : in out <Typ>;
3344 -- P : System.Address;
3347 -- C : out Ada.Tags.Prim_Op_Kind;
3353 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S);
3355 -- if C = Ada.Tags.POK_Procedure
3356 -- or else C = Ada.Tags.POK_Protected_Procedure
3357 -- or else C = Ada.Tags.POK_Task_Procedure
3363 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3364 -- System.Tasking.Protected_Objects.Operations.
3365 -- Timed_Protected_Entry_Call
3366 -- (T._object'Access,
3367 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
3372 -- end _Disp_Timed_Select;
3374 -- For task types, generate:
3376 -- procedure _Disp_Timed_Select
3377 -- (T : in out <Typ>;
3379 -- P : System.Address;
3382 -- C : out Ada.Tags.Prim_Op_Kind;
3388 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3389 -- System.Tasking.Rendezvous.Timed_Task_Entry_Call
3391 -- System.Tasking.Task_Entry_Index (I),
3396 -- end _Disp_Time_Select;
3398 function Make_Disp_Timed_Select_Body
3399 (Typ : Entity_Id) return Node_Id
3401 Loc : constant Source_Ptr := Sloc (Typ);
3402 Conc_Typ : Entity_Id := Empty;
3403 Decls : constant List_Id := New_List;
3405 Stmts : constant List_Id := New_List;
3409 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3411 -- Null body is generated for interface types
3413 if Is_Interface (Typ) then
3415 Make_Subprogram_Body (Loc,
3416 Specification => Make_Disp_Timed_Select_Spec (Typ),
3417 Declarations => New_List,
3418 Handled_Statement_Sequence =>
3419 Make_Handled_Sequence_Of_Statements (Loc,
3421 Make_Assignment_Statement (Loc,
3422 Name => Make_Identifier (Loc, Name_uF),
3423 Expression => New_Occurrence_Of (Standard_False, Loc)))));
3426 if Is_Concurrent_Record_Type (Typ) then
3427 Conc_Typ := Corresponding_Concurrent_Type (Typ);
3432 -- where I will be used to capture the entry index of the primitive
3433 -- wrapper at position S.
3436 Make_Object_Declaration (Loc,
3437 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI),
3438 Object_Definition =>
3439 New_Occurrence_Of (Standard_Integer, Loc)));
3442 -- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
3444 -- if C = POK_Procedure
3445 -- or else C = POK_Protected_Procedure
3446 -- or else C = POK_Task_Procedure;
3452 Build_Common_Dispatching_Select_Statements (Typ, Stmts);
3455 -- I := Get_Entry_Index (tag! (<type>VP), S);
3457 -- I is the entry index and S is the dispatch table slot
3459 if Tagged_Type_Expansion then
3461 Unchecked_Convert_To (RTE (RE_Tag),
3463 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
3467 Make_Attribute_Reference (Loc,
3468 Prefix => New_Occurrence_Of (Typ, Loc),
3469 Attribute_Name => Name_Tag);
3473 Make_Assignment_Statement (Loc,
3474 Name => Make_Identifier (Loc, Name_uI),
3476 Make_Function_Call (Loc,
3477 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
3478 Parameter_Associations => New_List (
3480 Make_Identifier (Loc, Name_uS)))));
3484 if Ekind (Conc_Typ) = E_Protected_Type then
3486 -- Build T._object'Access
3489 Make_Attribute_Reference (Loc,
3490 Attribute_Name => Name_Unchecked_Access,
3492 Make_Selected_Component (Loc,
3493 Prefix => Make_Identifier (Loc, Name_uT),
3494 Selector_Name => Make_Identifier (Loc, Name_uObject)));
3496 -- Normal case, No_Entry_Queue restriction not active. In this
3497 -- case we generate:
3499 -- Timed_Protected_Entry_Call
3500 -- (T._object'access,
3501 -- Protected_Entry_Index! (I),
3504 -- where T is the protected object, I is the entry index, P are
3505 -- the wrapped parameters, D is the delay amount, M is the delay
3506 -- mode and F is the status flag.
3508 -- Historically, there was also an implementation for single
3509 -- entry protected types (in s-tposen). However, it was removed
3510 -- by also testing for no No_Select_Statements restriction in
3511 -- Exp_Utils.Corresponding_Runtime_Package. This simplified the
3512 -- implementation of s-tposen.adb and provided consistency between
3513 -- all versions of System.Tasking.Protected_Objects.Single_Entry
3516 case Corresponding_Runtime_Package (Conc_Typ) is
3517 when System_Tasking_Protected_Objects_Entries =>
3519 Make_Procedure_Call_Statement (Loc,
3522 (RTE (RE_Timed_Protected_Entry_Call), Loc),
3523 Parameter_Associations => New_List (
3526 Make_Unchecked_Type_Conversion (Loc, -- entry index
3529 (RTE (RE_Protected_Entry_Index), Loc),
3530 Expression => Make_Identifier (Loc, Name_uI)),
3532 Make_Identifier (Loc, Name_uP), -- parameter block
3533 Make_Identifier (Loc, Name_uD), -- delay
3534 Make_Identifier (Loc, Name_uM), -- delay mode
3535 Make_Identifier (Loc, Name_uF)))); -- status flag
3538 raise Program_Error;
3544 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
3547 -- Timed_Task_Entry_Call (
3549 -- Task_Entry_Index! (I),
3555 -- where T is the task object, I is the entry index, P are the
3556 -- wrapped parameters, D is the delay amount, M is the delay
3557 -- mode and F is the status flag.
3560 Make_Procedure_Call_Statement (Loc,
3562 New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc),
3564 Parameter_Associations => New_List (
3565 Make_Selected_Component (Loc, -- T._task_id
3566 Prefix => Make_Identifier (Loc, Name_uT),
3567 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3569 Make_Unchecked_Type_Conversion (Loc, -- entry index
3571 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
3572 Expression => Make_Identifier (Loc, Name_uI)),
3574 Make_Identifier (Loc, Name_uP), -- parameter block
3575 Make_Identifier (Loc, Name_uD), -- delay
3576 Make_Identifier (Loc, Name_uM), -- delay mode
3577 Make_Identifier (Loc, Name_uF)))); -- status flag
3581 -- Initialize out parameters
3584 Make_Assignment_Statement (Loc,
3585 Name => Make_Identifier (Loc, Name_uF),
3586 Expression => New_Occurrence_Of (Standard_False, Loc)));
3588 Make_Assignment_Statement (Loc,
3589 Name => Make_Identifier (Loc, Name_uC),
3590 Expression => New_Occurrence_Of (RTE (RE_POK_Function), Loc)));
3594 Make_Subprogram_Body (Loc,
3595 Specification => Make_Disp_Timed_Select_Spec (Typ),
3596 Declarations => Decls,
3597 Handled_Statement_Sequence =>
3598 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
3599 end Make_Disp_Timed_Select_Body;
3601 ---------------------------------
3602 -- Make_Disp_Timed_Select_Spec --
3603 ---------------------------------
3605 function Make_Disp_Timed_Select_Spec
3606 (Typ : Entity_Id) return Node_Id
3608 Loc : constant Source_Ptr := Sloc (Typ);
3609 Def_Id : constant Node_Id :=
3610 Make_Defining_Identifier (Loc,
3611 Name_uDisp_Timed_Select);
3612 Params : constant List_Id := New_List;
3615 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3617 -- T : in out Typ; -- Object parameter
3618 -- S : Integer; -- Primitive operation slot
3619 -- P : Address; -- Wrapped parameters
3620 -- D : Duration; -- Delay
3621 -- M : Integer; -- Delay Mode
3622 -- C : out Prim_Op_Kind; -- Call kind
3623 -- F : out Boolean; -- Status flag
3625 Append_List_To (Params, New_List (
3627 Make_Parameter_Specification (Loc,
3628 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
3629 Parameter_Type => New_Occurrence_Of (Typ, Loc),
3631 Out_Present => True),
3633 Make_Parameter_Specification (Loc,
3634 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
3635 Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
3637 Make_Parameter_Specification (Loc,
3638 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
3639 Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)),
3641 Make_Parameter_Specification (Loc,
3642 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uD),
3643 Parameter_Type => New_Occurrence_Of (Standard_Duration, Loc)),
3645 Make_Parameter_Specification (Loc,
3646 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uM),
3647 Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
3649 Make_Parameter_Specification (Loc,
3650 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC),
3652 New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc),
3653 Out_Present => True)));
3656 Make_Parameter_Specification (Loc,
3657 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF),
3658 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
3659 Out_Present => True));
3662 Make_Procedure_Specification (Loc,
3663 Defining_Unit_Name => Def_Id,
3664 Parameter_Specifications => Params);
3665 end Make_Disp_Timed_Select_Spec;
3671 -- The frontend supports two models for expanding dispatch tables
3672 -- associated with library-level defined tagged types: statically and
3673 -- non-statically allocated dispatch tables. In the former case the object
3674 -- containing the dispatch table is constant and it is initialized by means
3675 -- of a positional aggregate. In the latter case, the object containing
3676 -- the dispatch table is a variable which is initialized by means of
3679 -- In case of locally defined tagged types, the object containing the
3680 -- object containing the dispatch table is always a variable (instead of a
3681 -- constant). This is currently required to give support to late overriding
3682 -- of primitives. For example:
3684 -- procedure Example is
3686 -- type T1 is tagged null record;
3687 -- procedure Prim (O : T1);
3690 -- type T2 is new Pkg.T1 with null record;
3691 -- procedure Prim (X : T2) is -- late overriding
3697 -- WARNING: This routine manages Ghost regions. Return statements must be
3698 -- replaced by gotos which jump to the end of the routine and restore the
3701 function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is
3702 Loc : constant Source_Ptr := Sloc (Typ);
3704 Max_Predef_Prims : constant Int :=
3708 (Parent (RTE (RE_Max_Predef_Prims)))));
3710 DT_Decl : constant Elist_Id := New_Elmt_List;
3711 DT_Aggr : constant Elist_Id := New_Elmt_List;
3712 -- Entities marked with attribute Is_Dispatch_Table_Entity
3714 Dummy_Object : Entity_Id := Empty;
3715 -- Extra nonexistent object of type Typ internally used to compute the
3716 -- offset to the components that reference secondary dispatch tables.
3717 -- Used to statically allocate secondary dispatch tables.
3719 procedure Check_Premature_Freezing
3721 Tagged_Type : Entity_Id;
3723 -- Verify that all untagged types in the profile of a subprogram are
3724 -- frozen at the point the subprogram is frozen. This enforces the rule
3725 -- on RM 13.14 (14) as modified by AI05-019. At the point a subprogram
3726 -- is frozen, enough must be known about it to build the activation
3727 -- record for it, which requires at least that the size of all
3728 -- parameters be known. Controlling arguments are by-reference,
3729 -- and therefore the rule only applies to untagged types. Typical
3730 -- violation of the rule involves an object declaration that freezes a
3731 -- tagged type, when one of its primitive operations has a type in its
3732 -- profile whose full view has not been analyzed yet. More complex cases
3733 -- involve composite types that have one private unfrozen subcomponent.
3735 procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0);
3736 -- Export the dispatch table DT of tagged type Typ. Required to generate
3737 -- forward references and statically allocate the table. For primary
3738 -- dispatch tables Index is 0; for secondary dispatch tables the value
3739 -- of index must match the Suffix_Index value assigned to the table by
3740 -- Make_Tags when generating its unique external name, and it is used to
3741 -- retrieve from the Dispatch_Table_Wrappers list associated with Typ
3742 -- the external name generated by Import_DT.
3744 procedure Make_Secondary_DT
3747 Iface_Comp : Node_Id;
3749 Num_Iface_Prims : Nat;
3750 Iface_DT_Ptr : Entity_Id;
3751 Predef_Prims_Ptr : Entity_Id;
3752 Build_Thunks : Boolean;
3754 -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch
3755 -- Table of Typ associated with Iface. Each abstract interface of Typ
3756 -- has two secondary dispatch tables: one containing pointers to thunks
3757 -- and another containing pointers to the primitives covering the
3758 -- interface primitives. The former secondary table is generated when
3759 -- Build_Thunks is True, and provides common support for dispatching
3760 -- calls through interface types; the latter secondary table is
3761 -- generated when Build_Thunks is False, and provides support for
3762 -- Generic Dispatching Constructors that dispatch calls through
3763 -- interface types. When constructing this latter table the value of
3764 -- Suffix_Index is -1 to indicate that there is no need to export such
3765 -- table when building statically allocated dispatch tables; a positive
3766 -- value of Suffix_Index must match the Suffix_Index value assigned to
3767 -- this secondary dispatch table by Make_Tags when its unique external
3768 -- name was generated.
3770 ------------------------------
3771 -- Check_Premature_Freezing --
3772 ------------------------------
3774 procedure Check_Premature_Freezing
3776 Tagged_Type : Entity_Id;
3781 function Is_Actual_For_Formal_Incomplete_Type
3782 (T : Entity_Id) return Boolean;
3783 -- In Ada 2012, if a nested generic has an incomplete formal type,
3784 -- the actual may be (and usually is) a private type whose completion
3785 -- appears later. It is safe to build the dispatch table in this
3786 -- case, gigi will have full views available.
3788 ------------------------------------------
3789 -- Is_Actual_For_Formal_Incomplete_Type --
3790 ------------------------------------------
3792 function Is_Actual_For_Formal_Incomplete_Type
3793 (T : Entity_Id) return Boolean
3795 Gen_Par : Entity_Id;
3799 if not Is_Generic_Instance (Current_Scope)
3800 or else not Used_As_Generic_Actual (T)
3804 Gen_Par := Generic_Parent (Parent (Current_Scope));
3809 (Generic_Formal_Declarations
3810 (Unit_Declaration_Node (Gen_Par)));
3811 while Present (F) loop
3812 if Ekind (Defining_Identifier (F)) = E_Incomplete_Type then
3820 end Is_Actual_For_Formal_Incomplete_Type;
3822 -- Start of processing for Check_Premature_Freezing
3825 -- Note that if the type is a (subtype of) a generic actual, the
3826 -- actual will have been frozen by the instantiation.
3829 and then Is_Private_Type (Typ)
3830 and then No (Full_View (Typ))
3831 and then not Is_Generic_Type (Typ)
3832 and then not Is_Tagged_Type (Typ)
3833 and then not Is_Frozen (Typ)
3834 and then not Is_Generic_Actual_Type (Typ)
3836 Error_Msg_Sloc := Sloc (Subp);
3838 ("declaration must appear after completion of type &", N, Typ);
3840 ("\which is an untagged type in the profile of "
3841 & "primitive operation & declared#", N, Subp);
3844 Comp := Private_Component (Typ);
3846 if not Is_Tagged_Type (Typ)
3847 and then Present (Comp)
3848 and then not Is_Frozen (Comp)
3849 and then not Is_Actual_For_Formal_Incomplete_Type (Comp)
3851 Error_Msg_Sloc := Sloc (Subp);
3852 Error_Msg_Node_2 := Subp;
3853 Error_Msg_Name_1 := Chars (Tagged_Type);
3855 ("declaration must appear after completion of type &",
3858 ("\which is a component of untagged type& in the profile "
3859 & "of primitive & of type % that is frozen by the "
3860 & "declaration ", N, Typ);
3863 end Check_Premature_Freezing;
3869 procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0)
3875 Set_Is_Statically_Allocated (DT);
3876 Set_Is_True_Constant (DT);
3877 Set_Is_Exported (DT);
3880 Elmt := First_Elmt (Dispatch_Table_Wrappers (Typ));
3881 while Count /= Index loop
3886 pragma Assert (Related_Type (Node (Elmt)) = Typ);
3888 Get_External_Name (Node (Elmt));
3889 Set_Interface_Name (DT,
3890 Make_String_Literal (Loc,
3891 Strval => String_From_Name_Buffer));
3893 -- Ensure proper Sprint output of this implicit importation
3895 Set_Is_Internal (DT);
3899 -----------------------
3900 -- Make_Secondary_DT --
3901 -----------------------
3903 procedure Make_Secondary_DT
3906 Iface_Comp : Node_Id;
3908 Num_Iface_Prims : Nat;
3909 Iface_DT_Ptr : Entity_Id;
3910 Predef_Prims_Ptr : Entity_Id;
3911 Build_Thunks : Boolean;
3914 Loc : constant Source_Ptr := Sloc (Typ);
3915 Exporting_Table : constant Boolean :=
3916 Building_Static_DT (Typ)
3917 and then Suffix_Index > 0;
3918 Iface_DT : constant Entity_Id := Make_Temporary (Loc, 'T');
3919 Predef_Prims : constant Entity_Id := Make_Temporary (Loc, 'R');
3920 DT_Constr_List : List_Id;
3921 DT_Aggr_List : List_Id;
3922 Empty_DT : Boolean := False;
3923 Nb_Predef_Prims : Nat := 0;
3927 OSD_Aggr_List : List_Id;
3930 Prim_Elmt : Elmt_Id;
3931 Prim_Ops_Aggr_List : List_Id;
3934 -- Handle cases in which we do not generate statically allocated
3937 if not Building_Static_DT (Typ) then
3938 Set_Ekind (Predef_Prims, E_Variable);
3939 Set_Ekind (Iface_DT, E_Variable);
3941 -- Statically allocated dispatch tables and related entities are
3945 Set_Ekind (Predef_Prims, E_Constant);
3946 Set_Is_Statically_Allocated (Predef_Prims);
3947 Set_Is_True_Constant (Predef_Prims);
3949 Set_Ekind (Iface_DT, E_Constant);
3950 Set_Is_Statically_Allocated (Iface_DT);
3951 Set_Is_True_Constant (Iface_DT);
3954 -- Calculate the number of slots of the dispatch table. If the number
3955 -- of primitives of Typ is 0 we reserve a dummy single entry for its
3956 -- DT because at run time the pointer to this dummy entry will be
3959 if Num_Iface_Prims = 0 then
3963 Nb_Prim := Num_Iface_Prims;
3968 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
3969 -- (predef-prim-op-thunk-1'address,
3970 -- predef-prim-op-thunk-2'address,
3972 -- predef-prim-op-thunk-n'address);
3973 -- for Predef_Prims'Alignment use Address'Alignment
3975 -- Stage 1: Calculate the number of predefined primitives
3977 if not Building_Static_DT (Typ) then
3978 Nb_Predef_Prims := Max_Predef_Prims;
3980 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3981 while Present (Prim_Elmt) loop
3982 Prim := Node (Prim_Elmt);
3984 if Is_Predefined_Dispatching_Operation (Prim)
3985 and then not Is_Abstract_Subprogram (Prim)
3987 Pos := UI_To_Int (DT_Position (Prim));
3989 if Pos > Nb_Predef_Prims then
3990 Nb_Predef_Prims := Pos;
3994 Next_Elmt (Prim_Elmt);
3998 if Generate_SCIL then
3999 Nb_Predef_Prims := 0;
4002 -- Stage 2: Create the thunks associated with the predefined
4003 -- primitives and save their entity to fill the aggregate.
4006 Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
4008 Thunk_Id : Entity_Id;
4009 Thunk_Code : Node_Id;
4012 Prim_Ops_Aggr_List := New_List;
4013 Prim_Table := (others => Empty);
4015 if Building_Static_DT (Typ) then
4016 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4017 while Present (Prim_Elmt) loop
4018 Prim := Node (Prim_Elmt);
4020 if Is_Predefined_Dispatching_Operation (Prim)
4021 and then not Is_Abstract_Subprogram (Prim)
4022 and then not Is_Eliminated (Prim)
4023 and then not Generate_SCIL
4024 and then not Present (Prim_Table
4025 (UI_To_Int (DT_Position (Prim))))
4027 if not Build_Thunks then
4028 Prim_Table (UI_To_Int (DT_Position (Prim))) :=
4032 Expand_Interface_Thunk
4033 (Ultimate_Alias (Prim), Thunk_Id, Thunk_Code);
4035 if Present (Thunk_Id) then
4036 Append_To (Result, Thunk_Code);
4037 Prim_Table (UI_To_Int (DT_Position (Prim))) :=
4043 Next_Elmt (Prim_Elmt);
4047 for J in Prim_Table'Range loop
4048 if Present (Prim_Table (J)) then
4050 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
4051 Make_Attribute_Reference (Loc,
4052 Prefix => New_Occurrence_Of (Prim_Table (J), Loc),
4053 Attribute_Name => Name_Unrestricted_Access));
4055 New_Node := Make_Null (Loc);
4058 Append_To (Prim_Ops_Aggr_List, New_Node);
4062 Make_Aggregate (Loc, Expressions => Prim_Ops_Aggr_List);
4064 -- Remember aggregates initializing dispatch tables
4066 Append_Elmt (New_Node, DT_Aggr);
4069 Make_Subtype_Declaration (Loc,
4070 Defining_Identifier => Make_Temporary (Loc, 'S'),
4071 Subtype_Indication =>
4072 New_Occurrence_Of (RTE (RE_Address_Array), Loc));
4074 Append_To (Result, Decl);
4077 Make_Object_Declaration (Loc,
4078 Defining_Identifier => Predef_Prims,
4079 Constant_Present => Building_Static_DT (Typ),
4080 Aliased_Present => True,
4081 Object_Definition => New_Occurrence_Of
4082 (Defining_Identifier (Decl), Loc),
4083 Expression => New_Node));
4086 Make_Attribute_Definition_Clause (Loc,
4087 Name => New_Occurrence_Of (Predef_Prims, Loc),
4088 Chars => Name_Alignment,
4090 Make_Attribute_Reference (Loc,
4092 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4093 Attribute_Name => Name_Alignment)));
4098 -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
4099 -- (OSD_Table => (1 => <value>,
4103 -- Iface_DT : Dispatch_Table (Nb_Prims) :=
4104 -- ([ Signature => <sig-value> ],
4105 -- Tag_Kind => <tag_kind-value>,
4106 -- Predef_Prims => Predef_Prims'Address,
4107 -- Offset_To_Top => 0,
4108 -- OSD => OSD'Address,
4109 -- Prims_Ptr => (prim-op-1'address,
4110 -- prim-op-2'address,
4112 -- prim-op-n'address));
4113 -- for Iface_DT'Alignment use Address'Alignment;
4115 -- Stage 3: Initialize the discriminant and the record components
4117 DT_Constr_List := New_List;
4118 DT_Aggr_List := New_List;
4122 Append_To (DT_Constr_List, Make_Integer_Literal (Loc, Nb_Prim));
4123 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, Nb_Prim));
4127 if RTE_Record_Component_Available (RE_Signature) then
4128 Append_To (DT_Aggr_List,
4129 New_Occurrence_Of (RTE (RE_Secondary_DT), Loc));
4134 if RTE_Record_Component_Available (RE_Tag_Kind) then
4135 Append_To (DT_Aggr_List, Tagged_Kind (Typ));
4140 Append_To (DT_Aggr_List,
4141 Make_Attribute_Reference (Loc,
4142 Prefix => New_Occurrence_Of (Predef_Prims, Loc),
4143 Attribute_Name => Name_Address));
4145 -- If the location of the component that references this secondary
4146 -- dispatch table is variable then we have not declared the internal
4147 -- dummy object; the value of Offset_To_Top will be set by the init
4150 if No (Dummy_Object) then
4151 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
4154 Append_To (DT_Aggr_List,
4156 Make_Attribute_Reference (Loc,
4158 Make_Selected_Component (Loc,
4160 New_Occurrence_Of (Dummy_Object, Loc),
4162 New_Occurrence_Of (Iface_Comp, Loc)),
4163 Attribute_Name => Name_Position)));
4166 -- Generate the Object Specific Data table required to dispatch calls
4167 -- through synchronized interfaces.
4170 or else Is_Abstract_Type (Typ)
4171 or else Is_Controlled (Typ)
4172 or else Restriction_Active (No_Dispatching_Calls)
4173 or else not Is_Limited_Type (Typ)
4174 or else not Has_Interfaces (Typ)
4175 or else not Build_Thunks
4176 or else not RTE_Record_Component_Available (RE_OSD_Table)
4178 -- No OSD table required
4180 Append_To (DT_Aggr_List,
4181 New_Occurrence_Of (RTE (RE_Null_Address), Loc));
4184 OSD_Aggr_List := New_List;
4187 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
4189 Prim_Alias : Entity_Id;
4190 Prim_Elmt : Elmt_Id;
4196 Prim_Table := (others => Empty);
4197 Prim_Alias := Empty;
4199 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4200 while Present (Prim_Elmt) loop
4201 Prim := Node (Prim_Elmt);
4203 if Present (Interface_Alias (Prim))
4204 and then Find_Dispatching_Type
4205 (Interface_Alias (Prim)) = Iface
4207 Prim_Alias := Interface_Alias (Prim);
4208 E := Ultimate_Alias (Prim);
4209 Pos := UI_To_Int (DT_Position (Prim_Alias));
4211 if Present (Prim_Table (Pos)) then
4212 pragma Assert (Prim_Table (Pos) = E);
4216 Prim_Table (Pos) := E;
4218 Append_To (OSD_Aggr_List,
4219 Make_Component_Association (Loc,
4220 Choices => New_List (
4221 Make_Integer_Literal (Loc,
4222 DT_Position (Prim_Alias))),
4224 Make_Integer_Literal (Loc,
4225 DT_Position (Alias (Prim)))));
4231 Next_Elmt (Prim_Elmt);
4233 pragma Assert (Count = Nb_Prim);
4236 OSD := Make_Temporary (Loc, 'I');
4239 Make_Object_Declaration (Loc,
4240 Defining_Identifier => OSD,
4241 Object_Definition =>
4242 Make_Subtype_Indication (Loc,
4244 New_Occurrence_Of (RTE (RE_Object_Specific_Data), Loc),
4246 Make_Index_Or_Discriminant_Constraint (Loc,
4247 Constraints => New_List (
4248 Make_Integer_Literal (Loc, Nb_Prim)))),
4251 Make_Aggregate (Loc,
4252 Component_Associations => New_List (
4253 Make_Component_Association (Loc,
4254 Choices => New_List (
4256 (RTE_Record_Component (RE_OSD_Num_Prims), Loc)),
4258 Make_Integer_Literal (Loc, Nb_Prim)),
4260 Make_Component_Association (Loc,
4261 Choices => New_List (
4263 (RTE_Record_Component (RE_OSD_Table), Loc)),
4264 Expression => Make_Aggregate (Loc,
4265 Component_Associations => OSD_Aggr_List))))));
4268 Make_Attribute_Definition_Clause (Loc,
4269 Name => New_Occurrence_Of (OSD, Loc),
4270 Chars => Name_Alignment,
4272 Make_Attribute_Reference (Loc,
4274 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4275 Attribute_Name => Name_Alignment)));
4277 -- In secondary dispatch tables the Typeinfo component contains
4278 -- the address of the Object Specific Data (see a-tags.ads)
4280 Append_To (DT_Aggr_List,
4281 Make_Attribute_Reference (Loc,
4282 Prefix => New_Occurrence_Of (OSD, Loc),
4283 Attribute_Name => Name_Address));
4286 -- Initialize the table of primitive operations
4288 Prim_Ops_Aggr_List := New_List;
4291 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
4293 elsif Is_Abstract_Type (Typ)
4294 or else not Building_Static_DT (Typ)
4296 for J in 1 .. Nb_Prim loop
4297 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
4302 CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
4305 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
4306 Thunk_Code : Node_Id;
4307 Thunk_Id : Entity_Id;
4310 Prim_Table := (others => Empty);
4312 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4313 while Present (Prim_Elmt) loop
4314 Prim := Node (Prim_Elmt);
4315 E := Ultimate_Alias (Prim);
4316 Prim_Pos := UI_To_Int (DT_Position (E));
4318 -- Do not reference predefined primitives because they are
4319 -- located in a separate dispatch table; skip abstract and
4320 -- eliminated primitives; skip primitives located in the C++
4321 -- part of the dispatch table because their slot is set by
4324 if not Is_Predefined_Dispatching_Operation (Prim)
4325 and then Present (Interface_Alias (Prim))
4326 and then not Is_Abstract_Subprogram (Alias (Prim))
4327 and then not Is_Eliminated (Alias (Prim))
4328 and then (not Is_CPP_Class (Root_Type (Typ))
4329 or else Prim_Pos > CPP_Nb_Prims)
4330 and then Find_Dispatching_Type
4331 (Interface_Alias (Prim)) = Iface
4333 -- Generate the code of the thunk only if the abstract
4334 -- interface type is not an immediate ancestor of
4335 -- Tagged_Type. Otherwise the DT associated with the
4336 -- interface is the primary DT.
4338 and then not Is_Ancestor (Iface, Typ,
4339 Use_Full_View => True)
4341 if not Build_Thunks then
4343 UI_To_Int (DT_Position (Interface_Alias (Prim)));
4344 Prim_Table (Prim_Pos) := Alias (Prim);
4347 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
4349 if Present (Thunk_Id) then
4351 UI_To_Int (DT_Position (Interface_Alias (Prim)));
4353 Prim_Table (Prim_Pos) := Thunk_Id;
4354 Append_To (Result, Thunk_Code);
4359 Next_Elmt (Prim_Elmt);
4362 for J in Prim_Table'Range loop
4363 if Present (Prim_Table (J)) then
4365 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
4366 Make_Attribute_Reference (Loc,
4367 Prefix => New_Occurrence_Of (Prim_Table (J), Loc),
4368 Attribute_Name => Name_Unrestricted_Access));
4371 New_Node := Make_Null (Loc);
4374 Append_To (Prim_Ops_Aggr_List, New_Node);
4380 Make_Aggregate (Loc,
4381 Expressions => Prim_Ops_Aggr_List);
4383 Append_To (DT_Aggr_List, New_Node);
4385 -- Remember aggregates initializing dispatch tables
4387 Append_Elmt (New_Node, DT_Aggr);
4389 -- Note: Secondary dispatch tables are declared constant only if
4390 -- we can compute their offset field by means of the extra dummy
4391 -- object; otherwise they cannot be declared constant and the
4392 -- Offset_To_Top component is initialized by the IP routine.
4395 Make_Object_Declaration (Loc,
4396 Defining_Identifier => Iface_DT,
4397 Aliased_Present => True,
4398 Constant_Present => Present (Dummy_Object),
4400 Object_Definition =>
4401 Make_Subtype_Indication (Loc,
4402 Subtype_Mark => New_Occurrence_Of
4403 (RTE (RE_Dispatch_Table_Wrapper), Loc),
4404 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
4405 Constraints => DT_Constr_List)),
4408 Make_Aggregate (Loc,
4409 Expressions => DT_Aggr_List)));
4412 Make_Attribute_Definition_Clause (Loc,
4413 Name => New_Occurrence_Of (Iface_DT, Loc),
4414 Chars => Name_Alignment,
4417 Make_Attribute_Reference (Loc,
4419 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4420 Attribute_Name => Name_Alignment)));
4422 if Exporting_Table then
4423 Export_DT (Typ, Iface_DT, Suffix_Index);
4425 -- Generate code to create the pointer to the dispatch table
4427 -- Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address);
4429 -- Note: This declaration is not added here if the table is exported
4430 -- because in such case Make_Tags has already added this declaration.
4434 Make_Object_Declaration (Loc,
4435 Defining_Identifier => Iface_DT_Ptr,
4436 Constant_Present => True,
4438 Object_Definition =>
4439 New_Occurrence_Of (RTE (RE_Interface_Tag), Loc),
4442 Unchecked_Convert_To (RTE (RE_Interface_Tag),
4443 Make_Attribute_Reference (Loc,
4445 Make_Selected_Component (Loc,
4446 Prefix => New_Occurrence_Of (Iface_DT, Loc),
4449 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
4450 Attribute_Name => Name_Address))));
4454 Make_Object_Declaration (Loc,
4455 Defining_Identifier => Predef_Prims_Ptr,
4456 Constant_Present => True,
4458 Object_Definition =>
4459 New_Occurrence_Of (RTE (RE_Address), Loc),
4462 Make_Attribute_Reference (Loc,
4464 Make_Selected_Component (Loc,
4465 Prefix => New_Occurrence_Of (Iface_DT, Loc),
4468 (RTE_Record_Component (RE_Predef_Prims), Loc)),
4469 Attribute_Name => Name_Address)));
4471 -- Remember entities containing dispatch tables
4473 Append_Elmt (Predef_Prims, DT_Decl);
4474 Append_Elmt (Iface_DT, DT_Decl);
4475 end Make_Secondary_DT;
4479 Elab_Code : constant List_Id := New_List;
4480 Result : constant List_Id := New_List;
4481 Tname : constant Name_Id := Chars (Typ);
4483 -- When pragmas Discard_Names and No_Tagged_Streams simultaneously apply
4484 -- we initialize the Expanded_Name and the External_Tag of this tagged
4485 -- type with an empty string. This is useful to avoid exposing entity
4486 -- names at binary level. It can be done when both pragmas apply because
4487 -- (1) Discard_Names allows initializing Expanded_Name with an
4488 -- implementation defined value (Ada RM Section C.5 (7/2)).
4489 -- (2) External_Tag (combined with Internal_Tag) is used for object
4490 -- streaming and No_Tagged_Streams inhibits the generation of
4493 Discard_Names : constant Boolean :=
4494 Present (No_Tagged_Streams_Pragma (Typ))
4495 and then (Global_Discard_Names
4496 or else Einfo.Discard_Names (Typ));
4498 -- The following name entries are used by Make_DT to generate a number
4499 -- of entities related to a tagged type. These entities may be generated
4500 -- in a scope other than that of the tagged type declaration, and if
4501 -- the entities for two tagged types with the same name happen to be
4502 -- generated in the same scope, we have to take care to use different
4503 -- names. This is achieved by means of a unique serial number appended
4504 -- to each generated entity name.
4506 Name_DT : constant Name_Id :=
4507 New_External_Name (Tname, 'T', Suffix_Index => -1);
4508 Name_Exname : constant Name_Id :=
4509 New_External_Name (Tname, 'E', Suffix_Index => -1);
4510 Name_HT_Link : constant Name_Id :=
4511 New_External_Name (Tname, 'H', Suffix_Index => -1);
4512 Name_Predef_Prims : constant Name_Id :=
4513 New_External_Name (Tname, 'R', Suffix_Index => -1);
4514 Name_SSD : constant Name_Id :=
4515 New_External_Name (Tname, 'S', Suffix_Index => -1);
4516 Name_TSD : constant Name_Id :=
4517 New_External_Name (Tname, 'B', Suffix_Index => -1);
4519 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
4520 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
4521 -- Save the Ghost-related attributes to restore on exit
4524 AI_Tag_Elmt : Elmt_Id;
4525 AI_Tag_Comp : Elmt_Id;
4527 DT_Aggr_List : List_Id;
4528 DT_Constr_List : List_Id;
4531 HT_Link : Entity_Id;
4534 Iface_Table_Node : Node_Id;
4535 Name_ITable : Name_Id;
4536 Nb_Predef_Prims : Nat := 0;
4539 Num_Ifaces : Nat := 0;
4540 Parent_Typ : Entity_Id;
4541 Predef_Prims : Entity_Id;
4543 Prim_Elmt : Elmt_Id;
4544 Prim_Ops_Aggr_List : List_Id;
4547 Typ_Comps : Elist_Id;
4548 Typ_Ifaces : Elist_Id;
4550 TSD_Aggr_List : List_Id;
4551 TSD_Tags_List : List_Id;
4553 -- Start of processing for Make_DT
4556 pragma Assert (Is_Frozen (Typ));
4558 -- The tagged type being processed may be subject to pragma Ghost. Set
4559 -- the mode now to ensure that any nodes generated during dispatch table
4560 -- creation are properly marked as Ghost.
4562 Set_Ghost_Mode (Typ);
4564 -- Handle cases in which there is no need to build the dispatch table
4566 if Has_Dispatch_Table (Typ)
4567 or else No (Access_Disp_Table (Typ))
4568 or else Is_CPP_Class (Typ)
4572 elsif No_Run_Time_Mode then
4573 Error_Msg_CRT ("tagged types", Typ);
4576 elsif not RTE_Available (RE_Tag) then
4578 Make_Object_Declaration (Loc,
4579 Defining_Identifier =>
4580 Node (First_Elmt (Access_Disp_Table (Typ))),
4581 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc),
4582 Constant_Present => True,
4584 Unchecked_Convert_To (RTE (RE_Tag),
4585 New_Occurrence_Of (RTE (RE_Null_Address), Loc))));
4587 Analyze_List (Result, Suppress => All_Checks);
4588 Error_Msg_CRT ("tagged types", Typ);
4592 -- Ensure that the value of Max_Predef_Prims defined in a-tags is
4593 -- correct. Valid values are 9 under configurable runtime or 15
4594 -- with full runtime.
4596 if RTE_Available (RE_Interface_Data) then
4597 if Max_Predef_Prims /= 15 then
4598 Error_Msg_N ("run-time library configuration error", Typ);
4602 if Max_Predef_Prims /= 9 then
4603 Error_Msg_N ("run-time library configuration error", Typ);
4604 Error_Msg_CRT ("tagged types", Typ);
4609 DT := Make_Defining_Identifier (Loc, Name_DT);
4610 Exname := Make_Defining_Identifier (Loc, Name_Exname);
4611 HT_Link := Make_Defining_Identifier (Loc, Name_HT_Link);
4612 Predef_Prims := Make_Defining_Identifier (Loc, Name_Predef_Prims);
4613 SSD := Make_Defining_Identifier (Loc, Name_SSD);
4614 TSD := Make_Defining_Identifier (Loc, Name_TSD);
4616 -- Initialize Parent_Typ handling private types
4618 Parent_Typ := Etype (Typ);
4620 if Present (Full_View (Parent_Typ)) then
4621 Parent_Typ := Full_View (Parent_Typ);
4624 -- Ensure that all the primitives are frozen. This is only required when
4625 -- building static dispatch tables --- the primitives must be frozen to
4626 -- be referenced (otherwise we have problems with the backend). It is
4627 -- not a requirement with nonstatic dispatch tables because in this case
4628 -- we generate now an empty dispatch table; the extra code required to
4629 -- register the primitives in the slots will be generated later --- when
4630 -- each primitive is frozen (see Freeze_Subprogram).
4632 if Building_Static_DT (Typ) then
4634 Saved_FLLTT : constant Boolean :=
4635 Freezing_Library_Level_Tagged_Type;
4640 Prim_Elmt : Elmt_Id;
4643 Freezing_Library_Level_Tagged_Type := True;
4645 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4646 while Present (Prim_Elmt) loop
4647 Prim := Node (Prim_Elmt);
4648 Frnodes := Freeze_Entity (Prim, Typ);
4650 -- We disable this check for abstract subprograms, given that
4651 -- they cannot be called directly and thus the state of their
4652 -- untagged formals is of no concern. The RM is unclear in any
4653 -- case concerning the need for this check, and this topic may
4654 -- go back to the ARG.
4656 if not Is_Abstract_Subprogram (Prim) then
4657 Formal := First_Formal (Prim);
4658 while Present (Formal) loop
4659 Check_Premature_Freezing (Prim, Typ, Etype (Formal));
4660 Next_Formal (Formal);
4663 Check_Premature_Freezing (Prim, Typ, Etype (Prim));
4666 if Present (Frnodes) then
4667 Append_List_To (Result, Frnodes);
4670 Next_Elmt (Prim_Elmt);
4673 Freezing_Library_Level_Tagged_Type := Saved_FLLTT;
4677 if Building_Static_Secondary_DT (Typ) then
4679 Cannot_Have_Null_Disc : Boolean := False;
4680 Name_Dummy_Object : constant Name_Id :=
4681 New_External_Name (Tname,
4682 'P', Suffix_Index => -1);
4684 Dummy_Object := Make_Defining_Identifier (Loc, Name_Dummy_Object);
4686 -- Define the extra object imported and constant to avoid linker
4687 -- errors (since this object is never declared). Required because
4688 -- we implement RM 13.3(19) for exported and imported (variable)
4689 -- objects by making them volatile.
4691 Set_Is_Imported (Dummy_Object);
4692 Set_Ekind (Dummy_Object, E_Constant);
4693 Set_Is_True_Constant (Dummy_Object);
4694 Set_Related_Type (Dummy_Object, Typ);
4696 -- The scope must be set now to call Get_External_Name
4698 Set_Scope (Dummy_Object, Current_Scope);
4700 Get_External_Name (Dummy_Object);
4701 Set_Interface_Name (Dummy_Object,
4702 Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
4704 -- Ensure proper Sprint output of this implicit importation
4706 Set_Is_Internal (Dummy_Object);
4708 if not Has_Discriminants (Typ) then
4710 Make_Object_Declaration (Loc,
4711 Defining_Identifier => Dummy_Object,
4712 Constant_Present => True,
4713 Object_Definition => New_Occurrence_Of (Typ, Loc)));
4716 Constr_List : constant List_Id := New_List;
4720 Discrim := First_Discriminant (Typ);
4721 while Present (Discrim) loop
4722 if Is_Discrete_Type (Etype (Discrim)) then
4723 Append_To (Constr_List,
4724 Make_Attribute_Reference (Loc,
4726 New_Occurrence_Of (Etype (Discrim), Loc),
4727 Attribute_Name => Name_First));
4730 pragma Assert (Is_Access_Type (Etype (Discrim)));
4731 Cannot_Have_Null_Disc :=
4732 Cannot_Have_Null_Disc
4733 or else Can_Never_Be_Null (Etype (Discrim));
4734 Append_To (Constr_List, Make_Null (Loc));
4737 Next_Discriminant (Discrim);
4741 Make_Object_Declaration (Loc,
4742 Defining_Identifier => Dummy_Object,
4743 Constant_Present => True,
4744 Object_Definition =>
4745 Make_Subtype_Indication (Loc,
4746 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
4748 Make_Index_Or_Discriminant_Constraint (Loc,
4749 Constraints => Constr_List))));
4753 -- Given that the dummy object will not be declared at run time,
4754 -- analyze its declaration with expansion disabled and warnings
4755 -- and error messages ignored.
4757 Expander_Mode_Save_And_Set (False);
4758 Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
4759 Analyze (Last (Result), Suppress => All_Checks);
4760 Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
4761 Expander_Mode_Restore;
4765 -- Ada 2005 (AI-251): Build the secondary dispatch tables
4767 if Has_Interfaces (Typ) then
4768 Collect_Interface_Components (Typ, Typ_Comps);
4770 -- Each secondary dispatch table is assigned an unique positive
4771 -- suffix index; such value also corresponds with the location of
4772 -- its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
4774 -- Note: This value must be kept sync with the Suffix_Index values
4775 -- generated by Make_Tags
4779 Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
4781 AI_Tag_Comp := First_Elmt (Typ_Comps);
4782 while Present (AI_Tag_Comp) loop
4783 pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'P'));
4785 -- Build the secondary table containing pointers to thunks
4790 Base_Type (Related_Type (Node (AI_Tag_Comp))),
4791 Iface_Comp => Node (AI_Tag_Comp),
4792 Suffix_Index => Suffix_Index,
4794 UI_To_Int (DT_Entry_Count (Node (AI_Tag_Comp))),
4795 Iface_DT_Ptr => Node (AI_Tag_Elmt),
4796 Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
4797 Build_Thunks => True,
4800 -- Skip secondary dispatch table referencing thunks to predefined
4803 Next_Elmt (AI_Tag_Elmt);
4804 pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Y'));
4806 -- Secondary dispatch table referencing user-defined primitives
4807 -- covered by this interface.
4809 Next_Elmt (AI_Tag_Elmt);
4810 pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'D'));
4812 -- Build the secondary table containing pointers to primitives
4813 -- (used to give support to Generic Dispatching Constructors).
4818 (Related_Type (Node (AI_Tag_Comp))),
4819 Iface_Comp => Node (AI_Tag_Comp),
4821 Num_Iface_Prims => UI_To_Int
4822 (DT_Entry_Count (Node (AI_Tag_Comp))),
4823 Iface_DT_Ptr => Node (AI_Tag_Elmt),
4824 Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
4825 Build_Thunks => False,
4828 -- Skip secondary dispatch table referencing predefined primitives
4830 Next_Elmt (AI_Tag_Elmt);
4831 pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Z'));
4833 Suffix_Index := Suffix_Index + 1;
4834 Next_Elmt (AI_Tag_Elmt);
4835 Next_Elmt (AI_Tag_Comp);
4839 -- Get the _tag entity and number of primitives of its dispatch table
4841 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
4842 Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
4844 if Generate_SCIL then
4848 Set_Is_Statically_Allocated (DT, Is_Library_Level_Tagged_Type (Typ));
4849 Set_Is_Statically_Allocated (SSD, Is_Library_Level_Tagged_Type (Typ));
4850 Set_Is_Statically_Allocated (TSD, Is_Library_Level_Tagged_Type (Typ));
4851 Set_Is_Statically_Allocated (Predef_Prims,
4852 Is_Library_Level_Tagged_Type (Typ));
4854 -- In case of locally defined tagged type we declare the object
4855 -- containing the dispatch table by means of a variable. Its
4856 -- initialization is done later by means of an assignment. This is
4857 -- required to generate its External_Tag.
4859 if not Building_Static_DT (Typ) then
4862 -- DT : No_Dispatch_Table_Wrapper;
4863 -- for DT'Alignment use Address'Alignment;
4864 -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
4866 if not Has_DT (Typ) then
4868 Make_Object_Declaration (Loc,
4869 Defining_Identifier => DT,
4870 Aliased_Present => True,
4871 Constant_Present => False,
4872 Object_Definition =>
4874 (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
4877 Make_Attribute_Definition_Clause (Loc,
4878 Name => New_Occurrence_Of (DT, Loc),
4879 Chars => Name_Alignment,
4881 Make_Attribute_Reference (Loc,
4883 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4884 Attribute_Name => Name_Alignment)));
4887 Make_Object_Declaration (Loc,
4888 Defining_Identifier => DT_Ptr,
4889 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc),
4890 Constant_Present => True,
4892 Unchecked_Convert_To (RTE (RE_Tag),
4893 Make_Attribute_Reference (Loc,
4895 Make_Selected_Component (Loc,
4896 Prefix => New_Occurrence_Of (DT, Loc),
4899 (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
4900 Attribute_Name => Name_Address))));
4902 Set_Is_Statically_Allocated (DT_Ptr,
4903 Is_Library_Level_Tagged_Type (Typ));
4905 -- Generate the SCIL node for the previous object declaration
4906 -- because it has a tag initialization.
4908 if Generate_SCIL then
4910 Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
4911 Set_SCIL_Entity (New_Node, Typ);
4912 Set_SCIL_Node (Last (Result), New_Node);
4916 -- Gnat2scil has its own implementation of dispatch tables,
4917 -- different than what is being implemented here. Generating
4918 -- further dispatch table initialization code would just
4919 -- cause gnat2scil to generate useless Scil which CodePeer
4920 -- would waste time and space analyzing, so we skip it.
4924 -- DT : Dispatch_Table_Wrapper (Nb_Prim);
4925 -- for DT'Alignment use Address'Alignment;
4926 -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
4929 -- If the tagged type has no primitives we add a dummy slot
4930 -- whose address will be the tag of this type.
4934 New_List (Make_Integer_Literal (Loc, 1));
4937 New_List (Make_Integer_Literal (Loc, Nb_Prim));
4941 Make_Object_Declaration (Loc,
4942 Defining_Identifier => DT,
4943 Aliased_Present => True,
4944 Constant_Present => False,
4945 Object_Definition =>
4946 Make_Subtype_Indication (Loc,
4948 New_Occurrence_Of (RTE (RE_Dispatch_Table_Wrapper), Loc),
4950 Make_Index_Or_Discriminant_Constraint (Loc,
4951 Constraints => DT_Constr_List))));
4954 Make_Attribute_Definition_Clause (Loc,
4955 Name => New_Occurrence_Of (DT, Loc),
4956 Chars => Name_Alignment,
4958 Make_Attribute_Reference (Loc,
4960 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4961 Attribute_Name => Name_Alignment)));
4964 Make_Object_Declaration (Loc,
4965 Defining_Identifier => DT_Ptr,
4966 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc),
4967 Constant_Present => True,
4969 Unchecked_Convert_To (RTE (RE_Tag),
4970 Make_Attribute_Reference (Loc,
4972 Make_Selected_Component (Loc,
4973 Prefix => New_Occurrence_Of (DT, Loc),
4976 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
4977 Attribute_Name => Name_Address))));
4979 Set_Is_Statically_Allocated (DT_Ptr,
4980 Is_Library_Level_Tagged_Type (Typ));
4982 -- Generate the SCIL node for the previous object declaration
4983 -- because it has a tag initialization.
4985 if Generate_SCIL then
4987 Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
4988 Set_SCIL_Entity (New_Node, Typ);
4989 Set_SCIL_Node (Last (Result), New_Node);
4993 -- Gnat2scil has its own implementation of dispatch tables,
4994 -- different than what is being implemented here. Generating
4995 -- further dispatch table initialization code would just
4996 -- cause gnat2scil to generate useless Scil which CodePeer
4997 -- would waste time and space analyzing, so we skip it.
5001 Make_Object_Declaration (Loc,
5002 Defining_Identifier =>
5003 Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))),
5004 Constant_Present => True,
5005 Object_Definition =>
5006 New_Occurrence_Of (RTE (RE_Address), Loc),
5008 Make_Attribute_Reference (Loc,
5010 Make_Selected_Component (Loc,
5011 Prefix => New_Occurrence_Of (DT, Loc),
5014 (RTE_Record_Component (RE_Predef_Prims), Loc)),
5015 Attribute_Name => Name_Address)));
5019 -- Generate: Expanded_Name : constant String := "";
5021 if Discard_Names then
5023 Make_Object_Declaration (Loc,
5024 Defining_Identifier => Exname,
5025 Constant_Present => True,
5026 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
5028 Make_String_Literal (Loc, "")));
5030 -- Generate: Exname : constant String := full_qualified_name (typ);
5031 -- The type itself may be an anonymous parent type, so use the first
5032 -- subtype to have a user-recognizable name.
5036 Make_Object_Declaration (Loc,
5037 Defining_Identifier => Exname,
5038 Constant_Present => True,
5039 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
5041 Make_String_Literal (Loc,
5042 Fully_Qualified_Name_String (First_Subtype (Typ)))));
5045 Set_Is_Statically_Allocated (Exname);
5046 Set_Is_True_Constant (Exname);
5048 -- Declare the object used by Ada.Tags.Register_Tag
5050 if RTE_Available (RE_Register_Tag) then
5052 Make_Object_Declaration (Loc,
5053 Defining_Identifier => HT_Link,
5054 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc),
5055 Expression => New_Occurrence_Of (RTE (RE_No_Tag), Loc)));
5058 -- Generate code to create the storage for the type specific data object
5059 -- with enough space to store the tags of the ancestors plus the tags
5060 -- of all the implemented interfaces (as described in a-tags.adb).
5062 -- TSD : Type_Specific_Data (I_Depth) :=
5063 -- (Idepth => I_Depth,
5064 -- Access_Level => Type_Access_Level (Typ),
5065 -- Alignment => Typ'Alignment,
5066 -- Expanded_Name => Cstring_Ptr!(Exname'Address))
5067 -- External_Tag => Cstring_Ptr!(Exname'Address))
5068 -- HT_Link => HT_Link'Address,
5069 -- Transportable => <<boolean-value>>,
5070 -- Is_Abstract => <<boolean-value>>,
5071 -- Needs_Finalization => <<boolean-value>>,
5072 -- [ Size_Func => Size_Prim'Access, ]
5073 -- [ Interfaces_Table => <<access-value>>, ]
5074 -- [ SSD => SSD_Table'Address ]
5075 -- Tags_Table => (0 => null,
5078 -- for TSD'Alignment use Address'Alignment
5080 TSD_Aggr_List := New_List;
5082 -- Idepth: Count ancestors to compute the inheritance depth. For private
5083 -- extensions, always go to the full view in order to compute the real
5084 -- inheritance depth.
5087 Current_Typ : Entity_Id;
5088 Parent_Typ : Entity_Id;
5094 Parent_Typ := Etype (Current_Typ);
5096 if Is_Private_Type (Parent_Typ) then
5097 Parent_Typ := Full_View (Base_Type (Parent_Typ));
5100 exit when Parent_Typ = Current_Typ;
5102 I_Depth := I_Depth + 1;
5103 Current_Typ := Parent_Typ;
5107 Append_To (TSD_Aggr_List,
5108 Make_Integer_Literal (Loc, I_Depth));
5112 Append_To (TSD_Aggr_List,
5113 Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
5117 -- For CPP types we cannot rely on the value of 'Alignment provided
5118 -- by the backend to initialize this TSD field.
5120 if Convention (Typ) = Convention_CPP
5121 or else Is_CPP_Class (Root_Type (Typ))
5123 Append_To (TSD_Aggr_List,
5124 Make_Integer_Literal (Loc, 0));
5126 Append_To (TSD_Aggr_List,
5127 Make_Attribute_Reference (Loc,
5128 Prefix => New_Occurrence_Of (Typ, Loc),
5129 Attribute_Name => Name_Alignment));
5134 Append_To (TSD_Aggr_List,
5135 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5136 Make_Attribute_Reference (Loc,
5137 Prefix => New_Occurrence_Of (Exname, Loc),
5138 Attribute_Name => Name_Address)));
5140 -- External_Tag of a local tagged type
5142 -- <typ>A : constant String :=
5143 -- "Internal tag at 16#tag-addr#: <full-name-of-typ>";
5145 -- The reason we generate this strange name is that we do not want to
5146 -- enter local tagged types in the global hash table used to compute
5147 -- the Internal_Tag attribute for two reasons:
5149 -- 1. It is hard to avoid a tasking race condition for entering the
5150 -- entry into the hash table.
5152 -- 2. It would cause a storage leak, unless we rig up considerable
5153 -- mechanism to remove the entry from the hash table on exit.
5155 -- So what we do is to generate the above external tag name, where the
5156 -- hex address is the address of the local dispatch table (i.e. exactly
5157 -- the value we want if Internal_Tag is computed from this string).
5159 -- Of course this value will only be valid if the tagged type is still
5160 -- in scope, but it clearly must be erroneous to compute the internal
5161 -- tag of a tagged type that is out of scope.
5163 -- We don't do this processing if an explicit external tag has been
5164 -- specified. That's an odd case for which we have already issued a
5165 -- warning, where we will not be able to compute the internal tag.
5167 if not Discard_Names
5168 and then not Is_Library_Level_Entity (Typ)
5169 and then not Has_External_Tag_Rep_Clause (Typ)
5172 Exname : constant Entity_Id :=
5173 Make_Defining_Identifier (Loc,
5174 Chars => New_External_Name (Tname, 'A'));
5175 Full_Name : constant String_Id :=
5176 Fully_Qualified_Name_String (First_Subtype (Typ));
5177 Str1_Id : String_Id;
5178 Str2_Id : String_Id;
5182 -- Str1 = "Internal tag at 16#";
5185 Store_String_Chars ("Internal tag at 16#");
5186 Str1_Id := End_String;
5189 -- Str2 = "#: <type-full-name>";
5192 Store_String_Chars ("#: ");
5193 Store_String_Chars (Full_Name);
5194 Str2_Id := End_String;
5197 -- Exname : constant String :=
5198 -- Str1 & Address_Image (Tag) & Str2;
5200 if RTE_Available (RE_Address_Image) then
5202 Make_Object_Declaration (Loc,
5203 Defining_Identifier => Exname,
5204 Constant_Present => True,
5205 Object_Definition => New_Occurrence_Of
5206 (Standard_String, Loc),
5208 Make_Op_Concat (Loc,
5209 Left_Opnd => Make_String_Literal (Loc, Str1_Id),
5211 Make_Op_Concat (Loc,
5213 Make_Function_Call (Loc,
5216 (RTE (RE_Address_Image), Loc),
5217 Parameter_Associations => New_List (
5218 Unchecked_Convert_To (RTE (RE_Address),
5219 New_Occurrence_Of (DT_Ptr, Loc)))),
5221 Make_String_Literal (Loc, Str2_Id)))));
5224 -- Exname : constant String := Str1 & Str2;
5228 Make_Object_Declaration (Loc,
5229 Defining_Identifier => Exname,
5230 Constant_Present => True,
5231 Object_Definition =>
5232 New_Occurrence_Of (Standard_String, Loc),
5234 Make_Op_Concat (Loc,
5235 Left_Opnd => Make_String_Literal (Loc, Str1_Id),
5236 Right_Opnd => Make_String_Literal (Loc, Str2_Id))));
5240 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5241 Make_Attribute_Reference (Loc,
5242 Prefix => New_Occurrence_Of (Exname, Loc),
5243 Attribute_Name => Name_Address));
5246 -- External tag of a library-level tagged type: Check for a definition
5247 -- of External_Tag. The clause is considered only if it applies to this
5248 -- specific tagged type, as opposed to one of its ancestors.
5249 -- If the type is an unconstrained type extension, we are building the
5250 -- dispatch table of its anonymous base type, so the external tag, if
5251 -- any was specified, must be retrieved from the first subtype. Go to
5252 -- the full view in case the clause is in the private part.
5256 Def : constant Node_Id := Get_Attribute_Definition_Clause
5257 (Underlying_Type (First_Subtype (Typ)),
5258 Attribute_External_Tag);
5260 Old_Val : String_Id;
5261 New_Val : String_Id;
5265 if not Present (Def)
5266 or else Entity (Name (Def)) /= First_Subtype (Typ)
5269 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5270 Make_Attribute_Reference (Loc,
5271 Prefix => New_Occurrence_Of (Exname, Loc),
5272 Attribute_Name => Name_Address));
5274 Old_Val := Strval (Expr_Value_S (Expression (Def)));
5276 -- For the rep clause "for <typ>'external_tag use y" generate:
5278 -- <typ>A : constant string := y;
5280 -- <typ>A'Address is used to set the External_Tag component
5283 -- Create a new nul terminated string if it is not already
5285 if String_Length (Old_Val) > 0
5287 Get_String_Char (Old_Val, String_Length (Old_Val)) = 0
5291 Start_String (Old_Val);
5292 Store_String_Char (Get_Char_Code (ASCII.NUL));
5293 New_Val := End_String;
5296 E := Make_Defining_Identifier (Loc,
5297 New_External_Name (Chars (Typ), 'A'));
5300 Make_Object_Declaration (Loc,
5301 Defining_Identifier => E,
5302 Constant_Present => True,
5303 Object_Definition =>
5304 New_Occurrence_Of (Standard_String, Loc),
5306 Make_String_Literal (Loc, New_Val)));
5309 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5310 Make_Attribute_Reference (Loc,
5311 Prefix => New_Occurrence_Of (E, Loc),
5312 Attribute_Name => Name_Address));
5317 Append_To (TSD_Aggr_List, New_Node);
5321 if RTE_Available (RE_Register_Tag) then
5322 Append_To (TSD_Aggr_List,
5323 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
5324 Make_Attribute_Reference (Loc,
5325 Prefix => New_Occurrence_Of (HT_Link, Loc),
5326 Attribute_Name => Name_Address)));
5328 elsif RTE_Record_Component_Available (RE_HT_Link) then
5329 Append_To (TSD_Aggr_List,
5330 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
5331 New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
5334 -- Transportable: Set for types that can be used in remote calls
5335 -- with respect to E.4(18) legality rules.
5338 Transportable : Entity_Id;
5344 or else Is_Shared_Passive (Typ)
5346 ((Is_Remote_Types (Typ)
5347 or else Is_Remote_Call_Interface (Typ))
5348 and then Original_View_In_Visible_Part (Typ))
5349 or else not Comes_From_Source (Typ));
5351 Append_To (TSD_Aggr_List,
5352 New_Occurrence_Of (Transportable, Loc));
5355 -- Is_Abstract (Ada 2012: AI05-0173). This functionality is not
5356 -- available in the HIE runtime.
5358 if RTE_Record_Component_Available (RE_Is_Abstract) then
5360 Is_Abstract : Entity_Id;
5362 Is_Abstract := Boolean_Literals (Is_Abstract_Type (Typ));
5363 Append_To (TSD_Aggr_List,
5364 New_Occurrence_Of (Is_Abstract, Loc));
5368 -- Needs_Finalization: Set if the type is controlled or has controlled
5372 Needs_Fin : Entity_Id;
5374 Needs_Fin := Boolean_Literals (Needs_Finalization (Typ));
5375 Append_To (TSD_Aggr_List, New_Occurrence_Of (Needs_Fin, Loc));
5380 if RTE_Record_Component_Available (RE_Size_Func) then
5382 -- Initialize this field to Null_Address if we are not building
5383 -- static dispatch tables static or if the size function is not
5384 -- available. In the former case we cannot initialize this field
5385 -- until the function is frozen and registered in the dispatch
5386 -- table (see Register_Primitive).
5388 if not Building_Static_DT (Typ) or else not Has_DT (Typ) then
5389 Append_To (TSD_Aggr_List,
5390 Unchecked_Convert_To (RTE (RE_Size_Ptr),
5391 New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
5395 Prim_Elmt : Elmt_Id;
5397 Size_Comp : Node_Id := Empty;
5400 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5401 while Present (Prim_Elmt) loop
5402 Prim := Node (Prim_Elmt);
5404 if Chars (Prim) = Name_uSize then
5405 Prim := Ultimate_Alias (Prim);
5407 if Is_Abstract_Subprogram (Prim) then
5409 Unchecked_Convert_To (RTE (RE_Size_Ptr),
5410 New_Occurrence_Of (RTE (RE_Null_Address), Loc));
5413 Unchecked_Convert_To (RTE (RE_Size_Ptr),
5414 Make_Attribute_Reference (Loc,
5415 Prefix => New_Occurrence_Of (Prim, Loc),
5416 Attribute_Name => Name_Unrestricted_Access));
5422 Next_Elmt (Prim_Elmt);
5425 pragma Assert (Present (Size_Comp));
5426 Append_To (TSD_Aggr_List, Size_Comp);
5431 -- Interfaces_Table (required for AI-405)
5433 if RTE_Record_Component_Available (RE_Interfaces_Table) then
5435 -- Count the number of interface types implemented by Typ
5437 Collect_Interfaces (Typ, Typ_Ifaces);
5439 AI := First_Elmt (Typ_Ifaces);
5440 while Present (AI) loop
5441 Num_Ifaces := Num_Ifaces + 1;
5445 if Num_Ifaces = 0 then
5446 Iface_Table_Node := Make_Null (Loc);
5448 -- Generate the Interface_Table object
5452 TSD_Ifaces_List : constant List_Id := New_List;
5454 Ifaces_List : Elist_Id := No_Elist;
5455 Ifaces_Comp_List : Elist_Id := No_Elist;
5456 Ifaces_Tag_List : Elist_Id;
5457 Offset_To_Top : Node_Id;
5458 Sec_DT_Tag : Node_Id;
5461 -- Collect interfaces information if we need to compute the
5462 -- offset to the top using the dummy object.
5464 if Present (Dummy_Object) then
5465 Collect_Interfaces_Info (Typ,
5466 Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List);
5469 AI := First_Elmt (Typ_Ifaces);
5470 while Present (AI) loop
5471 if Is_Ancestor (Node (AI), Typ, Use_Full_View => True) then
5472 Sec_DT_Tag := New_Occurrence_Of (DT_Ptr, Loc);
5477 (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
5478 pragma Assert (Has_Thunks (Node (Elmt)));
5480 while Is_Tag (Node (Elmt))
5482 Is_Ancestor (Node (AI), Related_Type (Node (Elmt)),
5483 Use_Full_View => True)
5485 pragma Assert (Has_Thunks (Node (Elmt)));
5487 pragma Assert (Has_Thunks (Node (Elmt)));
5489 pragma Assert (not Has_Thunks (Node (Elmt)));
5491 pragma Assert (not Has_Thunks (Node (Elmt)));
5495 pragma Assert (Ekind (Node (Elmt)) = E_Constant
5497 Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt)))));
5501 (Node (Next_Elmt (Next_Elmt (Elmt))), Loc);
5504 -- For static dispatch tables compute Offset_To_Top using
5505 -- the dummy object.
5507 if Present (Dummy_Object) then
5509 Iface : constant Node_Id := Node (AI);
5510 Iface_Comp : Node_Id := Empty;
5511 Iface_Comp_Elmt : Elmt_Id;
5512 Iface_Elmt : Elmt_Id;
5515 Iface_Elmt := First_Elmt (Ifaces_List);
5516 Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
5518 while Present (Iface_Elmt) loop
5519 if Node (Iface_Elmt) = Iface then
5520 Iface_Comp := Node (Iface_Comp_Elmt);
5524 Next_Elmt (Iface_Elmt);
5525 Next_Elmt (Iface_Comp_Elmt);
5528 pragma Assert (Present (Iface_Comp));
5532 Make_Attribute_Reference (Loc,
5534 Make_Selected_Component (Loc,
5536 New_Occurrence_Of (Dummy_Object, Loc),
5538 New_Occurrence_Of (Iface_Comp, Loc)),
5539 Attribute_Name => Name_Position));
5542 Offset_To_Top := Make_Integer_Literal (Loc, 0);
5545 Append_To (TSD_Ifaces_List,
5546 Make_Aggregate (Loc,
5547 Expressions => New_List (
5551 Unchecked_Convert_To (RTE (RE_Tag),
5553 (Node (First_Elmt (Access_Disp_Table (Node (AI)))),
5556 -- Static_Offset_To_Top
5558 New_Occurrence_Of (Standard_True, Loc),
5560 -- Offset_To_Top_Value
5564 -- Offset_To_Top_Func
5570 Unchecked_Convert_To (RTE (RE_Tag), Sec_DT_Tag))));
5575 Name_ITable := New_External_Name (Tname, 'I');
5576 ITable := Make_Defining_Identifier (Loc, Name_ITable);
5577 Set_Is_Statically_Allocated (ITable,
5578 Is_Library_Level_Tagged_Type (Typ));
5580 -- The table of interfaces is constant if we are building a
5581 -- static dispatch table; otherwise is not constant because
5582 -- its slots are filled at run time by the IP routine.
5585 Make_Object_Declaration (Loc,
5586 Defining_Identifier => ITable,
5587 Aliased_Present => True,
5588 Constant_Present => Present (Dummy_Object),
5589 Object_Definition =>
5590 Make_Subtype_Indication (Loc,
5592 New_Occurrence_Of (RTE (RE_Interface_Data), Loc),
5594 Make_Index_Or_Discriminant_Constraint (Loc,
5595 Constraints => New_List (
5596 Make_Integer_Literal (Loc, Num_Ifaces)))),
5599 Make_Aggregate (Loc,
5600 Expressions => New_List (
5601 Make_Integer_Literal (Loc, Num_Ifaces),
5602 Make_Aggregate (Loc, TSD_Ifaces_List)))));
5605 Make_Attribute_Definition_Clause (Loc,
5606 Name => New_Occurrence_Of (ITable, Loc),
5607 Chars => Name_Alignment,
5609 Make_Attribute_Reference (Loc,
5611 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5612 Attribute_Name => Name_Alignment)));
5615 Make_Attribute_Reference (Loc,
5616 Prefix => New_Occurrence_Of (ITable, Loc),
5617 Attribute_Name => Name_Unchecked_Access);
5621 Append_To (TSD_Aggr_List, Iface_Table_Node);
5624 -- Generate the Select Specific Data table for synchronized types that
5625 -- implement synchronized interfaces. The size of the table is
5626 -- constrained by the number of non-predefined primitive operations.
5628 if RTE_Record_Component_Available (RE_SSD) then
5629 if Ada_Version >= Ada_2005
5630 and then Has_DT (Typ)
5631 and then Is_Concurrent_Record_Type (Typ)
5632 and then Has_Interfaces (Typ)
5633 and then Nb_Prim > 0
5634 and then not Is_Abstract_Type (Typ)
5635 and then not Is_Controlled (Typ)
5636 and then not Restriction_Active (No_Dispatching_Calls)
5637 and then not Restriction_Active (No_Select_Statements)
5640 Make_Object_Declaration (Loc,
5641 Defining_Identifier => SSD,
5642 Aliased_Present => True,
5643 Object_Definition =>
5644 Make_Subtype_Indication (Loc,
5645 Subtype_Mark => New_Occurrence_Of (
5646 RTE (RE_Select_Specific_Data), Loc),
5648 Make_Index_Or_Discriminant_Constraint (Loc,
5649 Constraints => New_List (
5650 Make_Integer_Literal (Loc, Nb_Prim))))));
5653 Make_Attribute_Definition_Clause (Loc,
5654 Name => New_Occurrence_Of (SSD, Loc),
5655 Chars => Name_Alignment,
5657 Make_Attribute_Reference (Loc,
5659 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5660 Attribute_Name => Name_Alignment)));
5662 -- This table is initialized by Make_Select_Specific_Data_Table,
5663 -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
5665 Append_To (TSD_Aggr_List,
5666 Make_Attribute_Reference (Loc,
5667 Prefix => New_Occurrence_Of (SSD, Loc),
5668 Attribute_Name => Name_Unchecked_Access));
5670 Append_To (TSD_Aggr_List, Make_Null (Loc));
5674 -- Initialize the table of ancestor tags. In case of interface types
5675 -- this table is not needed.
5677 TSD_Tags_List := New_List;
5679 -- If we are not statically allocating the dispatch table then we must
5680 -- fill position 0 with null because we still have not generated the
5683 if not Building_Static_DT (Typ)
5684 or else Is_Interface (Typ)
5686 Append_To (TSD_Tags_List,
5687 Unchecked_Convert_To (RTE (RE_Tag),
5688 New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
5690 -- Otherwise we can safely reference the tag
5693 Append_To (TSD_Tags_List,
5694 New_Occurrence_Of (DT_Ptr, Loc));
5697 -- Fill the rest of the table with the tags of the ancestors
5700 Current_Typ : Entity_Id;
5701 Parent_Typ : Entity_Id;
5709 Parent_Typ := Etype (Current_Typ);
5711 if Is_Private_Type (Parent_Typ) then
5712 Parent_Typ := Full_View (Base_Type (Parent_Typ));
5715 exit when Parent_Typ = Current_Typ;
5717 if Is_CPP_Class (Parent_Typ) then
5719 -- The tags defined in the C++ side will be inherited when
5720 -- the object is constructed (Exp_Ch3.Build_Init_Procedure)
5722 Append_To (TSD_Tags_List,
5723 Unchecked_Convert_To (RTE (RE_Tag),
5724 New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
5726 Append_To (TSD_Tags_List,
5728 (Node (First_Elmt (Access_Disp_Table (Parent_Typ))),
5733 Current_Typ := Parent_Typ;
5736 pragma Assert (Pos = I_Depth + 1);
5739 Append_To (TSD_Aggr_List,
5740 Make_Aggregate (Loc,
5741 Expressions => TSD_Tags_List));
5743 -- Build the TSD object
5746 Make_Object_Declaration (Loc,
5747 Defining_Identifier => TSD,
5748 Aliased_Present => True,
5749 Constant_Present => Building_Static_DT (Typ),
5750 Object_Definition =>
5751 Make_Subtype_Indication (Loc,
5752 Subtype_Mark => New_Occurrence_Of (
5753 RTE (RE_Type_Specific_Data), Loc),
5755 Make_Index_Or_Discriminant_Constraint (Loc,
5756 Constraints => New_List (
5757 Make_Integer_Literal (Loc, I_Depth)))),
5759 Expression => Make_Aggregate (Loc,
5760 Expressions => TSD_Aggr_List)));
5762 Set_Is_True_Constant (TSD, Building_Static_DT (Typ));
5765 Make_Attribute_Definition_Clause (Loc,
5766 Name => New_Occurrence_Of (TSD, Loc),
5767 Chars => Name_Alignment,
5769 Make_Attribute_Reference (Loc,
5771 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5772 Attribute_Name => Name_Alignment)));
5774 -- Initialize or declare the dispatch table object
5776 if not Has_DT (Typ) then
5777 DT_Constr_List := New_List;
5778 DT_Aggr_List := New_List;
5783 Make_Attribute_Reference (Loc,
5784 Prefix => New_Occurrence_Of (TSD, Loc),
5785 Attribute_Name => Name_Address);
5787 Append_To (DT_Constr_List, New_Node);
5788 Append_To (DT_Aggr_List, New_Copy (New_Node));
5789 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
5791 -- In case of locally defined tagged types we have already declared
5792 -- and uninitialized object for the dispatch table, which is now
5793 -- initialized by means of the following assignment:
5795 -- DT := (TSD'Address, 0);
5797 if not Building_Static_DT (Typ) then
5799 Make_Assignment_Statement (Loc,
5800 Name => New_Occurrence_Of (DT, Loc),
5801 Expression => Make_Aggregate (Loc, DT_Aggr_List)));
5803 -- In case of library level tagged types we declare and export now
5804 -- the constant object containing the dummy dispatch table. There
5805 -- is no need to declare the tag here because it has been previously
5806 -- declared by Make_Tags
5808 -- DT : aliased constant No_Dispatch_Table :=
5809 -- (NDT_TSD => TSD'Address;
5810 -- NDT_Prims_Ptr => 0);
5811 -- for DT'Alignment use Address'Alignment;
5815 Make_Object_Declaration (Loc,
5816 Defining_Identifier => DT,
5817 Aliased_Present => True,
5818 Constant_Present => True,
5819 Object_Definition =>
5820 New_Occurrence_Of (RTE (RE_No_Dispatch_Table_Wrapper), Loc),
5821 Expression => Make_Aggregate (Loc, DT_Aggr_List)));
5824 Make_Attribute_Definition_Clause (Loc,
5825 Name => New_Occurrence_Of (DT, Loc),
5826 Chars => Name_Alignment,
5828 Make_Attribute_Reference (Loc,
5830 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5831 Attribute_Name => Name_Alignment)));
5833 Export_DT (Typ, DT);
5836 -- Common case: Typ has a dispatch table
5840 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
5841 -- (predef-prim-op-1'address,
5842 -- predef-prim-op-2'address,
5844 -- predef-prim-op-n'address);
5845 -- for Predef_Prims'Alignment use Address'Alignment
5847 -- DT : Dispatch_Table (Nb_Prims) :=
5848 -- (Signature => <sig-value>,
5849 -- Tag_Kind => <tag_kind-value>,
5850 -- Predef_Prims => Predef_Prims'First'Address,
5851 -- Offset_To_Top => 0,
5852 -- TSD => TSD'Address;
5853 -- Prims_Ptr => (prim-op-1'address,
5854 -- prim-op-2'address,
5856 -- prim-op-n'address));
5857 -- for DT'Alignment use Address'Alignment
5864 if not Building_Static_DT (Typ) then
5865 Nb_Predef_Prims := Max_Predef_Prims;
5868 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5869 while Present (Prim_Elmt) loop
5870 Prim := Node (Prim_Elmt);
5872 if Is_Predefined_Dispatching_Operation (Prim)
5873 and then not Is_Abstract_Subprogram (Prim)
5875 Pos := UI_To_Int (DT_Position (Prim));
5877 if Pos > Nb_Predef_Prims then
5878 Nb_Predef_Prims := Pos;
5882 Next_Elmt (Prim_Elmt);
5888 (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
5893 Prim_Ops_Aggr_List := New_List;
5895 Prim_Table := (others => Empty);
5897 if Building_Static_DT (Typ) then
5898 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5899 while Present (Prim_Elmt) loop
5900 Prim := Node (Prim_Elmt);
5902 if Is_Predefined_Dispatching_Operation (Prim)
5903 and then not Is_Abstract_Subprogram (Prim)
5904 and then not Is_Eliminated (Prim)
5905 and then not Present (Prim_Table
5906 (UI_To_Int (DT_Position (Prim))))
5908 E := Ultimate_Alias (Prim);
5909 pragma Assert (not Is_Abstract_Subprogram (E));
5910 Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
5913 Next_Elmt (Prim_Elmt);
5917 for J in Prim_Table'Range loop
5918 if Present (Prim_Table (J)) then
5920 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
5921 Make_Attribute_Reference (Loc,
5923 New_Occurrence_Of (Prim_Table (J), Loc),
5924 Attribute_Name => Name_Unrestricted_Access));
5926 New_Node := Make_Null (Loc);
5929 Append_To (Prim_Ops_Aggr_List, New_Node);
5933 Make_Aggregate (Loc,
5934 Expressions => Prim_Ops_Aggr_List);
5937 Make_Subtype_Declaration (Loc,
5938 Defining_Identifier => Make_Temporary (Loc, 'S'),
5939 Subtype_Indication =>
5940 New_Occurrence_Of (RTE (RE_Address_Array), Loc));
5942 Append_To (Result, Decl);
5945 Make_Object_Declaration (Loc,
5946 Defining_Identifier => Predef_Prims,
5947 Aliased_Present => True,
5948 Constant_Present => Building_Static_DT (Typ),
5949 Object_Definition =>
5950 New_Occurrence_Of (Defining_Identifier (Decl), Loc),
5951 Expression => New_Node));
5953 -- Remember aggregates initializing dispatch tables
5955 Append_Elmt (New_Node, DT_Aggr);
5958 Make_Attribute_Definition_Clause (Loc,
5959 Name => New_Occurrence_Of (Predef_Prims, Loc),
5960 Chars => Name_Alignment,
5962 Make_Attribute_Reference (Loc,
5964 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5965 Attribute_Name => Name_Alignment)));
5969 -- Stage 1: Initialize the discriminant and the record components
5971 DT_Constr_List := New_List;
5972 DT_Aggr_List := New_List;
5974 -- Num_Prims. If the tagged type has no primitives we add a dummy
5975 -- slot whose address will be the tag of this type.
5978 New_Node := Make_Integer_Literal (Loc, 1);
5980 New_Node := Make_Integer_Literal (Loc, Nb_Prim);
5983 Append_To (DT_Constr_List, New_Node);
5984 Append_To (DT_Aggr_List, New_Copy (New_Node));
5988 if RTE_Record_Component_Available (RE_Signature) then
5989 Append_To (DT_Aggr_List,
5990 New_Occurrence_Of (RTE (RE_Primary_DT), Loc));
5995 if RTE_Record_Component_Available (RE_Tag_Kind) then
5996 Append_To (DT_Aggr_List, Tagged_Kind (Typ));
6001 Append_To (DT_Aggr_List,
6002 Make_Attribute_Reference (Loc,
6003 Prefix => New_Occurrence_Of (Predef_Prims, Loc),
6004 Attribute_Name => Name_Address));
6008 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
6012 Append_To (DT_Aggr_List,
6013 Make_Attribute_Reference (Loc,
6014 Prefix => New_Occurrence_Of (TSD, Loc),
6015 Attribute_Name => Name_Address));
6017 -- Stage 2: Initialize the table of user-defined primitive operations
6019 Prim_Ops_Aggr_List := New_List;
6022 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
6024 elsif not Building_Static_DT (Typ) then
6025 for J in 1 .. Nb_Prim loop
6026 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
6031 CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
6034 Prim_Elmt : Elmt_Id;
6036 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
6039 Prim_Table := (others => Empty);
6041 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6042 while Present (Prim_Elmt) loop
6043 Prim := Node (Prim_Elmt);
6045 -- Retrieve the ultimate alias of the primitive for proper
6046 -- handling of renamings and eliminated primitives.
6048 E := Ultimate_Alias (Prim);
6050 -- If the alias is not a primitive operation then Prim does
6051 -- not rename another primitive, but rather an operation
6052 -- declared elsewhere (e.g. in another scope) and therefore
6053 -- Prim is a new primitive.
6055 if No (Find_Dispatching_Type (E)) then
6059 Prim_Pos := UI_To_Int (DT_Position (E));
6061 -- Skip predefined primitives because they are located in a
6062 -- separate dispatch table.
6064 if not Is_Predefined_Dispatching_Operation (Prim)
6065 and then not Is_Predefined_Dispatching_Operation (E)
6067 -- Skip entities with attribute Interface_Alias because
6068 -- those are only required to build secondary dispatch
6071 and then not Present (Interface_Alias (Prim))
6073 -- Skip abstract and eliminated primitives
6075 and then not Is_Abstract_Subprogram (E)
6076 and then not Is_Eliminated (E)
6078 -- For derivations of CPP types skip primitives located in
6079 -- the C++ part of the dispatch table because their slots
6080 -- are initialized by the IC routine.
6082 and then (not Is_CPP_Class (Root_Type (Typ))
6083 or else Prim_Pos > CPP_Nb_Prims)
6085 -- Skip ignored Ghost subprograms as those will be removed
6086 -- from the executable.
6088 and then not Is_Ignored_Ghost_Entity (E)
6091 (UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
6093 Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
6096 Next_Elmt (Prim_Elmt);
6099 for J in Prim_Table'Range loop
6100 if Present (Prim_Table (J)) then
6102 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6103 Make_Attribute_Reference (Loc,
6105 New_Occurrence_Of (Prim_Table (J), Loc),
6106 Attribute_Name => Name_Unrestricted_Access));
6108 New_Node := Make_Null (Loc);
6111 Append_To (Prim_Ops_Aggr_List, New_Node);
6117 Make_Aggregate (Loc,
6118 Expressions => Prim_Ops_Aggr_List);
6120 Append_To (DT_Aggr_List, New_Node);
6122 -- Remember aggregates initializing dispatch tables
6124 Append_Elmt (New_Node, DT_Aggr);
6126 -- In case of locally defined tagged types we have already declared
6127 -- and uninitialized object for the dispatch table, which is now
6128 -- initialized by means of an assignment.
6130 if not Building_Static_DT (Typ) then
6132 Make_Assignment_Statement (Loc,
6133 Name => New_Occurrence_Of (DT, Loc),
6134 Expression => Make_Aggregate (Loc, DT_Aggr_List)));
6136 -- In case of library level tagged types we declare now and export
6137 -- the constant object containing the dispatch table.
6141 Make_Object_Declaration (Loc,
6142 Defining_Identifier => DT,
6143 Aliased_Present => True,
6144 Constant_Present => True,
6145 Object_Definition =>
6146 Make_Subtype_Indication (Loc,
6147 Subtype_Mark => New_Occurrence_Of
6148 (RTE (RE_Dispatch_Table_Wrapper), Loc),
6149 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
6150 Constraints => DT_Constr_List)),
6151 Expression => Make_Aggregate (Loc, DT_Aggr_List)));
6154 Make_Attribute_Definition_Clause (Loc,
6155 Name => New_Occurrence_Of (DT, Loc),
6156 Chars => Name_Alignment,
6158 Make_Attribute_Reference (Loc,
6160 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
6161 Attribute_Name => Name_Alignment)));
6163 Export_DT (Typ, DT);
6167 -- Initialize the table of ancestor tags if not building static
6170 if not Building_Static_DT (Typ)
6171 and then not Is_Interface (Typ)
6172 and then not Is_CPP_Class (Typ)
6175 Make_Assignment_Statement (Loc,
6177 Make_Indexed_Component (Loc,
6179 Make_Selected_Component (Loc,
6180 Prefix => New_Occurrence_Of (TSD, Loc),
6183 (RTE_Record_Component (RE_Tags_Table), Loc)),
6185 New_List (Make_Integer_Literal (Loc, 0))),
6189 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
6192 -- Inherit the dispatch tables of the parent. There is no need to
6193 -- inherit anything from the parent when building static dispatch tables
6194 -- because the whole dispatch table (including inherited primitives) has
6195 -- been already built.
6197 if Building_Static_DT (Typ) then
6200 -- If the ancestor is a CPP_Class type we inherit the dispatch tables
6201 -- in the init proc, and we don't need to fill them in here.
6203 elsif Is_CPP_Class (Parent_Typ) then
6206 -- Otherwise we fill in the dispatch tables here
6209 if Typ /= Parent_Typ
6210 and then not Is_Interface (Typ)
6211 and then not Restriction_Active (No_Dispatching_Calls)
6213 -- Inherit the dispatch table
6215 if not Is_Interface (Typ)
6216 and then not Is_Interface (Parent_Typ)
6217 and then not Is_CPP_Class (Parent_Typ)
6220 Nb_Prims : constant Int :=
6221 UI_To_Int (DT_Entry_Count
6222 (First_Tag_Component (Parent_Typ)));
6225 Append_To (Elab_Code,
6226 Build_Inherit_Predefined_Prims (Loc,
6232 (Access_Disp_Table (Parent_Typ)))), Loc),
6238 (Access_Disp_Table (Typ)))), Loc)));
6240 if Nb_Prims /= 0 then
6241 Append_To (Elab_Code,
6242 Build_Inherit_Prims (Loc,
6248 (Access_Disp_Table (Parent_Typ))), Loc),
6249 New_Tag_Node => New_Occurrence_Of (DT_Ptr, Loc),
6250 Num_Prims => Nb_Prims));
6255 -- Inherit the secondary dispatch tables of the ancestor
6257 if not Is_CPP_Class (Parent_Typ) then
6259 Sec_DT_Ancestor : Elmt_Id :=
6265 Sec_DT_Typ : Elmt_Id :=
6269 (Access_Disp_Table (Typ))));
6271 procedure Copy_Secondary_DTs (Typ : Entity_Id);
6272 -- Local procedure required to climb through the ancestors
6273 -- and copy the contents of all their secondary dispatch
6276 ------------------------
6277 -- Copy_Secondary_DTs --
6278 ------------------------
6280 procedure Copy_Secondary_DTs (Typ : Entity_Id) is
6285 -- Climb to the ancestor (if any) handling private types
6287 if Present (Full_View (Etype (Typ))) then
6288 if Full_View (Etype (Typ)) /= Typ then
6289 Copy_Secondary_DTs (Full_View (Etype (Typ)));
6292 elsif Etype (Typ) /= Typ then
6293 Copy_Secondary_DTs (Etype (Typ));
6296 if Present (Interfaces (Typ))
6297 and then not Is_Empty_Elmt_List (Interfaces (Typ))
6299 Iface := First_Elmt (Interfaces (Typ));
6300 E := First_Entity (Typ);
6302 and then Present (Node (Sec_DT_Ancestor))
6303 and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
6305 if Is_Tag (E) and then Chars (E) /= Name_uTag then
6307 Num_Prims : constant Int :=
6308 UI_To_Int (DT_Entry_Count (E));
6311 if not Is_Interface (Etype (Typ)) then
6313 -- Inherit first secondary dispatch table
6315 Append_To (Elab_Code,
6316 Build_Inherit_Predefined_Prims (Loc,
6318 Unchecked_Convert_To (RTE (RE_Tag),
6321 (Next_Elmt (Sec_DT_Ancestor)),
6324 Unchecked_Convert_To (RTE (RE_Tag),
6326 (Node (Next_Elmt (Sec_DT_Typ)),
6329 if Num_Prims /= 0 then
6330 Append_To (Elab_Code,
6331 Build_Inherit_Prims (Loc,
6332 Typ => Node (Iface),
6334 Unchecked_Convert_To
6337 (Node (Sec_DT_Ancestor),
6340 Unchecked_Convert_To
6343 (Node (Sec_DT_Typ), Loc)),
6344 Num_Prims => Num_Prims));
6348 Next_Elmt (Sec_DT_Ancestor);
6349 Next_Elmt (Sec_DT_Typ);
6351 -- Skip the secondary dispatch table of
6352 -- predefined primitives
6354 Next_Elmt (Sec_DT_Ancestor);
6355 Next_Elmt (Sec_DT_Typ);
6357 if not Is_Interface (Etype (Typ)) then
6359 -- Inherit second secondary dispatch table
6361 Append_To (Elab_Code,
6362 Build_Inherit_Predefined_Prims (Loc,
6364 Unchecked_Convert_To (RTE (RE_Tag),
6367 (Next_Elmt (Sec_DT_Ancestor)),
6370 Unchecked_Convert_To (RTE (RE_Tag),
6372 (Node (Next_Elmt (Sec_DT_Typ)),
6375 if Num_Prims /= 0 then
6376 Append_To (Elab_Code,
6377 Build_Inherit_Prims (Loc,
6378 Typ => Node (Iface),
6380 Unchecked_Convert_To
6383 (Node (Sec_DT_Ancestor),
6386 Unchecked_Convert_To
6389 (Node (Sec_DT_Typ), Loc)),
6390 Num_Prims => Num_Prims));
6395 Next_Elmt (Sec_DT_Ancestor);
6396 Next_Elmt (Sec_DT_Typ);
6398 -- Skip the secondary dispatch table of
6399 -- predefined primitives
6401 Next_Elmt (Sec_DT_Ancestor);
6402 Next_Elmt (Sec_DT_Typ);
6410 end Copy_Secondary_DTs;
6413 if Present (Node (Sec_DT_Ancestor))
6414 and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
6416 -- Handle private types
6418 if Present (Full_View (Typ)) then
6419 Copy_Secondary_DTs (Full_View (Typ));
6421 Copy_Secondary_DTs (Typ);
6429 -- Generate code to check if the external tag of this type is the same
6430 -- as the external tag of some other declaration.
6432 -- Check_TSD (TSD'Unrestricted_Access);
6434 -- This check is a consequence of AI05-0113-1/06, so it officially
6435 -- applies to Ada 2005 (and Ada 2012). It might be argued that it is
6436 -- a desirable check to add in Ada 95 mode, but we hesitate to make
6437 -- this change, as it would be incompatible, and could conceivably
6438 -- cause a problem in existing Ada 95 code.
6440 -- We check for No_Run_Time_Mode here, because we do not want to pick
6441 -- up the RE_Check_TSD entity and call it in No_Run_Time mode.
6443 -- We cannot perform this check if the generation of its expanded name
6446 if not No_Run_Time_Mode
6447 and then not Discard_Names
6448 and then Ada_Version >= Ada_2005
6449 and then RTE_Available (RE_Check_TSD)
6450 and then not Duplicated_Tag_Checks_Suppressed (Typ)
6452 Append_To (Elab_Code,
6453 Make_Procedure_Call_Statement (Loc,
6455 New_Occurrence_Of (RTE (RE_Check_TSD), Loc),
6456 Parameter_Associations => New_List (
6457 Make_Attribute_Reference (Loc,
6458 Prefix => New_Occurrence_Of (TSD, Loc),
6459 Attribute_Name => Name_Unchecked_Access))));
6462 -- Generate code to register the Tag in the External_Tag hash table for
6463 -- the pure Ada type only.
6465 -- Register_Tag (Dt_Ptr);
6467 -- Skip this action in the following cases:
6468 -- 1) if Register_Tag is not available.
6469 -- 2) in No_Run_Time mode.
6470 -- 3) if Typ is not defined at the library level (this is required
6471 -- to avoid adding concurrency control to the hash table used
6472 -- by the run-time to register the tags).
6474 if not No_Run_Time_Mode
6475 and then Is_Library_Level_Entity (Typ)
6476 and then RTE_Available (RE_Register_Tag)
6478 Append_To (Elab_Code,
6479 Make_Procedure_Call_Statement (Loc,
6481 New_Occurrence_Of (RTE (RE_Register_Tag), Loc),
6482 Parameter_Associations =>
6483 New_List (New_Occurrence_Of (DT_Ptr, Loc))));
6486 if not Is_Empty_List (Elab_Code) then
6487 Append_List_To (Result, Elab_Code);
6490 -- Populate the two auxiliary tables used for dispatching asynchronous,
6491 -- conditional and timed selects for synchronized types that implement
6492 -- a limited interface. Skip this step in Ravenscar profile or when
6493 -- general dispatching is forbidden.
6495 if Ada_Version >= Ada_2005
6496 and then Is_Concurrent_Record_Type (Typ)
6497 and then Has_Interfaces (Typ)
6498 and then not Restriction_Active (No_Dispatching_Calls)
6499 and then not Restriction_Active (No_Select_Statements)
6501 Append_List_To (Result,
6502 Make_Select_Specific_Data_Table (Typ));
6505 -- Remember entities containing dispatch tables
6507 Append_Elmt (Predef_Prims, DT_Decl);
6508 Append_Elmt (DT, DT_Decl);
6510 Analyze_List (Result, Suppress => All_Checks);
6511 Set_Has_Dispatch_Table (Typ);
6513 -- Mark entities containing dispatch tables. Required by the backend to
6514 -- handle them properly.
6516 if Has_DT (Typ) then
6521 -- Object declarations
6523 Elmt := First_Elmt (DT_Decl);
6524 while Present (Elmt) loop
6525 Set_Is_Dispatch_Table_Entity (Node (Elmt));
6526 pragma Assert (Ekind (Etype (Node (Elmt))) = E_Array_Subtype
6527 or else Ekind (Etype (Node (Elmt))) = E_Record_Subtype);
6528 Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
6532 -- Aggregates initializing dispatch tables
6534 Elmt := First_Elmt (DT_Aggr);
6535 while Present (Elmt) loop
6536 Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
6544 -- Register the tagged type in the call graph nodes table
6546 Register_CG_Node (Typ);
6549 Restore_Ghost_Region (Saved_GM, Saved_IGR);
6554 -------------------------------------
6555 -- Make_Select_Specific_Data_Table --
6556 -------------------------------------
6558 function Make_Select_Specific_Data_Table
6559 (Typ : Entity_Id) return List_Id
6561 Assignments : constant List_Id := New_List;
6562 Loc : constant Source_Ptr := Sloc (Typ);
6564 Conc_Typ : Entity_Id;
6565 Decls : List_Id := No_List;
6567 Prim_Als : Entity_Id;
6568 Prim_Elmt : Elmt_Id;
6572 type Examined_Array is array (Int range <>) of Boolean;
6574 function Find_Entry_Index (E : Entity_Id) return Uint;
6575 -- Given an entry, find its index in the visible declarations of the
6576 -- corresponding concurrent type of Typ.
6578 ----------------------
6579 -- Find_Entry_Index --
6580 ----------------------
6582 function Find_Entry_Index (E : Entity_Id) return Uint is
6583 Index : Uint := Uint_1;
6584 Subp_Decl : Entity_Id;
6588 and then not Is_Empty_List (Decls)
6590 Subp_Decl := First (Decls);
6591 while Present (Subp_Decl) loop
6592 if Nkind (Subp_Decl) = N_Entry_Declaration then
6593 if Defining_Identifier (Subp_Decl) = E then
6605 end Find_Entry_Index;
6611 -- Start of processing for Make_Select_Specific_Data_Table
6614 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
6616 if Present (Corresponding_Concurrent_Type (Typ)) then
6617 Conc_Typ := Corresponding_Concurrent_Type (Typ);
6619 if Present (Full_View (Conc_Typ)) then
6620 Conc_Typ := Full_View (Conc_Typ);
6623 if Ekind (Conc_Typ) = E_Protected_Type then
6624 Decls := Visible_Declarations (Protected_Definition (
6625 Parent (Conc_Typ)));
6627 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
6628 Decls := Visible_Declarations (Task_Definition (
6629 Parent (Conc_Typ)));
6633 -- Count the non-predefined primitive operations
6635 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6636 while Present (Prim_Elmt) loop
6637 Prim := Node (Prim_Elmt);
6639 if not (Is_Predefined_Dispatching_Operation (Prim)
6640 or else Is_Predefined_Dispatching_Alias (Prim))
6642 Nb_Prim := Nb_Prim + 1;
6645 Next_Elmt (Prim_Elmt);
6649 Examined : Examined_Array (1 .. Nb_Prim) := (others => False);
6652 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6653 while Present (Prim_Elmt) loop
6654 Prim := Node (Prim_Elmt);
6656 -- Look for primitive overriding an abstract interface subprogram
6658 if Present (Interface_Alias (Prim))
6661 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
6662 Use_Full_View => True)
6663 and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
6665 Prim_Pos := DT_Position (Alias (Prim));
6666 pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
6667 Examined (UI_To_Int (Prim_Pos)) := True;
6669 -- Set the primitive operation kind regardless of subprogram
6671 -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
6673 if Tagged_Type_Expansion then
6676 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
6680 Make_Attribute_Reference (Loc,
6681 Prefix => New_Occurrence_Of (Typ, Loc),
6682 Attribute_Name => Name_Tag);
6685 Append_To (Assignments,
6686 Make_Procedure_Call_Statement (Loc,
6687 Name => New_Occurrence_Of (RTE (RE_Set_Prim_Op_Kind), Loc),
6688 Parameter_Associations => New_List (
6690 Make_Integer_Literal (Loc, Prim_Pos),
6691 Prim_Op_Kind (Alias (Prim), Typ))));
6693 -- Retrieve the root of the alias chain
6695 Prim_Als := Ultimate_Alias (Prim);
6697 -- In the case of an entry wrapper, set the entry index
6699 if Ekind (Prim) = E_Procedure
6700 and then Is_Primitive_Wrapper (Prim_Als)
6701 and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry
6704 -- Ada.Tags.Set_Entry_Index
6705 -- (DT_Ptr, <position>, <index>);
6707 if Tagged_Type_Expansion then
6710 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
6713 Make_Attribute_Reference (Loc,
6714 Prefix => New_Occurrence_Of (Typ, Loc),
6715 Attribute_Name => Name_Tag);
6718 Append_To (Assignments,
6719 Make_Procedure_Call_Statement (Loc,
6721 New_Occurrence_Of (RTE (RE_Set_Entry_Index), Loc),
6722 Parameter_Associations => New_List (
6724 Make_Integer_Literal (Loc, Prim_Pos),
6725 Make_Integer_Literal (Loc,
6726 Find_Entry_Index (Wrapped_Entity (Prim_Als))))));
6730 Next_Elmt (Prim_Elmt);
6735 end Make_Select_Specific_Data_Table;
6741 function Make_Tags (Typ : Entity_Id) return List_Id is
6742 Loc : constant Source_Ptr := Sloc (Typ);
6743 Result : constant List_Id := New_List;
6746 (Tag_Typ : Entity_Id;
6748 Is_Secondary_DT : Boolean);
6749 -- Import the dispatch table DT of tagged type Tag_Typ. Required to
6750 -- generate forward references and statically allocate the table. For
6751 -- primary dispatch tables that require no dispatch table generate:
6753 -- DT : static aliased constant Non_Dispatch_Table_Wrapper;
6754 -- pragma Import (Ada, DT);
6756 -- Otherwise generate:
6758 -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
6759 -- pragma Import (Ada, DT);
6766 (Tag_Typ : Entity_Id;
6768 Is_Secondary_DT : Boolean)
6770 DT_Constr_List : List_Id;
6774 Set_Is_Imported (DT);
6775 Set_Ekind (DT, E_Constant);
6776 Set_Related_Type (DT, Typ);
6778 -- The scope must be set now to call Get_External_Name
6780 Set_Scope (DT, Current_Scope);
6782 Get_External_Name (DT);
6783 Set_Interface_Name (DT,
6784 Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
6786 -- Ensure proper Sprint output of this implicit importation
6788 Set_Is_Internal (DT);
6790 -- Save this entity to allow Make_DT to generate its exportation
6792 Append_Elmt (DT, Dispatch_Table_Wrappers (Typ));
6794 -- No dispatch table required
6796 if not Is_Secondary_DT and then not Has_DT (Tag_Typ) then
6798 Make_Object_Declaration (Loc,
6799 Defining_Identifier => DT,
6800 Aliased_Present => True,
6801 Constant_Present => True,
6802 Object_Definition =>
6804 (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
6807 -- Calculate the number of primitives of the dispatch table and
6808 -- the size of the Type_Specific_Data record.
6811 UI_To_Int (DT_Entry_Count (First_Tag_Component (Tag_Typ)));
6813 -- If the tagged type has no primitives we add a dummy slot whose
6814 -- address will be the tag of this type.
6818 New_List (Make_Integer_Literal (Loc, 1));
6821 New_List (Make_Integer_Literal (Loc, Nb_Prim));
6825 Make_Object_Declaration (Loc,
6826 Defining_Identifier => DT,
6827 Aliased_Present => True,
6828 Constant_Present => True,
6829 Object_Definition =>
6830 Make_Subtype_Indication (Loc,
6832 New_Occurrence_Of (RTE (RE_Dispatch_Table_Wrapper), Loc),
6833 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
6834 Constraints => DT_Constr_List))));
6840 Tname : constant Name_Id := Chars (Typ);
6841 AI_Tag_Comp : Elmt_Id;
6842 DT : Node_Id := Empty;
6844 Predef_Prims_Ptr : Node_Id;
6845 Iface_DT : Node_Id := Empty;
6846 Iface_DT_Ptr : Node_Id;
6850 Typ_Comps : Elist_Id;
6852 -- Start of processing for Make_Tags
6855 pragma Assert (No (Access_Disp_Table (Typ)));
6856 Set_Access_Disp_Table (Typ, New_Elmt_List);
6858 -- If the elaboration of this tagged type needs a boolean flag then
6859 -- define now its entity. It is initialized to True to indicate that
6860 -- elaboration is still pending; set to False by the IP routine.
6862 -- TypFxx : boolean := True;
6864 if Elab_Flag_Needed (Typ) then
6865 Set_Access_Disp_Table_Elab_Flag (Typ,
6866 Make_Defining_Identifier (Loc,
6867 Chars => New_External_Name (Tname, 'F')));
6870 Make_Object_Declaration (Loc,
6871 Defining_Identifier => Access_Disp_Table_Elab_Flag (Typ),
6872 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
6873 Expression => New_Occurrence_Of (Standard_True, Loc)));
6876 -- 1) Generate the primary tag entities
6878 -- Primary dispatch table containing user-defined primitives
6880 DT_Ptr := Make_Defining_Identifier (Loc, New_External_Name (Tname, 'P'));
6881 Set_Etype (DT_Ptr, RTE (RE_Tag));
6882 Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
6884 -- Minimum decoration
6886 Set_Ekind (DT_Ptr, E_Variable);
6887 Set_Related_Type (DT_Ptr, Typ);
6889 -- Notify back end that the types are associated with a dispatch table
6891 Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr));
6892 Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr));
6894 -- For CPP types there is no need to build the dispatch tables since
6895 -- they are imported from the C++ side. If the CPP type has an IP then
6896 -- we declare now the variable that will store the copy of the C++ tag.
6897 -- If the CPP type is an interface, we need the variable as well because
6898 -- it becomes the pointer to the corresponding secondary table.
6900 if Is_CPP_Class (Typ) then
6901 if Has_CPP_Constructors (Typ) or else Is_Interface (Typ) then
6903 Make_Object_Declaration (Loc,
6904 Defining_Identifier => DT_Ptr,
6905 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc),
6907 Unchecked_Convert_To (RTE (RE_Tag),
6908 New_Occurrence_Of (RTE (RE_Null_Address), Loc))));
6910 Set_Is_Statically_Allocated (DT_Ptr,
6911 Is_Library_Level_Tagged_Type (Typ));
6917 -- Primary dispatch table containing predefined primitives
6920 Make_Defining_Identifier (Loc,
6921 Chars => New_External_Name (Tname, 'Y'));
6922 Set_Etype (Predef_Prims_Ptr, RTE (RE_Address));
6923 Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
6925 -- Import the forward declaration of the Dispatch Table wrapper
6926 -- record (Make_DT will take care of exporting it).
6928 if Building_Static_DT (Typ) then
6929 Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List);
6932 Make_Defining_Identifier (Loc,
6933 Chars => New_External_Name (Tname, 'T'));
6935 Import_DT (Typ, DT, Is_Secondary_DT => False);
6937 if Has_DT (Typ) then
6939 Make_Object_Declaration (Loc,
6940 Defining_Identifier => DT_Ptr,
6941 Constant_Present => True,
6942 Object_Definition =>
6943 New_Occurrence_Of (RTE (RE_Tag), Loc),
6945 Unchecked_Convert_To (RTE (RE_Tag),
6946 Make_Attribute_Reference (Loc,
6948 Make_Selected_Component (Loc,
6949 Prefix => New_Occurrence_Of (DT, Loc),
6952 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
6953 Attribute_Name => Name_Address))));
6955 -- Generate the SCIL node for the previous object declaration
6956 -- because it has a tag initialization.
6958 if Generate_SCIL then
6960 Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
6961 Set_SCIL_Entity (New_Node, Typ);
6962 Set_SCIL_Node (Last (Result), New_Node);
6966 Make_Object_Declaration (Loc,
6967 Defining_Identifier => Predef_Prims_Ptr,
6968 Constant_Present => True,
6969 Object_Definition =>
6970 New_Occurrence_Of (RTE (RE_Address), Loc),
6972 Make_Attribute_Reference (Loc,
6974 Make_Selected_Component (Loc,
6975 Prefix => New_Occurrence_Of (DT, Loc),
6978 (RTE_Record_Component (RE_Predef_Prims), Loc)),
6979 Attribute_Name => Name_Address)));
6981 -- No dispatch table required
6985 Make_Object_Declaration (Loc,
6986 Defining_Identifier => DT_Ptr,
6987 Constant_Present => True,
6988 Object_Definition =>
6989 New_Occurrence_Of (RTE (RE_Tag), Loc),
6991 Unchecked_Convert_To (RTE (RE_Tag),
6992 Make_Attribute_Reference (Loc,
6994 Make_Selected_Component (Loc,
6995 Prefix => New_Occurrence_Of (DT, Loc),
6998 (RTE_Record_Component (RE_NDT_Prims_Ptr),
7000 Attribute_Name => Name_Address))));
7003 Set_Is_True_Constant (DT_Ptr);
7004 Set_Is_Statically_Allocated (DT_Ptr);
7008 -- 2) Generate the secondary tag entities
7010 -- Collect the components associated with secondary dispatch tables
7012 if Has_Interfaces (Typ) then
7013 Collect_Interface_Components (Typ, Typ_Comps);
7015 -- For each interface type we build a unique external name associated
7016 -- with its secondary dispatch table. This name is used to declare an
7017 -- object that references this secondary dispatch table, whose value
7018 -- will be used for the elaboration of Typ objects, and also for the
7019 -- elaboration of objects of types derived from Typ that do not
7020 -- override the primitives of this interface type.
7024 -- Note: The value of Suffix_Index must be in sync with the values of
7025 -- Suffix_Index in secondary dispatch tables generated by Make_DT.
7027 if Is_CPP_Class (Typ) then
7028 AI_Tag_Comp := First_Elmt (Typ_Comps);
7029 while Present (AI_Tag_Comp) loop
7030 Get_Secondary_DT_External_Name
7031 (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
7032 Typ_Name := Name_Find;
7034 -- Declare variables to store copy of the C++ secondary tags
7037 Make_Defining_Identifier (Loc,
7038 Chars => New_External_Name (Typ_Name, 'P'));
7039 Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
7040 Set_Ekind (Iface_DT_Ptr, E_Variable);
7041 Set_Is_Tag (Iface_DT_Ptr);
7043 Set_Has_Thunks (Iface_DT_Ptr);
7045 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7046 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7049 Make_Object_Declaration (Loc,
7050 Defining_Identifier => Iface_DT_Ptr,
7051 Object_Definition => New_Occurrence_Of
7052 (RTE (RE_Interface_Tag), Loc),
7054 Unchecked_Convert_To (RTE (RE_Interface_Tag),
7055 New_Occurrence_Of (RTE (RE_Null_Address), Loc))));
7057 Set_Is_Statically_Allocated (Iface_DT_Ptr,
7058 Is_Library_Level_Tagged_Type (Typ));
7060 Next_Elmt (AI_Tag_Comp);
7063 -- This is not a CPP_Class type
7066 AI_Tag_Comp := First_Elmt (Typ_Comps);
7067 while Present (AI_Tag_Comp) loop
7068 Get_Secondary_DT_External_Name
7069 (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
7070 Typ_Name := Name_Find;
7072 if Building_Static_DT (Typ) then
7074 Make_Defining_Identifier (Loc,
7075 Chars => New_External_Name (Typ_Name, 'T'));
7077 (Tag_Typ => Related_Type (Node (AI_Tag_Comp)),
7079 Is_Secondary_DT => True);
7082 -- Secondary dispatch table referencing thunks to user-defined
7083 -- primitives covered by this interface.
7086 Make_Defining_Identifier (Loc,
7087 Chars => New_External_Name (Typ_Name, 'P'));
7088 Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
7089 Set_Ekind (Iface_DT_Ptr, E_Constant);
7090 Set_Is_Tag (Iface_DT_Ptr);
7091 Set_Has_Thunks (Iface_DT_Ptr);
7092 Set_Is_Statically_Allocated (Iface_DT_Ptr,
7093 Is_Library_Level_Tagged_Type (Typ));
7094 Set_Is_True_Constant (Iface_DT_Ptr);
7096 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7097 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7099 if Building_Static_DT (Typ) then
7101 Make_Object_Declaration (Loc,
7102 Defining_Identifier => Iface_DT_Ptr,
7103 Constant_Present => True,
7104 Object_Definition => New_Occurrence_Of
7105 (RTE (RE_Interface_Tag), Loc),
7107 Unchecked_Convert_To (RTE (RE_Interface_Tag),
7108 Make_Attribute_Reference (Loc,
7110 Make_Selected_Component (Loc,
7112 New_Occurrence_Of (Iface_DT, Loc),
7115 (RTE_Record_Component (RE_Prims_Ptr),
7117 Attribute_Name => Name_Address))));
7120 -- Secondary dispatch table referencing thunks to predefined
7124 Make_Defining_Identifier (Loc,
7125 Chars => New_External_Name (Typ_Name, 'Y'));
7126 Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
7127 Set_Ekind (Iface_DT_Ptr, E_Constant);
7128 Set_Is_Tag (Iface_DT_Ptr);
7129 Set_Has_Thunks (Iface_DT_Ptr);
7130 Set_Is_Statically_Allocated (Iface_DT_Ptr,
7131 Is_Library_Level_Tagged_Type (Typ));
7132 Set_Is_True_Constant (Iface_DT_Ptr);
7134 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7135 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7137 -- Secondary dispatch table referencing user-defined primitives
7138 -- covered by this interface.
7141 Make_Defining_Identifier (Loc,
7142 Chars => New_External_Name (Typ_Name, 'D'));
7143 Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
7144 Set_Ekind (Iface_DT_Ptr, E_Constant);
7145 Set_Is_Tag (Iface_DT_Ptr);
7146 Set_Is_Statically_Allocated (Iface_DT_Ptr,
7147 Is_Library_Level_Tagged_Type (Typ));
7148 Set_Is_True_Constant (Iface_DT_Ptr);
7150 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7151 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7153 -- Secondary dispatch table referencing predefined primitives
7156 Make_Defining_Identifier (Loc,
7157 Chars => New_External_Name (Typ_Name, 'Z'));
7158 Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
7159 Set_Ekind (Iface_DT_Ptr, E_Constant);
7160 Set_Is_Tag (Iface_DT_Ptr);
7161 Set_Is_Statically_Allocated (Iface_DT_Ptr,
7162 Is_Library_Level_Tagged_Type (Typ));
7163 Set_Is_True_Constant (Iface_DT_Ptr);
7165 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7166 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7168 Next_Elmt (AI_Tag_Comp);
7173 -- 3) At the end of Access_Disp_Table, if the type has user-defined
7174 -- primitives, we add the entity of an access type declaration that
7175 -- is used by Build_Get_Prim_Op_Address to expand dispatching calls
7176 -- through the primary dispatch table.
7178 if UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))) = 0 then
7179 Analyze_List (Result);
7182 -- subtype Typ_DT is Address_Array (1 .. Nb_Prims);
7183 -- type Typ_DT_Acc is access Typ_DT;
7187 Name_DT_Prims : constant Name_Id :=
7188 New_External_Name (Tname, 'G');
7189 Name_DT_Prims_Acc : constant Name_Id :=
7190 New_External_Name (Tname, 'H');
7191 DT_Prims : constant Entity_Id :=
7192 Make_Defining_Identifier (Loc,
7194 DT_Prims_Acc : constant Entity_Id :=
7195 Make_Defining_Identifier (Loc,
7199 Make_Subtype_Declaration (Loc,
7200 Defining_Identifier => DT_Prims,
7201 Subtype_Indication =>
7202 Make_Subtype_Indication (Loc,
7204 New_Occurrence_Of (RTE (RE_Address_Array), Loc),
7206 Make_Index_Or_Discriminant_Constraint (Loc, New_List (
7208 Low_Bound => Make_Integer_Literal (Loc, 1),
7209 High_Bound => Make_Integer_Literal (Loc,
7211 (First_Tag_Component (Typ)))))))));
7214 Make_Full_Type_Declaration (Loc,
7215 Defining_Identifier => DT_Prims_Acc,
7217 Make_Access_To_Object_Definition (Loc,
7218 Subtype_Indication =>
7219 New_Occurrence_Of (DT_Prims, Loc))));
7221 Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
7223 -- Analyze the resulting list and suppress the generation of the
7224 -- Init_Proc associated with the above array declaration because
7225 -- this type is never used in object declarations. It is only used
7226 -- to simplify the expansion associated with dispatching calls.
7228 Analyze_List (Result);
7229 Set_Suppress_Initialization (Base_Type (DT_Prims));
7231 -- Disable backend optimizations based on assumptions about the
7232 -- aliasing status of objects designated by the access to the
7233 -- dispatch table. Required to handle dispatch tables imported
7236 Set_No_Strict_Aliasing (Base_Type (DT_Prims_Acc));
7238 -- Add the freezing nodes of these declarations; required to avoid
7239 -- generating these freezing nodes in wrong scopes (for example in
7240 -- the IC routine of a derivation of Typ).
7242 -- What is an "IC routine"? Is "init_proc" meant here???
7244 Append_List_To (Result, Freeze_Entity (DT_Prims, Typ));
7245 Append_List_To (Result, Freeze_Entity (DT_Prims_Acc, Typ));
7247 -- Mark entity of dispatch table. Required by the back end to
7248 -- handle them properly.
7250 Set_Is_Dispatch_Table_Entity (DT_Prims);
7254 -- Mark entities of dispatch table. Required by the back end to handle
7257 if Present (DT) then
7258 Set_Is_Dispatch_Table_Entity (DT);
7259 Set_Is_Dispatch_Table_Entity (Etype (DT));
7262 if Present (Iface_DT) then
7263 Set_Is_Dispatch_Table_Entity (Iface_DT);
7264 Set_Is_Dispatch_Table_Entity (Etype (Iface_DT));
7267 if Is_CPP_Class (Root_Type (Typ)) then
7268 Set_Ekind (DT_Ptr, E_Variable);
7270 Set_Ekind (DT_Ptr, E_Constant);
7273 Set_Is_Tag (DT_Ptr);
7274 Set_Related_Type (DT_Ptr, Typ);
7283 function New_Value (From : Node_Id) return Node_Id is
7284 Res : constant Node_Id := Duplicate_Subexpr (From);
7286 if Is_Access_Type (Etype (From)) then
7287 return Make_Explicit_Dereference (Sloc (From), Prefix => Res);
7293 -----------------------------------
7294 -- Original_View_In_Visible_Part --
7295 -----------------------------------
7297 function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
7298 Scop : constant Entity_Id := Scope (Typ);
7301 -- The scope must be a package
7303 if not Is_Package_Or_Generic_Package (Scop) then
7307 -- A type with a private declaration has a private view declared in
7308 -- the visible part.
7310 if Has_Private_Declaration (Typ) then
7314 return List_Containing (Parent (Typ)) =
7315 Visible_Declarations (Package_Specification (Scop));
7316 end Original_View_In_Visible_Part;
7322 function Prim_Op_Kind
7324 Typ : Entity_Id) return Node_Id
7326 Full_Typ : Entity_Id := Typ;
7327 Loc : constant Source_Ptr := Sloc (Prim);
7328 Prim_Op : Entity_Id;
7331 -- Retrieve the original primitive operation
7333 Prim_Op := Ultimate_Alias (Prim);
7335 if Ekind (Typ) = E_Record_Type
7336 and then Present (Corresponding_Concurrent_Type (Typ))
7338 Full_Typ := Corresponding_Concurrent_Type (Typ);
7341 -- When a private tagged type is completed by a concurrent type,
7342 -- retrieve the full view.
7344 if Is_Private_Type (Full_Typ) then
7345 Full_Typ := Full_View (Full_Typ);
7348 if Ekind (Prim_Op) = E_Function then
7350 -- Protected function
7352 if Ekind (Full_Typ) = E_Protected_Type then
7353 return New_Occurrence_Of (RTE (RE_POK_Protected_Function), Loc);
7357 elsif Ekind (Full_Typ) = E_Task_Type then
7358 return New_Occurrence_Of (RTE (RE_POK_Task_Function), Loc);
7363 return New_Occurrence_Of (RTE (RE_POK_Function), Loc);
7367 pragma Assert (Ekind (Prim_Op) = E_Procedure);
7369 if Ekind (Full_Typ) = E_Protected_Type then
7373 if Is_Primitive_Wrapper (Prim_Op)
7374 and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
7376 return New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc);
7378 -- Protected procedure
7382 New_Occurrence_Of (RTE (RE_POK_Protected_Procedure), Loc);
7385 elsif Ekind (Full_Typ) = E_Task_Type then
7389 if Is_Primitive_Wrapper (Prim_Op)
7390 and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
7392 return New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc);
7394 -- Task "procedure". These are the internally Expander-generated
7395 -- procedures (task body for instance).
7398 return New_Occurrence_Of (RTE (RE_POK_Task_Procedure), Loc);
7401 -- Regular procedure
7404 return New_Occurrence_Of (RTE (RE_POK_Procedure), Loc);
7409 ------------------------
7410 -- Register_Primitive --
7411 ------------------------
7413 function Register_Primitive
7415 Prim : Entity_Id) return List_Id
7418 Iface_Prim : Entity_Id;
7419 Iface_Typ : Entity_Id;
7420 Iface_DT_Ptr : Entity_Id;
7421 Iface_DT_Elmt : Elmt_Id;
7422 L : constant List_Id := New_List;
7425 Tag_Typ : Entity_Id;
7426 Thunk_Id : Entity_Id;
7427 Thunk_Code : Node_Id;
7430 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
7432 -- Do not register in the dispatch table eliminated primitives
7434 if not RTE_Available (RE_Tag)
7435 or else Is_Eliminated (Ultimate_Alias (Prim))
7436 or else Generate_SCIL
7441 if not Present (Interface_Alias (Prim)) then
7442 Tag_Typ := Scope (DTC_Entity (Prim));
7443 Pos := DT_Position (Prim);
7444 Tag := First_Tag_Component (Tag_Typ);
7446 if Is_Predefined_Dispatching_Operation (Prim)
7447 or else Is_Predefined_Dispatching_Alias (Prim)
7450 Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ))));
7453 Build_Set_Predefined_Prim_Op_Address (Loc,
7454 Tag_Node => New_Occurrence_Of (DT_Ptr, Loc),
7457 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7458 Make_Attribute_Reference (Loc,
7459 Prefix => New_Occurrence_Of (Prim, Loc),
7460 Attribute_Name => Name_Unrestricted_Access))));
7462 -- Register copy of the pointer to the 'size primitive in the TSD
7464 if Chars (Prim) = Name_uSize
7465 and then RTE_Record_Component_Available (RE_Size_Func)
7467 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
7469 Build_Set_Size_Function (Loc,
7470 Tag_Node => New_Occurrence_Of (DT_Ptr, Loc),
7471 Size_Func => Prim));
7475 pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
7477 -- Skip registration of primitives located in the C++ part of the
7478 -- dispatch table. Their slot is set by the IC routine.
7480 if not Is_CPP_Class (Root_Type (Tag_Typ))
7481 or else Pos > CPP_Num_Prims (Tag_Typ)
7483 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
7485 Build_Set_Prim_Op_Address (Loc,
7487 Tag_Node => New_Occurrence_Of (DT_Ptr, Loc),
7490 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7491 Make_Attribute_Reference (Loc,
7492 Prefix => New_Occurrence_Of (Prim, Loc),
7493 Attribute_Name => Name_Unrestricted_Access))));
7497 -- Ada 2005 (AI-251): Primitive associated with an interface type
7499 -- Generate the code of the thunk only if the interface type is not an
7500 -- immediate ancestor of Typ; otherwise the dispatch table associated
7501 -- with the interface is the primary dispatch table and we have nothing
7505 Tag_Typ := Find_Dispatching_Type (Alias (Prim));
7506 Iface_Typ := Find_Dispatching_Type (Interface_Alias (Prim));
7508 pragma Assert (Is_Interface (Iface_Typ));
7510 -- No action needed for interfaces that are ancestors of Typ because
7511 -- their primitives are located in the primary dispatch table.
7513 if Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True) then
7516 -- No action needed for primitives located in the C++ part of the
7517 -- dispatch table. Their slot is set by the IC routine.
7519 elsif Is_CPP_Class (Root_Type (Tag_Typ))
7520 and then DT_Position (Alias (Prim)) <= CPP_Num_Prims (Tag_Typ)
7521 and then not Is_Predefined_Dispatching_Operation (Prim)
7522 and then not Is_Predefined_Dispatching_Alias (Prim)
7527 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
7529 if not Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True)
7530 and then Present (Thunk_Code)
7532 -- Generate the code necessary to fill the appropriate entry of
7533 -- the secondary dispatch table of Prim's controlling type with
7534 -- Thunk_Id's address.
7536 Iface_DT_Elmt := Find_Interface_ADT (Tag_Typ, Iface_Typ);
7537 Iface_DT_Ptr := Node (Iface_DT_Elmt);
7538 pragma Assert (Has_Thunks (Iface_DT_Ptr));
7540 Iface_Prim := Interface_Alias (Prim);
7541 Pos := DT_Position (Iface_Prim);
7542 Tag := First_Tag_Component (Iface_Typ);
7544 Prepend_To (L, Thunk_Code);
7546 if Is_Predefined_Dispatching_Operation (Prim)
7547 or else Is_Predefined_Dispatching_Alias (Prim)
7550 Build_Set_Predefined_Prim_Op_Address (Loc,
7552 New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
7555 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7556 Make_Attribute_Reference (Loc,
7557 Prefix => New_Occurrence_Of (Thunk_Id, Loc),
7558 Attribute_Name => Name_Unrestricted_Access))));
7560 Next_Elmt (Iface_DT_Elmt);
7561 Next_Elmt (Iface_DT_Elmt);
7562 Iface_DT_Ptr := Node (Iface_DT_Elmt);
7563 pragma Assert (not Has_Thunks (Iface_DT_Ptr));
7566 Build_Set_Predefined_Prim_Op_Address (Loc,
7568 New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
7571 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7572 Make_Attribute_Reference (Loc,
7574 New_Occurrence_Of (Alias (Prim), Loc),
7575 Attribute_Name => Name_Unrestricted_Access))));
7578 pragma Assert (Pos /= Uint_0
7579 and then Pos <= DT_Entry_Count (Tag));
7582 Build_Set_Prim_Op_Address (Loc,
7584 Tag_Node => New_Occurrence_Of (Iface_DT_Ptr, Loc),
7587 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7588 Make_Attribute_Reference (Loc,
7589 Prefix => New_Occurrence_Of (Thunk_Id, Loc),
7590 Attribute_Name => Name_Unrestricted_Access))));
7592 Next_Elmt (Iface_DT_Elmt);
7593 Next_Elmt (Iface_DT_Elmt);
7594 Iface_DT_Ptr := Node (Iface_DT_Elmt);
7595 pragma Assert (not Has_Thunks (Iface_DT_Ptr));
7598 Build_Set_Prim_Op_Address (Loc,
7600 Tag_Node => New_Occurrence_Of (Iface_DT_Ptr, Loc),
7603 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7604 Make_Attribute_Reference (Loc,
7606 New_Occurrence_Of (Alias (Prim), Loc),
7607 Attribute_Name => Name_Unrestricted_Access))));
7614 end Register_Primitive;
7616 -------------------------
7617 -- Set_All_DT_Position --
7618 -------------------------
7620 procedure Set_All_DT_Position (Typ : Entity_Id) is
7622 function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean;
7623 -- Returns True if Prim is located in the dispatch table of
7624 -- predefined primitives
7626 procedure Validate_Position (Prim : Entity_Id);
7627 -- Check that position assigned to Prim is completely safe (it has not
7628 -- been assigned to a previously defined primitive operation of Typ).
7630 ------------------------
7631 -- In_Predef_Prims_DT --
7632 ------------------------
7634 function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean is
7636 -- Predefined primitives
7638 if Is_Predefined_Dispatching_Operation (Prim) then
7641 -- Renamings of predefined primitives
7643 elsif Present (Alias (Prim))
7644 and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim))
7646 if Chars (Ultimate_Alias (Prim)) /= Name_Op_Eq then
7649 -- An overriding operation that is a user-defined renaming of
7650 -- predefined equality inherits its slot from the overridden
7651 -- operation. Otherwise it is treated as a predefined op and
7652 -- occupies the same predefined slot as equality. A call to it is
7653 -- transformed into a call to its alias, which is the predefined
7654 -- equality op. A dispatching call thus uses the proper slot if
7655 -- operation is further inherited and called with class-wide
7660 not Comes_From_Source (Prim)
7661 or else No (Overridden_Operation (Prim));
7664 -- User-defined primitives
7669 end In_Predef_Prims_DT;
7671 -----------------------
7672 -- Validate_Position --
7673 -----------------------
7675 procedure Validate_Position (Prim : Entity_Id) is
7680 -- Aliased primitives are safe
7682 if Present (Alias (Prim)) then
7686 Op_Elmt := First_Elmt (Primitive_Operations (Typ));
7687 while Present (Op_Elmt) loop
7688 Op := Node (Op_Elmt);
7690 -- No need to check against itself
7695 -- Primitive operations covering abstract interfaces are
7698 elsif Present (Interface_Alias (Op)) then
7701 -- Predefined dispatching operations are completely safe. They
7702 -- are allocated at fixed positions in a separate table.
7704 elsif Is_Predefined_Dispatching_Operation (Op)
7705 or else Is_Predefined_Dispatching_Alias (Op)
7709 -- Aliased subprograms are safe
7711 elsif Present (Alias (Op)) then
7714 elsif DT_Position (Op) = DT_Position (Prim)
7715 and then not Is_Predefined_Dispatching_Operation (Op)
7716 and then not Is_Predefined_Dispatching_Operation (Prim)
7717 and then not Is_Predefined_Dispatching_Alias (Op)
7718 and then not Is_Predefined_Dispatching_Alias (Prim)
7720 -- Handle aliased subprograms
7729 if Present (Overridden_Operation (Op_1)) then
7730 Op_1 := Overridden_Operation (Op_1);
7731 elsif Present (Alias (Op_1)) then
7732 Op_1 := Alias (Op_1);
7740 if Present (Overridden_Operation (Op_2)) then
7741 Op_2 := Overridden_Operation (Op_2);
7742 elsif Present (Alias (Op_2)) then
7743 Op_2 := Alias (Op_2);
7749 if Op_1 /= Op_2 then
7750 raise Program_Error;
7755 Next_Elmt (Op_Elmt);
7757 end Validate_Position;
7761 Parent_Typ : constant Entity_Id := Etype (Typ);
7762 First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
7763 The_Tag : constant Entity_Id := First_Tag_Component (Typ);
7765 Adjusted : Boolean := False;
7766 Finalized : Boolean := False;
7772 Prim_Elmt : Elmt_Id;
7774 -- Start of processing for Set_All_DT_Position
7777 pragma Assert (Present (First_Tag_Component (Typ)));
7779 -- Set the DT_Position for each primitive operation. Perform some sanity
7780 -- checks to avoid building inconsistent dispatch tables.
7782 -- First stage: Set DTC entity of all the primitive operations. This is
7783 -- required to properly read the DT_Position attribute in latter stages.
7785 Prim_Elmt := First_Prim;
7787 while Present (Prim_Elmt) loop
7788 Prim := Node (Prim_Elmt);
7790 -- Predefined primitives have a separate dispatch table
7792 if not In_Predef_Prims_DT (Prim) then
7793 Count_Prim := Count_Prim + 1;
7796 Set_DTC_Entity_Value (Typ, Prim);
7798 -- Clear any previous value of the DT_Position attribute. In this
7799 -- way we ensure that the final position of all the primitives is
7800 -- established by the following stages of this algorithm.
7802 Set_DT_Position_Value (Prim, No_Uint);
7804 Next_Elmt (Prim_Elmt);
7808 Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean :=
7813 procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id);
7814 -- Called if Typ is declared in a nested package or a public child
7815 -- package to handle inherited primitives that were inherited by Typ
7816 -- in the visible part, but whose declaration was deferred because
7817 -- the parent operation was private and not visible at that point.
7819 procedure Set_Fixed_Prim (Pos : Nat);
7820 -- Sets to true an element of the Fixed_Prim table to indicate
7821 -- that this entry of the dispatch table of Typ is occupied.
7823 ------------------------------------------
7824 -- Handle_Inherited_Private_Subprograms --
7825 ------------------------------------------
7827 procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id) is
7830 Op_Elmt_2 : Elmt_Id;
7831 Prim_Op : Entity_Id;
7832 Parent_Subp : Entity_Id;
7835 Op_List := Primitive_Operations (Typ);
7837 Op_Elmt := First_Elmt (Op_List);
7838 while Present (Op_Elmt) loop
7839 Prim_Op := Node (Op_Elmt);
7841 -- Search primitives that are implicit operations with an
7842 -- internal name whose parent operation has a normal name.
7844 if Present (Alias (Prim_Op))
7845 and then Find_Dispatching_Type (Alias (Prim_Op)) /= Typ
7846 and then not Comes_From_Source (Prim_Op)
7847 and then Is_Internal_Name (Chars (Prim_Op))
7848 and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
7850 Parent_Subp := Alias (Prim_Op);
7852 -- Check if the type has an explicit overriding for this
7855 Op_Elmt_2 := Next_Elmt (Op_Elmt);
7856 while Present (Op_Elmt_2) loop
7857 if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
7858 and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
7860 Set_DT_Position_Value (Prim_Op,
7861 DT_Position (Parent_Subp));
7862 Set_DT_Position_Value (Node (Op_Elmt_2),
7863 DT_Position (Parent_Subp));
7864 Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op)));
7866 goto Next_Primitive;
7869 Next_Elmt (Op_Elmt_2);
7874 Next_Elmt (Op_Elmt);
7876 end Handle_Inherited_Private_Subprograms;
7878 --------------------
7879 -- Set_Fixed_Prim --
7880 --------------------
7882 procedure Set_Fixed_Prim (Pos : Nat) is
7884 pragma Assert (Pos <= Count_Prim);
7885 Fixed_Prim (Pos) := True;
7887 when Constraint_Error =>
7888 raise Program_Error;
7892 -- In case of nested packages and public child package it may be
7893 -- necessary a special management on inherited subprograms so that
7894 -- the dispatch table is properly filled.
7896 if Ekind (Scope (Scope (Typ))) = E_Package
7897 and then Scope (Scope (Typ)) /= Standard_Standard
7898 and then ((Is_Derived_Type (Typ) and then not Is_Private_Type (Typ))
7900 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration
7901 and then Is_Generic_Type (Typ)))
7902 and then In_Open_Scopes (Scope (Etype (Typ)))
7903 and then Is_Base_Type (Typ)
7905 Handle_Inherited_Private_Subprograms (Typ);
7908 -- Second stage: Register fixed entries
7911 Prim_Elmt := First_Prim;
7912 while Present (Prim_Elmt) loop
7913 Prim := Node (Prim_Elmt);
7915 -- Predefined primitives have a separate table and all its
7916 -- entries are at predefined fixed positions.
7918 if In_Predef_Prims_DT (Prim) then
7919 if Is_Predefined_Dispatching_Operation (Prim) then
7920 Set_DT_Position_Value (Prim,
7921 Default_Prim_Op_Position (Prim));
7923 else pragma Assert (Present (Alias (Prim)));
7924 Set_DT_Position_Value (Prim,
7925 Default_Prim_Op_Position (Ultimate_Alias (Prim)));
7928 -- Overriding primitives of ancestor abstract interfaces
7930 elsif Present (Interface_Alias (Prim))
7931 and then Is_Ancestor
7932 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
7933 Use_Full_View => True)
7935 pragma Assert (DT_Position (Prim) = No_Uint
7936 and then Present (DTC_Entity (Interface_Alias (Prim))));
7938 E := Interface_Alias (Prim);
7939 Set_DT_Position_Value (Prim, DT_Position (E));
7942 (DT_Position (Alias (Prim)) = No_Uint
7943 or else DT_Position (Alias (Prim)) = DT_Position (E));
7944 Set_DT_Position_Value (Alias (Prim), DT_Position (E));
7945 Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
7947 -- Overriding primitives must use the same entry as the overridden
7948 -- primitive. Note that the Alias of the operation is set when the
7949 -- operation is declared by a renaming, in which case it is not
7950 -- overriding. If it renames another primitive it will use the
7951 -- same dispatch table slot, but if it renames an operation in a
7952 -- nested package it's a new primitive and will have its own slot.
7954 elsif not Present (Interface_Alias (Prim))
7955 and then Present (Alias (Prim))
7956 and then Chars (Prim) = Chars (Alias (Prim))
7957 and then Nkind (Unit_Declaration_Node (Prim)) /=
7958 N_Subprogram_Renaming_Declaration
7961 Par_Type : constant Entity_Id :=
7962 Find_Dispatching_Type (Alias (Prim));
7965 if Present (Par_Type)
7966 and then Par_Type /= Typ
7967 and then Is_Ancestor (Par_Type, Typ, Use_Full_View => True)
7968 and then Present (DTC_Entity (Alias (Prim)))
7971 Set_DT_Position_Value (Prim, DT_Position (E));
7973 if not Is_Predefined_Dispatching_Alias (E) then
7974 Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
7980 Next_Elmt (Prim_Elmt);
7983 -- Third stage: Fix the position of all the new primitives. Entries
7984 -- associated with primitives covering interfaces are handled in a
7987 Prim_Elmt := First_Prim;
7988 while Present (Prim_Elmt) loop
7989 Prim := Node (Prim_Elmt);
7991 -- Skip primitives previously set entries
7993 if DT_Position (Prim) /= No_Uint then
7996 -- Primitives covering interface primitives are handled later
7998 elsif Present (Interface_Alias (Prim)) then
8002 -- Take the next available position in the DT
8005 Nb_Prim := Nb_Prim + 1;
8006 pragma Assert (Nb_Prim <= Count_Prim);
8007 exit when not Fixed_Prim (Nb_Prim);
8010 Set_DT_Position_Value (Prim, UI_From_Int (Nb_Prim));
8011 Set_Fixed_Prim (Nb_Prim);
8014 Next_Elmt (Prim_Elmt);
8018 -- Fourth stage: Complete the decoration of primitives covering
8019 -- interfaces (that is, propagate the DT_Position attribute from
8020 -- the aliased primitive)
8022 Prim_Elmt := First_Prim;
8023 while Present (Prim_Elmt) loop
8024 Prim := Node (Prim_Elmt);
8026 if DT_Position (Prim) = No_Uint
8027 and then Present (Interface_Alias (Prim))
8029 pragma Assert (Present (Alias (Prim))
8030 and then Find_Dispatching_Type (Alias (Prim)) = Typ);
8032 -- Check if this entry will be placed in the primary DT
8035 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
8036 Use_Full_View => True)
8038 pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
8039 Set_DT_Position_Value (Prim, DT_Position (Alias (Prim)));
8041 -- Otherwise it will be placed in the secondary DT
8045 (DT_Position (Interface_Alias (Prim)) /= No_Uint);
8046 Set_DT_Position_Value (Prim,
8047 DT_Position (Interface_Alias (Prim)));
8051 Next_Elmt (Prim_Elmt);
8054 -- Generate listing showing the contents of the dispatch tables. This
8055 -- action is done before some further static checks because in case of
8056 -- critical errors caused by a wrong dispatch table we need to see the
8057 -- contents of such table.
8059 if Debug_Flag_ZZ then
8063 -- Final stage: Ensure that the table is correct plus some further
8064 -- verifications concerning the primitives.
8066 Prim_Elmt := First_Prim;
8068 while Present (Prim_Elmt) loop
8069 Prim := Node (Prim_Elmt);
8071 -- At this point all the primitives MUST have a position in the
8074 if DT_Position (Prim) = No_Uint then
8075 raise Program_Error;
8078 -- Calculate real size of the dispatch table
8080 if not In_Predef_Prims_DT (Prim)
8081 and then UI_To_Int (DT_Position (Prim)) > DT_Length
8083 DT_Length := UI_To_Int (DT_Position (Prim));
8086 -- Ensure that the assigned position to non-predefined dispatching
8087 -- operations in the dispatch table is correct.
8089 if not Is_Predefined_Dispatching_Operation (Prim)
8090 and then not Is_Predefined_Dispatching_Alias (Prim)
8092 Validate_Position (Prim);
8095 if Chars (Prim) = Name_Finalize then
8099 if Chars (Prim) = Name_Adjust then
8103 -- An abstract operation cannot be declared in the private part for a
8104 -- visible abstract type, because it can't be overridden outside this
8105 -- package hierarchy. For explicit declarations this is checked at
8106 -- the point of declaration, but for inherited operations it must be
8107 -- done when building the dispatch table.
8109 -- Ada 2005 (AI-251): Primitives associated with interfaces are
8110 -- excluded from this check because interfaces must be visible in
8111 -- the public and private part (RM 7.3 (7.3/2))
8113 -- We disable this check in Relaxed_RM_Semantics mode, to accommodate
8116 if not Relaxed_RM_Semantics
8117 and then Is_Abstract_Type (Typ)
8118 and then Is_Abstract_Subprogram (Prim)
8119 and then Present (Alias (Prim))
8120 and then not Is_Interface
8121 (Find_Dispatching_Type (Ultimate_Alias (Prim)))
8122 and then not Present (Interface_Alias (Prim))
8123 and then Is_Derived_Type (Typ)
8124 and then In_Private_Part (Current_Scope)
8126 List_Containing (Parent (Prim)) =
8127 Private_Declarations (Package_Specification (Current_Scope))
8128 and then Original_View_In_Visible_Part (Typ)
8130 -- We exclude Input and Output stream operations because
8131 -- Limited_Controlled inherits useless Input and Output stream
8132 -- operations from Root_Controlled, which can never be overridden.
8134 if not Is_TSS (Prim, TSS_Stream_Input)
8136 not Is_TSS (Prim, TSS_Stream_Output)
8139 ("abstract inherited private operation&" &
8140 " must be overridden (RM 3.9.3(10))",
8141 Parent (Typ), Prim);
8145 Next_Elmt (Prim_Elmt);
8150 if Is_Controlled (Typ) then
8151 if not Finalized then
8153 ("controlled type has no explicit Finalize method??", Typ);
8155 elsif not Adjusted then
8157 ("controlled type has no explicit Adjust method??", Typ);
8161 -- Set the final size of the Dispatch Table
8163 Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
8165 -- The derived type must have at least as many components as its parent
8166 -- (for root types Etype points to itself and the test cannot fail).
8168 if DT_Entry_Count (The_Tag) <
8169 DT_Entry_Count (First_Tag_Component (Parent_Typ))
8171 raise Program_Error;
8173 end Set_All_DT_Position;
8175 --------------------------
8176 -- Set_CPP_Constructors --
8177 --------------------------
8179 procedure Set_CPP_Constructors (Typ : Entity_Id) is
8181 function Gen_Parameters_Profile (E : Entity_Id) return List_Id;
8182 -- Duplicate the parameters profile of the imported C++ constructor
8183 -- adding the "this" pointer to the object as the additional first
8184 -- parameter under the usual form _Init : in out Typ.
8186 ----------------------------
8187 -- Gen_Parameters_Profile --
8188 ----------------------------
8190 function Gen_Parameters_Profile (E : Entity_Id) return List_Id is
8191 Loc : constant Source_Ptr := Sloc (E);
8198 Make_Parameter_Specification (Loc,
8199 Defining_Identifier =>
8200 Make_Defining_Identifier (Loc, Name_uInit),
8202 Out_Present => True,
8203 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
8205 if Present (Parameter_Specifications (Parent (E))) then
8206 P := First (Parameter_Specifications (Parent (E)));
8207 while Present (P) loop
8209 Make_Parameter_Specification (Loc,
8210 Defining_Identifier =>
8211 Make_Defining_Identifier (Loc,
8212 Chars => Chars (Defining_Identifier (P))),
8213 Parameter_Type => New_Copy_Tree (Parameter_Type (P)),
8214 Expression => New_Copy_Tree (Expression (P))));
8220 end Gen_Parameters_Profile;
8226 Found : Boolean := False;
8232 Covers_Default_Constructor : Entity_Id := Empty;
8234 -- Start of processing for Set_CPP_Constructor
8237 pragma Assert (Is_CPP_Class (Typ));
8239 -- Look for the constructor entities
8241 E := Next_Entity (Typ);
8242 while Present (E) loop
8243 if Ekind (E) = E_Function
8244 and then Is_Constructor (E)
8248 Parms := Gen_Parameters_Profile (E);
8249 IP := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
8251 -- Case 1: Constructor of untagged type
8253 -- If the C++ class has no virtual methods then the matching Ada
8254 -- type is an untagged record type. In such case there is no need
8255 -- to generate a wrapper of the C++ constructor because the _tag
8256 -- component is not available.
8258 if not Is_Tagged_Type (Typ) then
8260 (Make_Subprogram_Declaration (Loc,
8262 Make_Procedure_Specification (Loc,
8263 Defining_Unit_Name => IP,
8264 Parameter_Specifications => Parms)));
8266 Set_Init_Proc (Typ, IP);
8267 Set_Is_Imported (IP);
8268 Set_Is_Constructor (IP);
8269 Set_Interface_Name (IP, Interface_Name (E));
8270 Set_Convention (IP, Convention_CPP);
8272 Set_Has_Completion (IP);
8274 -- Case 2: Constructor of a tagged type
8276 -- In this case we generate the IP routine as a wrapper of the
8277 -- C++ constructor because IP must also save a copy of the _tag
8278 -- generated in the C++ side. The copy of the _tag is used by
8279 -- Build_CPP_Init_Procedure to elaborate derivations of C++ types.
8282 -- procedure IP (_init : in out Typ; ...) is
8283 -- procedure ConstructorP (_init : in out Typ; ...);
8284 -- pragma Import (ConstructorP);
8286 -- ConstructorP (_init, ...);
8287 -- if Typ._tag = null then
8288 -- Typ._tag := _init._tag;
8294 Body_Stmts : constant List_Id := New_List;
8295 Constructor_Id : Entity_Id;
8296 Constructor_Decl_Node : Node_Id;
8297 Init_Tags_List : List_Id;
8300 Constructor_Id := Make_Temporary (Loc, 'P');
8302 Constructor_Decl_Node :=
8303 Make_Subprogram_Declaration (Loc,
8304 Make_Procedure_Specification (Loc,
8305 Defining_Unit_Name => Constructor_Id,
8306 Parameter_Specifications => Parms));
8308 Set_Is_Imported (Constructor_Id);
8309 Set_Is_Constructor (Constructor_Id);
8310 Set_Interface_Name (Constructor_Id, Interface_Name (E));
8311 Set_Convention (Constructor_Id, Convention_CPP);
8312 Set_Is_Public (Constructor_Id);
8313 Set_Has_Completion (Constructor_Id);
8315 -- Build the init procedure as a wrapper of this constructor
8317 Parms := Gen_Parameters_Profile (E);
8319 -- Invoke the C++ constructor
8322 Actuals : constant List_Id := New_List;
8326 while Present (P) loop
8328 New_Occurrence_Of (Defining_Identifier (P), Loc));
8332 Append_To (Body_Stmts,
8333 Make_Procedure_Call_Statement (Loc,
8334 Name => New_Occurrence_Of (Constructor_Id, Loc),
8335 Parameter_Associations => Actuals));
8338 -- Initialize copies of C++ primary and secondary tags
8340 Init_Tags_List := New_List;
8347 Tag_Elmt := First_Elmt (Access_Disp_Table (Typ));
8348 Tag_Comp := First_Tag_Component (Typ);
8350 while Present (Tag_Elmt)
8351 and then Is_Tag (Node (Tag_Elmt))
8353 -- Skip the following assertion with primary tags
8354 -- because Related_Type is not set on primary tag
8358 (Tag_Comp = First_Tag_Component (Typ)
8359 or else Related_Type (Node (Tag_Elmt))
8360 = Related_Type (Tag_Comp));
8362 Append_To (Init_Tags_List,
8363 Make_Assignment_Statement (Loc,
8365 New_Occurrence_Of (Node (Tag_Elmt), Loc),
8367 Make_Selected_Component (Loc,
8369 Make_Identifier (Loc, Name_uInit),
8371 New_Occurrence_Of (Tag_Comp, Loc))));
8373 Tag_Comp := Next_Tag_Component (Tag_Comp);
8374 Next_Elmt (Tag_Elmt);
8378 Append_To (Body_Stmts,
8379 Make_If_Statement (Loc,
8384 (Node (First_Elmt (Access_Disp_Table (Typ))),
8387 Unchecked_Convert_To (RTE (RE_Tag),
8388 New_Occurrence_Of (RTE (RE_Null_Address), Loc))),
8389 Then_Statements => Init_Tags_List));
8392 Make_Subprogram_Body (Loc,
8394 Make_Procedure_Specification (Loc,
8395 Defining_Unit_Name => IP,
8396 Parameter_Specifications => Parms),
8397 Declarations => New_List (Constructor_Decl_Node),
8398 Handled_Statement_Sequence =>
8399 Make_Handled_Sequence_Of_Statements (Loc,
8400 Statements => Body_Stmts,
8401 Exception_Handlers => No_List));
8403 Discard_Node (IP_Body);
8404 Set_Init_Proc (Typ, IP);
8408 -- If this constructor has parameters and all its parameters have
8409 -- defaults then it covers the default constructor. The semantic
8410 -- analyzer ensures that only one constructor with defaults covers
8411 -- the default constructor.
8413 if Present (Parameter_Specifications (Parent (E)))
8414 and then Needs_No_Actuals (E)
8416 Covers_Default_Constructor := IP;
8423 -- If there are no constructors, mark the type as abstract since we
8424 -- won't be able to declare objects of that type.
8427 Set_Is_Abstract_Type (Typ);
8430 -- Handle constructor that has all its parameters with defaults and
8431 -- hence it covers the default constructor. We generate a wrapper IP
8432 -- which calls the covering constructor.
8434 if Present (Covers_Default_Constructor) then
8436 Body_Stmts : List_Id;
8439 Loc := Sloc (Covers_Default_Constructor);
8441 Body_Stmts := New_List (
8442 Make_Procedure_Call_Statement (Loc,
8444 New_Occurrence_Of (Covers_Default_Constructor, Loc),
8445 Parameter_Associations => New_List (
8446 Make_Identifier (Loc, Name_uInit))));
8448 IP := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
8451 Make_Subprogram_Body (Loc,
8453 Make_Procedure_Specification (Loc,
8454 Defining_Unit_Name => IP,
8455 Parameter_Specifications => New_List (
8456 Make_Parameter_Specification (Loc,
8457 Defining_Identifier =>
8458 Make_Defining_Identifier (Loc, Name_uInit),
8459 Parameter_Type => New_Occurrence_Of (Typ, Loc)))),
8461 Declarations => No_List,
8463 Handled_Statement_Sequence =>
8464 Make_Handled_Sequence_Of_Statements (Loc,
8465 Statements => Body_Stmts,
8466 Exception_Handlers => No_List));
8468 Discard_Node (IP_Body);
8469 Set_Init_Proc (Typ, IP);
8473 -- If the CPP type has constructors then it must import also the default
8474 -- C++ constructor. It is required for default initialization of objects
8475 -- of the type. It is also required to elaborate objects of Ada types
8476 -- that are defined as derivations of this CPP type.
8478 if Has_CPP_Constructors (Typ)
8479 and then No (Init_Proc (Typ))
8481 Error_Msg_N ("??default constructor must be imported from C++", Typ);
8483 end Set_CPP_Constructors;
8485 ---------------------------
8486 -- Set_DT_Position_Value --
8487 ---------------------------
8489 procedure Set_DT_Position_Value (Prim : Entity_Id; Value : Uint) is
8491 Set_DT_Position (Prim, Value);
8493 -- Propagate the value to the wrapped subprogram (if one is present)
8495 if Ekind_In (Prim, E_Function, E_Procedure)
8496 and then Is_Primitive_Wrapper (Prim)
8497 and then Present (Wrapped_Entity (Prim))
8498 and then Is_Dispatching_Operation (Wrapped_Entity (Prim))
8500 Set_DT_Position (Wrapped_Entity (Prim), Value);
8502 end Set_DT_Position_Value;
8504 --------------------------
8505 -- Set_DTC_Entity_Value --
8506 --------------------------
8508 procedure Set_DTC_Entity_Value
8509 (Tagged_Type : Entity_Id;
8513 if Present (Interface_Alias (Prim))
8514 and then Is_Interface
8515 (Find_Dispatching_Type (Interface_Alias (Prim)))
8517 Set_DTC_Entity (Prim,
8520 Iface => Find_Dispatching_Type (Interface_Alias (Prim))));
8522 Set_DTC_Entity (Prim,
8523 First_Tag_Component (Tagged_Type));
8526 -- Propagate the value to the wrapped subprogram (if one is present)
8528 if Ekind_In (Prim, E_Function, E_Procedure)
8529 and then Is_Primitive_Wrapper (Prim)
8530 and then Present (Wrapped_Entity (Prim))
8531 and then Is_Dispatching_Operation (Wrapped_Entity (Prim))
8533 Set_DTC_Entity (Wrapped_Entity (Prim), DTC_Entity (Prim));
8535 end Set_DTC_Entity_Value;
8541 function Tagged_Kind (T : Entity_Id) return Node_Id is
8542 Conc_Typ : Entity_Id;
8543 Loc : constant Source_Ptr := Sloc (T);
8547 (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind));
8551 if Is_Abstract_Type (T) then
8552 if Is_Limited_Record (T) then
8553 return New_Occurrence_Of
8554 (RTE (RE_TK_Abstract_Limited_Tagged), Loc);
8556 return New_Occurrence_Of
8557 (RTE (RE_TK_Abstract_Tagged), Loc);
8562 elsif Is_Concurrent_Record_Type (T) then
8563 Conc_Typ := Corresponding_Concurrent_Type (T);
8565 if Present (Full_View (Conc_Typ)) then
8566 Conc_Typ := Full_View (Conc_Typ);
8569 if Ekind (Conc_Typ) = E_Protected_Type then
8570 return New_Occurrence_Of (RTE (RE_TK_Protected), Loc);
8572 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
8573 return New_Occurrence_Of (RTE (RE_TK_Task), Loc);
8576 -- Regular tagged kinds
8579 if Is_Limited_Record (T) then
8580 return New_Occurrence_Of (RTE (RE_TK_Limited_Tagged), Loc);
8582 return New_Occurrence_Of (RTE (RE_TK_Tagged), Loc);
8591 procedure Write_DT (Typ : Entity_Id) is
8596 -- Protect this procedure against wrong usage. Required because it will
8597 -- be used directly from GDB
8599 if not (Typ <= Last_Node_Id)
8600 or else not Is_Tagged_Type (Typ)
8602 Write_Str ("wrong usage: Write_DT must be used with tagged types");
8607 Write_Int (Int (Typ));
8609 Write_Name (Chars (Typ));
8611 if Is_Interface (Typ) then
8612 Write_Str (" is interface");
8617 Elmt := First_Elmt (Primitive_Operations (Typ));
8618 while Present (Elmt) loop
8619 Prim := Node (Elmt);
8622 -- Indicate if this primitive will be allocated in the primary
8623 -- dispatch table or in a secondary dispatch table associated
8624 -- with an abstract interface type
8626 if Present (DTC_Entity (Prim)) then
8627 if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
8634 -- Output the node of this primitive operation and its name
8636 Write_Int (Int (Prim));
8639 if Is_Predefined_Dispatching_Operation (Prim) then
8640 Write_Str ("(predefined) ");
8643 -- Prefix the name of the primitive with its corresponding tagged
8644 -- type to facilitate seeing inherited primitives.
8646 if Present (Alias (Prim)) then
8648 (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim))));
8650 Write_Name (Chars (Typ));
8654 Write_Name (Chars (Prim));
8656 -- Indicate if this primitive has an aliased primitive
8658 if Present (Alias (Prim)) then
8659 Write_Str (" (alias = ");
8660 Write_Int (Int (Alias (Prim)));
8662 -- If the DTC_Entity attribute is already set we can also output
8663 -- the name of the interface covered by this primitive (if any).
8665 if Ekind_In (Alias (Prim), E_Function, E_Procedure)
8666 and then Present (DTC_Entity (Alias (Prim)))
8667 and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
8669 Write_Str (" from interface ");
8670 Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
8673 if Present (Interface_Alias (Prim)) then
8674 Write_Str (", AI_Alias of ");
8676 if Is_Null_Interface_Primitive (Interface_Alias (Prim)) then
8677 Write_Str ("null primitive ");
8681 (Chars (Find_Dispatching_Type (Interface_Alias (Prim))));
8683 Write_Int (Int (Interface_Alias (Prim)));
8689 -- Display the final position of this primitive in its associated
8690 -- (primary or secondary) dispatch table.
8692 if Present (DTC_Entity (Prim))
8693 and then DT_Position (Prim) /= No_Uint
8695 Write_Str (" at #");
8696 Write_Int (UI_To_Int (DT_Position (Prim)));
8699 if Is_Abstract_Subprogram (Prim) then
8700 Write_Str (" is abstract;");
8702 -- Check if this is a null primitive
8704 elsif Comes_From_Source (Prim)
8705 and then Ekind (Prim) = E_Procedure
8706 and then Null_Present (Parent (Prim))
8708 Write_Str (" is null;");
8711 if Is_Eliminated (Ultimate_Alias (Prim)) then
8712 Write_Str (" (eliminated)");
8715 if Is_Imported (Prim)
8716 and then Convention (Prim) = Convention_CPP
8718 Write_Str (" (C++)");