1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, 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 -- If the dispatching call appears in the same scope as the
732 -- declaration of the dispatching subprogram (for example in
733 -- the expression of a local expression function), the spec
734 -- has not been analyzed yet, in which case we use the Chars
735 -- field to recognize intended occurrences of the formals.
737 ---------------------
738 -- Replace_Formals --
739 ---------------------
741 function Replace_Formals (N : Node_Id) return Traverse_Result is
745 if Is_Entity_Name (N) then
746 F := First_Formal (Subp);
747 A := First_Actual (Call_Node);
749 if Present (Entity (N)) and then Is_Formal (Entity (N)) then
750 while Present (F) loop
751 if F = Entity (N) then
752 Rewrite (N, New_Copy_Tree (A));
754 -- If the formal is class-wide, and thus not a
755 -- controlling argument, preserve its type because
756 -- it may appear in a nested call with a class-wide
759 if Is_Class_Wide_Type (Etype (F)) then
760 Set_Etype (N, Etype (F));
762 -- Conversely, if this is a controlling argument
763 -- (in a dispatching call in the condition) that is a
764 -- dereference, the source is an access-to-class-wide
765 -- type, so preserve the dispatching nature of the
766 -- call in the rewritten condition.
768 elsif Nkind (Parent (N)) = N_Explicit_Dereference
769 and then Is_Controlling_Actual (Parent (N))
771 Set_Controlling_Argument (Parent (Parent (N)),
782 -- If the node is not analyzed, recognize occurrences of a
783 -- formal by name, as would be done when resolving the aspect
784 -- expression in the context of the subprogram.
786 elsif not Analyzed (N)
787 and then Nkind (N) = N_Identifier
788 and then No (Entity (N))
790 while Present (F) loop
791 if Chars (N) = Chars (F) then
792 Rewrite (N, New_Copy_Tree (A));
805 procedure Update is new Traverse_Proc (Replace_Formals);
809 Str_Loc : constant String := Build_Location_String (Loc);
815 -- Start of processing for Build_Class_Wide_Check
819 -- Locate class-wide precondition, if any
821 if Present (Contract (Subp))
822 and then Present (Pre_Post_Conditions (Contract (Subp)))
824 Prec := Pre_Post_Conditions (Contract (Subp));
826 while Present (Prec) loop
827 exit when Pragma_Name (Prec) = Name_Precondition
828 and then Class_Present (Prec);
829 Prec := Next_Pragma (Prec);
832 if No (Prec) or else Is_Ignored (Prec) then
836 -- The expression for the precondition is analyzed within the
837 -- generated pragma. The message text is the last parameter of
838 -- the generated pragma, indicating source of precondition.
842 (Expression (First (Pragma_Argument_Associations (Prec))));
845 -- Build message indicating the failed precondition and the
846 -- dispatching call that caused it.
848 Msg := Expression (Last (Pragma_Argument_Associations (Prec)));
850 Append (Global_Name_Buffer, Strval (Msg));
851 Append (Global_Name_Buffer, " in dispatching call at ");
852 Append (Global_Name_Buffer, Str_Loc);
853 Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len));
855 Insert_Action (Call_Node,
856 Make_If_Statement (Loc,
857 Condition => Make_Op_Not (Loc, Cond),
858 Then_Statements => New_List (
859 Make_Procedure_Call_Statement (Loc,
861 New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
862 Parameter_Associations => New_List (Msg)))));
864 end Build_Class_Wide_Check;
870 function New_Value (From : Node_Id) return Node_Id is
871 Res : constant Node_Id := Duplicate_Subexpr (From);
873 if Is_Access_Type (Etype (From)) then
875 Make_Explicit_Dereference (Sloc (From),
885 SCIL_Node : Node_Id := Empty;
886 SCIL_Related_Node : Node_Id := Call_Node;
888 -- Start of processing for Expand_Dispatching_Call
891 if No_Run_Time_Mode then
892 Error_Msg_CRT ("tagged types", Call_Node);
896 -- Expand_Dispatching_Call is called directly from the semantics, so we
897 -- only proceed if the expander is active.
899 if not Expander_Active
901 -- And there is no need to expand the call if we are compiling under
902 -- restriction No_Dispatching_Calls; the semantic analyzer has
903 -- previously notified the violation of this restriction.
905 or else Restriction_Active (No_Dispatching_Calls)
907 -- No action needed if the dispatching call has been already expanded
909 or else Is_Expanded_Dispatching_Call (Name (Call_Node))
914 -- Set subprogram. If this is an inherited operation that was
915 -- overridden, the body that is being called is its alias.
917 Subp := Entity (Name (Call_Node));
919 if Present (Alias (Subp))
920 and then Is_Inherited_Operation (Subp)
921 and then No (DTC_Entity (Subp))
923 Subp := Alias (Subp);
926 Build_Class_Wide_Check;
928 -- Definition of the class-wide type and the tagged type
930 -- If the controlling argument is itself a tag rather than a tagged
931 -- object, then use the class-wide type associated with the subprogram's
932 -- controlling type. This case can occur when a call to an inherited
933 -- primitive has an actual that originated from a default parameter
934 -- given by a tag-indeterminate call and when there is no other
935 -- controlling argument providing the tag (AI-239 requires dispatching).
936 -- This capability of dispatching directly by tag is also needed by the
937 -- implementation of AI-260 (for the generic dispatching constructors).
939 if Ctrl_Typ = RTE (RE_Tag)
940 or else (RTE_Available (RE_Interface_Tag)
941 and then Ctrl_Typ = RTE (RE_Interface_Tag))
943 CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
945 -- Class_Wide_Type is applied to the expressions used to initialize
946 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
947 -- there are cases where the controlling type is resolved to a specific
948 -- type (such as for designated types of arguments such as CW'Access).
950 elsif Is_Access_Type (Ctrl_Typ) then
951 CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ));
954 CW_Typ := Class_Wide_Type (Ctrl_Typ);
957 Typ := Find_Specific_Type (CW_Typ);
959 if not Is_Limited_Type (Typ) then
960 Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
963 -- Dispatching call to C++ primitive. Create a new parameter list
964 -- with no tag checks.
966 New_Params := New_List;
968 if Is_CPP_Class (Typ) then
969 Param := First_Actual (Call_Node);
970 while Present (Param) loop
971 Append_To (New_Params, Relocate_Node (Param));
975 -- Dispatching call to Ada primitive
977 elsif Present (Param_List) then
978 Apply_Tag_Checks (Call_Node);
980 Param := First_Actual (Call_Node);
981 while Present (Param) loop
983 -- Cases in which we may have generated run-time checks. Note that
984 -- we strip any qualification from Param before comparing with the
985 -- already-stripped controlling argument.
987 if Unqualify (Param) = Ctrl_Arg or else Subp = Eq_Prim_Op then
988 Append_To (New_Params,
989 Duplicate_Subexpr_Move_Checks (Param));
991 elsif Nkind (Parent (Param)) /= N_Parameter_Association
992 or else not Is_Accessibility_Actual (Parent (Param))
994 Append_To (New_Params, Relocate_Node (Param));
1001 -- Generate the appropriate subprogram pointer type
1003 if Etype (Subp) = Typ then
1006 Res_Typ := Etype (Subp);
1009 Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
1010 Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
1011 Set_Etype (Subp_Typ, Res_Typ);
1012 Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
1013 Set_Convention (Subp_Typ, Convention (Subp));
1015 -- Notify gigi that the designated type is a dispatching primitive
1017 Set_Is_Dispatch_Table_Entity (Subp_Typ);
1019 -- Create a new list of parameters which is a copy of the old formal
1020 -- list including the creation of a new set of matching entities.
1023 Old_Formal : Entity_Id := First_Formal (Subp);
1024 New_Formal : Entity_Id;
1025 Extra : Entity_Id := Empty;
1028 if Present (Old_Formal) then
1029 New_Formal := New_Copy (Old_Formal);
1030 Set_First_Entity (Subp_Typ, New_Formal);
1031 Param := First_Actual (Call_Node);
1034 Set_Scope (New_Formal, Subp_Typ);
1036 -- Change all the controlling argument types to be class-wide
1037 -- to avoid a recursion in dispatching.
1039 if Is_Controlling_Formal (New_Formal) then
1040 Set_Etype (New_Formal, Etype (Param));
1043 -- If the type of the formal is an itype, there was code here
1044 -- introduced in 1998 in revision 1.46, to create a new itype
1045 -- by copy. This seems useless, and in fact leads to semantic
1046 -- errors when the itype is the completion of a type derived
1047 -- from a private type.
1049 Extra := New_Formal;
1050 Next_Formal (Old_Formal);
1051 exit when No (Old_Formal);
1053 Link_Entities (New_Formal, New_Copy (Old_Formal));
1054 Next_Entity (New_Formal);
1055 Next_Actual (Param);
1058 Unlink_Next_Entity (New_Formal);
1059 Set_Last_Entity (Subp_Typ, Extra);
1062 -- Now that the explicit formals have been duplicated, any extra
1063 -- formals needed by the subprogram must be created.
1065 if Present (Extra) then
1066 Set_Extra_Formal (Extra, Empty);
1069 Create_Extra_Formals (Subp_Typ);
1072 -- Complete description of pointer type, including size information, as
1073 -- must be done with itypes to prevent order-of-elaboration anomalies
1076 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
1077 Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
1078 Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ));
1079 Layout_Type (Subp_Ptr_Typ);
1081 -- If the controlling argument is a value of type Ada.Tag or an abstract
1082 -- interface class-wide type then use it directly. Otherwise, the tag
1083 -- must be extracted from the controlling object.
1085 if Ctrl_Typ = RTE (RE_Tag)
1086 or else (RTE_Available (RE_Interface_Tag)
1087 and then Ctrl_Typ = RTE (RE_Interface_Tag))
1089 Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
1091 -- Extract the tag from an unchecked type conversion. Done to avoid
1092 -- the expansion of additional code just to obtain the value of such
1093 -- tag because the current management of interface type conversions
1094 -- generates in some cases this unchecked type conversion with the
1095 -- tag of the object (see Expand_Interface_Conversion).
1097 elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion
1099 (Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag)
1101 (RTE_Available (RE_Interface_Tag)
1103 Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag)))
1105 Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg));
1107 -- Ada 2005 (AI-251): Abstract interface class-wide type
1109 elsif Is_Interface (Ctrl_Typ)
1110 and then Is_Class_Wide_Type (Ctrl_Typ)
1112 Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
1116 Make_Selected_Component (Loc,
1117 Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
1118 Selector_Name => New_Occurrence_Of (DTC_Entity (Subp), Loc));
1121 -- Handle dispatching calls to predefined primitives
1123 if Is_Predefined_Dispatching_Operation (Subp)
1124 or else Is_Predefined_Dispatching_Alias (Subp)
1126 Build_Get_Predefined_Prim_Op_Address (Loc,
1127 Tag_Node => Controlling_Tag,
1128 Position => DT_Position (Subp),
1129 New_Node => New_Node);
1131 -- Handle dispatching calls to user-defined primitives
1134 Build_Get_Prim_Op_Address (Loc,
1135 Typ => Underlying_Type (Find_Dispatching_Type (Subp)),
1136 Tag_Node => Controlling_Tag,
1137 Position => DT_Position (Subp),
1138 New_Node => New_Node);
1142 Unchecked_Convert_To (Subp_Ptr_Typ, New_Node);
1144 -- Generate the SCIL node for this dispatching call. Done now because
1145 -- attribute SCIL_Controlling_Tag must be set after the new call name
1146 -- is built to reference the nodes that will see the SCIL backend
1147 -- (because Build_Get_Prim_Op_Address generates an unchecked type
1148 -- conversion which relocates the controlling tag node).
1150 if Generate_SCIL then
1151 SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node));
1152 Set_SCIL_Entity (SCIL_Node, Typ);
1153 Set_SCIL_Target_Prim (SCIL_Node, Subp);
1155 -- Common case: the controlling tag is the tag of an object
1156 -- (for example, obj.tag)
1158 if Nkind (Controlling_Tag) = N_Selected_Component then
1159 Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
1161 -- Handle renaming of selected component
1163 elsif Nkind (Controlling_Tag) = N_Identifier
1164 and then Nkind (Parent (Entity (Controlling_Tag))) =
1165 N_Object_Renaming_Declaration
1166 and then Nkind (Name (Parent (Entity (Controlling_Tag)))) =
1167 N_Selected_Component
1169 Set_SCIL_Controlling_Tag (SCIL_Node,
1170 Name (Parent (Entity (Controlling_Tag))));
1172 -- If the controlling tag is an identifier, the SCIL node references
1173 -- the corresponding object or parameter declaration
1175 elsif Nkind (Controlling_Tag) = N_Identifier
1176 and then Nkind_In (Parent (Entity (Controlling_Tag)),
1177 N_Object_Declaration,
1178 N_Parameter_Specification)
1180 Set_SCIL_Controlling_Tag (SCIL_Node,
1181 Parent (Entity (Controlling_Tag)));
1183 -- If the controlling tag is a dereference, the SCIL node references
1184 -- the corresponding object or parameter declaration
1186 elsif Nkind (Controlling_Tag) = N_Explicit_Dereference
1187 and then Nkind (Prefix (Controlling_Tag)) = N_Identifier
1188 and then Nkind_In (Parent (Entity (Prefix (Controlling_Tag))),
1189 N_Object_Declaration,
1190 N_Parameter_Specification)
1192 Set_SCIL_Controlling_Tag (SCIL_Node,
1193 Parent (Entity (Prefix (Controlling_Tag))));
1195 -- For a direct reference of the tag of the type the SCIL node
1196 -- references the internal object declaration containing the tag
1199 elsif Nkind (Controlling_Tag) = N_Attribute_Reference
1200 and then Attribute_Name (Controlling_Tag) = Name_Tag
1202 Set_SCIL_Controlling_Tag (SCIL_Node,
1206 (Access_Disp_Table (Entity (Prefix (Controlling_Tag)))))));
1208 -- Interfaces are not supported. For now we leave the SCIL node
1209 -- decorated with the Controlling_Tag. More work needed here???
1211 elsif Is_Interface (Etype (Controlling_Tag)) then
1212 Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
1215 pragma Assert (False);
1220 if Nkind (Call_Node) = N_Function_Call then
1222 Make_Function_Call (Loc,
1223 Name => New_Call_Name,
1224 Parameter_Associations => New_Params);
1226 -- If this is a dispatching "=", we must first compare the tags so
1227 -- we generate: x.tag = y.tag and then x = y
1229 if Subp = Eq_Prim_Op then
1230 Param := First_Actual (Call_Node);
1236 Make_Selected_Component (Loc,
1237 Prefix => New_Value (Param),
1239 New_Occurrence_Of (First_Tag_Component (Typ),
1243 Make_Selected_Component (Loc,
1245 Unchecked_Convert_To (Typ,
1246 New_Value (Next_Actual (Param))),
1249 (First_Tag_Component (Typ), Loc))),
1250 Right_Opnd => New_Call);
1252 SCIL_Related_Node := Right_Opnd (New_Call);
1257 Make_Procedure_Call_Statement (Loc,
1258 Name => New_Call_Name,
1259 Parameter_Associations => New_Params);
1262 -- Register the dispatching call in the call graph nodes table
1264 Register_CG_Node (Call_Node);
1266 Rewrite (Call_Node, New_Call);
1268 -- Associate the SCIL node of this dispatching call
1270 if Generate_SCIL then
1271 Set_SCIL_Node (SCIL_Related_Node, SCIL_Node);
1274 -- Suppress all checks during the analysis of the expanded code to avoid
1275 -- the generation of spurious warnings under ZFP run-time.
1277 Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks);
1278 end Expand_Dispatching_Call;
1280 ---------------------------------
1281 -- Expand_Interface_Conversion --
1282 ---------------------------------
1284 procedure Expand_Interface_Conversion (N : Node_Id) is
1285 function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id;
1286 -- Return the underlying record type of Typ
1288 ----------------------------
1289 -- Underlying_Record_Type --
1290 ----------------------------
1292 function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id is
1293 E : Entity_Id := Typ;
1296 -- Handle access types
1298 if Is_Access_Type (E) then
1299 E := Directly_Designated_Type (E);
1302 -- Handle class-wide types. This conversion can appear explicitly in
1303 -- the source code. Example: I'Class (Obj)
1305 if Is_Class_Wide_Type (E) then
1309 -- If the target type is a tagged synchronized type, the dispatch
1310 -- table info is in the corresponding record type.
1312 if Is_Concurrent_Type (E) then
1313 E := Corresponding_Record_Type (E);
1316 -- Handle private types
1318 E := Underlying_Type (E);
1322 return Base_Type (E);
1323 end Underlying_Record_Type;
1327 Loc : constant Source_Ptr := Sloc (N);
1328 Etyp : constant Entity_Id := Etype (N);
1329 Operand : constant Node_Id := Expression (N);
1330 Operand_Typ : Entity_Id := Etype (Operand);
1332 Iface_Typ : constant Entity_Id := Underlying_Record_Type (Etype (N));
1333 Iface_Tag : Entity_Id;
1334 Is_Static : Boolean;
1336 -- Start of processing for Expand_Interface_Conversion
1339 -- Freeze the entity associated with the target interface to have
1340 -- available the attribute Access_Disp_Table.
1342 Freeze_Before (N, Iface_Typ);
1344 -- Ada 2005 (AI-345): Handle synchronized interface type derivations
1346 if Is_Concurrent_Type (Operand_Typ) then
1347 Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
1350 -- No displacement of the pointer to the object needed when the type of
1351 -- the operand is not an interface type and the interface is one of
1352 -- its parent types (since they share the primary dispatch table).
1355 Opnd : Entity_Id := Operand_Typ;
1358 if Is_Access_Type (Opnd) then
1359 Opnd := Designated_Type (Opnd);
1362 Opnd := Underlying_Record_Type (Opnd);
1364 if not Is_Interface (Opnd)
1365 and then Is_Ancestor (Iface_Typ, Opnd, Use_Full_View => True)
1370 -- When the type of the operand and the target interface type match,
1371 -- it is generally safe to skip generating code to displace the
1372 -- pointer to the object to reference the secondary dispatch table
1373 -- associated with the target interface type. The exception to this
1374 -- general rule is when the underlying object of the type conversion
1375 -- is an object built by means of a dispatching constructor (since in
1376 -- such case the expansion of the constructor call is a direct call
1377 -- to an object primitive, i.e. without thunks, and the expansion of
1378 -- the constructor call adds an explicit conversion to the target
1379 -- interface type to force the displacement of the pointer to the
1380 -- object to reference the corresponding secondary dispatch table
1381 -- (cf. Make_DT and Expand_Dispatching_Constructor_Call)).
1383 -- At this stage we cannot identify whether the underlying object is
1384 -- a BIP object and hence we cannot skip generating the code to try
1385 -- displacing the pointer to the object. However, under configurable
1386 -- runtime it is safe to skip generating code to displace the pointer
1387 -- to the object, because generic dispatching constructors are not
1390 if Opnd = Iface_Typ and then not RTE_Available (RE_Displace) then
1395 -- Evaluate if we can statically displace the pointer to the object
1398 Opnd_Typ : constant Node_Id := Underlying_Record_Type (Operand_Typ);
1402 not Is_Interface (Opnd_Typ)
1403 and then Interface_Present_In_Ancestor
1406 and then (Etype (Opnd_Typ) = Opnd_Typ
1408 Is_Variable_Size_Record (Etype (Opnd_Typ)));
1411 if not Tagged_Type_Expansion then
1414 -- A static conversion to an interface type that is not class-wide is
1415 -- curious but legal if the interface operation is a null procedure.
1416 -- If the operation is abstract it will be rejected later.
1419 and then Is_Interface (Etype (N))
1420 and then not Is_Class_Wide_Type (Etype (N))
1421 and then Comes_From_Source (N)
1423 Rewrite (N, Unchecked_Convert_To (Etype (N), N));
1428 if not Is_Static then
1430 -- Give error if configurable run-time and Displace not available
1432 if not RTE_Available (RE_Displace) then
1433 Error_Msg_CRT ("dynamic interface conversion", N);
1437 -- Handle conversion of access-to-class-wide interface types. Target
1438 -- can be an access to an object or an access to another class-wide
1439 -- interface (see -1- and -2- in the following example):
1441 -- type Iface1_Ref is access all Iface1'Class;
1442 -- type Iface2_Ref is access all Iface1'Class;
1444 -- Acc1 : Iface1_Ref := new ...
1445 -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1
1446 -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
1448 if Is_Access_Type (Operand_Typ) then
1450 Unchecked_Convert_To (Etype (N),
1451 Make_Function_Call (Loc,
1452 Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
1453 Parameter_Associations => New_List (
1455 Unchecked_Convert_To (RTE (RE_Address),
1456 Relocate_Node (Expression (N))),
1459 (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
1467 Make_Function_Call (Loc,
1468 Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
1469 Parameter_Associations => New_List (
1470 Make_Attribute_Reference (Loc,
1471 Prefix => Relocate_Node (Expression (N)),
1472 Attribute_Name => Name_Address),
1475 (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
1480 -- If target is a class-wide interface, change the type of the data
1481 -- returned by IW_Convert to indicate this is a dispatching call.
1484 New_Itype : Entity_Id;
1487 New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
1488 Set_Etype (New_Itype, New_Itype);
1489 Set_Directly_Designated_Type (New_Itype, Etyp);
1492 Make_Explicit_Dereference (Loc,
1494 Unchecked_Convert_To (New_Itype, Relocate_Node (N))));
1496 Freeze_Itype (New_Itype, N);
1502 Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
1503 pragma Assert (Present (Iface_Tag));
1505 -- Keep separate access types to interfaces because one internal
1506 -- function is used to handle the null value (see following comments)
1508 if not Is_Access_Type (Etype (N)) then
1510 -- Statically displace the pointer to the object to reference the
1511 -- component containing the secondary dispatch table.
1514 Convert_Tag_To_Interface (Class_Wide_Type (Iface_Typ),
1515 Make_Selected_Component (Loc,
1516 Prefix => Relocate_Node (Expression (N)),
1517 Selector_Name => New_Occurrence_Of (Iface_Tag, Loc))));
1520 -- Build internal function to handle the case in which the actual is
1521 -- null. If the actual is null returns null because no displacement
1522 -- is required; otherwise performs a type conversion that will be
1523 -- expanded in the code that returns the value of the displaced
1526 -- function Func (O : Address) return Iface_Typ is
1527 -- type Op_Typ is access all Operand_Typ;
1528 -- Aux : Op_Typ := To_Op_Typ (O);
1530 -- if O = Null_Address then
1533 -- return Iface_Typ!(Aux.Iface_Tag'Address);
1538 Desig_Typ : Entity_Id;
1540 New_Typ_Decl : Node_Id;
1544 Desig_Typ := Etype (Expression (N));
1546 if Is_Access_Type (Desig_Typ) then
1548 Available_View (Directly_Designated_Type (Desig_Typ));
1551 if Is_Concurrent_Type (Desig_Typ) then
1552 Desig_Typ := Base_Type (Corresponding_Record_Type (Desig_Typ));
1556 Make_Full_Type_Declaration (Loc,
1557 Defining_Identifier => Make_Temporary (Loc, 'T'),
1559 Make_Access_To_Object_Definition (Loc,
1560 All_Present => True,
1561 Null_Exclusion_Present => False,
1562 Constant_Present => False,
1563 Subtype_Indication =>
1564 New_Occurrence_Of (Desig_Typ, Loc)));
1567 Make_Simple_Return_Statement (Loc,
1568 Unchecked_Convert_To (Etype (N),
1569 Make_Attribute_Reference (Loc,
1571 Make_Selected_Component (Loc,
1573 Unchecked_Convert_To
1574 (Defining_Identifier (New_Typ_Decl),
1575 Make_Identifier (Loc, Name_uO)),
1577 New_Occurrence_Of (Iface_Tag, Loc)),
1578 Attribute_Name => Name_Address))));
1580 -- If the type is null-excluding, no need for the null branch.
1581 -- Otherwise we need to check for it and return null.
1583 if not Can_Never_Be_Null (Etype (N)) then
1585 Make_If_Statement (Loc,
1588 Left_Opnd => Make_Identifier (Loc, Name_uO),
1589 Right_Opnd => New_Occurrence_Of
1590 (RTE (RE_Null_Address), Loc)),
1592 Then_Statements => New_List (
1593 Make_Simple_Return_Statement (Loc, Make_Null (Loc))),
1594 Else_Statements => Stats));
1597 Fent := Make_Temporary (Loc, 'F');
1599 Make_Subprogram_Body (Loc,
1601 Make_Function_Specification (Loc,
1602 Defining_Unit_Name => Fent,
1604 Parameter_Specifications => New_List (
1605 Make_Parameter_Specification (Loc,
1606 Defining_Identifier =>
1607 Make_Defining_Identifier (Loc, Name_uO),
1609 New_Occurrence_Of (RTE (RE_Address), Loc))),
1611 Result_Definition =>
1612 New_Occurrence_Of (Etype (N), Loc)),
1614 Declarations => New_List (New_Typ_Decl),
1616 Handled_Statement_Sequence =>
1617 Make_Handled_Sequence_Of_Statements (Loc, Stats));
1619 -- Place function body before the expression containing the
1620 -- conversion. We suppress all checks because the body of the
1621 -- internally generated function already takes care of the case
1622 -- in which the actual is null; therefore there is no need to
1623 -- double check that the pointer is not null when the program
1624 -- executes the alternative that performs the type conversion).
1626 Insert_Action (N, Func, Suppress => All_Checks);
1628 if Is_Access_Type (Etype (Expression (N))) then
1630 -- Generate: Func (Address!(Expression))
1633 Make_Function_Call (Loc,
1634 Name => New_Occurrence_Of (Fent, Loc),
1635 Parameter_Associations => New_List (
1636 Unchecked_Convert_To (RTE (RE_Address),
1637 Relocate_Node (Expression (N))))));
1640 -- Generate: Func (Operand_Typ!(Expression)'Address)
1643 Make_Function_Call (Loc,
1644 Name => New_Occurrence_Of (Fent, Loc),
1645 Parameter_Associations => New_List (
1646 Make_Attribute_Reference (Loc,
1647 Prefix => Unchecked_Convert_To (Operand_Typ,
1648 Relocate_Node (Expression (N))),
1649 Attribute_Name => Name_Address))));
1655 end Expand_Interface_Conversion;
1657 ------------------------------
1658 -- Expand_Interface_Actuals --
1659 ------------------------------
1661 procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
1663 Actual_Dup : Node_Id;
1664 Actual_Typ : Entity_Id;
1666 Conversion : Node_Id;
1668 Formal_Typ : Entity_Id;
1670 Formal_DDT : Entity_Id := Empty; -- initialize to prevent warning
1671 Actual_DDT : Entity_Id := Empty; -- initialize to prevent warning
1674 -- This subprogram is called directly from the semantics, so we need a
1675 -- check to see whether expansion is active before proceeding.
1677 if not Expander_Active then
1681 -- Call using access to subprogram with explicit dereference
1683 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
1684 Subp := Etype (Name (Call_Node));
1686 -- Call using selected component
1688 elsif Nkind (Name (Call_Node)) = N_Selected_Component then
1689 Subp := Entity (Selector_Name (Name (Call_Node)));
1691 -- Call using direct name
1694 Subp := Entity (Name (Call_Node));
1697 -- Ada 2005 (AI-251): Look for interface type formals to force "this"
1700 Formal := First_Formal (Subp);
1701 Actual := First_Actual (Call_Node);
1702 while Present (Formal) loop
1703 Formal_Typ := Etype (Formal);
1705 if Has_Non_Limited_View (Formal_Typ) then
1706 Formal_Typ := Non_Limited_View (Formal_Typ);
1709 if Ekind (Formal_Typ) = E_Record_Type_With_Private then
1710 Formal_Typ := Full_View (Formal_Typ);
1713 if Is_Access_Type (Formal_Typ) then
1714 Formal_DDT := Directly_Designated_Type (Formal_Typ);
1716 if Has_Non_Limited_View (Formal_DDT) then
1717 Formal_DDT := Non_Limited_View (Formal_DDT);
1721 Actual_Typ := Etype (Actual);
1723 if Has_Non_Limited_View (Actual_Typ) then
1724 Actual_Typ := Non_Limited_View (Actual_Typ);
1727 if Is_Access_Type (Actual_Typ) then
1728 Actual_DDT := Directly_Designated_Type (Actual_Typ);
1730 if Has_Non_Limited_View (Actual_DDT) then
1731 Actual_DDT := Non_Limited_View (Actual_DDT);
1735 if Is_Interface (Formal_Typ)
1736 and then Is_Class_Wide_Type (Formal_Typ)
1738 -- No need to displace the pointer if the type of the actual
1739 -- coincides with the type of the formal.
1741 if Actual_Typ = Formal_Typ then
1744 -- No need to displace the pointer if the interface type is a
1745 -- parent of the type of the actual because in this case the
1746 -- interface primitives are located in the primary dispatch table.
1748 elsif Is_Ancestor (Formal_Typ, Actual_Typ,
1749 Use_Full_View => True)
1753 -- Implicit conversion to the class-wide formal type to force the
1754 -- displacement of the pointer.
1757 -- Normally, expansion of actuals for calls to build-in-place
1758 -- functions happens as part of Expand_Actuals, but in this
1759 -- case the call will be wrapped in a conversion and soon after
1760 -- expanded further to handle the displacement for a class-wide
1761 -- interface conversion, so if this is a BIP call then we need
1762 -- to handle it now.
1764 if Is_Build_In_Place_Function_Call (Actual) then
1765 Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
1768 Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
1769 Rewrite (Actual, Conversion);
1770 Analyze_And_Resolve (Actual, Formal_Typ);
1773 -- Access to class-wide interface type
1775 elsif Is_Access_Type (Formal_Typ)
1776 and then Is_Interface (Formal_DDT)
1777 and then Is_Class_Wide_Type (Formal_DDT)
1778 and then Interface_Present_In_Ancestor
1780 Iface => Etype (Formal_DDT))
1782 -- Handle attributes 'Access and 'Unchecked_Access
1784 if Nkind (Actual) = N_Attribute_Reference
1786 (Attribute_Name (Actual) = Name_Access
1787 or else Attribute_Name (Actual) = Name_Unchecked_Access)
1789 -- This case must have been handled by the analysis and
1790 -- expansion of 'Access. The only exception is when types
1791 -- match and no further expansion is required.
1793 pragma Assert (Base_Type (Etype (Prefix (Actual)))
1794 = Base_Type (Formal_DDT));
1797 -- No need to displace the pointer if the type of the actual
1798 -- coincides with the type of the formal.
1800 elsif Actual_DDT = Formal_DDT then
1803 -- No need to displace the pointer if the interface type is
1804 -- a parent of the type of the actual because in this case the
1805 -- interface primitives are located in the primary dispatch table.
1807 elsif Is_Ancestor (Formal_DDT, Actual_DDT,
1808 Use_Full_View => True)
1813 Actual_Dup := Relocate_Node (Actual);
1815 if From_Limited_With (Actual_Typ) then
1817 -- If the type of the actual parameter comes from a limited
1818 -- with_clause and the nonlimited view is already available,
1819 -- we replace the anonymous access type by a duplicate
1820 -- declaration whose designated type is the nonlimited view.
1822 if Has_Non_Limited_View (Actual_DDT) then
1823 Anon := New_Copy (Actual_Typ);
1825 if Is_Itype (Anon) then
1826 Set_Scope (Anon, Current_Scope);
1829 Set_Directly_Designated_Type
1830 (Anon, Non_Limited_View (Actual_DDT));
1831 Set_Etype (Actual_Dup, Anon);
1835 Conversion := Convert_To (Formal_Typ, Actual_Dup);
1836 Rewrite (Actual, Conversion);
1837 Analyze_And_Resolve (Actual, Formal_Typ);
1841 Next_Actual (Actual);
1842 Next_Formal (Formal);
1844 end Expand_Interface_Actuals;
1846 ----------------------------
1847 -- Expand_Interface_Thunk --
1848 ----------------------------
1850 procedure Expand_Interface_Thunk
1852 Thunk_Id : out Entity_Id;
1853 Thunk_Code : out Node_Id;
1856 Loc : constant Source_Ptr := Sloc (Prim);
1857 Actuals : constant List_Id := New_List;
1858 Decl : constant List_Id := New_List;
1859 Formals : constant List_Id := New_List;
1860 Target : constant Entity_Id := Ultimate_Alias (Prim);
1867 Iface_Formal : Node_Id := Empty; -- initialize to prevent warning
1868 Is_Predef_Op : constant Boolean :=
1869 Is_Predefined_Dispatching_Operation (Prim)
1870 or else Is_Predefined_Dispatching_Operation (Target);
1872 Offset_To_Top : Node_Id;
1873 Target_Formal : Entity_Id;
1877 Thunk_Code := Empty;
1879 -- No thunk needed if the primitive has been eliminated
1881 if Is_Eliminated (Target) then
1884 -- In case of primitives that are functions without formals and a
1885 -- controlling result there is no need to build the thunk.
1887 elsif not Present (First_Formal (Target)) then
1888 pragma Assert (Ekind (Target) = E_Function
1889 and then Has_Controlling_Result (Target));
1893 -- Duplicate the formals of the Target primitive. In the thunk, the type
1894 -- of the controlling formal is the covered interface type (instead of
1895 -- the target tagged type). Done to avoid problems with discriminated
1896 -- tagged types because, if the controlling type has discriminants with
1897 -- default values, then the type conversions done inside the body of
1898 -- the thunk (after the displacement of the pointer to the base of the
1899 -- actual object) generate code that modify its contents.
1901 -- Note: This special management is not done for predefined primitives
1902 -- because they don't have available the Interface_Alias attribute (see
1903 -- Sem_Ch3.Add_Internal_Interface_Entities).
1905 if not Is_Predef_Op then
1906 Iface_Formal := First_Formal (Interface_Alias (Prim));
1909 Formal := First_Formal (Target);
1910 while Present (Formal) loop
1911 Ftyp := Etype (Formal);
1913 -- Use the interface type as the type of the controlling formal (see
1916 if not Is_Controlling_Formal (Formal) then
1917 Ftyp := Etype (Formal);
1918 Expr := New_Copy_Tree (Expression (Parent (Formal)));
1920 -- For predefined primitives the controlling type of the thunk is
1921 -- the interface type passed by the caller (since they don't have
1922 -- available the Interface_Alias attribute; see comment above).
1924 elsif Is_Predef_Op then
1929 Ftyp := Etype (Iface_Formal);
1932 -- Sanity check performed to ensure the proper controlling type
1933 -- when the thunk has exactly one controlling parameter and it
1934 -- comes first. In such case the GCC backend reuses the C++
1935 -- thunks machinery which perform a computation equivalent to
1936 -- the code generated by the expander; for other cases the GCC
1937 -- backend translates the expanded code unmodified. However, as
1938 -- a generalization, the check is performed for all controlling
1941 if Is_Access_Type (Ftyp) then
1942 pragma Assert (Base_Type (Designated_Type (Ftyp)) = Iface);
1945 Ftyp := Base_Type (Ftyp);
1946 pragma Assert (Ftyp = Iface);
1951 Make_Parameter_Specification (Loc,
1952 Defining_Identifier =>
1953 Make_Defining_Identifier (Sloc (Formal),
1954 Chars => Chars (Formal)),
1955 In_Present => In_Present (Parent (Formal)),
1956 Out_Present => Out_Present (Parent (Formal)),
1957 Parameter_Type => New_Occurrence_Of (Ftyp, Loc),
1958 Expression => Expr));
1960 if not Is_Predef_Op then
1961 Next_Formal (Iface_Formal);
1964 Next_Formal (Formal);
1967 Target_Formal := First_Formal (Target);
1968 Formal := First (Formals);
1969 while Present (Formal) loop
1971 -- If the parent is a constrained discriminated type, then the
1972 -- primitive operation will have been defined on a first subtype.
1973 -- For proper matching with controlling type, use base type.
1975 if Ekind (Target_Formal) = E_In_Parameter
1976 and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
1979 Base_Type (Directly_Designated_Type (Etype (Target_Formal)));
1981 Ftyp := Base_Type (Etype (Target_Formal));
1984 -- For concurrent types, the relevant information is found in the
1985 -- Corresponding_Record_Type, rather than the type entity itself.
1987 if Is_Concurrent_Type (Ftyp) then
1988 Ftyp := Corresponding_Record_Type (Ftyp);
1991 if Ekind (Target_Formal) = E_In_Parameter
1992 and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
1993 and then Is_Controlling_Formal (Target_Formal)
1996 -- type T is access all <<type of the target formal>>
1997 -- S : Storage_Offset := Storage_Offset!(Formal)
1998 -- + Offset_To_Top (address!(Formal))
2001 Make_Full_Type_Declaration (Loc,
2002 Defining_Identifier => Make_Temporary (Loc, 'T'),
2004 Make_Access_To_Object_Definition (Loc,
2005 All_Present => True,
2006 Null_Exclusion_Present => False,
2007 Constant_Present => False,
2008 Subtype_Indication =>
2009 New_Occurrence_Of (Ftyp, Loc)));
2012 Unchecked_Convert_To (RTE (RE_Address),
2013 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
2015 if not RTE_Available (RE_Offset_To_Top) then
2017 Build_Offset_To_Top (Loc, New_Arg);
2020 Make_Function_Call (Loc,
2021 Name => New_Occurrence_Of (RTE (RE_Offset_To_Top), Loc),
2022 Parameter_Associations => New_List (New_Arg));
2026 Make_Object_Declaration (Loc,
2027 Defining_Identifier => Make_Temporary (Loc, 'S'),
2028 Constant_Present => True,
2029 Object_Definition =>
2030 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
2034 Unchecked_Convert_To
2035 (RTE (RE_Storage_Offset),
2037 (Defining_Identifier (Formal), Loc)),
2041 Append_To (Decl, Decl_2);
2042 Append_To (Decl, Decl_1);
2044 -- Reference the new actual. Generate:
2048 Unchecked_Convert_To
2049 (Defining_Identifier (Decl_2),
2050 New_Occurrence_Of (Defining_Identifier (Decl_1), Loc)));
2052 elsif Is_Controlling_Formal (Target_Formal) then
2055 -- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
2056 -- + Offset_To_Top (Formal'Address)
2057 -- S2 : Addr_Ptr := Addr_Ptr!(S1)
2060 Make_Attribute_Reference (Loc,
2062 New_Occurrence_Of (Defining_Identifier (Formal), Loc),
2066 if not RTE_Available (RE_Offset_To_Top) then
2068 Build_Offset_To_Top (Loc, New_Arg);
2071 Make_Function_Call (Loc,
2072 Name => New_Occurrence_Of (RTE (RE_Offset_To_Top), Loc),
2073 Parameter_Associations => New_List (New_Arg));
2077 Make_Object_Declaration (Loc,
2078 Defining_Identifier => Make_Temporary (Loc, 'S'),
2079 Constant_Present => True,
2080 Object_Definition =>
2081 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
2085 Unchecked_Convert_To
2086 (RTE (RE_Storage_Offset),
2087 Make_Attribute_Reference (Loc,
2090 (Defining_Identifier (Formal), Loc),
2091 Attribute_Name => Name_Address)),
2096 Make_Object_Declaration (Loc,
2097 Defining_Identifier => Make_Temporary (Loc, 'S'),
2098 Constant_Present => True,
2099 Object_Definition =>
2100 New_Occurrence_Of (RTE (RE_Addr_Ptr), Loc),
2102 Unchecked_Convert_To
2104 New_Occurrence_Of (Defining_Identifier (Decl_1), Loc)));
2106 Append_To (Decl, Decl_1);
2107 Append_To (Decl, Decl_2);
2109 -- Reference the new actual, generate:
2110 -- Target_Formal (S2.all)
2113 Unchecked_Convert_To (Ftyp,
2114 Make_Explicit_Dereference (Loc,
2115 New_Occurrence_Of (Defining_Identifier (Decl_2), Loc))));
2117 -- Ensure proper matching of access types. Required to avoid
2118 -- reporting spurious errors.
2120 elsif Is_Access_Type (Etype (Target_Formal)) then
2122 Unchecked_Convert_To (Base_Type (Etype (Target_Formal)),
2123 New_Occurrence_Of (Defining_Identifier (Formal), Loc)));
2125 -- No special management required for this actual
2129 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
2132 Next_Formal (Target_Formal);
2136 Thunk_Id := Make_Temporary (Loc, 'T');
2137 Set_Ekind (Thunk_Id, Ekind (Prim));
2138 Set_Is_Thunk (Thunk_Id);
2139 Set_Convention (Thunk_Id, Convention (Prim));
2140 Set_Needs_Debug_Info (Thunk_Id, Needs_Debug_Info (Target));
2141 Set_Thunk_Entity (Thunk_Id, Target);
2145 if Ekind (Target) = E_Procedure then
2147 Make_Subprogram_Body (Loc,
2149 Make_Procedure_Specification (Loc,
2150 Defining_Unit_Name => Thunk_Id,
2151 Parameter_Specifications => Formals),
2152 Declarations => Decl,
2153 Handled_Statement_Sequence =>
2154 Make_Handled_Sequence_Of_Statements (Loc,
2155 Statements => New_List (
2156 Make_Procedure_Call_Statement (Loc,
2157 Name => New_Occurrence_Of (Target, Loc),
2158 Parameter_Associations => Actuals))));
2162 else pragma Assert (Ekind (Target) = E_Function);
2164 Result_Def : Node_Id;
2165 Call_Node : Node_Id;
2169 Make_Function_Call (Loc,
2170 Name => New_Occurrence_Of (Target, Loc),
2171 Parameter_Associations => Actuals);
2173 if not Is_Interface (Etype (Prim)) then
2174 Result_Def := New_Copy (Result_Definition (Parent (Target)));
2176 -- Thunk of function returning a class-wide interface object. No
2177 -- extra displacement needed since the displacement is generated
2178 -- in the return statement of Prim. Example:
2180 -- type Iface is interface ...
2181 -- function F (O : Iface) return Iface'Class;
2183 -- type T is new ... and Iface with ...
2184 -- function F (O : T) return Iface'Class;
2186 elsif Is_Class_Wide_Type (Etype (Prim)) then
2187 Result_Def := New_Occurrence_Of (Etype (Prim), Loc);
2189 -- Thunk of function returning an interface object. Displacement
2192 -- type Iface is interface ...
2193 -- function F (O : Iface) return Iface;
2195 -- type T is new ... and Iface with ...
2196 -- function F (O : T) return T;
2200 New_Occurrence_Of (Class_Wide_Type (Etype (Prim)), Loc);
2202 -- Adding implicit conversion to force the displacement of
2203 -- the pointer to the object to reference the corresponding
2204 -- secondary dispatch table.
2207 Make_Type_Conversion (Loc,
2209 New_Occurrence_Of (Class_Wide_Type (Etype (Prim)), Loc),
2210 Expression => Relocate_Node (Call_Node));
2214 Make_Subprogram_Body (Loc,
2216 Make_Function_Specification (Loc,
2217 Defining_Unit_Name => Thunk_Id,
2218 Parameter_Specifications => Formals,
2219 Result_Definition => Result_Def),
2220 Declarations => Decl,
2221 Handled_Statement_Sequence =>
2222 Make_Handled_Sequence_Of_Statements (Loc,
2223 Statements => New_List (
2224 Make_Simple_Return_Statement (Loc, Call_Node))));
2227 end Expand_Interface_Thunk;
2229 --------------------------
2230 -- Has_CPP_Constructors --
2231 --------------------------
2233 function Has_CPP_Constructors (Typ : Entity_Id) return Boolean is
2237 -- Look for the constructor entities
2239 E := Next_Entity (Typ);
2240 while Present (E) loop
2241 if Ekind (E) = E_Function and then Is_Constructor (E) then
2249 end Has_CPP_Constructors;
2255 function Has_DT (Typ : Entity_Id) return Boolean is
2257 return not Is_Interface (Typ)
2258 and then not Restriction_Active (No_Dispatching_Calls);
2261 ----------------------------------
2262 -- Is_Expanded_Dispatching_Call --
2263 ----------------------------------
2265 function Is_Expanded_Dispatching_Call (N : Node_Id) return Boolean is
2267 return Nkind (N) in N_Subprogram_Call
2268 and then Nkind (Name (N)) = N_Explicit_Dereference
2269 and then Is_Dispatch_Table_Entity (Etype (Name (N)));
2270 end Is_Expanded_Dispatching_Call;
2272 -------------------------------------
2273 -- Is_Predefined_Dispatching_Alias --
2274 -------------------------------------
2276 function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean
2279 return not Is_Predefined_Dispatching_Operation (Prim)
2280 and then Present (Alias (Prim))
2281 and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim));
2282 end Is_Predefined_Dispatching_Alias;
2284 ----------------------------------------
2285 -- Make_Disp_Asynchronous_Select_Body --
2286 ----------------------------------------
2288 -- For interface types, generate:
2290 -- procedure _Disp_Asynchronous_Select
2291 -- (T : in out <Typ>;
2293 -- P : System.Address;
2294 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2299 -- C := Ada.Tags.POK_Function;
2300 -- end _Disp_Asynchronous_Select;
2302 -- For protected types, generate:
2304 -- procedure _Disp_Asynchronous_Select
2305 -- (T : in out <Typ>;
2307 -- P : System.Address;
2308 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2312 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2313 -- Bnn : System.Tasking.Protected_Objects.Operations.
2314 -- Communication_Block;
2316 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2317 -- (T._object'Access,
2318 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2320 -- System.Tasking.Asynchronous_Call,
2322 -- B := System.Storage_Elements.Dummy_Communication_Block (Bnn);
2323 -- end _Disp_Asynchronous_Select;
2325 -- For task types, generate:
2327 -- procedure _Disp_Asynchronous_Select
2328 -- (T : in out <Typ>;
2330 -- P : System.Address;
2331 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2335 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2337 -- System.Tasking.Rendezvous.Task_Entry_Call
2339 -- System.Tasking.Task_Entry_Index (I),
2341 -- System.Tasking.Asynchronous_Call,
2343 -- end _Disp_Asynchronous_Select;
2345 function Make_Disp_Asynchronous_Select_Body
2346 (Typ : Entity_Id) return Node_Id
2348 Com_Block : Entity_Id;
2349 Conc_Typ : Entity_Id := Empty;
2350 Decls : constant List_Id := New_List;
2351 Loc : constant Source_Ptr := Sloc (Typ);
2353 Stmts : constant List_Id := New_List;
2357 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2359 -- Null body is generated for interface types
2361 if Is_Interface (Typ) then
2363 Make_Subprogram_Body (Loc,
2365 Make_Disp_Asynchronous_Select_Spec (Typ),
2366 Declarations => New_List,
2367 Handled_Statement_Sequence =>
2368 Make_Handled_Sequence_Of_Statements (Loc,
2370 Make_Assignment_Statement (Loc,
2371 Name => Make_Identifier (Loc, Name_uF),
2372 Expression => New_Occurrence_Of (Standard_False, Loc)))));
2375 if Is_Concurrent_Record_Type (Typ) then
2376 Conc_Typ := Corresponding_Concurrent_Type (Typ);
2380 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2382 -- where I will be used to capture the entry index of the primitive
2383 -- wrapper at position S.
2385 if Tagged_Type_Expansion then
2387 Unchecked_Convert_To (RTE (RE_Tag),
2389 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2392 Make_Attribute_Reference (Loc,
2393 Prefix => New_Occurrence_Of (Typ, Loc),
2394 Attribute_Name => Name_Tag);
2398 Make_Object_Declaration (Loc,
2399 Defining_Identifier =>
2400 Make_Defining_Identifier (Loc, Name_uI),
2401 Object_Definition =>
2402 New_Occurrence_Of (Standard_Integer, Loc),
2404 Make_Function_Call (Loc,
2406 New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
2407 Parameter_Associations =>
2408 New_List (Tag_Node, Make_Identifier (Loc, Name_uS)))));
2410 if Ekind (Conc_Typ) = E_Protected_Type then
2413 -- Bnn : Communication_Block;
2415 Com_Block := Make_Temporary (Loc, 'B');
2417 Make_Object_Declaration (Loc,
2418 Defining_Identifier => Com_Block,
2419 Object_Definition =>
2420 New_Occurrence_Of (RTE (RE_Communication_Block), Loc)));
2422 -- Build T._object'Access for calls below
2425 Make_Attribute_Reference (Loc,
2426 Attribute_Name => Name_Unchecked_Access,
2428 Make_Selected_Component (Loc,
2429 Prefix => Make_Identifier (Loc, Name_uT),
2430 Selector_Name => Make_Identifier (Loc, Name_uObject)));
2432 case Corresponding_Runtime_Package (Conc_Typ) is
2433 when System_Tasking_Protected_Objects_Entries =>
2436 -- Protected_Entry_Call
2437 -- (T._object'Access, -- Object
2438 -- Protected_Entry_Index! (I), -- E
2439 -- P, -- Uninterpreted_Data
2440 -- Asynchronous_Call, -- Mode
2441 -- Bnn); -- Communication_Block
2443 -- where T is the protected object, I is the entry index, P
2444 -- is the wrapped parameters and B is the name of the
2445 -- communication block.
2448 Make_Procedure_Call_Statement (Loc,
2450 New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc),
2451 Parameter_Associations =>
2455 Make_Unchecked_Type_Conversion (Loc, -- entry index
2458 (RTE (RE_Protected_Entry_Index), Loc),
2459 Expression => Make_Identifier (Loc, Name_uI)),
2461 Make_Identifier (Loc, Name_uP), -- parameter block
2462 New_Occurrence_Of -- Asynchronous_Call
2463 (RTE (RE_Asynchronous_Call), Loc),
2464 New_Occurrence_Of -- comm block
2465 (Com_Block, Loc))));
2468 raise Program_Error;
2472 -- B := Dummy_Communication_Block (Bnn);
2475 Make_Assignment_Statement (Loc,
2476 Name => Make_Identifier (Loc, Name_uB),
2478 Make_Unchecked_Type_Conversion (Loc,
2481 (RTE (RE_Dummy_Communication_Block), Loc),
2482 Expression => New_Occurrence_Of (Com_Block, Loc))));
2488 Make_Assignment_Statement (Loc,
2489 Name => Make_Identifier (Loc, Name_uF),
2490 Expression => New_Occurrence_Of (Standard_False, Loc)));
2493 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2497 -- (T._task_id, -- Acceptor
2498 -- Task_Entry_Index! (I), -- E
2499 -- P, -- Uninterpreted_Data
2500 -- Asynchronous_Call, -- Mode
2501 -- F); -- Rendezvous_Successful
2503 -- where T is the task object, I is the entry index, P is the
2504 -- wrapped parameters and F is the status flag.
2507 Make_Procedure_Call_Statement (Loc,
2509 New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc),
2510 Parameter_Associations =>
2512 Make_Selected_Component (Loc, -- T._task_id
2513 Prefix => Make_Identifier (Loc, Name_uT),
2514 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2516 Make_Unchecked_Type_Conversion (Loc, -- entry index
2518 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
2519 Expression => Make_Identifier (Loc, Name_uI)),
2521 Make_Identifier (Loc, Name_uP), -- parameter block
2522 New_Occurrence_Of -- Asynchronous_Call
2523 (RTE (RE_Asynchronous_Call), Loc),
2524 Make_Identifier (Loc, Name_uF)))); -- status flag
2528 -- Ensure that the statements list is non-empty
2531 Make_Assignment_Statement (Loc,
2532 Name => Make_Identifier (Loc, Name_uF),
2533 Expression => New_Occurrence_Of (Standard_False, Loc)));
2537 Make_Subprogram_Body (Loc,
2539 Make_Disp_Asynchronous_Select_Spec (Typ),
2540 Declarations => Decls,
2541 Handled_Statement_Sequence =>
2542 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2543 end Make_Disp_Asynchronous_Select_Body;
2545 ----------------------------------------
2546 -- Make_Disp_Asynchronous_Select_Spec --
2547 ----------------------------------------
2549 function Make_Disp_Asynchronous_Select_Spec
2550 (Typ : Entity_Id) return Node_Id
2552 Loc : constant Source_Ptr := Sloc (Typ);
2553 B_Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
2554 Def_Id : constant Entity_Id :=
2555 Make_Defining_Identifier (Loc,
2556 Name_uDisp_Asynchronous_Select);
2557 Params : constant List_Id := New_List;
2560 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2562 -- T : in out Typ; -- Object parameter
2563 -- S : Integer; -- Primitive operation slot
2564 -- P : Address; -- Wrapped parameters
2565 -- B : out Dummy_Communication_Block; -- Communication block dummy
2566 -- F : out Boolean; -- Status flag
2568 -- The B parameter may be left uninitialized
2570 Set_Warnings_Off (B_Id);
2572 Append_List_To (Params, New_List (
2574 Make_Parameter_Specification (Loc,
2575 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
2576 Parameter_Type => New_Occurrence_Of (Typ, Loc),
2578 Out_Present => True),
2580 Make_Parameter_Specification (Loc,
2581 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
2582 Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
2584 Make_Parameter_Specification (Loc,
2585 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
2586 Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)),
2588 Make_Parameter_Specification (Loc,
2589 Defining_Identifier => B_Id,
2591 New_Occurrence_Of (RTE (RE_Dummy_Communication_Block), Loc),
2592 Out_Present => True),
2594 Make_Parameter_Specification (Loc,
2595 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF),
2596 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
2597 Out_Present => True)));
2600 Make_Procedure_Specification (Loc,
2601 Defining_Unit_Name => Def_Id,
2602 Parameter_Specifications => Params);
2603 end Make_Disp_Asynchronous_Select_Spec;
2605 ---------------------------------------
2606 -- Make_Disp_Conditional_Select_Body --
2607 ---------------------------------------
2609 -- For interface types, generate:
2611 -- procedure _Disp_Conditional_Select
2612 -- (T : in out <Typ>;
2614 -- P : System.Address;
2615 -- C : out Ada.Tags.Prim_Op_Kind;
2620 -- C := Ada.Tags.POK_Function;
2621 -- end _Disp_Conditional_Select;
2623 -- For protected types, generate:
2625 -- procedure _Disp_Conditional_Select
2626 -- (T : in out <Typ>;
2628 -- P : System.Address;
2629 -- C : out Ada.Tags.Prim_Op_Kind;
2633 -- Bnn : System.Tasking.Protected_Objects.Operations.
2634 -- Communication_Block;
2637 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S));
2639 -- if C = Ada.Tags.POK_Procedure
2640 -- or else C = Ada.Tags.POK_Protected_Procedure
2641 -- or else C = Ada.Tags.POK_Task_Procedure
2647 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2648 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2649 -- (T.object'Access,
2650 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2652 -- System.Tasking.Conditional_Call,
2654 -- F := not Cancelled (Bnn);
2655 -- end _Disp_Conditional_Select;
2657 -- For task types, generate:
2659 -- procedure _Disp_Conditional_Select
2660 -- (T : in out <Typ>;
2662 -- P : System.Address;
2663 -- C : out Ada.Tags.Prim_Op_Kind;
2669 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2670 -- System.Tasking.Rendezvous.Task_Entry_Call
2672 -- System.Tasking.Task_Entry_Index (I),
2674 -- System.Tasking.Conditional_Call,
2676 -- end _Disp_Conditional_Select;
2678 function Make_Disp_Conditional_Select_Body
2679 (Typ : Entity_Id) return Node_Id
2681 Loc : constant Source_Ptr := Sloc (Typ);
2682 Blk_Nam : Entity_Id;
2683 Conc_Typ : Entity_Id := Empty;
2684 Decls : constant List_Id := New_List;
2686 Stmts : constant List_Id := New_List;
2690 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2692 -- Null body is generated for interface types
2694 if Is_Interface (Typ) then
2696 Make_Subprogram_Body (Loc,
2698 Make_Disp_Conditional_Select_Spec (Typ),
2699 Declarations => No_List,
2700 Handled_Statement_Sequence =>
2701 Make_Handled_Sequence_Of_Statements (Loc,
2702 New_List (Make_Assignment_Statement (Loc,
2703 Name => Make_Identifier (Loc, Name_uF),
2704 Expression => New_Occurrence_Of (Standard_False, Loc)))));
2707 if Is_Concurrent_Record_Type (Typ) then
2708 Conc_Typ := Corresponding_Concurrent_Type (Typ);
2713 -- where I will be used to capture the entry index of the primitive
2714 -- wrapper at position S.
2717 Make_Object_Declaration (Loc,
2718 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI),
2719 Object_Definition =>
2720 New_Occurrence_Of (Standard_Integer, Loc)));
2723 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S);
2725 -- if C = POK_Procedure
2726 -- or else C = POK_Protected_Procedure
2727 -- or else C = POK_Task_Procedure;
2733 Build_Common_Dispatching_Select_Statements (Typ, Stmts);
2736 -- Bnn : Communication_Block;
2738 -- where Bnn is the name of the communication block used in the
2739 -- call to Protected_Entry_Call.
2741 Blk_Nam := Make_Temporary (Loc, 'B');
2743 Make_Object_Declaration (Loc,
2744 Defining_Identifier => Blk_Nam,
2745 Object_Definition =>
2746 New_Occurrence_Of (RTE (RE_Communication_Block), Loc)));
2749 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2751 -- I is the entry index and S is the dispatch table slot
2753 if Tagged_Type_Expansion then
2755 Unchecked_Convert_To (RTE (RE_Tag),
2757 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2761 Make_Attribute_Reference (Loc,
2762 Prefix => New_Occurrence_Of (Typ, Loc),
2763 Attribute_Name => Name_Tag);
2767 Make_Assignment_Statement (Loc,
2768 Name => Make_Identifier (Loc, Name_uI),
2770 Make_Function_Call (Loc,
2772 New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
2773 Parameter_Associations => New_List (
2775 Make_Identifier (Loc, Name_uS)))));
2777 if Ekind (Conc_Typ) = E_Protected_Type then
2779 Obj_Ref := -- T._object'Access
2780 Make_Attribute_Reference (Loc,
2781 Attribute_Name => Name_Unchecked_Access,
2783 Make_Selected_Component (Loc,
2784 Prefix => Make_Identifier (Loc, Name_uT),
2785 Selector_Name => Make_Identifier (Loc, Name_uObject)));
2787 case Corresponding_Runtime_Package (Conc_Typ) is
2788 when System_Tasking_Protected_Objects_Entries =>
2791 -- Protected_Entry_Call
2792 -- (T._object'Access, -- Object
2793 -- Protected_Entry_Index! (I), -- E
2794 -- P, -- Uninterpreted_Data
2795 -- Conditional_Call, -- Mode
2798 -- where T is the protected object, I is the entry index, P
2799 -- are the wrapped parameters and Bnn is the name of the
2800 -- communication block.
2803 Make_Procedure_Call_Statement (Loc,
2805 New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc),
2806 Parameter_Associations => New_List (
2809 Make_Unchecked_Type_Conversion (Loc, -- entry index
2812 (RTE (RE_Protected_Entry_Index), Loc),
2813 Expression => Make_Identifier (Loc, Name_uI)),
2815 Make_Identifier (Loc, Name_uP), -- parameter block
2817 New_Occurrence_Of -- Conditional_Call
2818 (RTE (RE_Conditional_Call), Loc),
2819 New_Occurrence_Of -- Bnn
2822 when System_Tasking_Protected_Objects_Single_Entry =>
2824 -- If we are compiling for a restricted run-time, the call
2825 -- uses the simpler form.
2828 Make_Procedure_Call_Statement (Loc,
2831 (RTE (RE_Protected_Single_Entry_Call), Loc),
2832 Parameter_Associations => New_List (
2835 Make_Attribute_Reference (Loc,
2836 Prefix => Make_Identifier (Loc, Name_uP),
2837 Attribute_Name => Name_Address),
2840 (RTE (RE_Conditional_Call), Loc))));
2842 raise Program_Error;
2846 -- F := not Cancelled (Bnn);
2848 -- where F is the success flag. The status of Cancelled is negated
2849 -- in order to match the behavior of the version for task types.
2852 Make_Assignment_Statement (Loc,
2853 Name => Make_Identifier (Loc, Name_uF),
2857 Make_Function_Call (Loc,
2859 New_Occurrence_Of (RTE (RE_Cancelled), Loc),
2860 Parameter_Associations => New_List (
2861 New_Occurrence_Of (Blk_Nam, Loc))))));
2863 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2867 -- (T._task_id, -- Acceptor
2868 -- Task_Entry_Index! (I), -- E
2869 -- P, -- Uninterpreted_Data
2870 -- Conditional_Call, -- Mode
2871 -- F); -- Rendezvous_Successful
2873 -- where T is the task object, I is the entry index, P are the
2874 -- wrapped parameters and F is the status flag.
2877 Make_Procedure_Call_Statement (Loc,
2879 New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc),
2880 Parameter_Associations => New_List (
2882 Make_Selected_Component (Loc, -- T._task_id
2883 Prefix => Make_Identifier (Loc, Name_uT),
2884 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2886 Make_Unchecked_Type_Conversion (Loc, -- entry index
2888 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
2889 Expression => Make_Identifier (Loc, Name_uI)),
2891 Make_Identifier (Loc, Name_uP), -- parameter block
2892 New_Occurrence_Of -- Conditional_Call
2893 (RTE (RE_Conditional_Call), Loc),
2894 Make_Identifier (Loc, Name_uF)))); -- status flag
2898 -- Initialize out parameters
2901 Make_Assignment_Statement (Loc,
2902 Name => Make_Identifier (Loc, Name_uF),
2903 Expression => New_Occurrence_Of (Standard_False, Loc)));
2905 Make_Assignment_Statement (Loc,
2906 Name => Make_Identifier (Loc, Name_uC),
2907 Expression => New_Occurrence_Of (RTE (RE_POK_Function), Loc)));
2911 Make_Subprogram_Body (Loc,
2913 Make_Disp_Conditional_Select_Spec (Typ),
2914 Declarations => Decls,
2915 Handled_Statement_Sequence =>
2916 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2917 end Make_Disp_Conditional_Select_Body;
2919 ---------------------------------------
2920 -- Make_Disp_Conditional_Select_Spec --
2921 ---------------------------------------
2923 function Make_Disp_Conditional_Select_Spec
2924 (Typ : Entity_Id) return Node_Id
2926 Loc : constant Source_Ptr := Sloc (Typ);
2927 Def_Id : constant Node_Id :=
2928 Make_Defining_Identifier (Loc,
2929 Name_uDisp_Conditional_Select);
2930 Params : constant List_Id := New_List;
2933 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2935 -- T : in out Typ; -- Object parameter
2936 -- S : Integer; -- Primitive operation slot
2937 -- P : Address; -- Wrapped parameters
2938 -- C : out Prim_Op_Kind; -- Call kind
2939 -- F : out Boolean; -- Status flag
2941 Append_List_To (Params, New_List (
2943 Make_Parameter_Specification (Loc,
2944 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
2945 Parameter_Type => New_Occurrence_Of (Typ, Loc),
2947 Out_Present => True),
2949 Make_Parameter_Specification (Loc,
2950 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
2951 Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
2953 Make_Parameter_Specification (Loc,
2954 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
2955 Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)),
2957 Make_Parameter_Specification (Loc,
2958 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC),
2960 New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc),
2961 Out_Present => True),
2963 Make_Parameter_Specification (Loc,
2964 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF),
2965 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
2966 Out_Present => True)));
2969 Make_Procedure_Specification (Loc,
2970 Defining_Unit_Name => Def_Id,
2971 Parameter_Specifications => Params);
2972 end Make_Disp_Conditional_Select_Spec;
2974 -------------------------------------
2975 -- Make_Disp_Get_Prim_Op_Kind_Body --
2976 -------------------------------------
2978 function Make_Disp_Get_Prim_Op_Kind_Body (Typ : Entity_Id) return Node_Id is
2979 Loc : constant Source_Ptr := Sloc (Typ);
2983 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2985 if Is_Interface (Typ) then
2987 Make_Subprogram_Body (Loc,
2989 Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2990 Declarations => New_List,
2991 Handled_Statement_Sequence =>
2992 Make_Handled_Sequence_Of_Statements (Loc,
2993 New_List (Make_Null_Statement (Loc))));
2997 -- C := get_prim_op_kind (tag! (<type>VP), S);
2999 -- where C is the out parameter capturing the call kind and S is the
3000 -- dispatch table slot number.
3002 if Tagged_Type_Expansion then
3004 Unchecked_Convert_To (RTE (RE_Tag),
3006 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
3010 Make_Attribute_Reference (Loc,
3011 Prefix => New_Occurrence_Of (Typ, Loc),
3012 Attribute_Name => Name_Tag);
3016 Make_Subprogram_Body (Loc,
3018 Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
3019 Declarations => New_List,
3020 Handled_Statement_Sequence =>
3021 Make_Handled_Sequence_Of_Statements (Loc,
3023 Make_Assignment_Statement (Loc,
3024 Name => Make_Identifier (Loc, Name_uC),
3026 Make_Function_Call (Loc,
3028 New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc),
3029 Parameter_Associations => New_List (
3031 Make_Identifier (Loc, Name_uS)))))));
3032 end Make_Disp_Get_Prim_Op_Kind_Body;
3034 -------------------------------------
3035 -- Make_Disp_Get_Prim_Op_Kind_Spec --
3036 -------------------------------------
3038 function Make_Disp_Get_Prim_Op_Kind_Spec
3039 (Typ : Entity_Id) return Node_Id
3041 Loc : constant Source_Ptr := Sloc (Typ);
3042 Def_Id : constant Node_Id :=
3043 Make_Defining_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind);
3044 Params : constant List_Id := New_List;
3047 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3049 -- T : in out Typ; -- Object parameter
3050 -- S : Integer; -- Primitive operation slot
3051 -- C : out Prim_Op_Kind; -- Call kind
3053 Append_List_To (Params, New_List (
3055 Make_Parameter_Specification (Loc,
3056 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
3057 Parameter_Type => New_Occurrence_Of (Typ, Loc),
3059 Out_Present => True),
3061 Make_Parameter_Specification (Loc,
3062 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
3063 Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
3065 Make_Parameter_Specification (Loc,
3066 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC),
3068 New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc),
3069 Out_Present => True)));
3072 Make_Procedure_Specification (Loc,
3073 Defining_Unit_Name => Def_Id,
3074 Parameter_Specifications => Params);
3075 end Make_Disp_Get_Prim_Op_Kind_Spec;
3077 --------------------------------
3078 -- Make_Disp_Get_Task_Id_Body --
3079 --------------------------------
3081 function Make_Disp_Get_Task_Id_Body
3082 (Typ : Entity_Id) return Node_Id
3084 Loc : constant Source_Ptr := Sloc (Typ);
3088 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3090 if Is_Concurrent_Record_Type (Typ)
3091 and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type
3094 -- return To_Address (_T._task_id);
3097 Make_Simple_Return_Statement (Loc,
3099 Make_Unchecked_Type_Conversion (Loc,
3100 Subtype_Mark => New_Occurrence_Of (RTE (RE_Address), Loc),
3102 Make_Selected_Component (Loc,
3103 Prefix => Make_Identifier (Loc, Name_uT),
3104 Selector_Name => Make_Identifier (Loc, Name_uTask_Id))));
3106 -- A null body is constructed for non-task types
3110 -- return Null_Address;
3113 Make_Simple_Return_Statement (Loc,
3114 Expression => New_Occurrence_Of (RTE (RE_Null_Address), Loc));
3118 Make_Subprogram_Body (Loc,
3119 Specification => Make_Disp_Get_Task_Id_Spec (Typ),
3120 Declarations => New_List,
3121 Handled_Statement_Sequence =>
3122 Make_Handled_Sequence_Of_Statements (Loc, New_List (Ret)));
3123 end Make_Disp_Get_Task_Id_Body;
3125 --------------------------------
3126 -- Make_Disp_Get_Task_Id_Spec --
3127 --------------------------------
3129 function Make_Disp_Get_Task_Id_Spec
3130 (Typ : Entity_Id) return Node_Id
3132 Loc : constant Source_Ptr := Sloc (Typ);
3135 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3138 Make_Function_Specification (Loc,
3139 Defining_Unit_Name =>
3140 Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id),
3141 Parameter_Specifications => New_List (
3142 Make_Parameter_Specification (Loc,
3143 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
3144 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
3145 Result_Definition =>
3146 New_Occurrence_Of (RTE (RE_Address), Loc));
3147 end Make_Disp_Get_Task_Id_Spec;
3149 ----------------------------
3150 -- Make_Disp_Requeue_Body --
3151 ----------------------------
3153 function Make_Disp_Requeue_Body
3154 (Typ : Entity_Id) return Node_Id
3156 Loc : constant Source_Ptr := Sloc (Typ);
3157 Conc_Typ : Entity_Id := Empty;
3158 Stmts : constant List_Id := New_List;
3161 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3163 -- Null body is generated for interface types and non-concurrent
3166 if Is_Interface (Typ)
3167 or else not Is_Concurrent_Record_Type (Typ)
3170 Make_Subprogram_Body (Loc,
3171 Specification => Make_Disp_Requeue_Spec (Typ),
3172 Declarations => No_List,
3173 Handled_Statement_Sequence =>
3174 Make_Handled_Sequence_Of_Statements (Loc,
3175 New_List (Make_Null_Statement (Loc))));
3178 Conc_Typ := Corresponding_Concurrent_Type (Typ);
3180 if Ekind (Conc_Typ) = E_Protected_Type then
3182 -- Generate statements:
3184 -- System.Tasking.Protected_Objects.Operations.
3185 -- Requeue_Protected_Entry
3186 -- (Protection_Entries_Access (P),
3187 -- O._object'Unchecked_Access,
3188 -- Protected_Entry_Index (I),
3191 -- System.Tasking.Protected_Objects.Operations.
3192 -- Requeue_Task_To_Protected_Entry
3193 -- (O._object'Unchecked_Access,
3194 -- Protected_Entry_Index (I),
3198 if Restriction_Active (No_Entry_Queue) then
3199 Append_To (Stmts, Make_Null_Statement (Loc));
3202 Make_If_Statement (Loc,
3203 Condition => Make_Identifier (Loc, Name_uF),
3208 -- Call to Requeue_Protected_Entry
3210 Make_Procedure_Call_Statement (Loc,
3213 (RTE (RE_Requeue_Protected_Entry), Loc),
3214 Parameter_Associations =>
3217 Make_Unchecked_Type_Conversion (Loc, -- PEA (P)
3220 RTE (RE_Protection_Entries_Access), Loc),
3222 Make_Identifier (Loc, Name_uP)),
3224 Make_Attribute_Reference (Loc, -- O._object'Acc
3226 Name_Unchecked_Access,
3228 Make_Selected_Component (Loc,
3230 Make_Identifier (Loc, Name_uO),
3232 Make_Identifier (Loc, Name_uObject))),
3234 Make_Unchecked_Type_Conversion (Loc, -- entry index
3237 (RTE (RE_Protected_Entry_Index), Loc),
3238 Expression => Make_Identifier (Loc, Name_uI)),
3240 Make_Identifier (Loc, Name_uA)))), -- abort status
3245 -- Call to Requeue_Task_To_Protected_Entry
3247 Make_Procedure_Call_Statement (Loc,
3250 (RTE (RE_Requeue_Task_To_Protected_Entry), Loc),
3251 Parameter_Associations =>
3254 Make_Attribute_Reference (Loc, -- O._object'Acc
3255 Attribute_Name => Name_Unchecked_Access,
3257 Make_Selected_Component (Loc,
3259 Make_Identifier (Loc, Name_uO),
3261 Make_Identifier (Loc, Name_uObject))),
3263 Make_Unchecked_Type_Conversion (Loc, -- entry index
3266 (RTE (RE_Protected_Entry_Index), Loc),
3267 Expression => Make_Identifier (Loc, Name_uI)),
3269 Make_Identifier (Loc, Name_uA)))))); -- abort status
3273 pragma Assert (Is_Task_Type (Conc_Typ));
3277 -- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry
3278 -- (Protection_Entries_Access (P),
3280 -- Task_Entry_Index (I),
3283 -- System.Tasking.Rendezvous.Requeue_Task_Entry
3285 -- Task_Entry_Index (I),
3290 Make_If_Statement (Loc,
3291 Condition => Make_Identifier (Loc, Name_uF),
3293 Then_Statements => New_List (
3295 -- Call to Requeue_Protected_To_Task_Entry
3297 Make_Procedure_Call_Statement (Loc,
3300 (RTE (RE_Requeue_Protected_To_Task_Entry), Loc),
3302 Parameter_Associations => New_List (
3304 Make_Unchecked_Type_Conversion (Loc, -- PEA (P)
3307 (RTE (RE_Protection_Entries_Access), Loc),
3308 Expression => Make_Identifier (Loc, Name_uP)),
3310 Make_Selected_Component (Loc, -- O._task_id
3311 Prefix => Make_Identifier (Loc, Name_uO),
3312 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3314 Make_Unchecked_Type_Conversion (Loc, -- entry index
3316 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
3317 Expression => Make_Identifier (Loc, Name_uI)),
3319 Make_Identifier (Loc, Name_uA)))), -- abort status
3321 Else_Statements => New_List (
3323 -- Call to Requeue_Task_Entry
3325 Make_Procedure_Call_Statement (Loc,
3327 New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc),
3329 Parameter_Associations => New_List (
3331 Make_Selected_Component (Loc, -- O._task_id
3332 Prefix => Make_Identifier (Loc, Name_uO),
3333 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3335 Make_Unchecked_Type_Conversion (Loc, -- entry index
3337 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
3338 Expression => Make_Identifier (Loc, Name_uI)),
3340 Make_Identifier (Loc, Name_uA)))))); -- abort status
3343 -- Even though no declarations are needed in both cases, we allocate
3344 -- a list for entities added by Freeze.
3347 Make_Subprogram_Body (Loc,
3348 Specification => Make_Disp_Requeue_Spec (Typ),
3349 Declarations => New_List,
3350 Handled_Statement_Sequence =>
3351 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
3352 end Make_Disp_Requeue_Body;
3354 ----------------------------
3355 -- Make_Disp_Requeue_Spec --
3356 ----------------------------
3358 function Make_Disp_Requeue_Spec
3359 (Typ : Entity_Id) return Node_Id
3361 Loc : constant Source_Ptr := Sloc (Typ);
3364 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3366 -- O : in out Typ; - Object parameter
3367 -- F : Boolean; - Protected (True) / task (False) flag
3368 -- P : Address; - Protection_Entries_Access value
3369 -- I : Entry_Index - Index of entry call
3370 -- A : Boolean - Abort flag
3372 -- Note that the Protection_Entries_Access value is represented as a
3373 -- System.Address in order to avoid dragging in the tasking runtime
3374 -- when compiling sources without tasking constructs.
3377 Make_Procedure_Specification (Loc,
3378 Defining_Unit_Name =>
3379 Make_Defining_Identifier (Loc, Name_uDisp_Requeue),
3381 Parameter_Specifications => New_List (
3383 Make_Parameter_Specification (Loc, -- O
3384 Defining_Identifier =>
3385 Make_Defining_Identifier (Loc, Name_uO),
3387 New_Occurrence_Of (Typ, Loc),
3389 Out_Present => True),
3391 Make_Parameter_Specification (Loc, -- F
3392 Defining_Identifier =>
3393 Make_Defining_Identifier (Loc, Name_uF),
3395 New_Occurrence_Of (Standard_Boolean, Loc)),
3397 Make_Parameter_Specification (Loc, -- P
3398 Defining_Identifier =>
3399 Make_Defining_Identifier (Loc, Name_uP),
3401 New_Occurrence_Of (RTE (RE_Address), Loc)),
3403 Make_Parameter_Specification (Loc, -- I
3404 Defining_Identifier =>
3405 Make_Defining_Identifier (Loc, Name_uI),
3407 New_Occurrence_Of (Standard_Integer, Loc)),
3409 Make_Parameter_Specification (Loc, -- A
3410 Defining_Identifier =>
3411 Make_Defining_Identifier (Loc, Name_uA),
3413 New_Occurrence_Of (Standard_Boolean, Loc))));
3414 end Make_Disp_Requeue_Spec;
3416 ---------------------------------
3417 -- Make_Disp_Timed_Select_Body --
3418 ---------------------------------
3420 -- For interface types, generate:
3422 -- procedure _Disp_Timed_Select
3423 -- (T : in out <Typ>;
3425 -- P : System.Address;
3428 -- C : out Ada.Tags.Prim_Op_Kind;
3433 -- C := Ada.Tags.POK_Function;
3434 -- end _Disp_Timed_Select;
3436 -- For protected types, generate:
3438 -- procedure _Disp_Timed_Select
3439 -- (T : in out <Typ>;
3441 -- P : System.Address;
3444 -- C : out Ada.Tags.Prim_Op_Kind;
3450 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S);
3452 -- if C = Ada.Tags.POK_Procedure
3453 -- or else C = Ada.Tags.POK_Protected_Procedure
3454 -- or else C = Ada.Tags.POK_Task_Procedure
3460 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3461 -- System.Tasking.Protected_Objects.Operations.
3462 -- Timed_Protected_Entry_Call
3463 -- (T._object'Access,
3464 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
3469 -- end _Disp_Timed_Select;
3471 -- For task types, generate:
3473 -- procedure _Disp_Timed_Select
3474 -- (T : in out <Typ>;
3476 -- P : System.Address;
3479 -- C : out Ada.Tags.Prim_Op_Kind;
3485 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3486 -- System.Tasking.Rendezvous.Timed_Task_Entry_Call
3488 -- System.Tasking.Task_Entry_Index (I),
3493 -- end _Disp_Time_Select;
3495 function Make_Disp_Timed_Select_Body
3496 (Typ : Entity_Id) return Node_Id
3498 Loc : constant Source_Ptr := Sloc (Typ);
3499 Conc_Typ : Entity_Id := Empty;
3500 Decls : constant List_Id := New_List;
3502 Stmts : constant List_Id := New_List;
3506 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3508 -- Null body is generated for interface types
3510 if Is_Interface (Typ) then
3512 Make_Subprogram_Body (Loc,
3513 Specification => Make_Disp_Timed_Select_Spec (Typ),
3514 Declarations => New_List,
3515 Handled_Statement_Sequence =>
3516 Make_Handled_Sequence_Of_Statements (Loc,
3518 Make_Assignment_Statement (Loc,
3519 Name => Make_Identifier (Loc, Name_uF),
3520 Expression => New_Occurrence_Of (Standard_False, Loc)))));
3523 if Is_Concurrent_Record_Type (Typ) then
3524 Conc_Typ := Corresponding_Concurrent_Type (Typ);
3529 -- where I will be used to capture the entry index of the primitive
3530 -- wrapper at position S.
3533 Make_Object_Declaration (Loc,
3534 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI),
3535 Object_Definition =>
3536 New_Occurrence_Of (Standard_Integer, Loc)));
3539 -- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
3541 -- if C = POK_Procedure
3542 -- or else C = POK_Protected_Procedure
3543 -- or else C = POK_Task_Procedure;
3549 Build_Common_Dispatching_Select_Statements (Typ, Stmts);
3552 -- I := Get_Entry_Index (tag! (<type>VP), S);
3554 -- I is the entry index and S is the dispatch table slot
3556 if Tagged_Type_Expansion then
3558 Unchecked_Convert_To (RTE (RE_Tag),
3560 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
3564 Make_Attribute_Reference (Loc,
3565 Prefix => New_Occurrence_Of (Typ, Loc),
3566 Attribute_Name => Name_Tag);
3570 Make_Assignment_Statement (Loc,
3571 Name => Make_Identifier (Loc, Name_uI),
3573 Make_Function_Call (Loc,
3574 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
3575 Parameter_Associations => New_List (
3577 Make_Identifier (Loc, Name_uS)))));
3581 if Ekind (Conc_Typ) = E_Protected_Type then
3583 -- Build T._object'Access
3586 Make_Attribute_Reference (Loc,
3587 Attribute_Name => Name_Unchecked_Access,
3589 Make_Selected_Component (Loc,
3590 Prefix => Make_Identifier (Loc, Name_uT),
3591 Selector_Name => Make_Identifier (Loc, Name_uObject)));
3593 -- Normal case, No_Entry_Queue restriction not active. In this
3594 -- case we generate:
3596 -- Timed_Protected_Entry_Call
3597 -- (T._object'access,
3598 -- Protected_Entry_Index! (I),
3601 -- where T is the protected object, I is the entry index, P are
3602 -- the wrapped parameters, D is the delay amount, M is the delay
3603 -- mode and F is the status flag.
3605 -- Historically, there was also an implementation for single
3606 -- entry protected types (in s-tposen). However, it was removed
3607 -- by also testing for no No_Select_Statements restriction in
3608 -- Exp_Utils.Corresponding_Runtime_Package. This simplified the
3609 -- implementation of s-tposen.adb and provided consistency between
3610 -- all versions of System.Tasking.Protected_Objects.Single_Entry
3613 case Corresponding_Runtime_Package (Conc_Typ) is
3614 when System_Tasking_Protected_Objects_Entries =>
3616 Make_Procedure_Call_Statement (Loc,
3619 (RTE (RE_Timed_Protected_Entry_Call), Loc),
3620 Parameter_Associations => New_List (
3623 Make_Unchecked_Type_Conversion (Loc, -- entry index
3626 (RTE (RE_Protected_Entry_Index), Loc),
3627 Expression => Make_Identifier (Loc, Name_uI)),
3629 Make_Identifier (Loc, Name_uP), -- parameter block
3630 Make_Identifier (Loc, Name_uD), -- delay
3631 Make_Identifier (Loc, Name_uM), -- delay mode
3632 Make_Identifier (Loc, Name_uF)))); -- status flag
3635 raise Program_Error;
3641 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
3644 -- Timed_Task_Entry_Call (
3646 -- Task_Entry_Index! (I),
3652 -- where T is the task object, I is the entry index, P are the
3653 -- wrapped parameters, D is the delay amount, M is the delay
3654 -- mode and F is the status flag.
3657 Make_Procedure_Call_Statement (Loc,
3659 New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc),
3661 Parameter_Associations => New_List (
3662 Make_Selected_Component (Loc, -- T._task_id
3663 Prefix => Make_Identifier (Loc, Name_uT),
3664 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3666 Make_Unchecked_Type_Conversion (Loc, -- entry index
3668 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
3669 Expression => Make_Identifier (Loc, Name_uI)),
3671 Make_Identifier (Loc, Name_uP), -- parameter block
3672 Make_Identifier (Loc, Name_uD), -- delay
3673 Make_Identifier (Loc, Name_uM), -- delay mode
3674 Make_Identifier (Loc, Name_uF)))); -- status flag
3678 -- Initialize out parameters
3681 Make_Assignment_Statement (Loc,
3682 Name => Make_Identifier (Loc, Name_uF),
3683 Expression => New_Occurrence_Of (Standard_False, Loc)));
3685 Make_Assignment_Statement (Loc,
3686 Name => Make_Identifier (Loc, Name_uC),
3687 Expression => New_Occurrence_Of (RTE (RE_POK_Function), Loc)));
3691 Make_Subprogram_Body (Loc,
3692 Specification => Make_Disp_Timed_Select_Spec (Typ),
3693 Declarations => Decls,
3694 Handled_Statement_Sequence =>
3695 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
3696 end Make_Disp_Timed_Select_Body;
3698 ---------------------------------
3699 -- Make_Disp_Timed_Select_Spec --
3700 ---------------------------------
3702 function Make_Disp_Timed_Select_Spec
3703 (Typ : Entity_Id) return Node_Id
3705 Loc : constant Source_Ptr := Sloc (Typ);
3706 Def_Id : constant Node_Id :=
3707 Make_Defining_Identifier (Loc,
3708 Name_uDisp_Timed_Select);
3709 Params : constant List_Id := New_List;
3712 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3714 -- T : in out Typ; -- Object parameter
3715 -- S : Integer; -- Primitive operation slot
3716 -- P : Address; -- Wrapped parameters
3717 -- D : Duration; -- Delay
3718 -- M : Integer; -- Delay Mode
3719 -- C : out Prim_Op_Kind; -- Call kind
3720 -- F : out Boolean; -- Status flag
3722 Append_List_To (Params, New_List (
3724 Make_Parameter_Specification (Loc,
3725 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
3726 Parameter_Type => New_Occurrence_Of (Typ, Loc),
3728 Out_Present => True),
3730 Make_Parameter_Specification (Loc,
3731 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
3732 Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
3734 Make_Parameter_Specification (Loc,
3735 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
3736 Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)),
3738 Make_Parameter_Specification (Loc,
3739 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uD),
3740 Parameter_Type => New_Occurrence_Of (Standard_Duration, Loc)),
3742 Make_Parameter_Specification (Loc,
3743 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uM),
3744 Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
3746 Make_Parameter_Specification (Loc,
3747 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC),
3749 New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc),
3750 Out_Present => True)));
3753 Make_Parameter_Specification (Loc,
3754 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF),
3755 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
3756 Out_Present => True));
3759 Make_Procedure_Specification (Loc,
3760 Defining_Unit_Name => Def_Id,
3761 Parameter_Specifications => Params);
3762 end Make_Disp_Timed_Select_Spec;
3768 -- The frontend supports two models for expanding dispatch tables
3769 -- associated with library-level defined tagged types: statically and
3770 -- non-statically allocated dispatch tables. In the former case the object
3771 -- containing the dispatch table is constant and it is initialized by means
3772 -- of a positional aggregate. In the latter case, the object containing
3773 -- the dispatch table is a variable which is initialized by means of
3776 -- In case of locally defined tagged types, the object containing the
3777 -- object containing the dispatch table is always a variable (instead of a
3778 -- constant). This is currently required to give support to late overriding
3779 -- of primitives. For example:
3781 -- procedure Example is
3783 -- type T1 is tagged null record;
3784 -- procedure Prim (O : T1);
3787 -- type T2 is new Pkg.T1 with null record;
3788 -- procedure Prim (X : T2) is -- late overriding
3794 -- WARNING: This routine manages Ghost regions. Return statements must be
3795 -- replaced by gotos which jump to the end of the routine and restore the
3798 function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is
3799 Loc : constant Source_Ptr := Sloc (Typ);
3801 Max_Predef_Prims : constant Int :=
3805 (Parent (RTE (RE_Max_Predef_Prims)))));
3807 DT_Decl : constant Elist_Id := New_Elmt_List;
3808 DT_Aggr : constant Elist_Id := New_Elmt_List;
3809 -- Entities marked with attribute Is_Dispatch_Table_Entity
3811 Dummy_Object : Entity_Id := Empty;
3812 -- Extra nonexistent object of type Typ internally used to compute the
3813 -- offset to the components that reference secondary dispatch tables.
3814 -- Used to compute the offset of components located at fixed position.
3816 procedure Check_Premature_Freezing
3818 Tagged_Type : Entity_Id;
3820 -- Verify that all untagged types in the profile of a subprogram are
3821 -- frozen at the point the subprogram is frozen. This enforces the rule
3822 -- on RM 13.14 (14) as modified by AI05-019. At the point a subprogram
3823 -- is frozen, enough must be known about it to build the activation
3824 -- record for it, which requires at least that the size of all
3825 -- parameters be known. Controlling arguments are by-reference,
3826 -- and therefore the rule only applies to untagged types. Typical
3827 -- violation of the rule involves an object declaration that freezes a
3828 -- tagged type, when one of its primitive operations has a type in its
3829 -- profile whose full view has not been analyzed yet. More complex cases
3830 -- involve composite types that have one private unfrozen subcomponent.
3832 procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0);
3833 -- Export the dispatch table DT of tagged type Typ. Required to generate
3834 -- forward references and statically allocate the table. For primary
3835 -- dispatch tables Index is 0; for secondary dispatch tables the value
3836 -- of index must match the Suffix_Index value assigned to the table by
3837 -- Make_Tags when generating its unique external name, and it is used to
3838 -- retrieve from the Dispatch_Table_Wrappers list associated with Typ
3839 -- the external name generated by Import_DT.
3841 procedure Make_Secondary_DT
3844 Iface_Comp : Node_Id;
3846 Num_Iface_Prims : Nat;
3847 Iface_DT_Ptr : Entity_Id;
3848 Predef_Prims_Ptr : Entity_Id;
3849 Build_Thunks : Boolean;
3851 -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch
3852 -- Table of Typ associated with Iface. Each abstract interface of Typ
3853 -- has two secondary dispatch tables: one containing pointers to thunks
3854 -- and another containing pointers to the primitives covering the
3855 -- interface primitives. The former secondary table is generated when
3856 -- Build_Thunks is True, and provides common support for dispatching
3857 -- calls through interface types; the latter secondary table is
3858 -- generated when Build_Thunks is False, and provides support for
3859 -- Generic Dispatching Constructors that dispatch calls through
3860 -- interface types. When constructing this latter table the value of
3861 -- Suffix_Index is -1 to indicate that there is no need to export such
3862 -- table when building statically allocated dispatch tables; a positive
3863 -- value of Suffix_Index must match the Suffix_Index value assigned to
3864 -- this secondary dispatch table by Make_Tags when its unique external
3865 -- name was generated.
3867 function Number_Of_Predefined_Prims (Typ : Entity_Id) return Nat;
3868 -- Returns the number of predefined primitives of Typ
3870 ------------------------------
3871 -- Check_Premature_Freezing --
3872 ------------------------------
3874 procedure Check_Premature_Freezing
3876 Tagged_Type : Entity_Id;
3881 function Is_Actual_For_Formal_Incomplete_Type
3882 (T : Entity_Id) return Boolean;
3883 -- In Ada 2012, if a nested generic has an incomplete formal type,
3884 -- the actual may be (and usually is) a private type whose completion
3885 -- appears later. It is safe to build the dispatch table in this
3886 -- case, gigi will have full views available.
3888 ------------------------------------------
3889 -- Is_Actual_For_Formal_Incomplete_Type --
3890 ------------------------------------------
3892 function Is_Actual_For_Formal_Incomplete_Type
3893 (T : Entity_Id) return Boolean
3895 Gen_Par : Entity_Id;
3899 if not Is_Generic_Instance (Current_Scope)
3900 or else not Used_As_Generic_Actual (T)
3904 Gen_Par := Generic_Parent (Parent (Current_Scope));
3909 (Generic_Formal_Declarations
3910 (Unit_Declaration_Node (Gen_Par)));
3911 while Present (F) loop
3912 if Ekind (Defining_Identifier (F)) = E_Incomplete_Type then
3920 end Is_Actual_For_Formal_Incomplete_Type;
3922 -- Start of processing for Check_Premature_Freezing
3925 -- Note that if the type is a (subtype of) a generic actual, the
3926 -- actual will have been frozen by the instantiation.
3929 and then Is_Private_Type (Typ)
3930 and then No (Full_View (Typ))
3931 and then not Is_Generic_Type (Typ)
3932 and then not Is_Tagged_Type (Typ)
3933 and then not Is_Frozen (Typ)
3934 and then not Is_Generic_Actual_Type (Typ)
3936 Error_Msg_Sloc := Sloc (Subp);
3938 ("declaration must appear after completion of type &", N, Typ);
3940 ("\which is an untagged type in the profile of "
3941 & "primitive operation & declared#", N, Subp);
3944 Comp := Private_Component (Typ);
3946 if not Is_Tagged_Type (Typ)
3947 and then Present (Comp)
3948 and then not Is_Frozen (Comp)
3949 and then not Is_Actual_For_Formal_Incomplete_Type (Comp)
3951 Error_Msg_Sloc := Sloc (Subp);
3952 Error_Msg_Node_2 := Subp;
3953 Error_Msg_Name_1 := Chars (Tagged_Type);
3955 ("declaration must appear after completion of type &",
3958 ("\which is a component of untagged type& in the profile "
3959 & "of primitive & of type % that is frozen by the "
3960 & "declaration ", N, Typ);
3963 end Check_Premature_Freezing;
3969 procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0)
3975 Set_Is_Statically_Allocated (DT);
3976 Set_Is_True_Constant (DT);
3977 Set_Is_Exported (DT);
3980 Elmt := First_Elmt (Dispatch_Table_Wrappers (Typ));
3981 while Count /= Index loop
3986 pragma Assert (Related_Type (Node (Elmt)) = Typ);
3988 Get_External_Name (Node (Elmt));
3989 Set_Interface_Name (DT,
3990 Make_String_Literal (Loc,
3991 Strval => String_From_Name_Buffer));
3993 -- Ensure proper Sprint output of this implicit importation
3995 Set_Is_Internal (DT);
3999 -----------------------
4000 -- Make_Secondary_DT --
4001 -----------------------
4003 procedure Make_Secondary_DT
4006 Iface_Comp : Node_Id;
4008 Num_Iface_Prims : Nat;
4009 Iface_DT_Ptr : Entity_Id;
4010 Predef_Prims_Ptr : Entity_Id;
4011 Build_Thunks : Boolean;
4014 Loc : constant Source_Ptr := Sloc (Typ);
4015 Exporting_Table : constant Boolean :=
4016 Building_Static_DT (Typ)
4017 and then Suffix_Index > 0;
4018 Iface_DT : constant Entity_Id := Make_Temporary (Loc, 'T');
4019 Predef_Prims : constant Entity_Id := Make_Temporary (Loc, 'R');
4020 DT_Constr_List : List_Id;
4021 DT_Aggr_List : List_Id;
4022 Empty_DT : Boolean := False;
4026 OSD_Aggr_List : List_Id;
4028 Prim_Elmt : Elmt_Id;
4029 Prim_Ops_Aggr_List : List_Id;
4032 -- Handle cases in which we do not generate statically allocated
4035 if not Building_Static_DT (Typ) then
4036 Set_Ekind (Predef_Prims, E_Variable);
4037 Set_Ekind (Iface_DT, E_Variable);
4039 -- Statically allocated dispatch tables and related entities are
4043 Set_Ekind (Predef_Prims, E_Constant);
4044 Set_Is_Statically_Allocated (Predef_Prims);
4045 Set_Is_True_Constant (Predef_Prims);
4047 Set_Ekind (Iface_DT, E_Constant);
4048 Set_Is_Statically_Allocated (Iface_DT);
4049 Set_Is_True_Constant (Iface_DT);
4052 -- Calculate the number of slots of the dispatch table. If the number
4053 -- of primitives of Typ is 0 we reserve a dummy single entry for its
4054 -- DT because at run time the pointer to this dummy entry will be
4057 if Num_Iface_Prims = 0 then
4061 Nb_Prim := Num_Iface_Prims;
4066 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
4067 -- (predef-prim-op-thunk-1'address,
4068 -- predef-prim-op-thunk-2'address,
4070 -- predef-prim-op-thunk-n'address);
4072 -- Create the thunks associated with the predefined primitives and
4073 -- save their entity to fill the aggregate.
4076 Nb_P_Prims : constant Nat := Number_Of_Predefined_Prims (Typ);
4077 Prim_Table : array (Nat range 1 .. Nb_P_Prims) of Entity_Id;
4079 Thunk_Id : Entity_Id;
4080 Thunk_Code : Node_Id;
4083 Prim_Ops_Aggr_List := New_List;
4084 Prim_Table := (others => Empty);
4086 if Building_Static_DT (Typ) then
4087 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4088 while Present (Prim_Elmt) loop
4089 Prim := Node (Prim_Elmt);
4091 if Is_Predefined_Dispatching_Operation (Prim)
4092 and then not Is_Abstract_Subprogram (Prim)
4093 and then not Is_Eliminated (Prim)
4094 and then not Generate_SCIL
4095 and then not Present (Prim_Table
4096 (UI_To_Int (DT_Position (Prim))))
4098 if not Build_Thunks then
4099 Prim_Table (UI_To_Int (DT_Position (Prim))) :=
4103 Expand_Interface_Thunk
4104 (Prim, Thunk_Id, Thunk_Code, Iface);
4106 if Present (Thunk_Id) then
4107 Append_To (Result, Thunk_Code);
4108 Prim_Table (UI_To_Int (DT_Position (Prim))) :=
4114 Next_Elmt (Prim_Elmt);
4118 for J in Prim_Table'Range loop
4119 if Present (Prim_Table (J)) then
4121 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
4122 Make_Attribute_Reference (Loc,
4123 Prefix => New_Occurrence_Of (Prim_Table (J), Loc),
4124 Attribute_Name => Name_Unrestricted_Access));
4126 New_Node := Make_Null (Loc);
4129 Append_To (Prim_Ops_Aggr_List, New_Node);
4133 Make_Aggregate (Loc, Expressions => Prim_Ops_Aggr_List);
4135 -- Remember aggregates initializing dispatch tables
4137 Append_Elmt (New_Node, DT_Aggr);
4140 Make_Subtype_Declaration (Loc,
4141 Defining_Identifier => Make_Temporary (Loc, 'S'),
4142 Subtype_Indication =>
4143 New_Occurrence_Of (RTE (RE_Address_Array), Loc));
4145 Append_To (Result, Decl);
4148 Make_Object_Declaration (Loc,
4149 Defining_Identifier => Predef_Prims,
4150 Constant_Present => Building_Static_DT (Typ),
4151 Aliased_Present => True,
4152 Object_Definition => New_Occurrence_Of
4153 (Defining_Identifier (Decl), Loc),
4154 Expression => New_Node));
4159 -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
4160 -- (OSD_Table => (1 => <value>,
4163 -- for OSD'Alignment use Address'Alignment;
4165 -- Iface_DT : Dispatch_Table (Nb_Prims) :=
4166 -- ([ Signature => <sig-value> ],
4167 -- Tag_Kind => <tag_kind-value>,
4168 -- Predef_Prims => Predef_Prims'Address,
4169 -- Offset_To_Top => 0,
4170 -- OSD => OSD'Address,
4171 -- Prims_Ptr => (prim-op-1'address,
4172 -- prim-op-2'address,
4174 -- prim-op-n'address));
4176 -- Stage 3: Initialize the discriminant and the record components
4178 DT_Constr_List := New_List;
4179 DT_Aggr_List := New_List;
4183 Append_To (DT_Constr_List, Make_Integer_Literal (Loc, Nb_Prim));
4184 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, Nb_Prim));
4188 if RTE_Record_Component_Available (RE_Signature) then
4189 Append_To (DT_Aggr_List,
4190 New_Occurrence_Of (RTE (RE_Secondary_DT), Loc));
4195 if RTE_Record_Component_Available (RE_Tag_Kind) then
4196 Append_To (DT_Aggr_List, Tagged_Kind (Typ));
4201 Append_To (DT_Aggr_List,
4202 Make_Attribute_Reference (Loc,
4203 Prefix => New_Occurrence_Of (Predef_Prims, Loc),
4204 Attribute_Name => Name_Address));
4206 -- Interface component located at variable offset; the value of
4207 -- Offset_To_Top will be set by the init subprogram.
4209 if No (Dummy_Object)
4210 or else Is_Variable_Size_Record (Etype (Scope (Iface_Comp)))
4212 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
4214 -- Interface component located at fixed offset
4217 Append_To (DT_Aggr_List,
4219 Make_Attribute_Reference (Loc,
4221 Make_Selected_Component (Loc,
4223 New_Occurrence_Of (Dummy_Object, Loc),
4225 New_Occurrence_Of (Iface_Comp, Loc)),
4226 Attribute_Name => Name_Position)));
4229 -- Generate the Object Specific Data table required to dispatch calls
4230 -- through synchronized interfaces.
4233 or else Is_Abstract_Type (Typ)
4234 or else Is_Controlled (Typ)
4235 or else Restriction_Active (No_Dispatching_Calls)
4236 or else not Is_Limited_Type (Typ)
4237 or else not Has_Interfaces (Typ)
4238 or else not Build_Thunks
4239 or else not RTE_Record_Component_Available (RE_OSD_Table)
4241 -- No OSD table required
4243 Append_To (DT_Aggr_List,
4244 New_Occurrence_Of (RTE (RE_Null_Address), Loc));
4247 OSD_Aggr_List := New_List;
4250 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
4252 Prim_Alias : Entity_Id;
4253 Prim_Elmt : Elmt_Id;
4259 Prim_Table := (others => Empty);
4260 Prim_Alias := Empty;
4262 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4263 while Present (Prim_Elmt) loop
4264 Prim := Node (Prim_Elmt);
4266 if Present (Interface_Alias (Prim))
4267 and then Find_Dispatching_Type
4268 (Interface_Alias (Prim)) = Iface
4270 Prim_Alias := Interface_Alias (Prim);
4271 E := Ultimate_Alias (Prim);
4272 Pos := UI_To_Int (DT_Position (Prim_Alias));
4274 if Present (Prim_Table (Pos)) then
4275 pragma Assert (Prim_Table (Pos) = E);
4279 Prim_Table (Pos) := E;
4281 Append_To (OSD_Aggr_List,
4282 Make_Component_Association (Loc,
4283 Choices => New_List (
4284 Make_Integer_Literal (Loc,
4285 DT_Position (Prim_Alias))),
4287 Make_Integer_Literal (Loc,
4288 DT_Position (Alias (Prim)))));
4294 Next_Elmt (Prim_Elmt);
4296 pragma Assert (Count = Nb_Prim);
4299 OSD := Make_Temporary (Loc, 'I');
4302 Make_Object_Declaration (Loc,
4303 Defining_Identifier => OSD,
4304 Object_Definition =>
4305 Make_Subtype_Indication (Loc,
4307 New_Occurrence_Of (RTE (RE_Object_Specific_Data), Loc),
4309 Make_Index_Or_Discriminant_Constraint (Loc,
4310 Constraints => New_List (
4311 Make_Integer_Literal (Loc, Nb_Prim)))),
4314 Make_Aggregate (Loc,
4315 Component_Associations => New_List (
4316 Make_Component_Association (Loc,
4317 Choices => New_List (
4319 (RTE_Record_Component (RE_OSD_Num_Prims), Loc)),
4321 Make_Integer_Literal (Loc, Nb_Prim)),
4323 Make_Component_Association (Loc,
4324 Choices => New_List (
4326 (RTE_Record_Component (RE_OSD_Table), Loc)),
4327 Expression => Make_Aggregate (Loc,
4328 Component_Associations => OSD_Aggr_List))))));
4331 Make_Attribute_Definition_Clause (Loc,
4332 Name => New_Occurrence_Of (OSD, Loc),
4333 Chars => Name_Alignment,
4335 Make_Attribute_Reference (Loc,
4337 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4338 Attribute_Name => Name_Alignment)));
4340 -- In secondary dispatch tables the Typeinfo component contains
4341 -- the address of the Object Specific Data (see a-tags.ads)
4343 Append_To (DT_Aggr_List,
4344 Make_Attribute_Reference (Loc,
4345 Prefix => New_Occurrence_Of (OSD, Loc),
4346 Attribute_Name => Name_Address));
4349 -- Initialize the table of primitive operations
4351 Prim_Ops_Aggr_List := New_List;
4354 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
4356 elsif Is_Abstract_Type (Typ)
4357 or else not Building_Static_DT (Typ)
4359 for J in 1 .. Nb_Prim loop
4360 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
4365 CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
4368 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
4369 Thunk_Code : Node_Id;
4370 Thunk_Id : Entity_Id;
4373 Prim_Table := (others => Empty);
4375 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4376 while Present (Prim_Elmt) loop
4377 Prim := Node (Prim_Elmt);
4378 E := Ultimate_Alias (Prim);
4379 Prim_Pos := UI_To_Int (DT_Position (E));
4381 -- Do not reference predefined primitives because they are
4382 -- located in a separate dispatch table; skip abstract and
4383 -- eliminated primitives; skip primitives located in the C++
4384 -- part of the dispatch table because their slot is set by
4387 if not Is_Predefined_Dispatching_Operation (Prim)
4388 and then Present (Interface_Alias (Prim))
4389 and then not Is_Abstract_Subprogram (Alias (Prim))
4390 and then not Is_Eliminated (Alias (Prim))
4391 and then (not Is_CPP_Class (Root_Type (Typ))
4392 or else Prim_Pos > CPP_Nb_Prims)
4393 and then Find_Dispatching_Type
4394 (Interface_Alias (Prim)) = Iface
4396 -- Generate the code of the thunk only if the abstract
4397 -- interface type is not an immediate ancestor of
4398 -- Tagged_Type. Otherwise the DT associated with the
4399 -- interface is the primary DT.
4401 and then not Is_Ancestor (Iface, Typ,
4402 Use_Full_View => True)
4404 if not Build_Thunks then
4406 UI_To_Int (DT_Position (Interface_Alias (Prim)));
4407 Prim_Table (Prim_Pos) := Alias (Prim);
4410 Expand_Interface_Thunk
4411 (Prim, Thunk_Id, Thunk_Code, Iface);
4413 if Present (Thunk_Id) then
4415 UI_To_Int (DT_Position (Interface_Alias (Prim)));
4417 Prim_Table (Prim_Pos) := Thunk_Id;
4418 Append_To (Result, Thunk_Code);
4423 Next_Elmt (Prim_Elmt);
4426 for J in Prim_Table'Range loop
4427 if Present (Prim_Table (J)) then
4429 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
4430 Make_Attribute_Reference (Loc,
4431 Prefix => New_Occurrence_Of (Prim_Table (J), Loc),
4432 Attribute_Name => Name_Unrestricted_Access));
4435 New_Node := Make_Null (Loc);
4438 Append_To (Prim_Ops_Aggr_List, New_Node);
4444 Make_Aggregate (Loc,
4445 Expressions => Prim_Ops_Aggr_List);
4447 Append_To (DT_Aggr_List, New_Node);
4449 -- Remember aggregates initializing dispatch tables
4451 Append_Elmt (New_Node, DT_Aggr);
4453 -- Note: Secondary dispatch tables are declared constant only if
4454 -- we can compute their offset field by means of the extra dummy
4455 -- object; otherwise they cannot be declared constant and the
4456 -- Offset_To_Top component is initialized by the IP routine.
4459 Make_Object_Declaration (Loc,
4460 Defining_Identifier => Iface_DT,
4461 Aliased_Present => True,
4462 Constant_Present => Building_Static_Secondary_DT (Typ),
4464 Object_Definition =>
4465 Make_Subtype_Indication (Loc,
4466 Subtype_Mark => New_Occurrence_Of
4467 (RTE (RE_Dispatch_Table_Wrapper), Loc),
4468 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
4469 Constraints => DT_Constr_List)),
4472 Make_Aggregate (Loc,
4473 Expressions => DT_Aggr_List)));
4475 if Exporting_Table then
4476 Export_DT (Typ, Iface_DT, Suffix_Index);
4478 -- Generate code to create the pointer to the dispatch table
4480 -- Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address);
4482 -- Note: This declaration is not added here if the table is exported
4483 -- because in such case Make_Tags has already added this declaration.
4487 Make_Object_Declaration (Loc,
4488 Defining_Identifier => Iface_DT_Ptr,
4489 Constant_Present => True,
4491 Object_Definition =>
4492 New_Occurrence_Of (RTE (RE_Interface_Tag), Loc),
4495 Unchecked_Convert_To (RTE (RE_Interface_Tag),
4496 Make_Attribute_Reference (Loc,
4498 Make_Selected_Component (Loc,
4499 Prefix => New_Occurrence_Of (Iface_DT, Loc),
4502 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
4503 Attribute_Name => Name_Address))));
4507 Make_Object_Declaration (Loc,
4508 Defining_Identifier => Predef_Prims_Ptr,
4509 Constant_Present => True,
4511 Object_Definition =>
4512 New_Occurrence_Of (RTE (RE_Address), Loc),
4515 Make_Attribute_Reference (Loc,
4517 Make_Selected_Component (Loc,
4518 Prefix => New_Occurrence_Of (Iface_DT, Loc),
4521 (RTE_Record_Component (RE_Predef_Prims), Loc)),
4522 Attribute_Name => Name_Address)));
4524 -- Remember entities containing dispatch tables
4526 Append_Elmt (Predef_Prims, DT_Decl);
4527 Append_Elmt (Iface_DT, DT_Decl);
4528 end Make_Secondary_DT;
4530 --------------------------------
4531 -- Number_Of_Predefined_Prims --
4532 --------------------------------
4534 function Number_Of_Predefined_Prims (Typ : Entity_Id) return Nat is
4535 Nb_Predef_Prims : Nat := 0;
4538 if not Generate_SCIL then
4541 Prim_Elmt : Elmt_Id;
4545 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4546 while Present (Prim_Elmt) loop
4547 Prim := Node (Prim_Elmt);
4549 if Is_Predefined_Dispatching_Operation (Prim)
4550 and then not Is_Abstract_Subprogram (Prim)
4552 Pos := UI_To_Int (DT_Position (Prim));
4554 if Pos > Nb_Predef_Prims then
4555 Nb_Predef_Prims := Pos;
4559 Next_Elmt (Prim_Elmt);
4564 pragma Assert (Nb_Predef_Prims <= Max_Predef_Prims);
4565 return Nb_Predef_Prims;
4566 end Number_Of_Predefined_Prims;
4570 Elab_Code : constant List_Id := New_List;
4571 Result : constant List_Id := New_List;
4572 Tname : constant Name_Id := Chars (Typ);
4574 -- When pragmas Discard_Names and No_Tagged_Streams simultaneously apply
4575 -- we initialize the Expanded_Name and the External_Tag of this tagged
4576 -- type with an empty string. This is useful to avoid exposing entity
4577 -- names at binary level. It can be done when both pragmas apply because
4578 -- (1) Discard_Names allows initializing Expanded_Name with an
4579 -- implementation defined value (Ada RM Section C.5 (7/2)).
4580 -- (2) External_Tag (combined with Internal_Tag) is used for object
4581 -- streaming and No_Tagged_Streams inhibits the generation of
4584 Discard_Names : constant Boolean :=
4585 Present (No_Tagged_Streams_Pragma (Typ))
4586 and then (Global_Discard_Names
4587 or else Einfo.Discard_Names (Typ));
4589 -- The following name entries are used by Make_DT to generate a number
4590 -- of entities related to a tagged type. These entities may be generated
4591 -- in a scope other than that of the tagged type declaration, and if
4592 -- the entities for two tagged types with the same name happen to be
4593 -- generated in the same scope, we have to take care to use different
4594 -- names. This is achieved by means of a unique serial number appended
4595 -- to each generated entity name.
4597 Name_DT : constant Name_Id :=
4598 New_External_Name (Tname, 'T', Suffix_Index => -1);
4599 Name_Exname : constant Name_Id :=
4600 New_External_Name (Tname, 'E', Suffix_Index => -1);
4601 Name_HT_Link : constant Name_Id :=
4602 New_External_Name (Tname, 'H', Suffix_Index => -1);
4603 Name_Predef_Prims : constant Name_Id :=
4604 New_External_Name (Tname, 'R', Suffix_Index => -1);
4605 Name_SSD : constant Name_Id :=
4606 New_External_Name (Tname, 'S', Suffix_Index => -1);
4607 Name_TSD : constant Name_Id :=
4608 New_External_Name (Tname, 'B', Suffix_Index => -1);
4610 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
4611 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
4612 -- Save the Ghost-related attributes to restore on exit
4615 AI_Tag_Elmt : Elmt_Id;
4616 AI_Tag_Comp : Elmt_Id;
4618 DT_Aggr_List : List_Id;
4619 DT_Constr_List : List_Id;
4622 HT_Link : Entity_Id;
4625 Iface_Table_Node : Node_Id;
4626 Name_ITable : Name_Id;
4629 Num_Ifaces : Nat := 0;
4630 Parent_Typ : Entity_Id;
4631 Predef_Prims : Entity_Id;
4633 Prim_Elmt : Elmt_Id;
4634 Prim_Ops_Aggr_List : List_Id;
4637 Typ_Comps : Elist_Id;
4638 Typ_Ifaces : Elist_Id;
4640 TSD_Aggr_List : List_Id;
4641 TSD_Tags_List : List_Id;
4643 -- Start of processing for Make_DT
4646 pragma Assert (Is_Frozen (Typ));
4648 -- The tagged type being processed may be subject to pragma Ghost. Set
4649 -- the mode now to ensure that any nodes generated during dispatch table
4650 -- creation are properly marked as Ghost.
4652 Set_Ghost_Mode (Typ);
4654 -- Handle cases in which there is no need to build the dispatch table
4656 if Has_Dispatch_Table (Typ)
4657 or else No (Access_Disp_Table (Typ))
4658 or else Is_CPP_Class (Typ)
4662 elsif No_Run_Time_Mode then
4663 Error_Msg_CRT ("tagged types", Typ);
4666 elsif not RTE_Available (RE_Tag) then
4668 Make_Object_Declaration (Loc,
4669 Defining_Identifier =>
4670 Node (First_Elmt (Access_Disp_Table (Typ))),
4671 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc),
4672 Constant_Present => True,
4674 Unchecked_Convert_To (RTE (RE_Tag),
4675 New_Occurrence_Of (RTE (RE_Null_Address), Loc))));
4677 Analyze_List (Result, Suppress => All_Checks);
4678 Error_Msg_CRT ("tagged types", Typ);
4682 -- Ensure that the value of Max_Predef_Prims defined in a-tags is
4683 -- correct. Valid values are 9 under configurable runtime or 15
4684 -- with full runtime.
4686 if RTE_Available (RE_Interface_Data) then
4687 if Max_Predef_Prims /= 15 then
4688 Error_Msg_N ("run-time library configuration error", Typ);
4692 if Max_Predef_Prims /= 9 then
4693 Error_Msg_N ("run-time library configuration error", Typ);
4694 Error_Msg_CRT ("tagged types", Typ);
4699 DT := Make_Defining_Identifier (Loc, Name_DT);
4700 Exname := Make_Defining_Identifier (Loc, Name_Exname);
4701 HT_Link := Make_Defining_Identifier (Loc, Name_HT_Link);
4702 Predef_Prims := Make_Defining_Identifier (Loc, Name_Predef_Prims);
4703 SSD := Make_Defining_Identifier (Loc, Name_SSD);
4704 TSD := Make_Defining_Identifier (Loc, Name_TSD);
4706 -- Initialize Parent_Typ handling private types
4708 Parent_Typ := Etype (Typ);
4710 if Present (Full_View (Parent_Typ)) then
4711 Parent_Typ := Full_View (Parent_Typ);
4714 -- Ensure that all the primitives are frozen. This is only required when
4715 -- building static dispatch tables --- the primitives must be frozen to
4716 -- be referenced (otherwise we have problems with the backend). It is
4717 -- not a requirement with nonstatic dispatch tables because in this case
4718 -- we generate now an empty dispatch table; the extra code required to
4719 -- register the primitives in the slots will be generated later --- when
4720 -- each primitive is frozen (see Freeze_Subprogram).
4722 if Building_Static_DT (Typ) then
4724 Saved_FLLTT : constant Boolean :=
4725 Freezing_Library_Level_Tagged_Type;
4730 Prim_Elmt : Elmt_Id;
4733 Freezing_Library_Level_Tagged_Type := True;
4735 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4736 while Present (Prim_Elmt) loop
4737 Prim := Node (Prim_Elmt);
4738 Frnodes := Freeze_Entity (Prim, Typ);
4740 -- We disable this check for abstract subprograms, given that
4741 -- they cannot be called directly and thus the state of their
4742 -- untagged formals is of no concern. The RM is unclear in any
4743 -- case concerning the need for this check, and this topic may
4744 -- go back to the ARG.
4746 if not Is_Abstract_Subprogram (Prim) then
4747 Formal := First_Formal (Prim);
4748 while Present (Formal) loop
4749 Check_Premature_Freezing (Prim, Typ, Etype (Formal));
4750 Next_Formal (Formal);
4753 Check_Premature_Freezing (Prim, Typ, Etype (Prim));
4756 if Present (Frnodes) then
4757 Append_List_To (Result, Frnodes);
4760 Next_Elmt (Prim_Elmt);
4763 Freezing_Library_Level_Tagged_Type := Saved_FLLTT;
4767 if not Is_Interface (Typ) and then Has_Interfaces (Typ) then
4769 Cannot_Have_Null_Disc : Boolean := False;
4770 Dummy_Object_Typ : constant Entity_Id := Typ;
4771 Name_Dummy_Object : constant Name_Id :=
4772 New_External_Name (Tname,
4773 'P', Suffix_Index => -1);
4775 Dummy_Object := Make_Defining_Identifier (Loc, Name_Dummy_Object);
4777 -- Define the extra object imported and constant to avoid linker
4778 -- errors (since this object is never declared). Required because
4779 -- we implement RM 13.3(19) for exported and imported (variable)
4780 -- objects by making them volatile.
4782 Set_Is_Imported (Dummy_Object);
4783 Set_Ekind (Dummy_Object, E_Constant);
4784 Set_Is_True_Constant (Dummy_Object);
4785 Set_Related_Type (Dummy_Object, Typ);
4787 -- The scope must be set now to call Get_External_Name
4789 Set_Scope (Dummy_Object, Current_Scope);
4791 Get_External_Name (Dummy_Object);
4792 Set_Interface_Name (Dummy_Object,
4793 Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
4795 -- Ensure proper Sprint output of this implicit importation
4797 Set_Is_Internal (Dummy_Object);
4799 if not Has_Discriminants (Dummy_Object_Typ) then
4801 Make_Object_Declaration (Loc,
4802 Defining_Identifier => Dummy_Object,
4803 Constant_Present => True,
4804 Object_Definition => New_Occurrence_Of
4805 (Dummy_Object_Typ, Loc)));
4808 Constr_List : constant List_Id := New_List;
4812 Discrim := First_Discriminant (Dummy_Object_Typ);
4813 while Present (Discrim) loop
4814 if Is_Discrete_Type (Etype (Discrim)) then
4815 Append_To (Constr_List,
4816 Make_Attribute_Reference (Loc,
4818 New_Occurrence_Of (Etype (Discrim), Loc),
4819 Attribute_Name => Name_First));
4822 pragma Assert (Is_Access_Type (Etype (Discrim)));
4823 Cannot_Have_Null_Disc :=
4824 Cannot_Have_Null_Disc
4825 or else Can_Never_Be_Null (Etype (Discrim));
4826 Append_To (Constr_List, Make_Null (Loc));
4829 Next_Discriminant (Discrim);
4833 Make_Object_Declaration (Loc,
4834 Defining_Identifier => Dummy_Object,
4835 Constant_Present => True,
4836 Object_Definition =>
4837 Make_Subtype_Indication (Loc,
4839 New_Occurrence_Of (Dummy_Object_Typ, Loc),
4841 Make_Index_Or_Discriminant_Constraint (Loc,
4842 Constraints => Constr_List))));
4846 -- Given that the dummy object will not be declared at run time,
4847 -- analyze its declaration with expansion disabled and warnings
4848 -- and error messages ignored.
4850 Expander_Mode_Save_And_Set (False);
4851 Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
4852 Analyze (Last (Result), Suppress => All_Checks);
4853 Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
4854 Expander_Mode_Restore;
4858 -- Ada 2005 (AI-251): Build the secondary dispatch tables
4860 if Has_Interfaces (Typ) then
4861 Collect_Interface_Components (Typ, Typ_Comps);
4863 -- Each secondary dispatch table is assigned an unique positive
4864 -- suffix index; such value also corresponds with the location of
4865 -- its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
4867 -- Note: This value must be kept sync with the Suffix_Index values
4868 -- generated by Make_Tags
4872 Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
4874 AI_Tag_Comp := First_Elmt (Typ_Comps);
4875 while Present (AI_Tag_Comp) loop
4876 pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'P'));
4878 -- Build the secondary table containing pointers to thunks
4883 Base_Type (Related_Type (Node (AI_Tag_Comp))),
4884 Iface_Comp => Node (AI_Tag_Comp),
4885 Suffix_Index => Suffix_Index,
4887 UI_To_Int (DT_Entry_Count (Node (AI_Tag_Comp))),
4888 Iface_DT_Ptr => Node (AI_Tag_Elmt),
4889 Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
4890 Build_Thunks => True,
4893 -- Skip secondary dispatch table referencing thunks to predefined
4896 Next_Elmt (AI_Tag_Elmt);
4897 pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Y'));
4899 -- Secondary dispatch table referencing user-defined primitives
4900 -- covered by this interface.
4902 Next_Elmt (AI_Tag_Elmt);
4903 pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'D'));
4905 -- Build the secondary table containing pointers to primitives
4906 -- (used to give support to Generic Dispatching Constructors).
4911 (Related_Type (Node (AI_Tag_Comp))),
4912 Iface_Comp => Node (AI_Tag_Comp),
4914 Num_Iface_Prims => UI_To_Int
4915 (DT_Entry_Count (Node (AI_Tag_Comp))),
4916 Iface_DT_Ptr => Node (AI_Tag_Elmt),
4917 Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
4918 Build_Thunks => False,
4921 -- Skip secondary dispatch table referencing predefined primitives
4923 Next_Elmt (AI_Tag_Elmt);
4924 pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Z'));
4926 Suffix_Index := Suffix_Index + 1;
4927 Next_Elmt (AI_Tag_Elmt);
4928 Next_Elmt (AI_Tag_Comp);
4932 -- Get the _tag entity and number of primitives of its dispatch table
4934 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
4935 Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
4937 if Generate_SCIL then
4941 Set_Is_Statically_Allocated (DT, Is_Library_Level_Tagged_Type (Typ));
4942 Set_Is_Statically_Allocated (SSD, Is_Library_Level_Tagged_Type (Typ));
4943 Set_Is_Statically_Allocated (TSD, Is_Library_Level_Tagged_Type (Typ));
4944 Set_Is_Statically_Allocated (Predef_Prims,
4945 Is_Library_Level_Tagged_Type (Typ));
4947 -- In case of locally defined tagged type we declare the object
4948 -- containing the dispatch table by means of a variable. Its
4949 -- initialization is done later by means of an assignment. This is
4950 -- required to generate its External_Tag.
4952 if not Building_Static_DT (Typ) then
4955 -- DT : No_Dispatch_Table_Wrapper;
4956 -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
4958 if not Has_DT (Typ) then
4960 Make_Object_Declaration (Loc,
4961 Defining_Identifier => DT,
4962 Aliased_Present => True,
4963 Constant_Present => False,
4964 Object_Definition =>
4966 (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
4969 Make_Object_Declaration (Loc,
4970 Defining_Identifier => DT_Ptr,
4971 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc),
4972 Constant_Present => True,
4974 Unchecked_Convert_To (RTE (RE_Tag),
4975 Make_Attribute_Reference (Loc,
4977 Make_Selected_Component (Loc,
4978 Prefix => New_Occurrence_Of (DT, Loc),
4981 (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
4982 Attribute_Name => Name_Address))));
4984 Set_Is_Statically_Allocated (DT_Ptr,
4985 Is_Library_Level_Tagged_Type (Typ));
4987 -- Generate the SCIL node for the previous object declaration
4988 -- because it has a tag initialization.
4990 if Generate_SCIL then
4992 Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
4993 Set_SCIL_Entity (New_Node, Typ);
4994 Set_SCIL_Node (Last (Result), New_Node);
4998 -- Gnat2scil has its own implementation of dispatch tables,
4999 -- different than what is being implemented here. Generating
5000 -- further dispatch table initialization code would just
5001 -- cause gnat2scil to generate useless Scil which CodePeer
5002 -- would waste time and space analyzing, so we skip it.
5006 -- DT : Dispatch_Table_Wrapper (Nb_Prim);
5007 -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
5010 -- If the tagged type has no primitives we add a dummy slot
5011 -- whose address will be the tag of this type.
5015 New_List (Make_Integer_Literal (Loc, 1));
5018 New_List (Make_Integer_Literal (Loc, Nb_Prim));
5022 Make_Object_Declaration (Loc,
5023 Defining_Identifier => DT,
5024 Aliased_Present => True,
5025 Constant_Present => False,
5026 Object_Definition =>
5027 Make_Subtype_Indication (Loc,
5029 New_Occurrence_Of (RTE (RE_Dispatch_Table_Wrapper), Loc),
5031 Make_Index_Or_Discriminant_Constraint (Loc,
5032 Constraints => DT_Constr_List))));
5035 Make_Object_Declaration (Loc,
5036 Defining_Identifier => DT_Ptr,
5037 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc),
5038 Constant_Present => True,
5040 Unchecked_Convert_To (RTE (RE_Tag),
5041 Make_Attribute_Reference (Loc,
5043 Make_Selected_Component (Loc,
5044 Prefix => New_Occurrence_Of (DT, Loc),
5047 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
5048 Attribute_Name => Name_Address))));
5050 Set_Is_Statically_Allocated (DT_Ptr,
5051 Is_Library_Level_Tagged_Type (Typ));
5053 -- Generate the SCIL node for the previous object declaration
5054 -- because it has a tag initialization.
5056 if Generate_SCIL then
5058 Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
5059 Set_SCIL_Entity (New_Node, Typ);
5060 Set_SCIL_Node (Last (Result), New_Node);
5064 -- Gnat2scil has its own implementation of dispatch tables,
5065 -- different than what is being implemented here. Generating
5066 -- further dispatch table initialization code would just
5067 -- cause gnat2scil to generate useless Scil which CodePeer
5068 -- would waste time and space analyzing, so we skip it.
5072 Make_Object_Declaration (Loc,
5073 Defining_Identifier =>
5074 Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))),
5075 Constant_Present => True,
5076 Object_Definition =>
5077 New_Occurrence_Of (RTE (RE_Address), Loc),
5079 Make_Attribute_Reference (Loc,
5081 Make_Selected_Component (Loc,
5082 Prefix => New_Occurrence_Of (DT, Loc),
5085 (RTE_Record_Component (RE_Predef_Prims), Loc)),
5086 Attribute_Name => Name_Address)));
5090 -- Generate: Expanded_Name : constant String := "";
5092 if Discard_Names then
5094 Make_Object_Declaration (Loc,
5095 Defining_Identifier => Exname,
5096 Constant_Present => True,
5097 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
5099 Make_String_Literal (Loc, "")));
5101 -- Generate: Exname : constant String := full_qualified_name (typ);
5102 -- The type itself may be an anonymous parent type, so use the first
5103 -- subtype to have a user-recognizable name.
5107 Make_Object_Declaration (Loc,
5108 Defining_Identifier => Exname,
5109 Constant_Present => True,
5110 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
5112 Make_String_Literal (Loc,
5113 Fully_Qualified_Name_String (First_Subtype (Typ)))));
5116 Set_Is_Statically_Allocated (Exname);
5117 Set_Is_True_Constant (Exname);
5119 -- Declare the object used by Ada.Tags.Register_Tag
5121 if RTE_Available (RE_Register_Tag) then
5123 Make_Object_Declaration (Loc,
5124 Defining_Identifier => HT_Link,
5125 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc),
5126 Expression => New_Occurrence_Of (RTE (RE_No_Tag), Loc)));
5129 -- Generate code to create the storage for the type specific data object
5130 -- with enough space to store the tags of the ancestors plus the tags
5131 -- of all the implemented interfaces (as described in a-tags.adb).
5133 -- TSD : Type_Specific_Data (I_Depth) :=
5134 -- (Idepth => I_Depth,
5135 -- Access_Level => Type_Access_Level (Typ),
5136 -- Alignment => Typ'Alignment,
5137 -- Expanded_Name => Cstring_Ptr!(Exname'Address))
5138 -- External_Tag => Cstring_Ptr!(Exname'Address))
5139 -- HT_Link => HT_Link'Address,
5140 -- Transportable => <<boolean-value>>,
5141 -- Is_Abstract => <<boolean-value>>,
5142 -- Needs_Finalization => <<boolean-value>>,
5143 -- [ Size_Func => Size_Prim'Access, ]
5144 -- [ Interfaces_Table => <<access-value>>, ]
5145 -- [ SSD => SSD_Table'Address ]
5146 -- Tags_Table => (0 => null,
5150 TSD_Aggr_List := New_List;
5152 -- Idepth: Count ancestors to compute the inheritance depth. For private
5153 -- extensions, always go to the full view in order to compute the real
5154 -- inheritance depth.
5157 Current_Typ : Entity_Id;
5158 Parent_Typ : Entity_Id;
5164 Parent_Typ := Etype (Current_Typ);
5166 if Is_Private_Type (Parent_Typ) then
5167 Parent_Typ := Full_View (Base_Type (Parent_Typ));
5170 exit when Parent_Typ = Current_Typ;
5172 I_Depth := I_Depth + 1;
5173 Current_Typ := Parent_Typ;
5177 Append_To (TSD_Aggr_List,
5178 Make_Integer_Literal (Loc, I_Depth));
5182 Append_To (TSD_Aggr_List,
5183 Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
5187 -- For CPP types we cannot rely on the value of 'Alignment provided
5188 -- by the backend to initialize this TSD field.
5190 if Convention (Typ) = Convention_CPP
5191 or else Is_CPP_Class (Root_Type (Typ))
5193 Append_To (TSD_Aggr_List,
5194 Make_Integer_Literal (Loc, 0));
5196 Append_To (TSD_Aggr_List,
5197 Make_Attribute_Reference (Loc,
5198 Prefix => New_Occurrence_Of (Typ, Loc),
5199 Attribute_Name => Name_Alignment));
5204 Append_To (TSD_Aggr_List,
5205 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5206 Make_Attribute_Reference (Loc,
5207 Prefix => New_Occurrence_Of (Exname, Loc),
5208 Attribute_Name => Name_Address)));
5210 -- External_Tag of a local tagged type
5212 -- <typ>A : constant String :=
5213 -- "Internal tag at 16#tag-addr#: <full-name-of-typ>";
5215 -- The reason we generate this strange name is that we do not want to
5216 -- enter local tagged types in the global hash table used to compute
5217 -- the Internal_Tag attribute for two reasons:
5219 -- 1. It is hard to avoid a tasking race condition for entering the
5220 -- entry into the hash table.
5222 -- 2. It would cause a storage leak, unless we rig up considerable
5223 -- mechanism to remove the entry from the hash table on exit.
5225 -- So what we do is to generate the above external tag name, where the
5226 -- hex address is the address of the local dispatch table (i.e. exactly
5227 -- the value we want if Internal_Tag is computed from this string).
5229 -- Of course this value will only be valid if the tagged type is still
5230 -- in scope, but it clearly must be erroneous to compute the internal
5231 -- tag of a tagged type that is out of scope.
5233 -- We don't do this processing if an explicit external tag has been
5234 -- specified. That's an odd case for which we have already issued a
5235 -- warning, where we will not be able to compute the internal tag.
5237 if not Discard_Names
5238 and then not Is_Library_Level_Entity (Typ)
5239 and then not Has_External_Tag_Rep_Clause (Typ)
5242 Exname : constant Entity_Id :=
5243 Make_Defining_Identifier (Loc,
5244 Chars => New_External_Name (Tname, 'A'));
5245 Full_Name : constant String_Id :=
5246 Fully_Qualified_Name_String (First_Subtype (Typ));
5247 Str1_Id : String_Id;
5248 Str2_Id : String_Id;
5252 -- Str1 = "Internal tag at 16#";
5255 Store_String_Chars ("Internal tag at 16#");
5256 Str1_Id := End_String;
5259 -- Str2 = "#: <type-full-name>";
5262 Store_String_Chars ("#: ");
5263 Store_String_Chars (Full_Name);
5264 Str2_Id := End_String;
5267 -- Exname : constant String :=
5268 -- Str1 & Address_Image (Tag) & Str2;
5270 if RTE_Available (RE_Address_Image) then
5272 Make_Object_Declaration (Loc,
5273 Defining_Identifier => Exname,
5274 Constant_Present => True,
5275 Object_Definition => New_Occurrence_Of
5276 (Standard_String, Loc),
5278 Make_Op_Concat (Loc,
5279 Left_Opnd => Make_String_Literal (Loc, Str1_Id),
5281 Make_Op_Concat (Loc,
5283 Make_Function_Call (Loc,
5286 (RTE (RE_Address_Image), Loc),
5287 Parameter_Associations => New_List (
5288 Unchecked_Convert_To (RTE (RE_Address),
5289 New_Occurrence_Of (DT_Ptr, Loc)))),
5291 Make_String_Literal (Loc, Str2_Id)))));
5294 -- Exname : constant String := Str1 & Str2;
5298 Make_Object_Declaration (Loc,
5299 Defining_Identifier => Exname,
5300 Constant_Present => True,
5301 Object_Definition =>
5302 New_Occurrence_Of (Standard_String, Loc),
5304 Make_Op_Concat (Loc,
5305 Left_Opnd => Make_String_Literal (Loc, Str1_Id),
5306 Right_Opnd => Make_String_Literal (Loc, Str2_Id))));
5310 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5311 Make_Attribute_Reference (Loc,
5312 Prefix => New_Occurrence_Of (Exname, Loc),
5313 Attribute_Name => Name_Address));
5316 -- External tag of a library-level tagged type: Check for a definition
5317 -- of External_Tag. The clause is considered only if it applies to this
5318 -- specific tagged type, as opposed to one of its ancestors.
5319 -- If the type is an unconstrained type extension, we are building the
5320 -- dispatch table of its anonymous base type, so the external tag, if
5321 -- any was specified, must be retrieved from the first subtype. Go to
5322 -- the full view in case the clause is in the private part.
5326 Def : constant Node_Id := Get_Attribute_Definition_Clause
5327 (Underlying_Type (First_Subtype (Typ)),
5328 Attribute_External_Tag);
5330 Old_Val : String_Id;
5331 New_Val : String_Id;
5335 if not Present (Def)
5336 or else Entity (Name (Def)) /= First_Subtype (Typ)
5339 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5340 Make_Attribute_Reference (Loc,
5341 Prefix => New_Occurrence_Of (Exname, Loc),
5342 Attribute_Name => Name_Address));
5344 Old_Val := Strval (Expr_Value_S (Expression (Def)));
5346 -- For the rep clause "for <typ>'external_tag use y" generate:
5348 -- <typ>A : constant string := y;
5350 -- <typ>A'Address is used to set the External_Tag component
5353 -- Create a new nul terminated string if it is not already
5355 if String_Length (Old_Val) > 0
5357 Get_String_Char (Old_Val, String_Length (Old_Val)) = 0
5361 Start_String (Old_Val);
5362 Store_String_Char (Get_Char_Code (ASCII.NUL));
5363 New_Val := End_String;
5366 E := Make_Defining_Identifier (Loc,
5367 New_External_Name (Chars (Typ), 'A'));
5370 Make_Object_Declaration (Loc,
5371 Defining_Identifier => E,
5372 Constant_Present => True,
5373 Object_Definition =>
5374 New_Occurrence_Of (Standard_String, Loc),
5376 Make_String_Literal (Loc, New_Val)));
5379 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5380 Make_Attribute_Reference (Loc,
5381 Prefix => New_Occurrence_Of (E, Loc),
5382 Attribute_Name => Name_Address));
5387 Append_To (TSD_Aggr_List, New_Node);
5391 if RTE_Available (RE_Register_Tag) then
5392 Append_To (TSD_Aggr_List,
5393 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
5394 Make_Attribute_Reference (Loc,
5395 Prefix => New_Occurrence_Of (HT_Link, Loc),
5396 Attribute_Name => Name_Address)));
5398 elsif RTE_Record_Component_Available (RE_HT_Link) then
5399 Append_To (TSD_Aggr_List,
5400 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
5401 New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
5404 -- Transportable: Set for types that can be used in remote calls
5405 -- with respect to E.4(18) legality rules.
5408 Transportable : Entity_Id;
5414 or else Is_Shared_Passive (Typ)
5416 ((Is_Remote_Types (Typ)
5417 or else Is_Remote_Call_Interface (Typ))
5418 and then Original_View_In_Visible_Part (Typ))
5419 or else not Comes_From_Source (Typ));
5421 Append_To (TSD_Aggr_List,
5422 New_Occurrence_Of (Transportable, Loc));
5425 -- Is_Abstract (Ada 2012: AI05-0173). This functionality is not
5426 -- available in the HIE runtime.
5428 if RTE_Record_Component_Available (RE_Is_Abstract) then
5430 Is_Abstract : Entity_Id;
5432 Is_Abstract := Boolean_Literals (Is_Abstract_Type (Typ));
5433 Append_To (TSD_Aggr_List,
5434 New_Occurrence_Of (Is_Abstract, Loc));
5438 -- Needs_Finalization: Set if the type is controlled or has controlled
5442 Needs_Fin : Entity_Id;
5444 Needs_Fin := Boolean_Literals (Needs_Finalization (Typ));
5445 Append_To (TSD_Aggr_List, New_Occurrence_Of (Needs_Fin, Loc));
5450 if RTE_Record_Component_Available (RE_Size_Func) then
5452 -- Initialize this field to Null_Address if we are not building
5453 -- static dispatch tables static or if the size function is not
5454 -- available. In the former case we cannot initialize this field
5455 -- until the function is frozen and registered in the dispatch
5456 -- table (see Register_Primitive).
5458 if not Building_Static_DT (Typ) or else not Has_DT (Typ) then
5459 Append_To (TSD_Aggr_List,
5460 Unchecked_Convert_To (RTE (RE_Size_Ptr),
5461 New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
5465 Prim_Elmt : Elmt_Id;
5467 Size_Comp : Node_Id := Empty;
5470 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5471 while Present (Prim_Elmt) loop
5472 Prim := Node (Prim_Elmt);
5474 if Chars (Prim) = Name_uSize then
5475 Prim := Ultimate_Alias (Prim);
5477 if Is_Abstract_Subprogram (Prim) then
5479 Unchecked_Convert_To (RTE (RE_Size_Ptr),
5480 New_Occurrence_Of (RTE (RE_Null_Address), Loc));
5483 Unchecked_Convert_To (RTE (RE_Size_Ptr),
5484 Make_Attribute_Reference (Loc,
5485 Prefix => New_Occurrence_Of (Prim, Loc),
5486 Attribute_Name => Name_Unrestricted_Access));
5492 Next_Elmt (Prim_Elmt);
5495 pragma Assert (Present (Size_Comp));
5496 Append_To (TSD_Aggr_List, Size_Comp);
5501 -- Interfaces_Table (required for AI-405)
5503 if RTE_Record_Component_Available (RE_Interfaces_Table) then
5505 -- Count the number of interface types implemented by Typ
5507 Collect_Interfaces (Typ, Typ_Ifaces);
5509 AI := First_Elmt (Typ_Ifaces);
5510 while Present (AI) loop
5511 Num_Ifaces := Num_Ifaces + 1;
5515 if Num_Ifaces = 0 then
5516 Iface_Table_Node := Make_Null (Loc);
5518 -- Generate the Interface_Table object
5522 TSD_Ifaces_List : constant List_Id := New_List;
5524 Offset_To_Top : Node_Id;
5525 Sec_DT_Tag : Node_Id;
5527 Dummy_Object_Ifaces_List : Elist_Id := No_Elist;
5528 Dummy_Object_Ifaces_Comp_List : Elist_Id := No_Elist;
5529 Dummy_Object_Ifaces_Tag_List : Elist_Id := No_Elist;
5530 -- Interfaces information of the dummy object
5533 -- Collect interfaces information if we need to compute the
5534 -- offset to the top using the dummy object.
5536 if Present (Dummy_Object) then
5537 Collect_Interfaces_Info (Typ,
5538 Ifaces_List => Dummy_Object_Ifaces_List,
5539 Components_List => Dummy_Object_Ifaces_Comp_List,
5540 Tags_List => Dummy_Object_Ifaces_Tag_List);
5543 AI := First_Elmt (Typ_Ifaces);
5544 while Present (AI) loop
5545 if Is_Ancestor (Node (AI), Typ, Use_Full_View => True) then
5546 Sec_DT_Tag := New_Occurrence_Of (DT_Ptr, Loc);
5551 (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
5552 pragma Assert (Has_Thunks (Node (Elmt)));
5554 while Is_Tag (Node (Elmt))
5556 Is_Ancestor (Node (AI), Related_Type (Node (Elmt)),
5557 Use_Full_View => True)
5559 pragma Assert (Has_Thunks (Node (Elmt)));
5561 pragma Assert (Has_Thunks (Node (Elmt)));
5563 pragma Assert (not Has_Thunks (Node (Elmt)));
5565 pragma Assert (not Has_Thunks (Node (Elmt)));
5569 pragma Assert (Ekind (Node (Elmt)) = E_Constant
5571 Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt)))));
5575 (Node (Next_Elmt (Next_Elmt (Elmt))), Loc);
5578 -- Use the dummy object to compute Offset_To_Top of
5579 -- components located at fixed position.
5581 if Present (Dummy_Object) then
5583 Iface : constant Node_Id := Node (AI);
5584 Iface_Comp : Node_Id := Empty;
5585 Iface_Comp_Elmt : Elmt_Id;
5586 Iface_Elmt : Elmt_Id;
5590 First_Elmt (Dummy_Object_Ifaces_List);
5592 First_Elmt (Dummy_Object_Ifaces_Comp_List);
5594 while Present (Iface_Elmt) loop
5595 if Node (Iface_Elmt) = Iface then
5596 Iface_Comp := Node (Iface_Comp_Elmt);
5600 Next_Elmt (Iface_Elmt);
5601 Next_Elmt (Iface_Comp_Elmt);
5604 pragma Assert (Present (Iface_Comp));
5607 Is_Variable_Size_Record (Etype (Scope (Iface_Comp)))
5611 Make_Attribute_Reference (Loc,
5613 Make_Selected_Component (Loc,
5615 New_Occurrence_Of (Dummy_Object, Loc),
5617 New_Occurrence_Of (Iface_Comp, Loc)),
5618 Attribute_Name => Name_Position));
5620 Offset_To_Top := Make_Integer_Literal (Loc, 0);
5624 Offset_To_Top := Make_Integer_Literal (Loc, 0);
5627 Append_To (TSD_Ifaces_List,
5628 Make_Aggregate (Loc,
5629 Expressions => New_List (
5633 Unchecked_Convert_To (RTE (RE_Tag),
5635 (Node (First_Elmt (Access_Disp_Table (Node (AI)))),
5638 -- Static_Offset_To_Top
5640 New_Occurrence_Of (Standard_True, Loc),
5642 -- Offset_To_Top_Value
5646 -- Offset_To_Top_Func
5652 Unchecked_Convert_To (RTE (RE_Tag), Sec_DT_Tag))));
5657 Name_ITable := New_External_Name (Tname, 'I');
5658 ITable := Make_Defining_Identifier (Loc, Name_ITable);
5659 Set_Is_Statically_Allocated (ITable,
5660 Is_Library_Level_Tagged_Type (Typ));
5662 -- The table of interfaces is constant if we are building a
5663 -- static dispatch table; otherwise is not constant because
5664 -- its slots are filled at run time by the IP routine.
5667 Make_Object_Declaration (Loc,
5668 Defining_Identifier => ITable,
5669 Aliased_Present => True,
5670 Constant_Present => Building_Static_Secondary_DT (Typ),
5671 Object_Definition =>
5672 Make_Subtype_Indication (Loc,
5674 New_Occurrence_Of (RTE (RE_Interface_Data), Loc),
5676 Make_Index_Or_Discriminant_Constraint (Loc,
5677 Constraints => New_List (
5678 Make_Integer_Literal (Loc, Num_Ifaces)))),
5681 Make_Aggregate (Loc,
5682 Expressions => New_List (
5683 Make_Integer_Literal (Loc, Num_Ifaces),
5684 Make_Aggregate (Loc, TSD_Ifaces_List)))));
5687 Make_Attribute_Reference (Loc,
5688 Prefix => New_Occurrence_Of (ITable, Loc),
5689 Attribute_Name => Name_Unchecked_Access);
5693 Append_To (TSD_Aggr_List, Iface_Table_Node);
5696 -- Generate the Select Specific Data table for synchronized types that
5697 -- implement synchronized interfaces. The size of the table is
5698 -- constrained by the number of non-predefined primitive operations.
5700 if RTE_Record_Component_Available (RE_SSD) then
5701 if Ada_Version >= Ada_2005
5702 and then Has_DT (Typ)
5703 and then Is_Concurrent_Record_Type (Typ)
5704 and then Has_Interfaces (Typ)
5705 and then Nb_Prim > 0
5706 and then not Is_Abstract_Type (Typ)
5707 and then not Is_Controlled (Typ)
5708 and then not Restriction_Active (No_Dispatching_Calls)
5709 and then not Restriction_Active (No_Select_Statements)
5712 Make_Object_Declaration (Loc,
5713 Defining_Identifier => SSD,
5714 Aliased_Present => True,
5715 Object_Definition =>
5716 Make_Subtype_Indication (Loc,
5717 Subtype_Mark => New_Occurrence_Of (
5718 RTE (RE_Select_Specific_Data), Loc),
5720 Make_Index_Or_Discriminant_Constraint (Loc,
5721 Constraints => New_List (
5722 Make_Integer_Literal (Loc, Nb_Prim))))));
5725 Make_Attribute_Definition_Clause (Loc,
5726 Name => New_Occurrence_Of (SSD, Loc),
5727 Chars => Name_Alignment,
5729 Make_Attribute_Reference (Loc,
5731 New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5732 Attribute_Name => Name_Alignment)));
5734 -- This table is initialized by Make_Select_Specific_Data_Table,
5735 -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
5737 Append_To (TSD_Aggr_List,
5738 Make_Attribute_Reference (Loc,
5739 Prefix => New_Occurrence_Of (SSD, Loc),
5740 Attribute_Name => Name_Unchecked_Access));
5742 Append_To (TSD_Aggr_List, Make_Null (Loc));
5746 -- Initialize the table of ancestor tags. In case of interface types
5747 -- this table is not needed.
5749 TSD_Tags_List := New_List;
5751 -- If we are not statically allocating the dispatch table then we must
5752 -- fill position 0 with null because we still have not generated the
5755 if not Building_Static_DT (Typ)
5756 or else Is_Interface (Typ)
5758 Append_To (TSD_Tags_List,
5759 Unchecked_Convert_To (RTE (RE_Tag),
5760 New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
5762 -- Otherwise we can safely reference the tag
5765 Append_To (TSD_Tags_List,
5766 New_Occurrence_Of (DT_Ptr, Loc));
5769 -- Fill the rest of the table with the tags of the ancestors
5772 Current_Typ : Entity_Id;
5773 Parent_Typ : Entity_Id;
5781 Parent_Typ := Etype (Current_Typ);
5783 if Is_Private_Type (Parent_Typ) then
5784 Parent_Typ := Full_View (Base_Type (Parent_Typ));
5787 exit when Parent_Typ = Current_Typ;
5789 if Is_CPP_Class (Parent_Typ) then
5791 -- The tags defined in the C++ side will be inherited when
5792 -- the object is constructed (Exp_Ch3.Build_Init_Procedure)
5794 Append_To (TSD_Tags_List,
5795 Unchecked_Convert_To (RTE (RE_Tag),
5796 New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
5798 Append_To (TSD_Tags_List,
5800 (Node (First_Elmt (Access_Disp_Table (Parent_Typ))),
5805 Current_Typ := Parent_Typ;
5808 pragma Assert (Pos = I_Depth + 1);
5811 Append_To (TSD_Aggr_List,
5812 Make_Aggregate (Loc,
5813 Expressions => TSD_Tags_List));
5815 -- Build the TSD object
5818 Make_Object_Declaration (Loc,
5819 Defining_Identifier => TSD,
5820 Aliased_Present => True,
5821 Constant_Present => Building_Static_DT (Typ),
5822 Object_Definition =>
5823 Make_Subtype_Indication (Loc,
5824 Subtype_Mark => New_Occurrence_Of (
5825 RTE (RE_Type_Specific_Data), Loc),
5827 Make_Index_Or_Discriminant_Constraint (Loc,
5828 Constraints => New_List (
5829 Make_Integer_Literal (Loc, I_Depth)))),
5831 Expression => Make_Aggregate (Loc,
5832 Expressions => TSD_Aggr_List)));
5834 Set_Is_True_Constant (TSD, Building_Static_DT (Typ));
5836 -- Initialize or declare the dispatch table object
5838 if not Has_DT (Typ) then
5839 DT_Constr_List := New_List;
5840 DT_Aggr_List := New_List;
5845 Make_Attribute_Reference (Loc,
5846 Prefix => New_Occurrence_Of (TSD, Loc),
5847 Attribute_Name => Name_Address);
5849 Append_To (DT_Constr_List, New_Node);
5850 Append_To (DT_Aggr_List, New_Copy (New_Node));
5851 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
5853 -- In case of locally defined tagged types we have already declared
5854 -- and uninitialized object for the dispatch table, which is now
5855 -- initialized by means of the following assignment:
5857 -- DT := (TSD'Address, 0);
5859 if not Building_Static_DT (Typ) then
5861 Make_Assignment_Statement (Loc,
5862 Name => New_Occurrence_Of (DT, Loc),
5863 Expression => Make_Aggregate (Loc, DT_Aggr_List)));
5865 -- In case of library level tagged types we declare and export now
5866 -- the constant object containing the dummy dispatch table. There
5867 -- is no need to declare the tag here because it has been previously
5868 -- declared by Make_Tags
5870 -- DT : aliased constant No_Dispatch_Table :=
5871 -- (NDT_TSD => TSD'Address;
5872 -- NDT_Prims_Ptr => 0);
5876 Make_Object_Declaration (Loc,
5877 Defining_Identifier => DT,
5878 Aliased_Present => True,
5879 Constant_Present => True,
5880 Object_Definition =>
5881 New_Occurrence_Of (RTE (RE_No_Dispatch_Table_Wrapper), Loc),
5882 Expression => Make_Aggregate (Loc, DT_Aggr_List)));
5884 Export_DT (Typ, DT);
5887 -- Common case: Typ has a dispatch table
5891 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
5892 -- (predef-prim-op-1'address,
5893 -- predef-prim-op-2'address,
5895 -- predef-prim-op-n'address);
5897 -- DT : Dispatch_Table (Nb_Prims) :=
5898 -- (Signature => <sig-value>,
5899 -- Tag_Kind => <tag_kind-value>,
5900 -- Predef_Prims => Predef_Prims'First'Address,
5901 -- Offset_To_Top => 0,
5902 -- TSD => TSD'Address;
5903 -- Prims_Ptr => (prim-op-1'address,
5904 -- prim-op-2'address,
5906 -- prim-op-n'address));
5907 -- for DT'Alignment use Address'Alignment
5911 Nb_P_Prims : constant Nat := Number_Of_Predefined_Prims (Typ);
5912 Prim_Table : array (Nat range 1 .. Nb_P_Prims) of Entity_Id;
5917 Prim_Ops_Aggr_List := New_List;
5918 Prim_Table := (others => Empty);
5920 if Building_Static_DT (Typ) then
5921 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5922 while Present (Prim_Elmt) loop
5923 Prim := Node (Prim_Elmt);
5925 if Is_Predefined_Dispatching_Operation (Prim)
5926 and then not Is_Abstract_Subprogram (Prim)
5927 and then not Is_Eliminated (Prim)
5928 and then not Generate_SCIL
5929 and then not Present (Prim_Table
5930 (UI_To_Int (DT_Position (Prim))))
5932 E := Ultimate_Alias (Prim);
5933 pragma Assert (not Is_Abstract_Subprogram (E));
5934 Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
5937 Next_Elmt (Prim_Elmt);
5941 for J in Prim_Table'Range loop
5942 if Present (Prim_Table (J)) then
5944 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
5945 Make_Attribute_Reference (Loc,
5947 New_Occurrence_Of (Prim_Table (J), Loc),
5948 Attribute_Name => Name_Unrestricted_Access));
5950 New_Node := Make_Null (Loc);
5953 Append_To (Prim_Ops_Aggr_List, New_Node);
5957 Make_Aggregate (Loc,
5958 Expressions => Prim_Ops_Aggr_List);
5961 Make_Subtype_Declaration (Loc,
5962 Defining_Identifier => Make_Temporary (Loc, 'S'),
5963 Subtype_Indication =>
5964 New_Occurrence_Of (RTE (RE_Address_Array), Loc));
5966 Append_To (Result, Decl);
5969 Make_Object_Declaration (Loc,
5970 Defining_Identifier => Predef_Prims,
5971 Aliased_Present => True,
5972 Constant_Present => Building_Static_DT (Typ),
5973 Object_Definition =>
5974 New_Occurrence_Of (Defining_Identifier (Decl), Loc),
5975 Expression => New_Node));
5977 -- Remember aggregates initializing dispatch tables
5979 Append_Elmt (New_Node, DT_Aggr);
5982 -- Stage 1: Initialize the discriminant and the record components
5984 DT_Constr_List := New_List;
5985 DT_Aggr_List := New_List;
5987 -- Num_Prims. If the tagged type has no primitives we add a dummy
5988 -- slot whose address will be the tag of this type.
5991 New_Node := Make_Integer_Literal (Loc, 1);
5993 New_Node := Make_Integer_Literal (Loc, Nb_Prim);
5996 Append_To (DT_Constr_List, New_Node);
5997 Append_To (DT_Aggr_List, New_Copy (New_Node));
6001 if RTE_Record_Component_Available (RE_Signature) then
6002 Append_To (DT_Aggr_List,
6003 New_Occurrence_Of (RTE (RE_Primary_DT), Loc));
6008 if RTE_Record_Component_Available (RE_Tag_Kind) then
6009 Append_To (DT_Aggr_List, Tagged_Kind (Typ));
6014 Append_To (DT_Aggr_List,
6015 Make_Attribute_Reference (Loc,
6016 Prefix => New_Occurrence_Of (Predef_Prims, Loc),
6017 Attribute_Name => Name_Address));
6021 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
6025 Append_To (DT_Aggr_List,
6026 Make_Attribute_Reference (Loc,
6027 Prefix => New_Occurrence_Of (TSD, Loc),
6028 Attribute_Name => Name_Address));
6030 -- Stage 2: Initialize the table of user-defined primitive operations
6032 Prim_Ops_Aggr_List := New_List;
6035 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
6037 elsif not Building_Static_DT (Typ) then
6038 for J in 1 .. Nb_Prim loop
6039 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
6044 CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
6047 Prim_Elmt : Elmt_Id;
6049 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
6052 Prim_Table := (others => Empty);
6054 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6055 while Present (Prim_Elmt) loop
6056 Prim := Node (Prim_Elmt);
6058 -- Retrieve the ultimate alias of the primitive for proper
6059 -- handling of renamings and eliminated primitives.
6061 E := Ultimate_Alias (Prim);
6063 -- If the alias is not a primitive operation then Prim does
6064 -- not rename another primitive, but rather an operation
6065 -- declared elsewhere (e.g. in another scope) and therefore
6066 -- Prim is a new primitive.
6068 if No (Find_Dispatching_Type (E)) then
6072 Prim_Pos := UI_To_Int (DT_Position (E));
6074 -- Skip predefined primitives because they are located in a
6075 -- separate dispatch table.
6077 if not Is_Predefined_Dispatching_Operation (Prim)
6078 and then not Is_Predefined_Dispatching_Operation (E)
6080 -- Skip entities with attribute Interface_Alias because
6081 -- those are only required to build secondary dispatch
6084 and then not Present (Interface_Alias (Prim))
6086 -- Skip abstract and eliminated primitives
6088 and then not Is_Abstract_Subprogram (E)
6089 and then not Is_Eliminated (E)
6091 -- For derivations of CPP types skip primitives located in
6092 -- the C++ part of the dispatch table because their slots
6093 -- are initialized by the IC routine.
6095 and then (not Is_CPP_Class (Root_Type (Typ))
6096 or else Prim_Pos > CPP_Nb_Prims)
6098 -- Skip ignored Ghost subprograms as those will be removed
6099 -- from the executable.
6101 and then not Is_Ignored_Ghost_Entity (E)
6104 (UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
6106 Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
6109 Next_Elmt (Prim_Elmt);
6112 for J in Prim_Table'Range loop
6113 if Present (Prim_Table (J)) then
6115 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6116 Make_Attribute_Reference (Loc,
6118 New_Occurrence_Of (Prim_Table (J), Loc),
6119 Attribute_Name => Name_Unrestricted_Access));
6121 New_Node := Make_Null (Loc);
6124 Append_To (Prim_Ops_Aggr_List, New_Node);
6130 Make_Aggregate (Loc,
6131 Expressions => Prim_Ops_Aggr_List);
6133 Append_To (DT_Aggr_List, New_Node);
6135 -- Remember aggregates initializing dispatch tables
6137 Append_Elmt (New_Node, DT_Aggr);
6139 -- In case of locally defined tagged types we have already declared
6140 -- and uninitialized object for the dispatch table, which is now
6141 -- initialized by means of an assignment.
6143 if not Building_Static_DT (Typ) then
6145 Make_Assignment_Statement (Loc,
6146 Name => New_Occurrence_Of (DT, Loc),
6147 Expression => Make_Aggregate (Loc, DT_Aggr_List)));
6149 -- In case of library level tagged types we declare now and export
6150 -- the constant object containing the dispatch table.
6154 Make_Object_Declaration (Loc,
6155 Defining_Identifier => DT,
6156 Aliased_Present => True,
6157 Constant_Present => True,
6158 Object_Definition =>
6159 Make_Subtype_Indication (Loc,
6160 Subtype_Mark => New_Occurrence_Of
6161 (RTE (RE_Dispatch_Table_Wrapper), Loc),
6162 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
6163 Constraints => DT_Constr_List)),
6164 Expression => Make_Aggregate (Loc, DT_Aggr_List)));
6166 Export_DT (Typ, DT);
6170 -- Initialize the table of ancestor tags if not building static
6173 if not Building_Static_DT (Typ)
6174 and then not Is_Interface (Typ)
6175 and then not Is_CPP_Class (Typ)
6178 Make_Assignment_Statement (Loc,
6180 Make_Indexed_Component (Loc,
6182 Make_Selected_Component (Loc,
6183 Prefix => New_Occurrence_Of (TSD, Loc),
6186 (RTE_Record_Component (RE_Tags_Table), Loc)),
6188 New_List (Make_Integer_Literal (Loc, 0))),
6192 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
6195 -- Inherit the dispatch tables of the parent. There is no need to
6196 -- inherit anything from the parent when building static dispatch tables
6197 -- because the whole dispatch table (including inherited primitives) has
6198 -- been already built.
6200 if Building_Static_DT (Typ) then
6203 -- If the ancestor is a CPP_Class type we inherit the dispatch tables
6204 -- in the init proc, and we don't need to fill them in here.
6206 elsif Is_CPP_Class (Parent_Typ) then
6209 -- Otherwise we fill in the dispatch tables here
6212 if Typ /= Parent_Typ
6213 and then not Is_Interface (Typ)
6214 and then not Restriction_Active (No_Dispatching_Calls)
6216 -- Inherit the dispatch table
6218 if not Is_Interface (Typ)
6219 and then not Is_Interface (Parent_Typ)
6220 and then not Is_CPP_Class (Parent_Typ)
6223 Nb_Prims : constant Int :=
6224 UI_To_Int (DT_Entry_Count
6225 (First_Tag_Component (Parent_Typ)));
6228 Append_To (Elab_Code,
6229 Build_Inherit_Predefined_Prims (Loc,
6235 (Access_Disp_Table (Parent_Typ)))), Loc),
6241 (Access_Disp_Table (Typ)))), Loc),
6243 Number_Of_Predefined_Prims (Parent_Typ)));
6245 if Nb_Prims /= 0 then
6246 Append_To (Elab_Code,
6247 Build_Inherit_Prims (Loc,
6253 (Access_Disp_Table (Parent_Typ))), Loc),
6254 New_Tag_Node => New_Occurrence_Of (DT_Ptr, Loc),
6255 Num_Prims => Nb_Prims));
6260 -- Inherit the secondary dispatch tables of the ancestor
6262 if not Is_CPP_Class (Parent_Typ) then
6264 Sec_DT_Ancestor : Elmt_Id :=
6270 Sec_DT_Typ : Elmt_Id :=
6274 (Access_Disp_Table (Typ))));
6276 procedure Copy_Secondary_DTs (Typ : Entity_Id);
6277 -- Local procedure required to climb through the ancestors
6278 -- and copy the contents of all their secondary dispatch
6281 ------------------------
6282 -- Copy_Secondary_DTs --
6283 ------------------------
6285 procedure Copy_Secondary_DTs (Typ : Entity_Id) is
6290 -- Climb to the ancestor (if any) handling private types
6292 if Present (Full_View (Etype (Typ))) then
6293 if Full_View (Etype (Typ)) /= Typ then
6294 Copy_Secondary_DTs (Full_View (Etype (Typ)));
6297 elsif Etype (Typ) /= Typ then
6298 Copy_Secondary_DTs (Etype (Typ));
6301 if Present (Interfaces (Typ))
6302 and then not Is_Empty_Elmt_List (Interfaces (Typ))
6304 Iface := First_Elmt (Interfaces (Typ));
6305 E := First_Entity (Typ);
6307 and then Present (Node (Sec_DT_Ancestor))
6308 and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
6310 if Is_Tag (E) and then Chars (E) /= Name_uTag then
6312 Num_Prims : constant Int :=
6313 UI_To_Int (DT_Entry_Count (E));
6316 if not Is_Interface (Etype (Typ)) then
6318 -- Inherit first secondary dispatch table
6320 Append_To (Elab_Code,
6321 Build_Inherit_Predefined_Prims (Loc,
6323 Unchecked_Convert_To (RTE (RE_Tag),
6326 (Next_Elmt (Sec_DT_Ancestor)),
6329 Unchecked_Convert_To (RTE (RE_Tag),
6331 (Node (Next_Elmt (Sec_DT_Typ)),
6334 Number_Of_Predefined_Prims
6337 if Num_Prims /= 0 then
6338 Append_To (Elab_Code,
6339 Build_Inherit_Prims (Loc,
6340 Typ => Node (Iface),
6342 Unchecked_Convert_To
6345 (Node (Sec_DT_Ancestor),
6348 Unchecked_Convert_To
6351 (Node (Sec_DT_Typ), Loc)),
6352 Num_Prims => Num_Prims));
6356 Next_Elmt (Sec_DT_Ancestor);
6357 Next_Elmt (Sec_DT_Typ);
6359 -- Skip the secondary dispatch table of
6360 -- predefined primitives
6362 Next_Elmt (Sec_DT_Ancestor);
6363 Next_Elmt (Sec_DT_Typ);
6365 if not Is_Interface (Etype (Typ)) then
6367 -- Inherit second secondary dispatch table
6369 Append_To (Elab_Code,
6370 Build_Inherit_Predefined_Prims (Loc,
6372 Unchecked_Convert_To (RTE (RE_Tag),
6375 (Next_Elmt (Sec_DT_Ancestor)),
6378 Unchecked_Convert_To (RTE (RE_Tag),
6380 (Node (Next_Elmt (Sec_DT_Typ)),
6383 Number_Of_Predefined_Prims
6386 if Num_Prims /= 0 then
6387 Append_To (Elab_Code,
6388 Build_Inherit_Prims (Loc,
6389 Typ => Node (Iface),
6391 Unchecked_Convert_To
6394 (Node (Sec_DT_Ancestor),
6397 Unchecked_Convert_To
6400 (Node (Sec_DT_Typ), Loc)),
6401 Num_Prims => Num_Prims));
6406 Next_Elmt (Sec_DT_Ancestor);
6407 Next_Elmt (Sec_DT_Typ);
6409 -- Skip the secondary dispatch table of
6410 -- predefined primitives
6412 Next_Elmt (Sec_DT_Ancestor);
6413 Next_Elmt (Sec_DT_Typ);
6421 end Copy_Secondary_DTs;
6424 if Present (Node (Sec_DT_Ancestor))
6425 and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
6427 -- Handle private types
6429 if Present (Full_View (Typ)) then
6430 Copy_Secondary_DTs (Full_View (Typ));
6432 Copy_Secondary_DTs (Typ);
6440 -- Generate code to check if the external tag of this type is the same
6441 -- as the external tag of some other declaration.
6443 -- Check_TSD (TSD'Unrestricted_Access);
6445 -- This check is a consequence of AI05-0113-1/06, so it officially
6446 -- applies to Ada 2005 (and Ada 2012). It might be argued that it is
6447 -- a desirable check to add in Ada 95 mode, but we hesitate to make
6448 -- this change, as it would be incompatible, and could conceivably
6449 -- cause a problem in existing Ada 95 code.
6451 -- We check for No_Run_Time_Mode here, because we do not want to pick
6452 -- up the RE_Check_TSD entity and call it in No_Run_Time mode.
6454 -- We cannot perform this check if the generation of its expanded name
6457 if not No_Run_Time_Mode
6458 and then not Discard_Names
6459 and then Ada_Version >= Ada_2005
6460 and then RTE_Available (RE_Check_TSD)
6461 and then not Duplicated_Tag_Checks_Suppressed (Typ)
6463 Append_To (Elab_Code,
6464 Make_Procedure_Call_Statement (Loc,
6466 New_Occurrence_Of (RTE (RE_Check_TSD), Loc),
6467 Parameter_Associations => New_List (
6468 Make_Attribute_Reference (Loc,
6469 Prefix => New_Occurrence_Of (TSD, Loc),
6470 Attribute_Name => Name_Unchecked_Access))));
6473 -- Generate code to register the Tag in the External_Tag hash table for
6474 -- the pure Ada type only.
6476 -- Register_Tag (Dt_Ptr);
6478 -- Skip this action in the following cases:
6479 -- 1) if Register_Tag is not available.
6480 -- 2) in No_Run_Time mode.
6481 -- 3) if Typ is not defined at the library level (this is required
6482 -- to avoid adding concurrency control to the hash table used
6483 -- by the run-time to register the tags).
6485 if not No_Run_Time_Mode
6486 and then Is_Library_Level_Entity (Typ)
6487 and then RTE_Available (RE_Register_Tag)
6489 Append_To (Elab_Code,
6490 Make_Procedure_Call_Statement (Loc,
6492 New_Occurrence_Of (RTE (RE_Register_Tag), Loc),
6493 Parameter_Associations =>
6494 New_List (New_Occurrence_Of (DT_Ptr, Loc))));
6497 if not Is_Empty_List (Elab_Code) then
6498 Append_List_To (Result, Elab_Code);
6501 -- Populate the two auxiliary tables used for dispatching asynchronous,
6502 -- conditional and timed selects for synchronized types that implement
6503 -- a limited interface. Skip this step in Ravenscar profile or when
6504 -- general dispatching is forbidden.
6506 if Ada_Version >= Ada_2005
6507 and then Is_Concurrent_Record_Type (Typ)
6508 and then Has_Interfaces (Typ)
6509 and then not Restriction_Active (No_Dispatching_Calls)
6510 and then not Restriction_Active (No_Select_Statements)
6512 Append_List_To (Result,
6513 Make_Select_Specific_Data_Table (Typ));
6516 -- Remember entities containing dispatch tables
6518 Append_Elmt (Predef_Prims, DT_Decl);
6519 Append_Elmt (DT, DT_Decl);
6521 Analyze_List (Result, Suppress => All_Checks);
6522 Set_Has_Dispatch_Table (Typ);
6524 -- Mark entities containing dispatch tables. Required by the backend to
6525 -- handle them properly.
6527 if Has_DT (Typ) then
6532 -- Object declarations
6534 Elmt := First_Elmt (DT_Decl);
6535 while Present (Elmt) loop
6536 Set_Is_Dispatch_Table_Entity (Node (Elmt));
6537 pragma Assert (Ekind (Etype (Node (Elmt))) = E_Array_Subtype
6538 or else Ekind (Etype (Node (Elmt))) = E_Record_Subtype);
6539 Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
6543 -- Aggregates initializing dispatch tables
6545 Elmt := First_Elmt (DT_Aggr);
6546 while Present (Elmt) loop
6547 Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
6555 -- Register the tagged type in the call graph nodes table
6557 Register_CG_Node (Typ);
6560 Restore_Ghost_Region (Saved_GM, Saved_IGR);
6565 -------------------------------------
6566 -- Make_Select_Specific_Data_Table --
6567 -------------------------------------
6569 function Make_Select_Specific_Data_Table
6570 (Typ : Entity_Id) return List_Id
6572 Assignments : constant List_Id := New_List;
6573 Loc : constant Source_Ptr := Sloc (Typ);
6575 Conc_Typ : Entity_Id;
6576 Decls : List_Id := No_List;
6578 Prim_Als : Entity_Id;
6579 Prim_Elmt : Elmt_Id;
6583 type Examined_Array is array (Int range <>) of Boolean;
6585 function Find_Entry_Index (E : Entity_Id) return Uint;
6586 -- Given an entry, find its index in the visible declarations of the
6587 -- corresponding concurrent type of Typ.
6589 ----------------------
6590 -- Find_Entry_Index --
6591 ----------------------
6593 function Find_Entry_Index (E : Entity_Id) return Uint is
6594 Index : Uint := Uint_1;
6595 Subp_Decl : Entity_Id;
6599 and then not Is_Empty_List (Decls)
6601 Subp_Decl := First (Decls);
6602 while Present (Subp_Decl) loop
6603 if Nkind (Subp_Decl) = N_Entry_Declaration then
6604 if Defining_Identifier (Subp_Decl) = E then
6616 end Find_Entry_Index;
6622 -- Start of processing for Make_Select_Specific_Data_Table
6625 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
6627 if Present (Corresponding_Concurrent_Type (Typ)) then
6628 Conc_Typ := Corresponding_Concurrent_Type (Typ);
6630 if Present (Full_View (Conc_Typ)) then
6631 Conc_Typ := Full_View (Conc_Typ);
6634 if Ekind (Conc_Typ) = E_Protected_Type then
6635 Decls := Visible_Declarations (Protected_Definition (
6636 Parent (Conc_Typ)));
6638 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
6639 Decls := Visible_Declarations (Task_Definition (
6640 Parent (Conc_Typ)));
6644 -- Count the non-predefined primitive operations
6646 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6647 while Present (Prim_Elmt) loop
6648 Prim := Node (Prim_Elmt);
6650 if not (Is_Predefined_Dispatching_Operation (Prim)
6651 or else Is_Predefined_Dispatching_Alias (Prim))
6653 Nb_Prim := Nb_Prim + 1;
6656 Next_Elmt (Prim_Elmt);
6660 Examined : Examined_Array (1 .. Nb_Prim) := (others => False);
6663 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6664 while Present (Prim_Elmt) loop
6665 Prim := Node (Prim_Elmt);
6667 -- Look for primitive overriding an abstract interface subprogram
6669 if Present (Interface_Alias (Prim))
6672 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
6673 Use_Full_View => True)
6674 and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
6676 Prim_Pos := DT_Position (Alias (Prim));
6677 pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
6678 Examined (UI_To_Int (Prim_Pos)) := True;
6680 -- Set the primitive operation kind regardless of subprogram
6682 -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
6684 if Tagged_Type_Expansion then
6687 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
6691 Make_Attribute_Reference (Loc,
6692 Prefix => New_Occurrence_Of (Typ, Loc),
6693 Attribute_Name => Name_Tag);
6696 Append_To (Assignments,
6697 Make_Procedure_Call_Statement (Loc,
6698 Name => New_Occurrence_Of (RTE (RE_Set_Prim_Op_Kind), Loc),
6699 Parameter_Associations => New_List (
6701 Make_Integer_Literal (Loc, Prim_Pos),
6702 Prim_Op_Kind (Alias (Prim), Typ))));
6704 -- Retrieve the root of the alias chain
6706 Prim_Als := Ultimate_Alias (Prim);
6708 -- In the case of an entry wrapper, set the entry index
6710 if Ekind (Prim) = E_Procedure
6711 and then Is_Primitive_Wrapper (Prim_Als)
6712 and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry
6715 -- Ada.Tags.Set_Entry_Index
6716 -- (DT_Ptr, <position>, <index>);
6718 if Tagged_Type_Expansion then
6721 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
6724 Make_Attribute_Reference (Loc,
6725 Prefix => New_Occurrence_Of (Typ, Loc),
6726 Attribute_Name => Name_Tag);
6729 Append_To (Assignments,
6730 Make_Procedure_Call_Statement (Loc,
6732 New_Occurrence_Of (RTE (RE_Set_Entry_Index), Loc),
6733 Parameter_Associations => New_List (
6735 Make_Integer_Literal (Loc, Prim_Pos),
6736 Make_Integer_Literal (Loc,
6737 Find_Entry_Index (Wrapped_Entity (Prim_Als))))));
6741 Next_Elmt (Prim_Elmt);
6746 end Make_Select_Specific_Data_Table;
6752 function Make_Tags (Typ : Entity_Id) return List_Id is
6753 Loc : constant Source_Ptr := Sloc (Typ);
6754 Result : constant List_Id := New_List;
6757 (Tag_Typ : Entity_Id;
6759 Is_Secondary_DT : Boolean);
6760 -- Import the dispatch table DT of tagged type Tag_Typ. Required to
6761 -- generate forward references and statically allocate the table. For
6762 -- primary dispatch tables that require no dispatch table generate:
6764 -- DT : static aliased constant Non_Dispatch_Table_Wrapper;
6765 -- pragma Import (Ada, DT);
6767 -- Otherwise generate:
6769 -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
6770 -- pragma Import (Ada, DT);
6777 (Tag_Typ : Entity_Id;
6779 Is_Secondary_DT : Boolean)
6781 DT_Constr_List : List_Id;
6785 Set_Is_Imported (DT);
6786 Set_Ekind (DT, E_Constant);
6787 Set_Related_Type (DT, Typ);
6789 -- The scope must be set now to call Get_External_Name
6791 Set_Scope (DT, Current_Scope);
6793 Get_External_Name (DT);
6794 Set_Interface_Name (DT,
6795 Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
6797 -- Ensure proper Sprint output of this implicit importation
6799 Set_Is_Internal (DT);
6801 -- Save this entity to allow Make_DT to generate its exportation
6803 Append_Elmt (DT, Dispatch_Table_Wrappers (Typ));
6805 -- No dispatch table required
6807 if not Is_Secondary_DT and then not Has_DT (Tag_Typ) then
6809 Make_Object_Declaration (Loc,
6810 Defining_Identifier => DT,
6811 Aliased_Present => True,
6812 Constant_Present => True,
6813 Object_Definition =>
6815 (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
6818 -- Calculate the number of primitives of the dispatch table and
6819 -- the size of the Type_Specific_Data record.
6822 UI_To_Int (DT_Entry_Count (First_Tag_Component (Tag_Typ)));
6824 -- If the tagged type has no primitives we add a dummy slot whose
6825 -- address will be the tag of this type.
6829 New_List (Make_Integer_Literal (Loc, 1));
6832 New_List (Make_Integer_Literal (Loc, Nb_Prim));
6836 Make_Object_Declaration (Loc,
6837 Defining_Identifier => DT,
6838 Aliased_Present => True,
6839 Constant_Present => True,
6840 Object_Definition =>
6841 Make_Subtype_Indication (Loc,
6843 New_Occurrence_Of (RTE (RE_Dispatch_Table_Wrapper), Loc),
6844 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
6845 Constraints => DT_Constr_List))));
6851 Tname : constant Name_Id := Chars (Typ);
6852 AI_Tag_Comp : Elmt_Id;
6853 DT : Node_Id := Empty;
6855 Predef_Prims_Ptr : Node_Id;
6856 Iface_DT : Node_Id := Empty;
6857 Iface_DT_Ptr : Node_Id;
6861 Typ_Comps : Elist_Id;
6863 -- Start of processing for Make_Tags
6866 pragma Assert (No (Access_Disp_Table (Typ)));
6867 Set_Access_Disp_Table (Typ, New_Elmt_List);
6869 -- If the elaboration of this tagged type needs a boolean flag then
6870 -- define now its entity. It is initialized to True to indicate that
6871 -- elaboration is still pending; set to False by the IP routine.
6873 -- TypFxx : boolean := True;
6875 if Elab_Flag_Needed (Typ) then
6876 Set_Access_Disp_Table_Elab_Flag (Typ,
6877 Make_Defining_Identifier (Loc,
6878 Chars => New_External_Name (Tname, 'F')));
6881 Make_Object_Declaration (Loc,
6882 Defining_Identifier => Access_Disp_Table_Elab_Flag (Typ),
6883 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
6884 Expression => New_Occurrence_Of (Standard_True, Loc)));
6887 -- 1) Generate the primary tag entities
6889 -- Primary dispatch table containing user-defined primitives
6891 DT_Ptr := Make_Defining_Identifier (Loc, New_External_Name (Tname, 'P'));
6892 Set_Etype (DT_Ptr, RTE (RE_Tag));
6893 Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
6895 -- Minimum decoration
6897 Set_Ekind (DT_Ptr, E_Variable);
6898 Set_Related_Type (DT_Ptr, Typ);
6900 -- Notify back end that the types are associated with a dispatch table
6902 Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr));
6903 Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr));
6905 -- For CPP types there is no need to build the dispatch tables since
6906 -- they are imported from the C++ side. If the CPP type has an IP then
6907 -- we declare now the variable that will store the copy of the C++ tag.
6908 -- If the CPP type is an interface, we need the variable as well because
6909 -- it becomes the pointer to the corresponding secondary table.
6911 if Is_CPP_Class (Typ) then
6912 if Has_CPP_Constructors (Typ) or else Is_Interface (Typ) then
6914 Make_Object_Declaration (Loc,
6915 Defining_Identifier => DT_Ptr,
6916 Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc),
6918 Unchecked_Convert_To (RTE (RE_Tag),
6919 New_Occurrence_Of (RTE (RE_Null_Address), Loc))));
6921 Set_Is_Statically_Allocated (DT_Ptr,
6922 Is_Library_Level_Tagged_Type (Typ));
6928 -- Primary dispatch table containing predefined primitives
6931 Make_Defining_Identifier (Loc,
6932 Chars => New_External_Name (Tname, 'Y'));
6933 Set_Etype (Predef_Prims_Ptr, RTE (RE_Address));
6934 Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
6936 -- Import the forward declaration of the Dispatch Table wrapper
6937 -- record (Make_DT will take care of exporting it).
6939 if Building_Static_DT (Typ) then
6940 Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List);
6943 Make_Defining_Identifier (Loc,
6944 Chars => New_External_Name (Tname, 'T'));
6946 Import_DT (Typ, DT, Is_Secondary_DT => False);
6948 if Has_DT (Typ) then
6950 Make_Object_Declaration (Loc,
6951 Defining_Identifier => DT_Ptr,
6952 Constant_Present => True,
6953 Object_Definition =>
6954 New_Occurrence_Of (RTE (RE_Tag), Loc),
6956 Unchecked_Convert_To (RTE (RE_Tag),
6957 Make_Attribute_Reference (Loc,
6959 Make_Selected_Component (Loc,
6960 Prefix => New_Occurrence_Of (DT, Loc),
6963 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
6964 Attribute_Name => Name_Address))));
6966 -- Generate the SCIL node for the previous object declaration
6967 -- because it has a tag initialization.
6969 if Generate_SCIL then
6971 Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
6972 Set_SCIL_Entity (New_Node, Typ);
6973 Set_SCIL_Node (Last (Result), New_Node);
6977 Make_Object_Declaration (Loc,
6978 Defining_Identifier => Predef_Prims_Ptr,
6979 Constant_Present => True,
6980 Object_Definition =>
6981 New_Occurrence_Of (RTE (RE_Address), Loc),
6983 Make_Attribute_Reference (Loc,
6985 Make_Selected_Component (Loc,
6986 Prefix => New_Occurrence_Of (DT, Loc),
6989 (RTE_Record_Component (RE_Predef_Prims), Loc)),
6990 Attribute_Name => Name_Address)));
6992 -- No dispatch table required
6996 Make_Object_Declaration (Loc,
6997 Defining_Identifier => DT_Ptr,
6998 Constant_Present => True,
6999 Object_Definition =>
7000 New_Occurrence_Of (RTE (RE_Tag), Loc),
7002 Unchecked_Convert_To (RTE (RE_Tag),
7003 Make_Attribute_Reference (Loc,
7005 Make_Selected_Component (Loc,
7006 Prefix => New_Occurrence_Of (DT, Loc),
7009 (RTE_Record_Component (RE_NDT_Prims_Ptr),
7011 Attribute_Name => Name_Address))));
7014 Set_Is_True_Constant (DT_Ptr);
7015 Set_Is_Statically_Allocated (DT_Ptr);
7019 -- 2) Generate the secondary tag entities
7021 -- Collect the components associated with secondary dispatch tables
7023 if Has_Interfaces (Typ) then
7024 Collect_Interface_Components (Typ, Typ_Comps);
7026 -- For each interface type we build a unique external name associated
7027 -- with its secondary dispatch table. This name is used to declare an
7028 -- object that references this secondary dispatch table, whose value
7029 -- will be used for the elaboration of Typ objects, and also for the
7030 -- elaboration of objects of types derived from Typ that do not
7031 -- override the primitives of this interface type.
7035 -- Note: The value of Suffix_Index must be in sync with the values of
7036 -- Suffix_Index in secondary dispatch tables generated by Make_DT.
7038 if Is_CPP_Class (Typ) then
7039 AI_Tag_Comp := First_Elmt (Typ_Comps);
7040 while Present (AI_Tag_Comp) loop
7041 Get_Secondary_DT_External_Name
7042 (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
7043 Typ_Name := Name_Find;
7045 -- Declare variables to store copy of the C++ secondary tags
7048 Make_Defining_Identifier (Loc,
7049 Chars => New_External_Name (Typ_Name, 'P'));
7050 Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
7051 Set_Ekind (Iface_DT_Ptr, E_Variable);
7052 Set_Is_Tag (Iface_DT_Ptr);
7054 Set_Has_Thunks (Iface_DT_Ptr);
7056 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7057 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7060 Make_Object_Declaration (Loc,
7061 Defining_Identifier => Iface_DT_Ptr,
7062 Object_Definition => New_Occurrence_Of
7063 (RTE (RE_Interface_Tag), Loc),
7065 Unchecked_Convert_To (RTE (RE_Interface_Tag),
7066 New_Occurrence_Of (RTE (RE_Null_Address), Loc))));
7068 Set_Is_Statically_Allocated (Iface_DT_Ptr,
7069 Is_Library_Level_Tagged_Type (Typ));
7071 Next_Elmt (AI_Tag_Comp);
7074 -- This is not a CPP_Class type
7077 AI_Tag_Comp := First_Elmt (Typ_Comps);
7078 while Present (AI_Tag_Comp) loop
7079 Get_Secondary_DT_External_Name
7080 (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
7081 Typ_Name := Name_Find;
7083 if Building_Static_DT (Typ) then
7085 Make_Defining_Identifier (Loc,
7086 Chars => New_External_Name (Typ_Name, 'T'));
7088 (Tag_Typ => Related_Type (Node (AI_Tag_Comp)),
7090 Is_Secondary_DT => True);
7093 -- Secondary dispatch table referencing thunks to user-defined
7094 -- primitives covered by this interface.
7097 Make_Defining_Identifier (Loc,
7098 Chars => New_External_Name (Typ_Name, 'P'));
7099 Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
7100 Set_Ekind (Iface_DT_Ptr, E_Constant);
7101 Set_Is_Tag (Iface_DT_Ptr);
7102 Set_Has_Thunks (Iface_DT_Ptr);
7103 Set_Is_Statically_Allocated (Iface_DT_Ptr,
7104 Is_Library_Level_Tagged_Type (Typ));
7105 Set_Is_True_Constant (Iface_DT_Ptr);
7107 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7108 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7110 if Building_Static_DT (Typ) then
7112 Make_Object_Declaration (Loc,
7113 Defining_Identifier => Iface_DT_Ptr,
7114 Constant_Present => True,
7115 Object_Definition => New_Occurrence_Of
7116 (RTE (RE_Interface_Tag), Loc),
7118 Unchecked_Convert_To (RTE (RE_Interface_Tag),
7119 Make_Attribute_Reference (Loc,
7121 Make_Selected_Component (Loc,
7123 New_Occurrence_Of (Iface_DT, Loc),
7126 (RTE_Record_Component (RE_Prims_Ptr),
7128 Attribute_Name => Name_Address))));
7131 -- Secondary dispatch table referencing thunks to predefined
7135 Make_Defining_Identifier (Loc,
7136 Chars => New_External_Name (Typ_Name, 'Y'));
7137 Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
7138 Set_Ekind (Iface_DT_Ptr, E_Constant);
7139 Set_Is_Tag (Iface_DT_Ptr);
7140 Set_Has_Thunks (Iface_DT_Ptr);
7141 Set_Is_Statically_Allocated (Iface_DT_Ptr,
7142 Is_Library_Level_Tagged_Type (Typ));
7143 Set_Is_True_Constant (Iface_DT_Ptr);
7145 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7146 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7148 -- Secondary dispatch table referencing user-defined primitives
7149 -- covered by this interface.
7152 Make_Defining_Identifier (Loc,
7153 Chars => New_External_Name (Typ_Name, 'D'));
7154 Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
7155 Set_Ekind (Iface_DT_Ptr, E_Constant);
7156 Set_Is_Tag (Iface_DT_Ptr);
7157 Set_Is_Statically_Allocated (Iface_DT_Ptr,
7158 Is_Library_Level_Tagged_Type (Typ));
7159 Set_Is_True_Constant (Iface_DT_Ptr);
7161 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7162 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7164 -- Secondary dispatch table referencing predefined primitives
7167 Make_Defining_Identifier (Loc,
7168 Chars => New_External_Name (Typ_Name, 'Z'));
7169 Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
7170 Set_Ekind (Iface_DT_Ptr, E_Constant);
7171 Set_Is_Tag (Iface_DT_Ptr);
7172 Set_Is_Statically_Allocated (Iface_DT_Ptr,
7173 Is_Library_Level_Tagged_Type (Typ));
7174 Set_Is_True_Constant (Iface_DT_Ptr);
7176 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7177 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7179 Next_Elmt (AI_Tag_Comp);
7184 -- 3) At the end of Access_Disp_Table, if the type has user-defined
7185 -- primitives, we add the entity of an access type declaration that
7186 -- is used by Build_Get_Prim_Op_Address to expand dispatching calls
7187 -- through the primary dispatch table.
7189 if UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))) = 0 then
7190 Analyze_List (Result);
7193 -- subtype Typ_DT is Address_Array (1 .. Nb_Prims);
7194 -- type Typ_DT_Acc is access Typ_DT;
7198 Name_DT_Prims : constant Name_Id :=
7199 New_External_Name (Tname, 'G');
7200 Name_DT_Prims_Acc : constant Name_Id :=
7201 New_External_Name (Tname, 'H');
7202 DT_Prims : constant Entity_Id :=
7203 Make_Defining_Identifier (Loc,
7205 DT_Prims_Acc : constant Entity_Id :=
7206 Make_Defining_Identifier (Loc,
7210 Make_Subtype_Declaration (Loc,
7211 Defining_Identifier => DT_Prims,
7212 Subtype_Indication =>
7213 Make_Subtype_Indication (Loc,
7215 New_Occurrence_Of (RTE (RE_Address_Array), Loc),
7217 Make_Index_Or_Discriminant_Constraint (Loc, New_List (
7219 Low_Bound => Make_Integer_Literal (Loc, 1),
7221 Make_Integer_Literal (Loc,
7223 (First_Tag_Component (Typ)))))))));
7226 Make_Full_Type_Declaration (Loc,
7227 Defining_Identifier => DT_Prims_Acc,
7229 Make_Access_To_Object_Definition (Loc,
7230 Subtype_Indication =>
7231 New_Occurrence_Of (DT_Prims, Loc))));
7233 Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
7235 -- Analyze the resulting list and suppress the generation of the
7236 -- Init_Proc associated with the above array declaration because
7237 -- this type is never used in object declarations. It is only used
7238 -- to simplify the expansion associated with dispatching calls.
7240 Analyze_List (Result);
7241 Set_Suppress_Initialization (Base_Type (DT_Prims));
7243 -- Disable backend optimizations based on assumptions about the
7244 -- aliasing status of objects designated by the access to the
7245 -- dispatch table. Required to handle dispatch tables imported
7248 Set_No_Strict_Aliasing (Base_Type (DT_Prims_Acc));
7250 -- Add the freezing nodes of these declarations; required to avoid
7251 -- generating these freezing nodes in wrong scopes (for example in
7252 -- the IC routine of a derivation of Typ).
7254 -- What is an "IC routine"? Is "init_proc" meant here???
7256 Append_List_To (Result, Freeze_Entity (DT_Prims, Typ));
7257 Append_List_To (Result, Freeze_Entity (DT_Prims_Acc, Typ));
7259 -- Mark entity of dispatch table. Required by the back end to
7260 -- handle them properly.
7262 Set_Is_Dispatch_Table_Entity (DT_Prims);
7266 -- Mark entities of dispatch table. Required by the back end to handle
7269 if Present (DT) then
7270 Set_Is_Dispatch_Table_Entity (DT);
7271 Set_Is_Dispatch_Table_Entity (Etype (DT));
7274 if Present (Iface_DT) then
7275 Set_Is_Dispatch_Table_Entity (Iface_DT);
7276 Set_Is_Dispatch_Table_Entity (Etype (Iface_DT));
7279 if Is_CPP_Class (Root_Type (Typ)) then
7280 Set_Ekind (DT_Ptr, E_Variable);
7282 Set_Ekind (DT_Ptr, E_Constant);
7285 Set_Is_Tag (DT_Ptr);
7286 Set_Related_Type (DT_Ptr, Typ);
7295 function New_Value (From : Node_Id) return Node_Id is
7296 Res : constant Node_Id := Duplicate_Subexpr (From);
7298 if Is_Access_Type (Etype (From)) then
7299 return Make_Explicit_Dereference (Sloc (From), Prefix => Res);
7305 -----------------------------------
7306 -- Original_View_In_Visible_Part --
7307 -----------------------------------
7309 function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
7310 Scop : constant Entity_Id := Scope (Typ);
7313 -- The scope must be a package
7315 if not Is_Package_Or_Generic_Package (Scop) then
7319 -- A type with a private declaration has a private view declared in
7320 -- the visible part.
7322 if Has_Private_Declaration (Typ) then
7326 return List_Containing (Parent (Typ)) =
7327 Visible_Declarations (Package_Specification (Scop));
7328 end Original_View_In_Visible_Part;
7334 function Prim_Op_Kind
7336 Typ : Entity_Id) return Node_Id
7338 Full_Typ : Entity_Id := Typ;
7339 Loc : constant Source_Ptr := Sloc (Prim);
7340 Prim_Op : Entity_Id;
7343 -- Retrieve the original primitive operation
7345 Prim_Op := Ultimate_Alias (Prim);
7347 if Ekind (Typ) = E_Record_Type
7348 and then Present (Corresponding_Concurrent_Type (Typ))
7350 Full_Typ := Corresponding_Concurrent_Type (Typ);
7353 -- When a private tagged type is completed by a concurrent type,
7354 -- retrieve the full view.
7356 if Is_Private_Type (Full_Typ) then
7357 Full_Typ := Full_View (Full_Typ);
7360 if Ekind (Prim_Op) = E_Function then
7362 -- Protected function
7364 if Ekind (Full_Typ) = E_Protected_Type then
7365 return New_Occurrence_Of (RTE (RE_POK_Protected_Function), Loc);
7369 elsif Ekind (Full_Typ) = E_Task_Type then
7370 return New_Occurrence_Of (RTE (RE_POK_Task_Function), Loc);
7375 return New_Occurrence_Of (RTE (RE_POK_Function), Loc);
7379 pragma Assert (Ekind (Prim_Op) = E_Procedure);
7381 if Ekind (Full_Typ) = E_Protected_Type then
7385 if Is_Primitive_Wrapper (Prim_Op)
7386 and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
7388 return New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc);
7390 -- Protected procedure
7394 New_Occurrence_Of (RTE (RE_POK_Protected_Procedure), Loc);
7397 elsif Ekind (Full_Typ) = E_Task_Type then
7401 if Is_Primitive_Wrapper (Prim_Op)
7402 and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
7404 return New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc);
7406 -- Task "procedure". These are the internally Expander-generated
7407 -- procedures (task body for instance).
7410 return New_Occurrence_Of (RTE (RE_POK_Task_Procedure), Loc);
7413 -- Regular procedure
7416 return New_Occurrence_Of (RTE (RE_POK_Procedure), Loc);
7421 ------------------------
7422 -- Register_Primitive --
7423 ------------------------
7425 function Register_Primitive
7427 Prim : Entity_Id) return List_Id
7430 Iface_Prim : Entity_Id;
7431 Iface_Typ : Entity_Id;
7432 Iface_DT_Ptr : Entity_Id;
7433 Iface_DT_Elmt : Elmt_Id;
7434 L : constant List_Id := New_List;
7437 Tag_Typ : Entity_Id;
7438 Thunk_Id : Entity_Id;
7439 Thunk_Code : Node_Id;
7442 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
7444 -- Do not register in the dispatch table eliminated primitives
7446 if not RTE_Available (RE_Tag)
7447 or else Is_Eliminated (Ultimate_Alias (Prim))
7448 or else Generate_SCIL
7453 if not Present (Interface_Alias (Prim)) then
7454 Tag_Typ := Scope (DTC_Entity (Prim));
7455 Pos := DT_Position (Prim);
7456 Tag := First_Tag_Component (Tag_Typ);
7458 if Is_Predefined_Dispatching_Operation (Prim)
7459 or else Is_Predefined_Dispatching_Alias (Prim)
7462 Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ))));
7465 Build_Set_Predefined_Prim_Op_Address (Loc,
7466 Tag_Node => New_Occurrence_Of (DT_Ptr, Loc),
7469 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7470 Make_Attribute_Reference (Loc,
7471 Prefix => New_Occurrence_Of (Prim, Loc),
7472 Attribute_Name => Name_Unrestricted_Access))));
7474 -- Register copy of the pointer to the 'size primitive in the TSD
7476 if Chars (Prim) = Name_uSize
7477 and then RTE_Record_Component_Available (RE_Size_Func)
7479 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
7481 Build_Set_Size_Function (Loc,
7482 Tag_Node => New_Occurrence_Of (DT_Ptr, Loc),
7483 Size_Func => Prim));
7487 pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
7489 -- Skip registration of primitives located in the C++ part of the
7490 -- dispatch table. Their slot is set by the IC routine.
7492 if not Is_CPP_Class (Root_Type (Tag_Typ))
7493 or else Pos > CPP_Num_Prims (Tag_Typ)
7495 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
7497 Build_Set_Prim_Op_Address (Loc,
7499 Tag_Node => New_Occurrence_Of (DT_Ptr, Loc),
7502 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7503 Make_Attribute_Reference (Loc,
7504 Prefix => New_Occurrence_Of (Prim, Loc),
7505 Attribute_Name => Name_Unrestricted_Access))));
7509 -- Ada 2005 (AI-251): Primitive associated with an interface type
7511 -- Generate the code of the thunk only if the interface type is not an
7512 -- immediate ancestor of Typ; otherwise the dispatch table associated
7513 -- with the interface is the primary dispatch table and we have nothing
7517 Tag_Typ := Find_Dispatching_Type (Alias (Prim));
7518 Iface_Typ := Find_Dispatching_Type (Interface_Alias (Prim));
7520 pragma Assert (Is_Interface (Iface_Typ));
7522 -- No action needed for interfaces that are ancestors of Typ because
7523 -- their primitives are located in the primary dispatch table.
7525 if Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True) then
7528 -- No action needed for primitives located in the C++ part of the
7529 -- dispatch table. Their slot is set by the IC routine.
7531 elsif Is_CPP_Class (Root_Type (Tag_Typ))
7532 and then DT_Position (Alias (Prim)) <= CPP_Num_Prims (Tag_Typ)
7533 and then not Is_Predefined_Dispatching_Operation (Prim)
7534 and then not Is_Predefined_Dispatching_Alias (Prim)
7539 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code, Iface_Typ);
7541 if not Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True)
7542 and then Present (Thunk_Code)
7544 -- Generate the code necessary to fill the appropriate entry of
7545 -- the secondary dispatch table of Prim's controlling type with
7546 -- Thunk_Id's address.
7548 Iface_DT_Elmt := Find_Interface_ADT (Tag_Typ, Iface_Typ);
7549 Iface_DT_Ptr := Node (Iface_DT_Elmt);
7550 pragma Assert (Has_Thunks (Iface_DT_Ptr));
7552 Iface_Prim := Interface_Alias (Prim);
7553 Pos := DT_Position (Iface_Prim);
7554 Tag := First_Tag_Component (Iface_Typ);
7556 Prepend_To (L, Thunk_Code);
7558 if Is_Predefined_Dispatching_Operation (Prim)
7559 or else Is_Predefined_Dispatching_Alias (Prim)
7562 Build_Set_Predefined_Prim_Op_Address (Loc,
7564 New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
7567 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7568 Make_Attribute_Reference (Loc,
7569 Prefix => New_Occurrence_Of (Thunk_Id, Loc),
7570 Attribute_Name => Name_Unrestricted_Access))));
7572 Next_Elmt (Iface_DT_Elmt);
7573 Next_Elmt (Iface_DT_Elmt);
7574 Iface_DT_Ptr := Node (Iface_DT_Elmt);
7575 pragma Assert (not Has_Thunks (Iface_DT_Ptr));
7578 Build_Set_Predefined_Prim_Op_Address (Loc,
7580 New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
7583 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7584 Make_Attribute_Reference (Loc,
7586 New_Occurrence_Of (Alias (Prim), Loc),
7587 Attribute_Name => Name_Unrestricted_Access))));
7590 pragma Assert (Pos /= Uint_0
7591 and then Pos <= DT_Entry_Count (Tag));
7594 Build_Set_Prim_Op_Address (Loc,
7596 Tag_Node => New_Occurrence_Of (Iface_DT_Ptr, Loc),
7599 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7600 Make_Attribute_Reference (Loc,
7601 Prefix => New_Occurrence_Of (Thunk_Id, Loc),
7602 Attribute_Name => Name_Unrestricted_Access))));
7604 Next_Elmt (Iface_DT_Elmt);
7605 Next_Elmt (Iface_DT_Elmt);
7606 Iface_DT_Ptr := Node (Iface_DT_Elmt);
7607 pragma Assert (not Has_Thunks (Iface_DT_Ptr));
7610 Build_Set_Prim_Op_Address (Loc,
7612 Tag_Node => New_Occurrence_Of (Iface_DT_Ptr, Loc),
7615 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7616 Make_Attribute_Reference (Loc,
7618 New_Occurrence_Of (Ultimate_Alias (Prim), Loc),
7619 Attribute_Name => Name_Unrestricted_Access))));
7626 end Register_Primitive;
7628 -------------------------
7629 -- Set_All_DT_Position --
7630 -------------------------
7632 procedure Set_All_DT_Position (Typ : Entity_Id) is
7634 function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean;
7635 -- Returns True if Prim is located in the dispatch table of
7636 -- predefined primitives
7638 procedure Validate_Position (Prim : Entity_Id);
7639 -- Check that position assigned to Prim is completely safe (it has not
7640 -- been assigned to a previously defined primitive operation of Typ).
7642 ------------------------
7643 -- In_Predef_Prims_DT --
7644 ------------------------
7646 function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean is
7648 -- Predefined primitives
7650 if Is_Predefined_Dispatching_Operation (Prim) then
7653 -- Renamings of predefined primitives
7655 elsif Present (Alias (Prim))
7656 and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim))
7658 if Chars (Ultimate_Alias (Prim)) /= Name_Op_Eq then
7661 -- An overriding operation that is a user-defined renaming of
7662 -- predefined equality inherits its slot from the overridden
7663 -- operation. Otherwise it is treated as a predefined op and
7664 -- occupies the same predefined slot as equality. A call to it is
7665 -- transformed into a call to its alias, which is the predefined
7666 -- equality op. A dispatching call thus uses the proper slot if
7667 -- operation is further inherited and called with class-wide
7672 not Comes_From_Source (Prim)
7673 or else No (Overridden_Operation (Prim));
7676 -- User-defined primitives
7681 end In_Predef_Prims_DT;
7683 -----------------------
7684 -- Validate_Position --
7685 -----------------------
7687 procedure Validate_Position (Prim : Entity_Id) is
7692 -- Aliased primitives are safe
7694 if Present (Alias (Prim)) then
7698 Op_Elmt := First_Elmt (Primitive_Operations (Typ));
7699 while Present (Op_Elmt) loop
7700 Op := Node (Op_Elmt);
7702 -- No need to check against itself
7707 -- Primitive operations covering abstract interfaces are
7710 elsif Present (Interface_Alias (Op)) then
7713 -- Predefined dispatching operations are completely safe. They
7714 -- are allocated at fixed positions in a separate table.
7716 elsif Is_Predefined_Dispatching_Operation (Op)
7717 or else Is_Predefined_Dispatching_Alias (Op)
7721 -- Aliased subprograms are safe
7723 elsif Present (Alias (Op)) then
7726 elsif DT_Position (Op) = DT_Position (Prim)
7727 and then not Is_Predefined_Dispatching_Operation (Op)
7728 and then not Is_Predefined_Dispatching_Operation (Prim)
7729 and then not Is_Predefined_Dispatching_Alias (Op)
7730 and then not Is_Predefined_Dispatching_Alias (Prim)
7732 -- Handle aliased subprograms
7741 if Present (Overridden_Operation (Op_1)) then
7742 Op_1 := Overridden_Operation (Op_1);
7743 elsif Present (Alias (Op_1)) then
7744 Op_1 := Alias (Op_1);
7752 if Present (Overridden_Operation (Op_2)) then
7753 Op_2 := Overridden_Operation (Op_2);
7754 elsif Present (Alias (Op_2)) then
7755 Op_2 := Alias (Op_2);
7761 if Op_1 /= Op_2 then
7762 raise Program_Error;
7767 Next_Elmt (Op_Elmt);
7769 end Validate_Position;
7773 Parent_Typ : constant Entity_Id := Etype (Typ);
7774 First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
7775 The_Tag : constant Entity_Id := First_Tag_Component (Typ);
7777 Adjusted : Boolean := False;
7778 Finalized : Boolean := False;
7784 Prim_Elmt : Elmt_Id;
7786 -- Start of processing for Set_All_DT_Position
7789 pragma Assert (Present (First_Tag_Component (Typ)));
7791 -- Set the DT_Position for each primitive operation. Perform some sanity
7792 -- checks to avoid building inconsistent dispatch tables.
7794 -- First stage: Set DTC entity of all the primitive operations. This is
7795 -- required to properly read the DT_Position attribute in latter stages.
7797 Prim_Elmt := First_Prim;
7799 while Present (Prim_Elmt) loop
7800 Prim := Node (Prim_Elmt);
7802 -- Predefined primitives have a separate dispatch table
7804 if not In_Predef_Prims_DT (Prim) then
7805 Count_Prim := Count_Prim + 1;
7808 Set_DTC_Entity_Value (Typ, Prim);
7810 -- Clear any previous value of the DT_Position attribute. In this
7811 -- way we ensure that the final position of all the primitives is
7812 -- established by the following stages of this algorithm.
7814 Set_DT_Position_Value (Prim, No_Uint);
7816 Next_Elmt (Prim_Elmt);
7820 Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean :=
7825 procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id);
7826 -- Called if Typ is declared in a nested package or a public child
7827 -- package to handle inherited primitives that were inherited by Typ
7828 -- in the visible part, but whose declaration was deferred because
7829 -- the parent operation was private and not visible at that point.
7831 procedure Set_Fixed_Prim (Pos : Nat);
7832 -- Sets to true an element of the Fixed_Prim table to indicate
7833 -- that this entry of the dispatch table of Typ is occupied.
7835 ------------------------------------------
7836 -- Handle_Inherited_Private_Subprograms --
7837 ------------------------------------------
7839 procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id) is
7842 Op_Elmt_2 : Elmt_Id;
7843 Prim_Op : Entity_Id;
7844 Parent_Subp : Entity_Id;
7847 Op_List := Primitive_Operations (Typ);
7849 Op_Elmt := First_Elmt (Op_List);
7850 while Present (Op_Elmt) loop
7851 Prim_Op := Node (Op_Elmt);
7853 -- Search primitives that are implicit operations with an
7854 -- internal name whose parent operation has a normal name.
7856 if Present (Alias (Prim_Op))
7857 and then Find_Dispatching_Type (Alias (Prim_Op)) /= Typ
7858 and then not Comes_From_Source (Prim_Op)
7859 and then Is_Internal_Name (Chars (Prim_Op))
7860 and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
7862 Parent_Subp := Alias (Prim_Op);
7864 -- Check if the type has an explicit overriding for this
7867 Op_Elmt_2 := Next_Elmt (Op_Elmt);
7868 while Present (Op_Elmt_2) loop
7869 if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
7870 and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
7872 Set_DT_Position_Value (Prim_Op,
7873 DT_Position (Parent_Subp));
7874 Set_DT_Position_Value (Node (Op_Elmt_2),
7875 DT_Position (Parent_Subp));
7876 Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op)));
7878 goto Next_Primitive;
7881 Next_Elmt (Op_Elmt_2);
7886 Next_Elmt (Op_Elmt);
7888 end Handle_Inherited_Private_Subprograms;
7890 --------------------
7891 -- Set_Fixed_Prim --
7892 --------------------
7894 procedure Set_Fixed_Prim (Pos : Nat) is
7896 pragma Assert (Pos <= Count_Prim);
7897 Fixed_Prim (Pos) := True;
7899 when Constraint_Error =>
7900 raise Program_Error;
7904 -- In case of nested packages and public child package it may be
7905 -- necessary a special management on inherited subprograms so that
7906 -- the dispatch table is properly filled.
7908 if Ekind (Scope (Scope (Typ))) = E_Package
7909 and then Scope (Scope (Typ)) /= Standard_Standard
7910 and then ((Is_Derived_Type (Typ) and then not Is_Private_Type (Typ))
7912 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration
7913 and then Is_Generic_Type (Typ)))
7914 and then In_Open_Scopes (Scope (Etype (Typ)))
7915 and then Is_Base_Type (Typ)
7917 Handle_Inherited_Private_Subprograms (Typ);
7920 -- Second stage: Register fixed entries
7923 Prim_Elmt := First_Prim;
7924 while Present (Prim_Elmt) loop
7925 Prim := Node (Prim_Elmt);
7927 -- Predefined primitives have a separate table and all its
7928 -- entries are at predefined fixed positions.
7930 if In_Predef_Prims_DT (Prim) then
7931 if Is_Predefined_Dispatching_Operation (Prim) then
7932 Set_DT_Position_Value (Prim,
7933 Default_Prim_Op_Position (Prim));
7935 else pragma Assert (Present (Alias (Prim)));
7936 Set_DT_Position_Value (Prim,
7937 Default_Prim_Op_Position (Ultimate_Alias (Prim)));
7940 -- Overriding primitives of ancestor abstract interfaces
7942 elsif Present (Interface_Alias (Prim))
7943 and then Is_Ancestor
7944 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
7945 Use_Full_View => True)
7947 pragma Assert (DT_Position (Prim) = No_Uint
7948 and then Present (DTC_Entity (Interface_Alias (Prim))));
7950 E := Interface_Alias (Prim);
7951 Set_DT_Position_Value (Prim, DT_Position (E));
7954 (DT_Position (Alias (Prim)) = No_Uint
7955 or else DT_Position (Alias (Prim)) = DT_Position (E));
7956 Set_DT_Position_Value (Alias (Prim), DT_Position (E));
7957 Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
7959 -- Overriding primitives must use the same entry as the overridden
7960 -- primitive. Note that the Alias of the operation is set when the
7961 -- operation is declared by a renaming, in which case it is not
7962 -- overriding. If it renames another primitive it will use the
7963 -- same dispatch table slot, but if it renames an operation in a
7964 -- nested package it's a new primitive and will have its own slot.
7966 elsif not Present (Interface_Alias (Prim))
7967 and then Present (Alias (Prim))
7968 and then Chars (Prim) = Chars (Alias (Prim))
7969 and then Nkind (Unit_Declaration_Node (Prim)) /=
7970 N_Subprogram_Renaming_Declaration
7973 Par_Type : constant Entity_Id :=
7974 Find_Dispatching_Type (Alias (Prim));
7977 if Present (Par_Type)
7978 and then Par_Type /= Typ
7979 and then Is_Ancestor (Par_Type, Typ, Use_Full_View => True)
7980 and then Present (DTC_Entity (Alias (Prim)))
7983 Set_DT_Position_Value (Prim, DT_Position (E));
7985 if not Is_Predefined_Dispatching_Alias (E) then
7986 Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
7992 Next_Elmt (Prim_Elmt);
7995 -- Third stage: Fix the position of all the new primitives. Entries
7996 -- associated with primitives covering interfaces are handled in a
7999 Prim_Elmt := First_Prim;
8000 while Present (Prim_Elmt) loop
8001 Prim := Node (Prim_Elmt);
8003 -- Skip primitives previously set entries
8005 if DT_Position (Prim) /= No_Uint then
8008 -- Primitives covering interface primitives are handled later
8010 elsif Present (Interface_Alias (Prim)) then
8014 -- Take the next available position in the DT
8017 Nb_Prim := Nb_Prim + 1;
8018 pragma Assert (Nb_Prim <= Count_Prim);
8019 exit when not Fixed_Prim (Nb_Prim);
8022 Set_DT_Position_Value (Prim, UI_From_Int (Nb_Prim));
8023 Set_Fixed_Prim (Nb_Prim);
8026 Next_Elmt (Prim_Elmt);
8030 -- Fourth stage: Complete the decoration of primitives covering
8031 -- interfaces (that is, propagate the DT_Position attribute from
8032 -- the aliased primitive)
8034 Prim_Elmt := First_Prim;
8035 while Present (Prim_Elmt) loop
8036 Prim := Node (Prim_Elmt);
8038 if DT_Position (Prim) = No_Uint
8039 and then Present (Interface_Alias (Prim))
8041 pragma Assert (Present (Alias (Prim))
8042 and then Find_Dispatching_Type (Alias (Prim)) = Typ);
8044 -- Check if this entry will be placed in the primary DT
8047 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
8048 Use_Full_View => True)
8050 pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
8051 Set_DT_Position_Value (Prim, DT_Position (Alias (Prim)));
8053 -- Otherwise it will be placed in the secondary DT
8057 (DT_Position (Interface_Alias (Prim)) /= No_Uint);
8058 Set_DT_Position_Value (Prim,
8059 DT_Position (Interface_Alias (Prim)));
8063 Next_Elmt (Prim_Elmt);
8066 -- Generate listing showing the contents of the dispatch tables. This
8067 -- action is done before some further static checks because in case of
8068 -- critical errors caused by a wrong dispatch table we need to see the
8069 -- contents of such table.
8071 if Debug_Flag_ZZ then
8075 -- Final stage: Ensure that the table is correct plus some further
8076 -- verifications concerning the primitives.
8078 Prim_Elmt := First_Prim;
8080 while Present (Prim_Elmt) loop
8081 Prim := Node (Prim_Elmt);
8083 -- At this point all the primitives MUST have a position in the
8086 if DT_Position (Prim) = No_Uint then
8087 raise Program_Error;
8090 -- Calculate real size of the dispatch table
8092 if not In_Predef_Prims_DT (Prim)
8093 and then UI_To_Int (DT_Position (Prim)) > DT_Length
8095 DT_Length := UI_To_Int (DT_Position (Prim));
8098 -- Ensure that the assigned position to non-predefined dispatching
8099 -- operations in the dispatch table is correct.
8101 if not Is_Predefined_Dispatching_Operation (Prim)
8102 and then not Is_Predefined_Dispatching_Alias (Prim)
8104 Validate_Position (Prim);
8107 if Chars (Prim) = Name_Finalize then
8111 if Chars (Prim) = Name_Adjust then
8115 -- An abstract operation cannot be declared in the private part for a
8116 -- visible abstract type, because it can't be overridden outside this
8117 -- package hierarchy. For explicit declarations this is checked at
8118 -- the point of declaration, but for inherited operations it must be
8119 -- done when building the dispatch table.
8121 -- Ada 2005 (AI-251): Primitives associated with interfaces are
8122 -- excluded from this check because interfaces must be visible in
8123 -- the public and private part (RM 7.3 (7.3/2))
8125 -- We disable this check in Relaxed_RM_Semantics mode, to accommodate
8128 if not Relaxed_RM_Semantics
8129 and then Is_Abstract_Type (Typ)
8130 and then Is_Abstract_Subprogram (Prim)
8131 and then Present (Alias (Prim))
8132 and then not Is_Interface
8133 (Find_Dispatching_Type (Ultimate_Alias (Prim)))
8134 and then not Present (Interface_Alias (Prim))
8135 and then Is_Derived_Type (Typ)
8136 and then In_Private_Part (Current_Scope)
8138 List_Containing (Parent (Prim)) =
8139 Private_Declarations (Package_Specification (Current_Scope))
8140 and then Original_View_In_Visible_Part (Typ)
8142 -- We exclude Input and Output stream operations because
8143 -- Limited_Controlled inherits useless Input and Output stream
8144 -- operations from Root_Controlled, which can never be overridden.
8146 if not Is_TSS (Prim, TSS_Stream_Input)
8148 not Is_TSS (Prim, TSS_Stream_Output)
8151 ("abstract inherited private operation&" &
8152 " must be overridden (RM 3.9.3(10))",
8153 Parent (Typ), Prim);
8157 Next_Elmt (Prim_Elmt);
8162 if Is_Controlled (Typ) then
8163 if not Finalized then
8165 ("controlled type has no explicit Finalize method??", Typ);
8167 elsif not Adjusted then
8169 ("controlled type has no explicit Adjust method??", Typ);
8173 -- Set the final size of the Dispatch Table
8175 Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
8177 -- The derived type must have at least as many components as its parent
8178 -- (for root types Etype points to itself and the test cannot fail).
8180 if DT_Entry_Count (The_Tag) <
8181 DT_Entry_Count (First_Tag_Component (Parent_Typ))
8183 raise Program_Error;
8185 end Set_All_DT_Position;
8187 --------------------------
8188 -- Set_CPP_Constructors --
8189 --------------------------
8191 procedure Set_CPP_Constructors (Typ : Entity_Id) is
8193 function Gen_Parameters_Profile (E : Entity_Id) return List_Id;
8194 -- Duplicate the parameters profile of the imported C++ constructor
8195 -- adding the "this" pointer to the object as the additional first
8196 -- parameter under the usual form _Init : in out Typ.
8198 ----------------------------
8199 -- Gen_Parameters_Profile --
8200 ----------------------------
8202 function Gen_Parameters_Profile (E : Entity_Id) return List_Id is
8203 Loc : constant Source_Ptr := Sloc (E);
8210 Make_Parameter_Specification (Loc,
8211 Defining_Identifier =>
8212 Make_Defining_Identifier (Loc, Name_uInit),
8214 Out_Present => True,
8215 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
8217 if Present (Parameter_Specifications (Parent (E))) then
8218 P := First (Parameter_Specifications (Parent (E)));
8219 while Present (P) loop
8221 Make_Parameter_Specification (Loc,
8222 Defining_Identifier =>
8223 Make_Defining_Identifier (Loc,
8224 Chars => Chars (Defining_Identifier (P))),
8225 Parameter_Type => New_Copy_Tree (Parameter_Type (P)),
8226 Expression => New_Copy_Tree (Expression (P))));
8232 end Gen_Parameters_Profile;
8238 Found : Boolean := False;
8244 Covers_Default_Constructor : Entity_Id := Empty;
8246 -- Start of processing for Set_CPP_Constructor
8249 pragma Assert (Is_CPP_Class (Typ));
8251 -- Look for the constructor entities
8253 E := Next_Entity (Typ);
8254 while Present (E) loop
8255 if Ekind (E) = E_Function
8256 and then Is_Constructor (E)
8260 Parms := Gen_Parameters_Profile (E);
8261 IP := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
8263 -- Case 1: Constructor of untagged type
8265 -- If the C++ class has no virtual methods then the matching Ada
8266 -- type is an untagged record type. In such case there is no need
8267 -- to generate a wrapper of the C++ constructor because the _tag
8268 -- component is not available.
8270 if not Is_Tagged_Type (Typ) then
8272 (Make_Subprogram_Declaration (Loc,
8274 Make_Procedure_Specification (Loc,
8275 Defining_Unit_Name => IP,
8276 Parameter_Specifications => Parms)));
8278 Set_Init_Proc (Typ, IP);
8279 Set_Is_Imported (IP);
8280 Set_Is_Constructor (IP);
8281 Set_Interface_Name (IP, Interface_Name (E));
8282 Set_Convention (IP, Convention_CPP);
8284 Set_Has_Completion (IP);
8286 -- Case 2: Constructor of a tagged type
8288 -- In this case we generate the IP routine as a wrapper of the
8289 -- C++ constructor because IP must also save a copy of the _tag
8290 -- generated in the C++ side. The copy of the _tag is used by
8291 -- Build_CPP_Init_Procedure to elaborate derivations of C++ types.
8294 -- procedure IP (_init : in out Typ; ...) is
8295 -- procedure ConstructorP (_init : in out Typ; ...);
8296 -- pragma Import (ConstructorP);
8298 -- ConstructorP (_init, ...);
8299 -- if Typ._tag = null then
8300 -- Typ._tag := _init._tag;
8306 Body_Stmts : constant List_Id := New_List;
8307 Constructor_Id : Entity_Id;
8308 Constructor_Decl_Node : Node_Id;
8309 Init_Tags_List : List_Id;
8312 Constructor_Id := Make_Temporary (Loc, 'P');
8314 Constructor_Decl_Node :=
8315 Make_Subprogram_Declaration (Loc,
8316 Make_Procedure_Specification (Loc,
8317 Defining_Unit_Name => Constructor_Id,
8318 Parameter_Specifications => Parms));
8320 Set_Is_Imported (Constructor_Id);
8321 Set_Is_Constructor (Constructor_Id);
8322 Set_Interface_Name (Constructor_Id, Interface_Name (E));
8323 Set_Convention (Constructor_Id, Convention_CPP);
8324 Set_Is_Public (Constructor_Id);
8325 Set_Has_Completion (Constructor_Id);
8327 -- Build the init procedure as a wrapper of this constructor
8329 Parms := Gen_Parameters_Profile (E);
8331 -- Invoke the C++ constructor
8334 Actuals : constant List_Id := New_List;
8338 while Present (P) loop
8340 New_Occurrence_Of (Defining_Identifier (P), Loc));
8344 Append_To (Body_Stmts,
8345 Make_Procedure_Call_Statement (Loc,
8346 Name => New_Occurrence_Of (Constructor_Id, Loc),
8347 Parameter_Associations => Actuals));
8350 -- Initialize copies of C++ primary and secondary tags
8352 Init_Tags_List := New_List;
8359 Tag_Elmt := First_Elmt (Access_Disp_Table (Typ));
8360 Tag_Comp := First_Tag_Component (Typ);
8362 while Present (Tag_Elmt)
8363 and then Is_Tag (Node (Tag_Elmt))
8365 -- Skip the following assertion with primary tags
8366 -- because Related_Type is not set on primary tag
8370 (Tag_Comp = First_Tag_Component (Typ)
8371 or else Related_Type (Node (Tag_Elmt))
8372 = Related_Type (Tag_Comp));
8374 Append_To (Init_Tags_List,
8375 Make_Assignment_Statement (Loc,
8377 New_Occurrence_Of (Node (Tag_Elmt), Loc),
8379 Make_Selected_Component (Loc,
8381 Make_Identifier (Loc, Name_uInit),
8383 New_Occurrence_Of (Tag_Comp, Loc))));
8385 Tag_Comp := Next_Tag_Component (Tag_Comp);
8386 Next_Elmt (Tag_Elmt);
8390 Append_To (Body_Stmts,
8391 Make_If_Statement (Loc,
8396 (Node (First_Elmt (Access_Disp_Table (Typ))),
8399 Unchecked_Convert_To (RTE (RE_Tag),
8400 New_Occurrence_Of (RTE (RE_Null_Address), Loc))),
8401 Then_Statements => Init_Tags_List));
8404 Make_Subprogram_Body (Loc,
8406 Make_Procedure_Specification (Loc,
8407 Defining_Unit_Name => IP,
8408 Parameter_Specifications => Parms),
8409 Declarations => New_List (Constructor_Decl_Node),
8410 Handled_Statement_Sequence =>
8411 Make_Handled_Sequence_Of_Statements (Loc,
8412 Statements => Body_Stmts,
8413 Exception_Handlers => No_List));
8415 Discard_Node (IP_Body);
8416 Set_Init_Proc (Typ, IP);
8420 -- If this constructor has parameters and all its parameters have
8421 -- defaults then it covers the default constructor. The semantic
8422 -- analyzer ensures that only one constructor with defaults covers
8423 -- the default constructor.
8425 if Present (Parameter_Specifications (Parent (E)))
8426 and then Needs_No_Actuals (E)
8428 Covers_Default_Constructor := IP;
8435 -- If there are no constructors, mark the type as abstract since we
8436 -- won't be able to declare objects of that type.
8439 Set_Is_Abstract_Type (Typ);
8442 -- Handle constructor that has all its parameters with defaults and
8443 -- hence it covers the default constructor. We generate a wrapper IP
8444 -- which calls the covering constructor.
8446 if Present (Covers_Default_Constructor) then
8448 Body_Stmts : List_Id;
8451 Loc := Sloc (Covers_Default_Constructor);
8453 Body_Stmts := New_List (
8454 Make_Procedure_Call_Statement (Loc,
8456 New_Occurrence_Of (Covers_Default_Constructor, Loc),
8457 Parameter_Associations => New_List (
8458 Make_Identifier (Loc, Name_uInit))));
8460 IP := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
8463 Make_Subprogram_Body (Loc,
8465 Make_Procedure_Specification (Loc,
8466 Defining_Unit_Name => IP,
8467 Parameter_Specifications => New_List (
8468 Make_Parameter_Specification (Loc,
8469 Defining_Identifier =>
8470 Make_Defining_Identifier (Loc, Name_uInit),
8471 Parameter_Type => New_Occurrence_Of (Typ, Loc)))),
8473 Declarations => No_List,
8475 Handled_Statement_Sequence =>
8476 Make_Handled_Sequence_Of_Statements (Loc,
8477 Statements => Body_Stmts,
8478 Exception_Handlers => No_List));
8480 Discard_Node (IP_Body);
8481 Set_Init_Proc (Typ, IP);
8485 -- If the CPP type has constructors then it must import also the default
8486 -- C++ constructor. It is required for default initialization of objects
8487 -- of the type. It is also required to elaborate objects of Ada types
8488 -- that are defined as derivations of this CPP type.
8490 if Has_CPP_Constructors (Typ)
8491 and then No (Init_Proc (Typ))
8493 Error_Msg_N ("??default constructor must be imported from C++", Typ);
8495 end Set_CPP_Constructors;
8497 ---------------------------
8498 -- Set_DT_Position_Value --
8499 ---------------------------
8501 procedure Set_DT_Position_Value (Prim : Entity_Id; Value : Uint) is
8503 Set_DT_Position (Prim, Value);
8505 -- Propagate the value to the wrapped subprogram (if one is present)
8507 if Ekind_In (Prim, E_Function, E_Procedure)
8508 and then Is_Primitive_Wrapper (Prim)
8509 and then Present (Wrapped_Entity (Prim))
8510 and then Is_Dispatching_Operation (Wrapped_Entity (Prim))
8512 Set_DT_Position (Wrapped_Entity (Prim), Value);
8514 end Set_DT_Position_Value;
8516 --------------------------
8517 -- Set_DTC_Entity_Value --
8518 --------------------------
8520 procedure Set_DTC_Entity_Value
8521 (Tagged_Type : Entity_Id;
8525 if Present (Interface_Alias (Prim))
8526 and then Is_Interface
8527 (Find_Dispatching_Type (Interface_Alias (Prim)))
8529 Set_DTC_Entity (Prim,
8532 Iface => Find_Dispatching_Type (Interface_Alias (Prim))));
8534 Set_DTC_Entity (Prim,
8535 First_Tag_Component (Tagged_Type));
8538 -- Propagate the value to the wrapped subprogram (if one is present)
8540 if Ekind_In (Prim, E_Function, E_Procedure)
8541 and then Is_Primitive_Wrapper (Prim)
8542 and then Present (Wrapped_Entity (Prim))
8543 and then Is_Dispatching_Operation (Wrapped_Entity (Prim))
8545 Set_DTC_Entity (Wrapped_Entity (Prim), DTC_Entity (Prim));
8547 end Set_DTC_Entity_Value;
8553 function Tagged_Kind (T : Entity_Id) return Node_Id is
8554 Conc_Typ : Entity_Id;
8555 Loc : constant Source_Ptr := Sloc (T);
8559 (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind));
8563 if Is_Abstract_Type (T) then
8564 if Is_Limited_Record (T) then
8565 return New_Occurrence_Of
8566 (RTE (RE_TK_Abstract_Limited_Tagged), Loc);
8568 return New_Occurrence_Of
8569 (RTE (RE_TK_Abstract_Tagged), Loc);
8574 elsif Is_Concurrent_Record_Type (T) then
8575 Conc_Typ := Corresponding_Concurrent_Type (T);
8577 if Present (Full_View (Conc_Typ)) then
8578 Conc_Typ := Full_View (Conc_Typ);
8581 if Ekind (Conc_Typ) = E_Protected_Type then
8582 return New_Occurrence_Of (RTE (RE_TK_Protected), Loc);
8584 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
8585 return New_Occurrence_Of (RTE (RE_TK_Task), Loc);
8588 -- Regular tagged kinds
8591 if Is_Limited_Record (T) then
8592 return New_Occurrence_Of (RTE (RE_TK_Limited_Tagged), Loc);
8594 return New_Occurrence_Of (RTE (RE_TK_Tagged), Loc);
8603 procedure Write_DT (Typ : Entity_Id) is
8608 -- Protect this procedure against wrong usage. Required because it will
8609 -- be used directly from GDB
8611 if not (Typ <= Last_Node_Id)
8612 or else not Is_Tagged_Type (Typ)
8614 Write_Str ("wrong usage: Write_DT must be used with tagged types");
8619 Write_Int (Int (Typ));
8621 Write_Name (Chars (Typ));
8623 if Is_Interface (Typ) then
8624 Write_Str (" is interface");
8629 Elmt := First_Elmt (Primitive_Operations (Typ));
8630 while Present (Elmt) loop
8631 Prim := Node (Elmt);
8634 -- Indicate if this primitive will be allocated in the primary
8635 -- dispatch table or in a secondary dispatch table associated
8636 -- with an abstract interface type
8638 if Present (DTC_Entity (Prim)) then
8639 if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
8646 -- Output the node of this primitive operation and its name
8648 Write_Int (Int (Prim));
8651 if Is_Predefined_Dispatching_Operation (Prim) then
8652 Write_Str ("(predefined) ");
8655 -- Prefix the name of the primitive with its corresponding tagged
8656 -- type to facilitate seeing inherited primitives.
8658 if Present (Alias (Prim)) then
8660 (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim))));
8662 Write_Name (Chars (Typ));
8666 Write_Name (Chars (Prim));
8668 -- Indicate if this primitive has an aliased primitive
8670 if Present (Alias (Prim)) then
8671 Write_Str (" (alias = ");
8672 Write_Int (Int (Alias (Prim)));
8674 -- If the DTC_Entity attribute is already set we can also output
8675 -- the name of the interface covered by this primitive (if any).
8677 if Ekind_In (Alias (Prim), E_Function, E_Procedure)
8678 and then Present (DTC_Entity (Alias (Prim)))
8679 and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
8681 Write_Str (" from interface ");
8682 Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
8685 if Present (Interface_Alias (Prim)) then
8686 Write_Str (", AI_Alias of ");
8688 if Is_Null_Interface_Primitive (Interface_Alias (Prim)) then
8689 Write_Str ("null primitive ");
8693 (Chars (Find_Dispatching_Type (Interface_Alias (Prim))));
8695 Write_Int (Int (Interface_Alias (Prim)));
8701 -- Display the final position of this primitive in its associated
8702 -- (primary or secondary) dispatch table.
8704 if Present (DTC_Entity (Prim))
8705 and then DT_Position (Prim) /= No_Uint
8707 Write_Str (" at #");
8708 Write_Int (UI_To_Int (DT_Position (Prim)));
8711 if Is_Abstract_Subprogram (Prim) then
8712 Write_Str (" is abstract;");
8714 -- Check if this is a null primitive
8716 elsif Comes_From_Source (Prim)
8717 and then Ekind (Prim) = E_Procedure
8718 and then Null_Present (Parent (Prim))
8720 Write_Str (" is null;");
8723 if Is_Eliminated (Ultimate_Alias (Prim)) then
8724 Write_Str (" (eliminated)");
8727 if Is_Imported (Prim)
8728 and then Convention (Prim) = Convention_CPP
8730 Write_Str (" (C++)");