1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, 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 Exp_Atag; use Exp_Atag;
33 with Exp_Ch6; use Exp_Ch6;
34 with Exp_CG; use Exp_CG;
35 with Exp_Dbug; use Exp_Dbug;
36 with Exp_Tss; use Exp_Tss;
37 with Exp_Util; use Exp_Util;
38 with Freeze; use Freeze;
39 with Itypes; use Itypes;
40 with Layout; use Layout;
41 with Nlists; use Nlists;
42 with Nmake; use Nmake;
43 with Namet; use Namet;
45 with Output; use Output;
46 with Restrict; use Restrict;
47 with Rident; use Rident;
48 with Rtsfind; use Rtsfind;
50 with Sem_Aux; use Sem_Aux;
51 with Sem_Ch6; use Sem_Ch6;
52 with Sem_Ch7; use Sem_Ch7;
53 with Sem_Ch8; use Sem_Ch8;
54 with Sem_Disp; use Sem_Disp;
55 with Sem_Eval; use Sem_Eval;
56 with Sem_Res; use Sem_Res;
57 with Sem_Type; use Sem_Type;
58 with Sem_Util; use Sem_Util;
59 with Sinfo; use Sinfo;
60 with Snames; use Snames;
61 with Stand; use Stand;
62 with Stringt; use Stringt;
63 with SCIL_LL; use SCIL_LL;
64 with Targparm; use Targparm;
65 with Tbuild; use Tbuild;
66 with Uintp; use Uintp;
68 package body Exp_Disp is
70 -----------------------
71 -- Local Subprograms --
72 -----------------------
74 function Default_Prim_Op_Position (E : Entity_Id) return Uint;
75 -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
76 -- of the default primitive operations.
78 function Has_DT (Typ : Entity_Id) return Boolean;
79 pragma Inline (Has_DT);
80 -- Returns true if we generate a dispatch table for tagged type Typ
82 function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean;
83 -- Returns true if Prim is not a predefined dispatching primitive but it is
84 -- an alias of a predefined dispatching primitive (i.e. through a renaming)
86 function New_Value (From : Node_Id) return Node_Id;
87 -- From is the original Expression. New_Value is equivalent to a call
88 -- to Duplicate_Subexpr with an explicit dereference when From is an
91 function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
92 -- Check if the type has a private view or if the public view appears
93 -- in the visible part of a package spec.
97 Typ : Entity_Id) return Node_Id;
98 -- Ada 2005 (AI-345): Determine the primitive operation kind of Prim
99 -- according to its type Typ. Return a reference to an RE_Prim_Op_Kind
100 -- enumeration value.
102 function Tagged_Kind (T : Entity_Id) return Node_Id;
103 -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
104 -- to an RE_Tagged_Kind enumeration value.
106 ----------------------
107 -- Apply_Tag_Checks --
108 ----------------------
110 procedure Apply_Tag_Checks (Call_Node : Node_Id) is
111 Loc : constant Source_Ptr := Sloc (Call_Node);
112 Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node);
113 Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
114 Param_List : constant List_Id := Parameter_Associations (Call_Node);
120 Eq_Prim_Op : Entity_Id := Empty;
123 if No_Run_Time_Mode then
124 Error_Msg_CRT ("tagged types", Call_Node);
128 -- Apply_Tag_Checks is called directly from the semantics, so we need
129 -- a check to see whether expansion is active before proceeding. In
130 -- addition, there is no need to expand the call when compiling under
131 -- restriction No_Dispatching_Calls; the semantic analyzer has
132 -- previously notified the violation of this restriction.
134 if not Expander_Active
135 or else Restriction_Active (No_Dispatching_Calls)
140 -- Set subprogram. If this is an inherited operation that was
141 -- overridden, the body that is being called is its alias.
143 Subp := Entity (Name (Call_Node));
145 if Present (Alias (Subp))
146 and then Is_Inherited_Operation (Subp)
147 and then No (DTC_Entity (Subp))
149 Subp := Alias (Subp);
152 -- Definition of the class-wide type and the tagged type
154 -- If the controlling argument is itself a tag rather than a tagged
155 -- object, then use the class-wide type associated with the subprogram's
156 -- controlling type. This case can occur when a call to an inherited
157 -- primitive has an actual that originated from a default parameter
158 -- given by a tag-indeterminate call and when there is no other
159 -- controlling argument providing the tag (AI-239 requires dispatching).
160 -- This capability of dispatching directly by tag is also needed by the
161 -- implementation of AI-260 (for the generic dispatching constructors).
163 if Ctrl_Typ = RTE (RE_Tag)
164 or else (RTE_Available (RE_Interface_Tag)
165 and then Ctrl_Typ = RTE (RE_Interface_Tag))
167 CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
169 -- Class_Wide_Type is applied to the expressions used to initialize
170 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
171 -- there are cases where the controlling type is resolved to a specific
172 -- type (such as for designated types of arguments such as CW'Access).
174 elsif Is_Access_Type (Ctrl_Typ) then
175 CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ));
178 CW_Typ := Class_Wide_Type (Ctrl_Typ);
181 Typ := Root_Type (CW_Typ);
183 if Ekind (Typ) = E_Incomplete_Type then
184 Typ := Non_Limited_View (Typ);
187 if not Is_Limited_Type (Typ) then
188 Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
191 -- Dispatching call to C++ primitive
193 if Is_CPP_Class (Typ) then
196 -- Dispatching call to Ada primitive
198 elsif Present (Param_List) then
200 -- Generate the Tag checks when appropriate
202 Param := First_Actual (Call_Node);
203 while Present (Param) loop
205 -- No tag check with itself
207 if Param = Ctrl_Arg then
210 -- No tag check for parameter whose type is neither tagged nor
211 -- access to tagged (for access parameters)
213 elsif No (Find_Controlling_Arg (Param)) then
216 -- No tag check for function dispatching on result if the
217 -- Tag given by the context is this one
219 elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
222 -- "=" is the only dispatching operation allowed to get
223 -- operands with incompatible tags (it just returns false).
224 -- We use Duplicate_Subexpr_Move_Checks instead of calling
225 -- Relocate_Node because the value will be duplicated to
228 elsif Subp = Eq_Prim_Op then
231 -- No check in presence of suppress flags
233 elsif Tag_Checks_Suppressed (Etype (Param))
234 or else (Is_Access_Type (Etype (Param))
235 and then Tag_Checks_Suppressed
236 (Designated_Type (Etype (Param))))
240 -- Optimization: no tag checks if the parameters are identical
242 elsif Is_Entity_Name (Param)
243 and then Is_Entity_Name (Ctrl_Arg)
244 and then Entity (Param) = Entity (Ctrl_Arg)
248 -- Now we need to generate the Tag check
251 -- Generate code for tag equality check
252 -- Perhaps should have Checks.Apply_Tag_Equality_Check???
254 Insert_Action (Ctrl_Arg,
255 Make_Implicit_If_Statement (Call_Node,
259 Make_Selected_Component (Loc,
260 Prefix => New_Value (Ctrl_Arg),
263 (First_Tag_Component (Typ), Loc)),
266 Make_Selected_Component (Loc,
268 Unchecked_Convert_To (Typ, New_Value (Param)),
271 (First_Tag_Component (Typ), Loc))),
274 New_List (New_Constraint_Error (Loc))));
280 end Apply_Tag_Checks;
282 ------------------------
283 -- Building_Static_DT --
284 ------------------------
286 function Building_Static_DT (Typ : Entity_Id) return Boolean is
287 Root_Typ : Entity_Id := Root_Type (Typ);
290 -- Handle private types
292 if Present (Full_View (Root_Typ)) then
293 Root_Typ := Full_View (Root_Typ);
296 return Static_Dispatch_Tables
297 and then Is_Library_Level_Tagged_Type (Typ)
298 and then VM_Target = No_VM
300 -- If the type is derived from a CPP class we cannot statically
301 -- build the dispatch tables because we must inherit primitives
302 -- from the CPP side.
304 and then not Is_CPP_Class (Root_Typ);
305 end Building_Static_DT;
307 ----------------------------------
308 -- Build_Static_Dispatch_Tables --
309 ----------------------------------
311 procedure Build_Static_Dispatch_Tables (N : Entity_Id) is
312 Target_List : List_Id;
314 procedure Build_Dispatch_Tables (List : List_Id);
315 -- Build the static dispatch table of tagged types found in the list of
316 -- declarations. The generated nodes are added at the end of Target_List
318 procedure Build_Package_Dispatch_Tables (N : Node_Id);
319 -- Build static dispatch tables associated with package declaration N
321 ---------------------------
322 -- Build_Dispatch_Tables --
323 ---------------------------
325 procedure Build_Dispatch_Tables (List : List_Id) is
330 while Present (D) loop
332 -- Handle nested packages and package bodies recursively. The
333 -- generated code is placed on the Target_List established for
334 -- the enclosing compilation unit.
336 if Nkind (D) = N_Package_Declaration then
337 Build_Package_Dispatch_Tables (D);
339 elsif Nkind (D) = N_Package_Body then
340 Build_Dispatch_Tables (Declarations (D));
342 elsif Nkind (D) = N_Package_Body_Stub
343 and then Present (Library_Unit (D))
345 Build_Dispatch_Tables
346 (Declarations (Proper_Body (Unit (Library_Unit (D)))));
348 -- Handle full type declarations and derivations of library
349 -- level tagged types
351 elsif Nkind_In (D, N_Full_Type_Declaration,
352 N_Derived_Type_Definition)
353 and then Is_Library_Level_Tagged_Type (Defining_Entity (D))
354 and then Ekind (Defining_Entity (D)) /= E_Record_Subtype
355 and then not Is_Private_Type (Defining_Entity (D))
357 -- We do not generate dispatch tables for the internal types
358 -- created for a type extension with unknown discriminants
359 -- The needed information is shared with the source type,
360 -- See Expand_N_Record_Extension.
362 if Is_Underlying_Record_View (Defining_Entity (D))
364 (not Comes_From_Source (Defining_Entity (D))
366 Has_Unknown_Discriminants (Etype (Defining_Entity (D)))
368 not Comes_From_Source
369 (First_Subtype (Defining_Entity (D))))
373 Insert_List_After_And_Analyze (Last (Target_List),
374 Make_DT (Defining_Entity (D)));
377 -- Handle private types of library level tagged types. We must
378 -- exchange the private and full-view to ensure the correct
379 -- expansion. If the full view is a synchronized type ignore
380 -- the type because the table will be built for the corresponding
381 -- record type, that has its own declaration.
383 elsif (Nkind (D) = N_Private_Type_Declaration
384 or else Nkind (D) = N_Private_Extension_Declaration)
385 and then Present (Full_View (Defining_Entity (D)))
388 E1 : constant Entity_Id := Defining_Entity (D);
389 E2 : constant Entity_Id := Full_View (E1);
392 if Is_Library_Level_Tagged_Type (E2)
393 and then Ekind (E2) /= E_Record_Subtype
394 and then not Is_Concurrent_Type (E2)
396 Exchange_Declarations (E1);
397 Insert_List_After_And_Analyze (Last (Target_List),
399 Exchange_Declarations (E2);
406 end Build_Dispatch_Tables;
408 -----------------------------------
409 -- Build_Package_Dispatch_Tables --
410 -----------------------------------
412 procedure Build_Package_Dispatch_Tables (N : Node_Id) is
413 Spec : constant Node_Id := Specification (N);
414 Id : constant Entity_Id := Defining_Entity (N);
415 Vis_Decls : constant List_Id := Visible_Declarations (Spec);
416 Priv_Decls : constant List_Id := Private_Declarations (Spec);
421 if Present (Priv_Decls) then
422 Build_Dispatch_Tables (Vis_Decls);
423 Build_Dispatch_Tables (Priv_Decls);
425 elsif Present (Vis_Decls) then
426 Build_Dispatch_Tables (Vis_Decls);
430 end Build_Package_Dispatch_Tables;
432 -- Start of processing for Build_Static_Dispatch_Tables
435 if not Expander_Active
436 or else not Tagged_Type_Expansion
441 if Nkind (N) = N_Package_Declaration then
443 Spec : constant Node_Id := Specification (N);
444 Vis_Decls : constant List_Id := Visible_Declarations (Spec);
445 Priv_Decls : constant List_Id := Private_Declarations (Spec);
448 if Present (Priv_Decls)
449 and then Is_Non_Empty_List (Priv_Decls)
451 Target_List := Priv_Decls;
453 elsif not Present (Vis_Decls) then
454 Target_List := New_List;
455 Set_Private_Declarations (Spec, Target_List);
457 Target_List := Vis_Decls;
460 Build_Package_Dispatch_Tables (N);
463 else pragma Assert (Nkind (N) = N_Package_Body);
464 Target_List := Declarations (N);
465 Build_Dispatch_Tables (Target_List);
467 end Build_Static_Dispatch_Tables;
469 ------------------------------
470 -- Convert_Tag_To_Interface --
471 ------------------------------
473 function Convert_Tag_To_Interface
475 Expr : Node_Id) return Node_Id
477 Loc : constant Source_Ptr := Sloc (Expr);
478 Anon_Type : Entity_Id;
482 pragma Assert (Is_Class_Wide_Type (Typ)
483 and then Is_Interface (Typ)
485 ((Nkind (Expr) = N_Selected_Component
486 and then Is_Tag (Entity (Selector_Name (Expr))))
488 (Nkind (Expr) = N_Function_Call
489 and then RTE_Available (RE_Displace)
490 and then Entity (Name (Expr)) = RTE (RE_Displace))));
492 Anon_Type := Create_Itype (E_Anonymous_Access_Type, Expr);
493 Set_Directly_Designated_Type (Anon_Type, Typ);
494 Set_Etype (Anon_Type, Anon_Type);
495 Set_Can_Never_Be_Null (Anon_Type);
497 -- Decorate the size and alignment attributes of the anonymous access
498 -- type, as required by gigi.
500 Layout_Type (Anon_Type);
502 if Nkind (Expr) = N_Selected_Component
503 and then Is_Tag (Entity (Selector_Name (Expr)))
506 Make_Explicit_Dereference (Loc,
507 Unchecked_Convert_To (Anon_Type,
508 Make_Attribute_Reference (Loc,
510 Attribute_Name => Name_Address)));
513 Make_Explicit_Dereference (Loc,
514 Unchecked_Convert_To (Anon_Type, Expr));
518 end Convert_Tag_To_Interface;
524 function CPP_Num_Prims (Typ : Entity_Id) return Nat is
526 Tag_Comp : Entity_Id;
529 if not Is_Tagged_Type (Typ)
530 or else not Is_CPP_Class (Root_Type (Typ))
535 CPP_Typ := Enclosing_CPP_Parent (Typ);
536 Tag_Comp := First_Tag_Component (CPP_Typ);
538 -- If the number of primitives is already set in the tag component
541 if Present (Tag_Comp)
542 and then DT_Entry_Count (Tag_Comp) /= No_Uint
544 return UI_To_Int (DT_Entry_Count (Tag_Comp));
546 -- Otherwise, count the primitives of the enclosing CPP type
554 Elmt := First_Elmt (Primitive_Operations (CPP_Typ));
555 while Present (Elmt) loop
566 ------------------------------
567 -- Default_Prim_Op_Position --
568 ------------------------------
570 function Default_Prim_Op_Position (E : Entity_Id) return Uint is
571 TSS_Name : TSS_Name_Type;
574 Get_Name_String (Chars (E));
577 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
579 if Chars (E) = Name_uSize then
582 elsif Chars (E) = Name_uAlignment then
585 elsif TSS_Name = TSS_Stream_Read then
588 elsif TSS_Name = TSS_Stream_Write then
591 elsif TSS_Name = TSS_Stream_Input then
594 elsif TSS_Name = TSS_Stream_Output then
597 elsif Chars (E) = Name_Op_Eq then
600 elsif Chars (E) = Name_uAssign then
603 elsif TSS_Name = TSS_Deep_Adjust then
606 elsif TSS_Name = TSS_Deep_Finalize then
609 -- In VM targets unconditionally allow obtaining the position associated
610 -- with predefined interface primitives since in these platforms any
611 -- tagged type has these primitives.
613 elsif Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion then
614 if Chars (E) = Name_uDisp_Asynchronous_Select then
617 elsif Chars (E) = Name_uDisp_Conditional_Select then
620 elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
623 elsif Chars (E) = Name_uDisp_Get_Task_Id then
626 elsif Chars (E) = Name_uDisp_Requeue then
629 elsif Chars (E) = Name_uDisp_Timed_Select then
635 end Default_Prim_Op_Position;
637 -----------------------------
638 -- Expand_Dispatching_Call --
639 -----------------------------
641 procedure Expand_Dispatching_Call (Call_Node : Node_Id) is
642 Loc : constant Source_Ptr := Sloc (Call_Node);
643 Call_Typ : constant Entity_Id := Etype (Call_Node);
645 Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node);
646 Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
647 Param_List : constant List_Id := Parameter_Associations (Call_Node);
652 New_Call_Name : Node_Id;
653 New_Params : List_Id := No_List;
656 Subp_Ptr_Typ : Entity_Id;
657 Subp_Typ : Entity_Id;
659 Eq_Prim_Op : Entity_Id := Empty;
660 Controlling_Tag : Node_Id;
662 function New_Value (From : Node_Id) return Node_Id;
663 -- From is the original Expression. New_Value is equivalent to a call
664 -- to Duplicate_Subexpr with an explicit dereference when From is an
671 function New_Value (From : Node_Id) return Node_Id is
672 Res : constant Node_Id := Duplicate_Subexpr (From);
674 if Is_Access_Type (Etype (From)) then
676 Make_Explicit_Dereference (Sloc (From),
687 SCIL_Related_Node : Node_Id := Call_Node;
689 -- Start of processing for Expand_Dispatching_Call
692 if No_Run_Time_Mode then
693 Error_Msg_CRT ("tagged types", Call_Node);
697 -- Expand_Dispatching_Call is called directly from the semantics,
698 -- so we need a check to see whether expansion is active before
699 -- proceeding. In addition, there is no need to expand the call
700 -- if we are compiling under restriction No_Dispatching_Calls;
701 -- the semantic analyzer has previously notified the violation
702 -- of this restriction.
704 if not Expander_Active
705 or else Restriction_Active (No_Dispatching_Calls)
710 -- Set subprogram. If this is an inherited operation that was
711 -- overridden, the body that is being called is its alias.
713 Subp := Entity (Name (Call_Node));
715 if Present (Alias (Subp))
716 and then Is_Inherited_Operation (Subp)
717 and then No (DTC_Entity (Subp))
719 Subp := Alias (Subp);
722 -- Definition of the class-wide type and the tagged type
724 -- If the controlling argument is itself a tag rather than a tagged
725 -- object, then use the class-wide type associated with the subprogram's
726 -- controlling type. This case can occur when a call to an inherited
727 -- primitive has an actual that originated from a default parameter
728 -- given by a tag-indeterminate call and when there is no other
729 -- controlling argument providing the tag (AI-239 requires dispatching).
730 -- This capability of dispatching directly by tag is also needed by the
731 -- implementation of AI-260 (for the generic dispatching constructors).
733 if Ctrl_Typ = RTE (RE_Tag)
734 or else (RTE_Available (RE_Interface_Tag)
735 and then Ctrl_Typ = RTE (RE_Interface_Tag))
737 CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
739 -- Class_Wide_Type is applied to the expressions used to initialize
740 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
741 -- there are cases where the controlling type is resolved to a specific
742 -- type (such as for designated types of arguments such as CW'Access).
744 elsif Is_Access_Type (Ctrl_Typ) then
745 CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ));
748 CW_Typ := Class_Wide_Type (Ctrl_Typ);
751 Typ := Root_Type (CW_Typ);
753 if Ekind (Typ) = E_Incomplete_Type then
754 Typ := Non_Limited_View (Typ);
757 if not Is_Limited_Type (Typ) then
758 Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
761 -- Dispatching call to C++ primitive. Create a new parameter list
762 -- with no tag checks.
764 New_Params := New_List;
766 if Is_CPP_Class (Typ) then
767 Param := First_Actual (Call_Node);
768 while Present (Param) loop
769 Append_To (New_Params, Relocate_Node (Param));
773 -- Dispatching call to Ada primitive
775 elsif Present (Param_List) then
776 Apply_Tag_Checks (Call_Node);
778 Param := First_Actual (Call_Node);
779 while Present (Param) loop
780 -- Cases in which we may have generated runtime checks
783 or else Subp = Eq_Prim_Op
785 Append_To (New_Params,
786 Duplicate_Subexpr_Move_Checks (Param));
788 elsif Nkind (Parent (Param)) /= N_Parameter_Association
789 or else not Is_Accessibility_Actual (Parent (Param))
791 Append_To (New_Params, Relocate_Node (Param));
798 -- Generate the appropriate subprogram pointer type
800 if Etype (Subp) = Typ then
803 Res_Typ := Etype (Subp);
806 Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
807 Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
808 Set_Etype (Subp_Typ, Res_Typ);
809 Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
811 -- Create a new list of parameters which is a copy of the old formal
812 -- list including the creation of a new set of matching entities.
815 Old_Formal : Entity_Id := First_Formal (Subp);
816 New_Formal : Entity_Id;
817 Extra : Entity_Id := Empty;
820 if Present (Old_Formal) then
821 New_Formal := New_Copy (Old_Formal);
822 Set_First_Entity (Subp_Typ, New_Formal);
823 Param := First_Actual (Call_Node);
826 Set_Scope (New_Formal, Subp_Typ);
828 -- Change all the controlling argument types to be class-wide
829 -- to avoid a recursion in dispatching.
831 if Is_Controlling_Formal (New_Formal) then
832 Set_Etype (New_Formal, Etype (Param));
835 -- If the type of the formal is an itype, there was code here
836 -- introduced in 1998 in revision 1.46, to create a new itype
837 -- by copy. This seems useless, and in fact leads to semantic
838 -- errors when the itype is the completion of a type derived
839 -- from a private type.
842 Next_Formal (Old_Formal);
843 exit when No (Old_Formal);
845 Set_Next_Entity (New_Formal, New_Copy (Old_Formal));
846 Next_Entity (New_Formal);
850 Set_Next_Entity (New_Formal, Empty);
851 Set_Last_Entity (Subp_Typ, Extra);
854 -- Now that the explicit formals have been duplicated, any extra
855 -- formals needed by the subprogram must be created.
857 if Present (Extra) then
858 Set_Extra_Formal (Extra, Empty);
861 Create_Extra_Formals (Subp_Typ);
864 -- Complete description of pointer type, including size information, as
865 -- must be done with itypes to prevent order-of-elaboration anomalies
868 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
869 Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
870 Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ));
871 Layout_Type (Subp_Ptr_Typ);
873 -- If the controlling argument is a value of type Ada.Tag or an abstract
874 -- interface class-wide type then use it directly. Otherwise, the tag
875 -- must be extracted from the controlling object.
877 if Ctrl_Typ = RTE (RE_Tag)
878 or else (RTE_Available (RE_Interface_Tag)
879 and then Ctrl_Typ = RTE (RE_Interface_Tag))
881 Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
883 -- Extract the tag from an unchecked type conversion. Done to avoid
884 -- the expansion of additional code just to obtain the value of such
885 -- tag because the current management of interface type conversions
886 -- generates in some cases this unchecked type conversion with the
887 -- tag of the object (see Expand_Interface_Conversion).
889 elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion
891 (Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag)
893 (RTE_Available (RE_Interface_Tag)
895 Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag)))
897 Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg));
899 -- Ada 2005 (AI-251): Abstract interface class-wide type
901 elsif Is_Interface (Ctrl_Typ)
902 and then Is_Class_Wide_Type (Ctrl_Typ)
904 Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
908 Make_Selected_Component (Loc,
909 Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
910 Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc));
913 -- Handle dispatching calls to predefined primitives
915 if Is_Predefined_Dispatching_Operation (Subp)
916 or else Is_Predefined_Dispatching_Alias (Subp)
918 Build_Get_Predefined_Prim_Op_Address (Loc,
919 Tag_Node => Controlling_Tag,
920 Position => DT_Position (Subp),
921 New_Node => New_Node);
923 -- Handle dispatching calls to user-defined primitives
926 Build_Get_Prim_Op_Address (Loc,
927 Typ => Underlying_Type (Find_Dispatching_Type (Subp)),
928 Tag_Node => Controlling_Tag,
929 Position => DT_Position (Subp),
930 New_Node => New_Node);
934 Unchecked_Convert_To (Subp_Ptr_Typ, New_Node);
936 -- Generate the SCIL node for this dispatching call. Done now because
937 -- attribute SCIL_Controlling_Tag must be set after the new call name
938 -- is built to reference the nodes that will see the SCIL backend
939 -- (because Build_Get_Prim_Op_Address generates an unchecked type
940 -- conversion which relocates the controlling tag node).
942 if Generate_SCIL then
943 SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node));
944 Set_SCIL_Entity (SCIL_Node, Typ);
945 Set_SCIL_Target_Prim (SCIL_Node, Subp);
947 -- Common case: the controlling tag is the tag of an object
948 -- (for example, obj.tag)
950 if Nkind (Controlling_Tag) = N_Selected_Component then
951 Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
953 -- Handle renaming of selected component
955 elsif Nkind (Controlling_Tag) = N_Identifier
956 and then Nkind (Parent (Entity (Controlling_Tag))) =
957 N_Object_Renaming_Declaration
958 and then Nkind (Name (Parent (Entity (Controlling_Tag)))) =
961 Set_SCIL_Controlling_Tag (SCIL_Node,
962 Name (Parent (Entity (Controlling_Tag))));
964 -- If the controlling tag is an identifier, the SCIL node references
965 -- the corresponding object or parameter declaration
967 elsif Nkind (Controlling_Tag) = N_Identifier
968 and then Nkind_In (Parent (Entity (Controlling_Tag)),
969 N_Object_Declaration,
970 N_Parameter_Specification)
972 Set_SCIL_Controlling_Tag (SCIL_Node,
973 Parent (Entity (Controlling_Tag)));
975 -- If the controlling tag is a dereference, the SCIL node references
976 -- the corresponding object or parameter declaration
978 elsif Nkind (Controlling_Tag) = N_Explicit_Dereference
979 and then Nkind (Prefix (Controlling_Tag)) = N_Identifier
980 and then Nkind_In (Parent (Entity (Prefix (Controlling_Tag))),
981 N_Object_Declaration,
982 N_Parameter_Specification)
984 Set_SCIL_Controlling_Tag (SCIL_Node,
985 Parent (Entity (Prefix (Controlling_Tag))));
987 -- For a direct reference of the tag of the type the SCIL node
988 -- references the internal object declaration containing the tag
991 elsif Nkind (Controlling_Tag) = N_Attribute_Reference
992 and then Attribute_Name (Controlling_Tag) = Name_Tag
994 Set_SCIL_Controlling_Tag (SCIL_Node,
998 (Access_Disp_Table (Entity (Prefix (Controlling_Tag)))))));
1000 -- Interfaces are not supported. For now we leave the SCIL node
1001 -- decorated with the Controlling_Tag. More work needed here???
1003 elsif Is_Interface (Etype (Controlling_Tag)) then
1004 Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
1007 pragma Assert (False);
1012 if Nkind (Call_Node) = N_Function_Call then
1014 Make_Function_Call (Loc,
1015 Name => New_Call_Name,
1016 Parameter_Associations => New_Params);
1018 -- If this is a dispatching "=", we must first compare the tags so
1019 -- we generate: x.tag = y.tag and then x = y
1021 if Subp = Eq_Prim_Op then
1022 Param := First_Actual (Call_Node);
1028 Make_Selected_Component (Loc,
1029 Prefix => New_Value (Param),
1031 New_Reference_To (First_Tag_Component (Typ),
1035 Make_Selected_Component (Loc,
1037 Unchecked_Convert_To (Typ,
1038 New_Value (Next_Actual (Param))),
1041 (First_Tag_Component (Typ), Loc))),
1042 Right_Opnd => New_Call);
1044 SCIL_Related_Node := Right_Opnd (New_Call);
1049 Make_Procedure_Call_Statement (Loc,
1050 Name => New_Call_Name,
1051 Parameter_Associations => New_Params);
1054 -- Register the dispatching call in the call graph nodes table
1056 Register_CG_Node (Call_Node);
1058 Rewrite (Call_Node, New_Call);
1060 -- Associate the SCIL node of this dispatching call
1062 if Generate_SCIL then
1063 Set_SCIL_Node (SCIL_Related_Node, SCIL_Node);
1066 -- Suppress all checks during the analysis of the expanded code
1067 -- to avoid the generation of spurious warnings under ZFP run-time.
1069 Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks);
1070 end Expand_Dispatching_Call;
1072 ---------------------------------
1073 -- Expand_Interface_Conversion --
1074 ---------------------------------
1076 procedure Expand_Interface_Conversion
1078 Is_Static : Boolean := True)
1080 Loc : constant Source_Ptr := Sloc (N);
1081 Etyp : constant Entity_Id := Etype (N);
1082 Operand : constant Node_Id := Expression (N);
1083 Operand_Typ : Entity_Id := Etype (Operand);
1085 Iface_Typ : Entity_Id := Etype (N);
1086 Iface_Tag : Entity_Id;
1089 -- Ada 2005 (AI-345): Handle synchronized interface type derivations
1091 if Is_Concurrent_Type (Operand_Typ) then
1092 Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
1095 -- Handle access to class-wide interface types
1097 if Is_Access_Type (Iface_Typ) then
1098 Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ));
1101 -- Handle class-wide interface types. This conversion can appear
1102 -- explicitly in the source code. Example: I'Class (Obj)
1104 if Is_Class_Wide_Type (Iface_Typ) then
1105 Iface_Typ := Root_Type (Iface_Typ);
1108 -- If the target type is a tagged synchronized type, the dispatch table
1109 -- info is in the corresponding record type.
1111 if Is_Concurrent_Type (Iface_Typ) then
1112 Iface_Typ := Corresponding_Record_Type (Iface_Typ);
1115 -- Handle private types
1117 Iface_Typ := Underlying_Type (Iface_Typ);
1119 -- Freeze the entity associated with the target interface to have
1120 -- available the attribute Access_Disp_Table.
1122 Freeze_Before (N, Iface_Typ);
1124 pragma Assert (not Is_Static
1125 or else (not Is_Class_Wide_Type (Iface_Typ)
1126 and then Is_Interface (Iface_Typ)));
1128 if not Tagged_Type_Expansion then
1129 if VM_Target /= No_VM then
1130 if Is_Access_Type (Operand_Typ) then
1131 Operand_Typ := Designated_Type (Operand_Typ);
1134 if Is_Class_Wide_Type (Operand_Typ) then
1135 Operand_Typ := Root_Type (Operand_Typ);
1139 and then Operand_Typ /= Iface_Typ
1142 Make_Procedure_Call_Statement (Loc,
1143 Name => New_Occurrence_Of
1144 (RTE (RE_Check_Interface_Conversion), Loc),
1145 Parameter_Associations => New_List (
1146 Make_Attribute_Reference (Loc,
1147 Prefix => Duplicate_Subexpr (Expression (N)),
1148 Attribute_Name => Name_Tag),
1149 Make_Attribute_Reference (Loc,
1150 Prefix => New_Reference_To (Iface_Typ, Loc),
1151 Attribute_Name => Name_Tag))));
1154 -- Just do a conversion ???
1156 Rewrite (N, Unchecked_Convert_To (Etype (N), N));
1163 if not Is_Static then
1165 -- Give error if configurable run time and Displace not available
1167 if not RTE_Available (RE_Displace) then
1168 Error_Msg_CRT ("dynamic interface conversion", N);
1172 -- Handle conversion of access-to-class-wide interface types. Target
1173 -- can be an access to an object or an access to another class-wide
1174 -- interface (see -1- and -2- in the following example):
1176 -- type Iface1_Ref is access all Iface1'Class;
1177 -- type Iface2_Ref is access all Iface1'Class;
1179 -- Acc1 : Iface1_Ref := new ...
1180 -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1
1181 -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
1183 if Is_Access_Type (Operand_Typ) then
1185 Unchecked_Convert_To (Etype (N),
1186 Make_Function_Call (Loc,
1187 Name => New_Reference_To (RTE (RE_Displace), Loc),
1188 Parameter_Associations => New_List (
1190 Unchecked_Convert_To (RTE (RE_Address),
1191 Relocate_Node (Expression (N))),
1194 (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
1202 Make_Function_Call (Loc,
1203 Name => New_Reference_To (RTE (RE_Displace), Loc),
1204 Parameter_Associations => New_List (
1205 Make_Attribute_Reference (Loc,
1206 Prefix => Relocate_Node (Expression (N)),
1207 Attribute_Name => Name_Address),
1210 (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
1215 -- If the target is a class-wide interface we change the type of the
1216 -- data returned by IW_Convert to indicate that this is a dispatching
1220 New_Itype : Entity_Id;
1223 New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
1224 Set_Etype (New_Itype, New_Itype);
1225 Set_Directly_Designated_Type (New_Itype, Etyp);
1228 Make_Explicit_Dereference (Loc,
1230 Unchecked_Convert_To (New_Itype, Relocate_Node (N))));
1232 Freeze_Itype (New_Itype, N);
1238 Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
1239 pragma Assert (Iface_Tag /= Empty);
1241 -- Keep separate access types to interfaces because one internal
1242 -- function is used to handle the null value (see following comments)
1244 if not Is_Access_Type (Etype (N)) then
1246 -- Statically displace the pointer to the object to reference
1247 -- the component containing the secondary dispatch table.
1250 Convert_Tag_To_Interface (Class_Wide_Type (Iface_Typ),
1251 Make_Selected_Component (Loc,
1252 Prefix => Relocate_Node (Expression (N)),
1253 Selector_Name => New_Occurrence_Of (Iface_Tag, Loc))));
1256 -- Build internal function to handle the case in which the
1257 -- actual is null. If the actual is null returns null because
1258 -- no displacement is required; otherwise performs a type
1259 -- conversion that will be expanded in the code that returns
1260 -- the value of the displaced actual. That is:
1262 -- function Func (O : Address) return Iface_Typ is
1263 -- type Op_Typ is access all Operand_Typ;
1264 -- Aux : Op_Typ := To_Op_Typ (O);
1266 -- if O = Null_Address then
1269 -- return Iface_Typ!(Aux.Iface_Tag'Address);
1274 Desig_Typ : Entity_Id;
1276 New_Typ_Decl : Node_Id;
1280 Desig_Typ := Etype (Expression (N));
1282 if Is_Access_Type (Desig_Typ) then
1284 Available_View (Directly_Designated_Type (Desig_Typ));
1287 if Is_Concurrent_Type (Desig_Typ) then
1288 Desig_Typ := Base_Type (Corresponding_Record_Type (Desig_Typ));
1292 Make_Full_Type_Declaration (Loc,
1293 Defining_Identifier => Make_Temporary (Loc, 'T'),
1295 Make_Access_To_Object_Definition (Loc,
1296 All_Present => True,
1297 Null_Exclusion_Present => False,
1298 Constant_Present => False,
1299 Subtype_Indication =>
1300 New_Reference_To (Desig_Typ, Loc)));
1303 Make_Simple_Return_Statement (Loc,
1304 Unchecked_Convert_To (Etype (N),
1305 Make_Attribute_Reference (Loc,
1307 Make_Selected_Component (Loc,
1309 Unchecked_Convert_To
1310 (Defining_Identifier (New_Typ_Decl),
1311 Make_Identifier (Loc, Name_uO)),
1313 New_Occurrence_Of (Iface_Tag, Loc)),
1314 Attribute_Name => Name_Address))));
1316 -- If the type is null-excluding, no need for the null branch.
1317 -- Otherwise we need to check for it and return null.
1319 if not Can_Never_Be_Null (Etype (N)) then
1321 Make_If_Statement (Loc,
1324 Left_Opnd => Make_Identifier (Loc, Name_uO),
1325 Right_Opnd => New_Reference_To
1326 (RTE (RE_Null_Address), Loc)),
1328 Then_Statements => New_List (
1329 Make_Simple_Return_Statement (Loc,
1331 Else_Statements => Stats));
1334 Fent := Make_Temporary (Loc, 'F');
1336 Make_Subprogram_Body (Loc,
1338 Make_Function_Specification (Loc,
1339 Defining_Unit_Name => Fent,
1341 Parameter_Specifications => New_List (
1342 Make_Parameter_Specification (Loc,
1343 Defining_Identifier =>
1344 Make_Defining_Identifier (Loc, Name_uO),
1346 New_Reference_To (RTE (RE_Address), Loc))),
1348 Result_Definition =>
1349 New_Reference_To (Etype (N), Loc)),
1351 Declarations => New_List (New_Typ_Decl),
1353 Handled_Statement_Sequence =>
1354 Make_Handled_Sequence_Of_Statements (Loc, Stats));
1356 -- Place function body before the expression containing the
1357 -- conversion. We suppress all checks because the body of the
1358 -- internally generated function already takes care of the case
1359 -- in which the actual is null; therefore there is no need to
1360 -- double check that the pointer is not null when the program
1361 -- executes the alternative that performs the type conversion).
1363 Insert_Action (N, Func, Suppress => All_Checks);
1365 if Is_Access_Type (Etype (Expression (N))) then
1367 -- Generate: Func (Address!(Expression))
1370 Make_Function_Call (Loc,
1371 Name => New_Reference_To (Fent, Loc),
1372 Parameter_Associations => New_List (
1373 Unchecked_Convert_To (RTE (RE_Address),
1374 Relocate_Node (Expression (N))))));
1377 -- Generate: Func (Operand_Typ!(Expression)'Address)
1380 Make_Function_Call (Loc,
1381 Name => New_Reference_To (Fent, Loc),
1382 Parameter_Associations => New_List (
1383 Make_Attribute_Reference (Loc,
1384 Prefix => Unchecked_Convert_To (Operand_Typ,
1385 Relocate_Node (Expression (N))),
1386 Attribute_Name => Name_Address))));
1392 end Expand_Interface_Conversion;
1394 ------------------------------
1395 -- Expand_Interface_Actuals --
1396 ------------------------------
1398 procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
1400 Actual_Dup : Node_Id;
1401 Actual_Typ : Entity_Id;
1403 Conversion : Node_Id;
1405 Formal_Typ : Entity_Id;
1407 Formal_DDT : Entity_Id;
1408 Actual_DDT : Entity_Id;
1411 -- This subprogram is called directly from the semantics, so we need a
1412 -- check to see whether expansion is active before proceeding.
1414 if not Expander_Active then
1418 -- Call using access to subprogram with explicit dereference
1420 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
1421 Subp := Etype (Name (Call_Node));
1423 -- Call using selected component
1425 elsif Nkind (Name (Call_Node)) = N_Selected_Component then
1426 Subp := Entity (Selector_Name (Name (Call_Node)));
1428 -- Call using direct name
1431 Subp := Entity (Name (Call_Node));
1434 -- Ada 2005 (AI-251): Look for interface type formals to force "this"
1437 Formal := First_Formal (Subp);
1438 Actual := First_Actual (Call_Node);
1439 while Present (Formal) loop
1440 Formal_Typ := Etype (Formal);
1442 if Ekind (Formal_Typ) = E_Record_Type_With_Private then
1443 Formal_Typ := Full_View (Formal_Typ);
1446 if Is_Access_Type (Formal_Typ) then
1447 Formal_DDT := Directly_Designated_Type (Formal_Typ);
1450 Actual_Typ := Etype (Actual);
1452 if Is_Access_Type (Actual_Typ) then
1453 Actual_DDT := Directly_Designated_Type (Actual_Typ);
1456 if Is_Interface (Formal_Typ)
1457 and then Is_Class_Wide_Type (Formal_Typ)
1459 -- No need to displace the pointer if the type of the actual
1460 -- coincides with the type of the formal.
1462 if Actual_Typ = Formal_Typ then
1465 -- No need to displace the pointer if the interface type is
1466 -- a parent of the type of the actual because in this case the
1467 -- interface primitives are located in the primary dispatch table.
1469 elsif Is_Ancestor (Formal_Typ, Actual_Typ,
1470 Use_Full_View => True)
1474 -- Implicit conversion to the class-wide formal type to force
1475 -- the displacement of the pointer.
1478 -- Normally, expansion of actuals for calls to build-in-place
1479 -- functions happens as part of Expand_Actuals, but in this
1480 -- case the call will be wrapped in a conversion and soon after
1481 -- expanded further to handle the displacement for a class-wide
1482 -- interface conversion, so if this is a BIP call then we need
1483 -- to handle it now.
1485 if Ada_Version >= Ada_2005
1486 and then Is_Build_In_Place_Function_Call (Actual)
1488 Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
1491 Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
1492 Rewrite (Actual, Conversion);
1493 Analyze_And_Resolve (Actual, Formal_Typ);
1496 -- Access to class-wide interface type
1498 elsif Is_Access_Type (Formal_Typ)
1499 and then Is_Interface (Formal_DDT)
1500 and then Is_Class_Wide_Type (Formal_DDT)
1501 and then Interface_Present_In_Ancestor
1503 Iface => Etype (Formal_DDT))
1505 -- Handle attributes 'Access and 'Unchecked_Access
1507 if Nkind (Actual) = N_Attribute_Reference
1509 (Attribute_Name (Actual) = Name_Access
1510 or else Attribute_Name (Actual) = Name_Unchecked_Access)
1512 -- This case must have been handled by the analysis and
1513 -- expansion of 'Access. The only exception is when types
1514 -- match and no further expansion is required.
1516 pragma Assert (Base_Type (Etype (Prefix (Actual)))
1517 = Base_Type (Formal_DDT));
1520 -- No need to displace the pointer if the type of the actual
1521 -- coincides with the type of the formal.
1523 elsif Actual_DDT = Formal_DDT then
1526 -- No need to displace the pointer if the interface type is
1527 -- a parent of the type of the actual because in this case the
1528 -- interface primitives are located in the primary dispatch table.
1530 elsif Is_Ancestor (Formal_DDT, Actual_DDT,
1531 Use_Full_View => True)
1536 Actual_Dup := Relocate_Node (Actual);
1538 if From_With_Type (Actual_Typ) then
1540 -- If the type of the actual parameter comes from a limited
1541 -- with-clause and the non-limited view is already available
1542 -- we replace the anonymous access type by a duplicate
1543 -- declaration whose designated type is the non-limited view
1545 if Ekind (Actual_DDT) = E_Incomplete_Type
1546 and then Present (Non_Limited_View (Actual_DDT))
1548 Anon := New_Copy (Actual_Typ);
1550 if Is_Itype (Anon) then
1551 Set_Scope (Anon, Current_Scope);
1554 Set_Directly_Designated_Type (Anon,
1555 Non_Limited_View (Actual_DDT));
1556 Set_Etype (Actual_Dup, Anon);
1558 elsif Is_Class_Wide_Type (Actual_DDT)
1559 and then Ekind (Etype (Actual_DDT)) = E_Incomplete_Type
1560 and then Present (Non_Limited_View (Etype (Actual_DDT)))
1562 Anon := New_Copy (Actual_Typ);
1564 if Is_Itype (Anon) then
1565 Set_Scope (Anon, Current_Scope);
1568 Set_Directly_Designated_Type (Anon,
1569 New_Copy (Actual_DDT));
1570 Set_Class_Wide_Type (Directly_Designated_Type (Anon),
1571 New_Copy (Class_Wide_Type (Actual_DDT)));
1572 Set_Etype (Directly_Designated_Type (Anon),
1573 Non_Limited_View (Etype (Actual_DDT)));
1575 Class_Wide_Type (Directly_Designated_Type (Anon)),
1576 Non_Limited_View (Etype (Actual_DDT)));
1577 Set_Etype (Actual_Dup, Anon);
1581 Conversion := Convert_To (Formal_Typ, Actual_Dup);
1582 Rewrite (Actual, Conversion);
1583 Analyze_And_Resolve (Actual, Formal_Typ);
1587 Next_Actual (Actual);
1588 Next_Formal (Formal);
1590 end Expand_Interface_Actuals;
1592 ----------------------------
1593 -- Expand_Interface_Thunk --
1594 ----------------------------
1596 procedure Expand_Interface_Thunk
1598 Thunk_Id : out Entity_Id;
1599 Thunk_Code : out Node_Id)
1601 Loc : constant Source_Ptr := Sloc (Prim);
1602 Actuals : constant List_Id := New_List;
1603 Decl : constant List_Id := New_List;
1604 Formals : constant List_Id := New_List;
1605 Target : constant Entity_Id := Ultimate_Alias (Prim);
1607 Controlling_Typ : Entity_Id;
1613 Iface_Formal : Node_Id;
1615 Offset_To_Top : Node_Id;
1616 Target_Formal : Entity_Id;
1620 Thunk_Code := Empty;
1622 -- No thunk needed if the primitive has been eliminated
1624 if Is_Eliminated (Ultimate_Alias (Prim)) then
1627 -- In case of primitives that are functions without formals and a
1628 -- controlling result there is no need to build the thunk.
1630 elsif not Present (First_Formal (Target)) then
1631 pragma Assert (Ekind (Target) = E_Function
1632 and then Has_Controlling_Result (Target));
1636 -- Duplicate the formals of the Target primitive. In the thunk, the type
1637 -- of the controlling formal is the covered interface type (instead of
1638 -- the target tagged type). Done to avoid problems with discriminated
1639 -- tagged types because, if the controlling type has discriminants with
1640 -- default values, then the type conversions done inside the body of
1641 -- the thunk (after the displacement of the pointer to the base of the
1642 -- actual object) generate code that modify its contents.
1644 -- Note: This special management is not done for predefined primitives
1647 if not Is_Predefined_Dispatching_Operation (Prim) then
1648 Iface_Formal := First_Formal (Interface_Alias (Prim));
1651 Formal := First_Formal (Target);
1652 while Present (Formal) loop
1653 Ftyp := Etype (Formal);
1655 -- Use the interface type as the type of the controlling formal (see
1658 if not Is_Controlling_Formal (Formal)
1659 or else Is_Predefined_Dispatching_Operation (Prim)
1661 Ftyp := Etype (Formal);
1662 Expr := New_Copy_Tree (Expression (Parent (Formal)));
1664 Ftyp := Etype (Iface_Formal);
1669 Make_Parameter_Specification (Loc,
1670 Defining_Identifier =>
1671 Make_Defining_Identifier (Sloc (Formal),
1672 Chars => Chars (Formal)),
1673 In_Present => In_Present (Parent (Formal)),
1674 Out_Present => Out_Present (Parent (Formal)),
1675 Parameter_Type => New_Reference_To (Ftyp, Loc),
1676 Expression => Expr));
1678 if not Is_Predefined_Dispatching_Operation (Prim) then
1679 Next_Formal (Iface_Formal);
1682 Next_Formal (Formal);
1685 Controlling_Typ := Find_Dispatching_Type (Target);
1687 Target_Formal := First_Formal (Target);
1688 Formal := First (Formals);
1689 while Present (Formal) loop
1691 -- If the parent is a constrained discriminated type, then the
1692 -- primitive operation will have been defined on a first subtype.
1693 -- For proper matching with controlling type, use base type.
1695 if Ekind (Target_Formal) = E_In_Parameter
1696 and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
1699 Base_Type (Directly_Designated_Type (Etype (Target_Formal)));
1701 Ftyp := Base_Type (Etype (Target_Formal));
1704 -- For concurrent types, the relevant information is found in the
1705 -- Corresponding_Record_Type, rather than the type entity itself.
1707 if Is_Concurrent_Type (Ftyp) then
1708 Ftyp := Corresponding_Record_Type (Ftyp);
1711 if Ekind (Target_Formal) = E_In_Parameter
1712 and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
1713 and then Ftyp = Controlling_Typ
1716 -- type T is access all <<type of the target formal>>
1717 -- S : Storage_Offset := Storage_Offset!(Formal)
1718 -- - Offset_To_Top (address!(Formal))
1721 Make_Full_Type_Declaration (Loc,
1722 Defining_Identifier => Make_Temporary (Loc, 'T'),
1724 Make_Access_To_Object_Definition (Loc,
1725 All_Present => True,
1726 Null_Exclusion_Present => False,
1727 Constant_Present => False,
1728 Subtype_Indication =>
1729 New_Reference_To (Ftyp, Loc)));
1732 Unchecked_Convert_To (RTE (RE_Address),
1733 New_Reference_To (Defining_Identifier (Formal), Loc));
1735 if not RTE_Available (RE_Offset_To_Top) then
1737 Build_Offset_To_Top (Loc, New_Arg);
1740 Make_Function_Call (Loc,
1741 Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
1742 Parameter_Associations => New_List (New_Arg));
1746 Make_Object_Declaration (Loc,
1747 Defining_Identifier => Make_Temporary (Loc, 'S'),
1748 Constant_Present => True,
1749 Object_Definition =>
1750 New_Reference_To (RTE (RE_Storage_Offset), Loc),
1752 Make_Op_Subtract (Loc,
1754 Unchecked_Convert_To
1755 (RTE (RE_Storage_Offset),
1756 New_Reference_To (Defining_Identifier (Formal), Loc)),
1760 Append_To (Decl, Decl_2);
1761 Append_To (Decl, Decl_1);
1763 -- Reference the new actual. Generate:
1767 Unchecked_Convert_To
1768 (Defining_Identifier (Decl_2),
1769 New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1771 elsif Ftyp = Controlling_Typ then
1774 -- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
1775 -- - Offset_To_Top (Formal'Address)
1776 -- S2 : Addr_Ptr := Addr_Ptr!(S1)
1779 Make_Attribute_Reference (Loc,
1781 New_Reference_To (Defining_Identifier (Formal), Loc),
1785 if not RTE_Available (RE_Offset_To_Top) then
1787 Build_Offset_To_Top (Loc, New_Arg);
1790 Make_Function_Call (Loc,
1791 Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
1792 Parameter_Associations => New_List (New_Arg));
1796 Make_Object_Declaration (Loc,
1797 Defining_Identifier => Make_Temporary (Loc, 'S'),
1798 Constant_Present => True,
1799 Object_Definition =>
1800 New_Reference_To (RTE (RE_Storage_Offset), Loc),
1802 Make_Op_Subtract (Loc,
1804 Unchecked_Convert_To
1805 (RTE (RE_Storage_Offset),
1806 Make_Attribute_Reference (Loc,
1809 (Defining_Identifier (Formal), Loc),
1810 Attribute_Name => Name_Address)),
1815 Make_Object_Declaration (Loc,
1816 Defining_Identifier => Make_Temporary (Loc, 'S'),
1817 Constant_Present => True,
1818 Object_Definition =>
1819 New_Reference_To (RTE (RE_Addr_Ptr), Loc),
1821 Unchecked_Convert_To
1823 New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1825 Append_To (Decl, Decl_1);
1826 Append_To (Decl, Decl_2);
1828 -- Reference the new actual, generate:
1829 -- Target_Formal (S2.all)
1832 Unchecked_Convert_To (Ftyp,
1833 Make_Explicit_Dereference (Loc,
1834 New_Reference_To (Defining_Identifier (Decl_2), Loc))));
1836 -- No special management required for this actual
1840 New_Reference_To (Defining_Identifier (Formal), Loc));
1843 Next_Formal (Target_Formal);
1847 Thunk_Id := Make_Temporary (Loc, 'T');
1848 Set_Is_Thunk (Thunk_Id);
1852 if Ekind (Target) = E_Procedure then
1854 Make_Subprogram_Body (Loc,
1856 Make_Procedure_Specification (Loc,
1857 Defining_Unit_Name => Thunk_Id,
1858 Parameter_Specifications => Formals),
1859 Declarations => Decl,
1860 Handled_Statement_Sequence =>
1861 Make_Handled_Sequence_Of_Statements (Loc,
1862 Statements => New_List (
1863 Make_Procedure_Call_Statement (Loc,
1864 Name => New_Occurrence_Of (Target, Loc),
1865 Parameter_Associations => Actuals))));
1869 else pragma Assert (Ekind (Target) = E_Function);
1871 Make_Subprogram_Body (Loc,
1873 Make_Function_Specification (Loc,
1874 Defining_Unit_Name => Thunk_Id,
1875 Parameter_Specifications => Formals,
1876 Result_Definition =>
1877 New_Copy (Result_Definition (Parent (Target)))),
1878 Declarations => Decl,
1879 Handled_Statement_Sequence =>
1880 Make_Handled_Sequence_Of_Statements (Loc,
1881 Statements => New_List (
1882 Make_Simple_Return_Statement (Loc,
1883 Make_Function_Call (Loc,
1884 Name => New_Occurrence_Of (Target, Loc),
1885 Parameter_Associations => Actuals)))));
1887 end Expand_Interface_Thunk;
1889 --------------------------
1890 -- Has_CPP_Constructors --
1891 --------------------------
1893 function Has_CPP_Constructors (Typ : Entity_Id) return Boolean is
1897 -- Look for the constructor entities
1899 E := Next_Entity (Typ);
1900 while Present (E) loop
1901 if Ekind (E) = E_Function
1902 and then Is_Constructor (E)
1911 end Has_CPP_Constructors;
1917 function Has_DT (Typ : Entity_Id) return Boolean is
1919 return not Is_Interface (Typ)
1920 and then not Restriction_Active (No_Dispatching_Calls);
1923 -----------------------------------------
1924 -- Is_Predefined_Dispatching_Operation --
1925 -----------------------------------------
1927 function Is_Predefined_Dispatching_Operation
1928 (E : Entity_Id) return Boolean
1930 TSS_Name : TSS_Name_Type;
1933 if not Is_Dispatching_Operation (E) then
1937 Get_Name_String (Chars (E));
1939 -- Most predefined primitives have internally generated names. Equality
1940 -- must be treated differently; the predefined operation is recognized
1941 -- as a homogeneous binary operator that returns Boolean.
1943 if Name_Len > TSS_Name_Type'Last then
1944 TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
1946 if Chars (E) = Name_uSize
1947 or else Chars (E) = Name_uAlignment
1948 or else TSS_Name = TSS_Stream_Read
1949 or else TSS_Name = TSS_Stream_Write
1950 or else TSS_Name = TSS_Stream_Input
1951 or else TSS_Name = TSS_Stream_Output
1953 (Chars (E) = Name_Op_Eq
1954 and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
1955 or else Chars (E) = Name_uAssign
1956 or else TSS_Name = TSS_Deep_Adjust
1957 or else TSS_Name = TSS_Deep_Finalize
1958 or else Is_Predefined_Interface_Primitive (E)
1965 end Is_Predefined_Dispatching_Operation;
1967 ---------------------------------------
1968 -- Is_Predefined_Internal_Operation --
1969 ---------------------------------------
1971 function Is_Predefined_Internal_Operation
1972 (E : Entity_Id) return Boolean
1974 TSS_Name : TSS_Name_Type;
1977 if not Is_Dispatching_Operation (E) then
1981 Get_Name_String (Chars (E));
1983 -- Most predefined primitives have internally generated names. Equality
1984 -- must be treated differently; the predefined operation is recognized
1985 -- as a homogeneous binary operator that returns Boolean.
1987 if Name_Len > TSS_Name_Type'Last then
1990 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
1992 if Chars (E) = Name_uSize
1993 or else Chars (E) = Name_uAlignment
1995 (Chars (E) = Name_Op_Eq
1996 and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
1997 or else Chars (E) = Name_uAssign
1998 or else TSS_Name = TSS_Deep_Adjust
1999 or else TSS_Name = TSS_Deep_Finalize
2000 or else Is_Predefined_Interface_Primitive (E)
2007 end Is_Predefined_Internal_Operation;
2009 -------------------------------------
2010 -- Is_Predefined_Dispatching_Alias --
2011 -------------------------------------
2013 function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean
2016 return not Is_Predefined_Dispatching_Operation (Prim)
2017 and then Present (Alias (Prim))
2018 and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim));
2019 end Is_Predefined_Dispatching_Alias;
2021 ---------------------------------------
2022 -- Is_Predefined_Interface_Primitive --
2023 ---------------------------------------
2025 function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is
2027 -- In VM targets we don't restrict the functionality of this test to
2028 -- compiling in Ada 2005 mode since in VM targets any tagged type has
2031 return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion)
2032 and then (Chars (E) = Name_uDisp_Asynchronous_Select or else
2033 Chars (E) = Name_uDisp_Conditional_Select or else
2034 Chars (E) = Name_uDisp_Get_Prim_Op_Kind or else
2035 Chars (E) = Name_uDisp_Get_Task_Id or else
2036 Chars (E) = Name_uDisp_Requeue or else
2037 Chars (E) = Name_uDisp_Timed_Select);
2038 end Is_Predefined_Interface_Primitive;
2040 ----------------------------------------
2041 -- Make_Disp_Asynchronous_Select_Body --
2042 ----------------------------------------
2044 -- For interface types, generate:
2046 -- procedure _Disp_Asynchronous_Select
2047 -- (T : in out <Typ>;
2049 -- P : System.Address;
2050 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2055 -- end _Disp_Asynchronous_Select;
2057 -- For protected types, generate:
2059 -- procedure _Disp_Asynchronous_Select
2060 -- (T : in out <Typ>;
2062 -- P : System.Address;
2063 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2067 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2068 -- Bnn : System.Tasking.Protected_Objects.Operations.
2069 -- Communication_Block;
2071 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2072 -- (T._object'Access,
2073 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2075 -- System.Tasking.Asynchronous_Call,
2077 -- B := System.Storage_Elements.Dummy_Communication_Block (Bnn);
2078 -- end _Disp_Asynchronous_Select;
2080 -- For task types, generate:
2082 -- procedure _Disp_Asynchronous_Select
2083 -- (T : in out <Typ>;
2085 -- P : System.Address;
2086 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2090 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2092 -- System.Tasking.Rendezvous.Task_Entry_Call
2094 -- System.Tasking.Task_Entry_Index (I),
2096 -- System.Tasking.Asynchronous_Call,
2098 -- end _Disp_Asynchronous_Select;
2100 function Make_Disp_Asynchronous_Select_Body
2101 (Typ : Entity_Id) return Node_Id
2103 Com_Block : Entity_Id;
2104 Conc_Typ : Entity_Id := Empty;
2105 Decls : constant List_Id := New_List;
2106 Loc : constant Source_Ptr := Sloc (Typ);
2108 Stmts : constant List_Id := New_List;
2112 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2114 -- Null body is generated for interface types
2116 if Is_Interface (Typ) then
2118 Make_Subprogram_Body (Loc,
2120 Make_Disp_Asynchronous_Select_Spec (Typ),
2123 Handled_Statement_Sequence =>
2124 Make_Handled_Sequence_Of_Statements (Loc,
2125 New_List (Make_Null_Statement (Loc))));
2128 if Is_Concurrent_Record_Type (Typ) then
2129 Conc_Typ := Corresponding_Concurrent_Type (Typ);
2133 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2135 -- where I will be used to capture the entry index of the primitive
2136 -- wrapper at position S.
2138 if Tagged_Type_Expansion then
2140 Unchecked_Convert_To (RTE (RE_Tag),
2142 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2145 Make_Attribute_Reference (Loc,
2146 Prefix => New_Reference_To (Typ, Loc),
2147 Attribute_Name => Name_Tag);
2151 Make_Object_Declaration (Loc,
2152 Defining_Identifier =>
2153 Make_Defining_Identifier (Loc, Name_uI),
2154 Object_Definition =>
2155 New_Reference_To (Standard_Integer, Loc),
2157 Make_Function_Call (Loc,
2159 New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
2160 Parameter_Associations =>
2163 Make_Identifier (Loc, Name_uS)))));
2165 if Ekind (Conc_Typ) = E_Protected_Type then
2168 -- Bnn : Communication_Block;
2170 Com_Block := Make_Temporary (Loc, 'B');
2172 Make_Object_Declaration (Loc,
2173 Defining_Identifier =>
2175 Object_Definition =>
2176 New_Reference_To (RTE (RE_Communication_Block), Loc)));
2178 -- Build T._object'Access for calls below
2181 Make_Attribute_Reference (Loc,
2182 Attribute_Name => Name_Unchecked_Access,
2184 Make_Selected_Component (Loc,
2185 Prefix => Make_Identifier (Loc, Name_uT),
2186 Selector_Name => Make_Identifier (Loc, Name_uObject)));
2188 case Corresponding_Runtime_Package (Conc_Typ) is
2189 when System_Tasking_Protected_Objects_Entries =>
2192 -- Protected_Entry_Call
2193 -- (T._object'Access, -- Object
2194 -- Protected_Entry_Index! (I), -- E
2195 -- P, -- Uninterpreted_Data
2196 -- Asynchronous_Call, -- Mode
2197 -- Bnn); -- Communication_Block
2199 -- where T is the protected object, I is the entry index, P
2200 -- is the wrapped parameters and B is the name of the
2201 -- communication block.
2204 Make_Procedure_Call_Statement (Loc,
2206 New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
2207 Parameter_Associations =>
2211 Make_Unchecked_Type_Conversion (Loc, -- entry index
2214 (RTE (RE_Protected_Entry_Index), Loc),
2215 Expression => Make_Identifier (Loc, Name_uI)),
2217 Make_Identifier (Loc, Name_uP), -- parameter block
2218 New_Reference_To -- Asynchronous_Call
2219 (RTE (RE_Asynchronous_Call), Loc),
2221 New_Reference_To (Com_Block, Loc)))); -- comm block
2223 when System_Tasking_Protected_Objects_Single_Entry =>
2226 -- procedure Protected_Single_Entry_Call
2227 -- (Object : Protection_Entry_Access;
2228 -- Uninterpreted_Data : System.Address;
2229 -- Mode : Call_Modes);
2232 Make_Procedure_Call_Statement (Loc,
2235 (RTE (RE_Protected_Single_Entry_Call), Loc),
2236 Parameter_Associations =>
2240 Make_Attribute_Reference (Loc,
2241 Prefix => Make_Identifier (Loc, Name_uP),
2242 Attribute_Name => Name_Address),
2245 (RTE (RE_Asynchronous_Call), Loc))));
2248 raise Program_Error;
2252 -- B := Dummy_Communication_Block (Bnn);
2255 Make_Assignment_Statement (Loc,
2256 Name => Make_Identifier (Loc, Name_uB),
2258 Make_Unchecked_Type_Conversion (Loc,
2261 RTE (RE_Dummy_Communication_Block), Loc),
2263 New_Reference_To (Com_Block, Loc))));
2266 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2270 -- (T._task_id, -- Acceptor
2271 -- Task_Entry_Index! (I), -- E
2272 -- P, -- Uninterpreted_Data
2273 -- Asynchronous_Call, -- Mode
2274 -- F); -- Rendezvous_Successful
2276 -- where T is the task object, I is the entry index, P is the
2277 -- wrapped parameters and F is the status flag.
2280 Make_Procedure_Call_Statement (Loc,
2282 New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
2283 Parameter_Associations =>
2285 Make_Selected_Component (Loc, -- T._task_id
2286 Prefix => Make_Identifier (Loc, Name_uT),
2287 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2289 Make_Unchecked_Type_Conversion (Loc, -- entry index
2291 New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
2292 Expression => Make_Identifier (Loc, Name_uI)),
2294 Make_Identifier (Loc, Name_uP), -- parameter block
2295 New_Reference_To -- Asynchronous_Call
2296 (RTE (RE_Asynchronous_Call), Loc),
2297 Make_Identifier (Loc, Name_uF)))); -- status flag
2301 -- Ensure that the statements list is non-empty
2303 Append_To (Stmts, Make_Null_Statement (Loc));
2307 Make_Subprogram_Body (Loc,
2309 Make_Disp_Asynchronous_Select_Spec (Typ),
2312 Handled_Statement_Sequence =>
2313 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2314 end Make_Disp_Asynchronous_Select_Body;
2316 ----------------------------------------
2317 -- Make_Disp_Asynchronous_Select_Spec --
2318 ----------------------------------------
2320 function Make_Disp_Asynchronous_Select_Spec
2321 (Typ : Entity_Id) return Node_Id
2323 Loc : constant Source_Ptr := Sloc (Typ);
2324 Def_Id : constant Node_Id :=
2325 Make_Defining_Identifier (Loc,
2326 Name_uDisp_Asynchronous_Select);
2327 Params : constant List_Id := New_List;
2330 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2332 -- T : in out Typ; -- Object parameter
2333 -- S : Integer; -- Primitive operation slot
2334 -- P : Address; -- Wrapped parameters
2335 -- B : out Dummy_Communication_Block; -- Communication block dummy
2336 -- F : out Boolean; -- Status flag
2338 Append_List_To (Params, New_List (
2340 Make_Parameter_Specification (Loc,
2341 Defining_Identifier =>
2342 Make_Defining_Identifier (Loc, Name_uT),
2344 New_Reference_To (Typ, Loc),
2346 Out_Present => True),
2348 Make_Parameter_Specification (Loc,
2349 Defining_Identifier =>
2350 Make_Defining_Identifier (Loc, Name_uS),
2352 New_Reference_To (Standard_Integer, Loc)),
2354 Make_Parameter_Specification (Loc,
2355 Defining_Identifier =>
2356 Make_Defining_Identifier (Loc, Name_uP),
2358 New_Reference_To (RTE (RE_Address), Loc)),
2360 Make_Parameter_Specification (Loc,
2361 Defining_Identifier =>
2362 Make_Defining_Identifier (Loc, Name_uB),
2364 New_Reference_To (RTE (RE_Dummy_Communication_Block), Loc),
2365 Out_Present => True),
2367 Make_Parameter_Specification (Loc,
2368 Defining_Identifier =>
2369 Make_Defining_Identifier (Loc, Name_uF),
2371 New_Reference_To (Standard_Boolean, Loc),
2372 Out_Present => True)));
2375 Make_Procedure_Specification (Loc,
2376 Defining_Unit_Name => Def_Id,
2377 Parameter_Specifications => Params);
2378 end Make_Disp_Asynchronous_Select_Spec;
2380 ---------------------------------------
2381 -- Make_Disp_Conditional_Select_Body --
2382 ---------------------------------------
2384 -- For interface types, generate:
2386 -- procedure _Disp_Conditional_Select
2387 -- (T : in out <Typ>;
2389 -- P : System.Address;
2390 -- C : out Ada.Tags.Prim_Op_Kind;
2395 -- end _Disp_Conditional_Select;
2397 -- For protected types, generate:
2399 -- procedure _Disp_Conditional_Select
2400 -- (T : in out <Typ>;
2402 -- P : System.Address;
2403 -- C : out Ada.Tags.Prim_Op_Kind;
2407 -- Bnn : System.Tasking.Protected_Objects.Operations.
2408 -- Communication_Block;
2411 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S));
2413 -- if C = Ada.Tags.POK_Procedure
2414 -- or else C = Ada.Tags.POK_Protected_Procedure
2415 -- or else C = Ada.Tags.POK_Task_Procedure
2421 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2422 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2423 -- (T.object'Access,
2424 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2426 -- System.Tasking.Conditional_Call,
2428 -- F := not Cancelled (Bnn);
2429 -- end _Disp_Conditional_Select;
2431 -- For task types, generate:
2433 -- procedure _Disp_Conditional_Select
2434 -- (T : in out <Typ>;
2436 -- P : System.Address;
2437 -- C : out Ada.Tags.Prim_Op_Kind;
2443 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2444 -- System.Tasking.Rendezvous.Task_Entry_Call
2446 -- System.Tasking.Task_Entry_Index (I),
2448 -- System.Tasking.Conditional_Call,
2450 -- end _Disp_Conditional_Select;
2452 function Make_Disp_Conditional_Select_Body
2453 (Typ : Entity_Id) return Node_Id
2455 Loc : constant Source_Ptr := Sloc (Typ);
2456 Blk_Nam : Entity_Id;
2457 Conc_Typ : Entity_Id := Empty;
2458 Decls : constant List_Id := New_List;
2460 Stmts : constant List_Id := New_List;
2464 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2466 -- Null body is generated for interface types
2468 if Is_Interface (Typ) then
2470 Make_Subprogram_Body (Loc,
2472 Make_Disp_Conditional_Select_Spec (Typ),
2475 Handled_Statement_Sequence =>
2476 Make_Handled_Sequence_Of_Statements (Loc,
2477 New_List (Make_Null_Statement (Loc))));
2480 if Is_Concurrent_Record_Type (Typ) then
2481 Conc_Typ := Corresponding_Concurrent_Type (Typ);
2486 -- where I will be used to capture the entry index of the primitive
2487 -- wrapper at position S.
2490 Make_Object_Declaration (Loc,
2491 Defining_Identifier =>
2492 Make_Defining_Identifier (Loc, Name_uI),
2493 Object_Definition =>
2494 New_Reference_To (Standard_Integer, Loc)));
2497 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S);
2499 -- if C = POK_Procedure
2500 -- or else C = POK_Protected_Procedure
2501 -- or else C = POK_Task_Procedure;
2507 Build_Common_Dispatching_Select_Statements (Typ, Stmts);
2510 -- Bnn : Communication_Block;
2512 -- where Bnn is the name of the communication block used in the
2513 -- call to Protected_Entry_Call.
2515 Blk_Nam := Make_Temporary (Loc, 'B');
2517 Make_Object_Declaration (Loc,
2518 Defining_Identifier =>
2520 Object_Definition =>
2521 New_Reference_To (RTE (RE_Communication_Block), Loc)));
2524 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2526 -- I is the entry index and S is the dispatch table slot
2528 if Tagged_Type_Expansion then
2530 Unchecked_Convert_To (RTE (RE_Tag),
2532 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2536 Make_Attribute_Reference (Loc,
2537 Prefix => New_Reference_To (Typ, Loc),
2538 Attribute_Name => Name_Tag);
2542 Make_Assignment_Statement (Loc,
2543 Name => Make_Identifier (Loc, Name_uI),
2545 Make_Function_Call (Loc,
2547 New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
2548 Parameter_Associations =>
2551 Make_Identifier (Loc, Name_uS)))));
2553 if Ekind (Conc_Typ) = E_Protected_Type then
2555 Obj_Ref := -- T._object'Access
2556 Make_Attribute_Reference (Loc,
2557 Attribute_Name => Name_Unchecked_Access,
2559 Make_Selected_Component (Loc,
2560 Prefix => Make_Identifier (Loc, Name_uT),
2561 Selector_Name => Make_Identifier (Loc, Name_uObject)));
2563 case Corresponding_Runtime_Package (Conc_Typ) is
2564 when System_Tasking_Protected_Objects_Entries =>
2567 -- Protected_Entry_Call
2568 -- (T._object'Access, -- Object
2569 -- Protected_Entry_Index! (I), -- E
2570 -- P, -- Uninterpreted_Data
2571 -- Conditional_Call, -- Mode
2574 -- where T is the protected object, I is the entry index, P
2575 -- are the wrapped parameters and Bnn is the name of the
2576 -- communication block.
2579 Make_Procedure_Call_Statement (Loc,
2581 New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
2582 Parameter_Associations =>
2586 Make_Unchecked_Type_Conversion (Loc, -- entry index
2589 (RTE (RE_Protected_Entry_Index), Loc),
2590 Expression => Make_Identifier (Loc, Name_uI)),
2592 Make_Identifier (Loc, Name_uP), -- parameter block
2594 New_Reference_To ( -- Conditional_Call
2595 RTE (RE_Conditional_Call), Loc),
2596 New_Reference_To ( -- Bnn
2599 when System_Tasking_Protected_Objects_Single_Entry =>
2601 -- If we are compiling for a restricted run-time, the call
2602 -- uses the simpler form.
2605 Make_Procedure_Call_Statement (Loc,
2608 (RTE (RE_Protected_Single_Entry_Call), Loc),
2609 Parameter_Associations =>
2613 Make_Attribute_Reference (Loc,
2614 Prefix => Make_Identifier (Loc, Name_uP),
2615 Attribute_Name => Name_Address),
2618 (RTE (RE_Conditional_Call), Loc))));
2620 raise Program_Error;
2624 -- F := not Cancelled (Bnn);
2626 -- where F is the success flag. The status of Cancelled is negated
2627 -- in order to match the behaviour of the version for task types.
2630 Make_Assignment_Statement (Loc,
2631 Name => Make_Identifier (Loc, Name_uF),
2635 Make_Function_Call (Loc,
2637 New_Reference_To (RTE (RE_Cancelled), Loc),
2638 Parameter_Associations =>
2640 New_Reference_To (Blk_Nam, Loc))))));
2642 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2646 -- (T._task_id, -- Acceptor
2647 -- Task_Entry_Index! (I), -- E
2648 -- P, -- Uninterpreted_Data
2649 -- Conditional_Call, -- Mode
2650 -- F); -- Rendezvous_Successful
2652 -- where T is the task object, I is the entry index, P are the
2653 -- wrapped parameters and F is the status flag.
2656 Make_Procedure_Call_Statement (Loc,
2658 New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
2659 Parameter_Associations =>
2662 Make_Selected_Component (Loc, -- T._task_id
2663 Prefix => Make_Identifier (Loc, Name_uT),
2664 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2666 Make_Unchecked_Type_Conversion (Loc, -- entry index
2668 New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
2669 Expression => Make_Identifier (Loc, Name_uI)),
2671 Make_Identifier (Loc, Name_uP), -- parameter block
2672 New_Reference_To -- Conditional_Call
2673 (RTE (RE_Conditional_Call), Loc),
2674 Make_Identifier (Loc, Name_uF)))); -- status flag
2678 -- Ensure that the statements list is non-empty
2680 Append_To (Stmts, Make_Null_Statement (Loc));
2684 Make_Subprogram_Body (Loc,
2686 Make_Disp_Conditional_Select_Spec (Typ),
2689 Handled_Statement_Sequence =>
2690 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2691 end Make_Disp_Conditional_Select_Body;
2693 ---------------------------------------
2694 -- Make_Disp_Conditional_Select_Spec --
2695 ---------------------------------------
2697 function Make_Disp_Conditional_Select_Spec
2698 (Typ : Entity_Id) return Node_Id
2700 Loc : constant Source_Ptr := Sloc (Typ);
2701 Def_Id : constant Node_Id :=
2702 Make_Defining_Identifier (Loc,
2703 Name_uDisp_Conditional_Select);
2704 Params : constant List_Id := New_List;
2707 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2709 -- T : in out Typ; -- Object parameter
2710 -- S : Integer; -- Primitive operation slot
2711 -- P : Address; -- Wrapped parameters
2712 -- C : out Prim_Op_Kind; -- Call kind
2713 -- F : out Boolean; -- Status flag
2715 Append_List_To (Params, New_List (
2717 Make_Parameter_Specification (Loc,
2718 Defining_Identifier =>
2719 Make_Defining_Identifier (Loc, Name_uT),
2721 New_Reference_To (Typ, Loc),
2723 Out_Present => True),
2725 Make_Parameter_Specification (Loc,
2726 Defining_Identifier =>
2727 Make_Defining_Identifier (Loc, Name_uS),
2729 New_Reference_To (Standard_Integer, Loc)),
2731 Make_Parameter_Specification (Loc,
2732 Defining_Identifier =>
2733 Make_Defining_Identifier (Loc, Name_uP),
2735 New_Reference_To (RTE (RE_Address), Loc)),
2737 Make_Parameter_Specification (Loc,
2738 Defining_Identifier =>
2739 Make_Defining_Identifier (Loc, Name_uC),
2741 New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
2742 Out_Present => True),
2744 Make_Parameter_Specification (Loc,
2745 Defining_Identifier =>
2746 Make_Defining_Identifier (Loc, Name_uF),
2748 New_Reference_To (Standard_Boolean, Loc),
2749 Out_Present => True)));
2752 Make_Procedure_Specification (Loc,
2753 Defining_Unit_Name => Def_Id,
2754 Parameter_Specifications => Params);
2755 end Make_Disp_Conditional_Select_Spec;
2757 -------------------------------------
2758 -- Make_Disp_Get_Prim_Op_Kind_Body --
2759 -------------------------------------
2761 function Make_Disp_Get_Prim_Op_Kind_Body
2762 (Typ : Entity_Id) return Node_Id
2764 Loc : constant Source_Ptr := Sloc (Typ);
2768 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2770 if Is_Interface (Typ) then
2772 Make_Subprogram_Body (Loc,
2774 Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2777 Handled_Statement_Sequence =>
2778 Make_Handled_Sequence_Of_Statements (Loc,
2779 New_List (Make_Null_Statement (Loc))));
2783 -- C := get_prim_op_kind (tag! (<type>VP), S);
2785 -- where C is the out parameter capturing the call kind and S is the
2786 -- dispatch table slot number.
2788 if Tagged_Type_Expansion then
2790 Unchecked_Convert_To (RTE (RE_Tag),
2792 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2796 Make_Attribute_Reference (Loc,
2797 Prefix => New_Reference_To (Typ, Loc),
2798 Attribute_Name => Name_Tag);
2802 Make_Subprogram_Body (Loc,
2804 Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2807 Handled_Statement_Sequence =>
2808 Make_Handled_Sequence_Of_Statements (Loc,
2810 Make_Assignment_Statement (Loc,
2812 Make_Identifier (Loc, Name_uC),
2814 Make_Function_Call (Loc,
2816 New_Reference_To (RTE (RE_Get_Prim_Op_Kind), Loc),
2817 Parameter_Associations => New_List (
2819 Make_Identifier (Loc, Name_uS)))))));
2820 end Make_Disp_Get_Prim_Op_Kind_Body;
2822 -------------------------------------
2823 -- Make_Disp_Get_Prim_Op_Kind_Spec --
2824 -------------------------------------
2826 function Make_Disp_Get_Prim_Op_Kind_Spec
2827 (Typ : Entity_Id) return Node_Id
2829 Loc : constant Source_Ptr := Sloc (Typ);
2830 Def_Id : constant Node_Id :=
2831 Make_Defining_Identifier (Loc,
2832 Name_uDisp_Get_Prim_Op_Kind);
2833 Params : constant List_Id := New_List;
2836 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2838 -- T : in out Typ; -- Object parameter
2839 -- S : Integer; -- Primitive operation slot
2840 -- C : out Prim_Op_Kind; -- Call kind
2842 Append_List_To (Params, New_List (
2844 Make_Parameter_Specification (Loc,
2845 Defining_Identifier =>
2846 Make_Defining_Identifier (Loc, Name_uT),
2848 New_Reference_To (Typ, Loc),
2850 Out_Present => True),
2852 Make_Parameter_Specification (Loc,
2853 Defining_Identifier =>
2854 Make_Defining_Identifier (Loc, Name_uS),
2856 New_Reference_To (Standard_Integer, Loc)),
2858 Make_Parameter_Specification (Loc,
2859 Defining_Identifier =>
2860 Make_Defining_Identifier (Loc, Name_uC),
2862 New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
2863 Out_Present => True)));
2866 Make_Procedure_Specification (Loc,
2867 Defining_Unit_Name => Def_Id,
2868 Parameter_Specifications => Params);
2869 end Make_Disp_Get_Prim_Op_Kind_Spec;
2871 --------------------------------
2872 -- Make_Disp_Get_Task_Id_Body --
2873 --------------------------------
2875 function Make_Disp_Get_Task_Id_Body
2876 (Typ : Entity_Id) return Node_Id
2878 Loc : constant Source_Ptr := Sloc (Typ);
2882 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2884 if Is_Concurrent_Record_Type (Typ)
2885 and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type
2888 -- return To_Address (_T._task_id);
2891 Make_Simple_Return_Statement (Loc,
2893 Make_Unchecked_Type_Conversion (Loc,
2895 New_Reference_To (RTE (RE_Address), Loc),
2897 Make_Selected_Component (Loc,
2898 Prefix => Make_Identifier (Loc, Name_uT),
2899 Selector_Name => Make_Identifier (Loc, Name_uTask_Id))));
2901 -- A null body is constructed for non-task types
2905 -- return Null_Address;
2908 Make_Simple_Return_Statement (Loc,
2910 New_Reference_To (RTE (RE_Null_Address), Loc));
2914 Make_Subprogram_Body (Loc,
2916 Make_Disp_Get_Task_Id_Spec (Typ),
2919 Handled_Statement_Sequence =>
2920 Make_Handled_Sequence_Of_Statements (Loc,
2922 end Make_Disp_Get_Task_Id_Body;
2924 --------------------------------
2925 -- Make_Disp_Get_Task_Id_Spec --
2926 --------------------------------
2928 function Make_Disp_Get_Task_Id_Spec
2929 (Typ : Entity_Id) return Node_Id
2931 Loc : constant Source_Ptr := Sloc (Typ);
2934 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2937 Make_Function_Specification (Loc,
2938 Defining_Unit_Name =>
2939 Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id),
2940 Parameter_Specifications => New_List (
2941 Make_Parameter_Specification (Loc,
2942 Defining_Identifier =>
2943 Make_Defining_Identifier (Loc, Name_uT),
2945 New_Reference_To (Typ, Loc))),
2946 Result_Definition =>
2947 New_Reference_To (RTE (RE_Address), Loc));
2948 end Make_Disp_Get_Task_Id_Spec;
2950 ----------------------------
2951 -- Make_Disp_Requeue_Body --
2952 ----------------------------
2954 function Make_Disp_Requeue_Body
2955 (Typ : Entity_Id) return Node_Id
2957 Loc : constant Source_Ptr := Sloc (Typ);
2958 Conc_Typ : Entity_Id := Empty;
2959 Stmts : constant List_Id := New_List;
2962 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2964 -- Null body is generated for interface types and non-concurrent
2967 if Is_Interface (Typ)
2968 or else not Is_Concurrent_Record_Type (Typ)
2971 Make_Subprogram_Body (Loc,
2973 Make_Disp_Requeue_Spec (Typ),
2976 Handled_Statement_Sequence =>
2977 Make_Handled_Sequence_Of_Statements (Loc,
2978 New_List (Make_Null_Statement (Loc))));
2981 Conc_Typ := Corresponding_Concurrent_Type (Typ);
2983 if Ekind (Conc_Typ) = E_Protected_Type then
2985 -- Generate statements:
2987 -- System.Tasking.Protected_Objects.Operations.
2988 -- Requeue_Protected_Entry
2989 -- (Protection_Entries_Access (P),
2990 -- O._object'Unchecked_Access,
2991 -- Protected_Entry_Index (I),
2994 -- System.Tasking.Protected_Objects.Operations.
2995 -- Requeue_Task_To_Protected_Entry
2996 -- (O._object'Unchecked_Access,
2997 -- Protected_Entry_Index (I),
3001 if Restriction_Active (No_Entry_Queue) then
3002 Append_To (Stmts, Make_Null_Statement (Loc));
3005 Make_If_Statement (Loc,
3006 Condition => Make_Identifier (Loc, Name_uF),
3011 -- Call to Requeue_Protected_Entry
3013 Make_Procedure_Call_Statement (Loc,
3016 RTE (RE_Requeue_Protected_Entry), Loc),
3017 Parameter_Associations =>
3020 Make_Unchecked_Type_Conversion (Loc, -- PEA (P)
3023 RTE (RE_Protection_Entries_Access), Loc),
3025 Make_Identifier (Loc, Name_uP)),
3027 Make_Attribute_Reference (Loc, -- O._object'Acc
3029 Name_Unchecked_Access,
3031 Make_Selected_Component (Loc,
3033 Make_Identifier (Loc, Name_uO),
3035 Make_Identifier (Loc, Name_uObject))),
3037 Make_Unchecked_Type_Conversion (Loc, -- entry index
3040 RTE (RE_Protected_Entry_Index), Loc),
3041 Expression => Make_Identifier (Loc, Name_uI)),
3043 Make_Identifier (Loc, Name_uA)))), -- abort status
3048 -- Call to Requeue_Task_To_Protected_Entry
3050 Make_Procedure_Call_Statement (Loc,
3053 RTE (RE_Requeue_Task_To_Protected_Entry), Loc),
3054 Parameter_Associations =>
3057 Make_Attribute_Reference (Loc, -- O._object'Acc
3059 Name_Unchecked_Access,
3061 Make_Selected_Component (Loc,
3063 Make_Identifier (Loc, Name_uO),
3065 Make_Identifier (Loc, Name_uObject))),
3067 Make_Unchecked_Type_Conversion (Loc, -- entry index
3070 RTE (RE_Protected_Entry_Index), Loc),
3072 Make_Identifier (Loc, Name_uI)),
3074 Make_Identifier (Loc, Name_uA)))))); -- abort status
3077 pragma Assert (Is_Task_Type (Conc_Typ));
3081 -- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry
3082 -- (Protection_Entries_Access (P),
3084 -- Task_Entry_Index (I),
3087 -- System.Tasking.Rendezvous.Requeue_Task_Entry
3089 -- Task_Entry_Index (I),
3094 Make_If_Statement (Loc,
3095 Condition => Make_Identifier (Loc, Name_uF),
3097 Then_Statements => New_List (
3099 -- Call to Requeue_Protected_To_Task_Entry
3101 Make_Procedure_Call_Statement (Loc,
3104 (RTE (RE_Requeue_Protected_To_Task_Entry), Loc),
3106 Parameter_Associations => New_List (
3108 Make_Unchecked_Type_Conversion (Loc, -- PEA (P)
3111 (RTE (RE_Protection_Entries_Access), Loc),
3112 Expression => Make_Identifier (Loc, Name_uP)),
3114 Make_Selected_Component (Loc, -- O._task_id
3115 Prefix => Make_Identifier (Loc, Name_uO),
3116 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3118 Make_Unchecked_Type_Conversion (Loc, -- entry index
3120 New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
3121 Expression => Make_Identifier (Loc, Name_uI)),
3123 Make_Identifier (Loc, Name_uA)))), -- abort status
3125 Else_Statements => New_List (
3127 -- Call to Requeue_Task_Entry
3129 Make_Procedure_Call_Statement (Loc,
3130 Name => New_Reference_To (RTE (RE_Requeue_Task_Entry), Loc),
3132 Parameter_Associations => New_List (
3134 Make_Selected_Component (Loc, -- O._task_id
3135 Prefix => Make_Identifier (Loc, Name_uO),
3136 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3138 Make_Unchecked_Type_Conversion (Loc, -- entry index
3140 New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
3141 Expression => Make_Identifier (Loc, Name_uI)),
3143 Make_Identifier (Loc, Name_uA)))))); -- abort status
3146 -- Even though no declarations are needed in both cases, we allocate
3147 -- a list for entities added by Freeze.
3150 Make_Subprogram_Body (Loc,
3152 Make_Disp_Requeue_Spec (Typ),
3155 Handled_Statement_Sequence =>
3156 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
3157 end Make_Disp_Requeue_Body;
3159 ----------------------------
3160 -- Make_Disp_Requeue_Spec --
3161 ----------------------------
3163 function Make_Disp_Requeue_Spec
3164 (Typ : Entity_Id) return Node_Id
3166 Loc : constant Source_Ptr := Sloc (Typ);
3169 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3171 -- O : in out Typ; - Object parameter
3172 -- F : Boolean; - Protected (True) / task (False) flag
3173 -- P : Address; - Protection_Entries_Access value
3174 -- I : Entry_Index - Index of entry call
3175 -- A : Boolean - Abort flag
3177 -- Note that the Protection_Entries_Access value is represented as a
3178 -- System.Address in order to avoid dragging in the tasking runtime
3179 -- when compiling sources without tasking constructs.
3182 Make_Procedure_Specification (Loc,
3183 Defining_Unit_Name =>
3184 Make_Defining_Identifier (Loc, Name_uDisp_Requeue),
3186 Parameter_Specifications =>
3189 Make_Parameter_Specification (Loc, -- O
3190 Defining_Identifier =>
3191 Make_Defining_Identifier (Loc, Name_uO),
3193 New_Reference_To (Typ, Loc),
3195 Out_Present => True),
3197 Make_Parameter_Specification (Loc, -- F
3198 Defining_Identifier =>
3199 Make_Defining_Identifier (Loc, Name_uF),
3201 New_Reference_To (Standard_Boolean, Loc)),
3203 Make_Parameter_Specification (Loc, -- P
3204 Defining_Identifier =>
3205 Make_Defining_Identifier (Loc, Name_uP),
3207 New_Reference_To (RTE (RE_Address), Loc)),
3209 Make_Parameter_Specification (Loc, -- I
3210 Defining_Identifier =>
3211 Make_Defining_Identifier (Loc, Name_uI),
3213 New_Reference_To (Standard_Integer, Loc)),
3215 Make_Parameter_Specification (Loc, -- A
3216 Defining_Identifier =>
3217 Make_Defining_Identifier (Loc, Name_uA),
3219 New_Reference_To (Standard_Boolean, Loc))));
3220 end Make_Disp_Requeue_Spec;
3222 ---------------------------------
3223 -- Make_Disp_Timed_Select_Body --
3224 ---------------------------------
3226 -- For interface types, generate:
3228 -- procedure _Disp_Timed_Select
3229 -- (T : in out <Typ>;
3231 -- P : System.Address;
3234 -- C : out Ada.Tags.Prim_Op_Kind;
3239 -- end _Disp_Timed_Select;
3241 -- For protected types, generate:
3243 -- procedure _Disp_Timed_Select
3244 -- (T : in out <Typ>;
3246 -- P : System.Address;
3249 -- C : out Ada.Tags.Prim_Op_Kind;
3255 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S);
3257 -- if C = Ada.Tags.POK_Procedure
3258 -- or else C = Ada.Tags.POK_Protected_Procedure
3259 -- or else C = Ada.Tags.POK_Task_Procedure
3265 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3266 -- System.Tasking.Protected_Objects.Operations.
3267 -- Timed_Protected_Entry_Call
3268 -- (T._object'Access,
3269 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
3274 -- end _Disp_Timed_Select;
3276 -- For task types, generate:
3278 -- procedure _Disp_Timed_Select
3279 -- (T : in out <Typ>;
3281 -- P : System.Address;
3284 -- C : out Ada.Tags.Prim_Op_Kind;
3290 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3291 -- System.Tasking.Rendezvous.Timed_Task_Entry_Call
3293 -- System.Tasking.Task_Entry_Index (I),
3298 -- end _Disp_Time_Select;
3300 function Make_Disp_Timed_Select_Body
3301 (Typ : Entity_Id) return Node_Id
3303 Loc : constant Source_Ptr := Sloc (Typ);
3304 Conc_Typ : Entity_Id := Empty;
3305 Decls : constant List_Id := New_List;
3307 Stmts : constant List_Id := New_List;
3311 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3313 -- Null body is generated for interface types
3315 if Is_Interface (Typ) then
3317 Make_Subprogram_Body (Loc,
3319 Make_Disp_Timed_Select_Spec (Typ),
3322 Handled_Statement_Sequence =>
3323 Make_Handled_Sequence_Of_Statements (Loc,
3324 New_List (Make_Null_Statement (Loc))));
3327 if Is_Concurrent_Record_Type (Typ) then
3328 Conc_Typ := Corresponding_Concurrent_Type (Typ);
3333 -- where I will be used to capture the entry index of the primitive
3334 -- wrapper at position S.
3337 Make_Object_Declaration (Loc,
3338 Defining_Identifier =>
3339 Make_Defining_Identifier (Loc, Name_uI),
3340 Object_Definition =>
3341 New_Reference_To (Standard_Integer, Loc)));
3344 -- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
3346 -- if C = POK_Procedure
3347 -- or else C = POK_Protected_Procedure
3348 -- or else C = POK_Task_Procedure;
3354 Build_Common_Dispatching_Select_Statements (Typ, Stmts);
3357 -- I := Get_Entry_Index (tag! (<type>VP), S);
3359 -- I is the entry index and S is the dispatch table slot
3361 if Tagged_Type_Expansion then
3363 Unchecked_Convert_To (RTE (RE_Tag),
3365 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
3369 Make_Attribute_Reference (Loc,
3370 Prefix => New_Reference_To (Typ, Loc),
3371 Attribute_Name => Name_Tag);
3375 Make_Assignment_Statement (Loc,
3376 Name => Make_Identifier (Loc, Name_uI),
3378 Make_Function_Call (Loc,
3380 New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
3381 Parameter_Associations =>
3384 Make_Identifier (Loc, Name_uS)))));
3388 if Ekind (Conc_Typ) = E_Protected_Type then
3390 -- Build T._object'Access
3393 Make_Attribute_Reference (Loc,
3394 Attribute_Name => Name_Unchecked_Access,
3396 Make_Selected_Component (Loc,
3397 Prefix => Make_Identifier (Loc, Name_uT),
3398 Selector_Name => Make_Identifier (Loc, Name_uObject)));
3400 -- Normal case, No_Entry_Queue restriction not active. In this
3401 -- case we generate:
3403 -- Timed_Protected_Entry_Call
3404 -- (T._object'access,
3405 -- Protected_Entry_Index! (I),
3408 -- where T is the protected object, I is the entry index, P are
3409 -- the wrapped parameters, D is the delay amount, M is the delay
3410 -- mode and F is the status flag.
3412 case Corresponding_Runtime_Package (Conc_Typ) is
3413 when System_Tasking_Protected_Objects_Entries =>
3415 Make_Procedure_Call_Statement (Loc,
3418 (RTE (RE_Timed_Protected_Entry_Call), Loc),
3419 Parameter_Associations =>
3423 Make_Unchecked_Type_Conversion (Loc, -- entry index
3426 (RTE (RE_Protected_Entry_Index), Loc),
3428 Make_Identifier (Loc, Name_uI)),
3430 Make_Identifier (Loc, Name_uP), -- parameter block
3431 Make_Identifier (Loc, Name_uD), -- delay
3432 Make_Identifier (Loc, Name_uM), -- delay mode
3433 Make_Identifier (Loc, Name_uF)))); -- status flag
3435 when System_Tasking_Protected_Objects_Single_Entry =>
3438 -- Timed_Protected_Single_Entry_Call
3439 -- (T._object'access, P, D, M, F);
3441 -- where T is the protected object, P is the wrapped
3442 -- parameters, D is the delay amount, M is the delay mode, F
3443 -- is the status flag.
3446 Make_Procedure_Call_Statement (Loc,
3449 (RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
3450 Parameter_Associations =>
3453 Make_Identifier (Loc, Name_uP), -- parameter block
3454 Make_Identifier (Loc, Name_uD), -- delay
3455 Make_Identifier (Loc, Name_uM), -- delay mode
3456 Make_Identifier (Loc, Name_uF)))); -- status flag
3459 raise Program_Error;
3465 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
3468 -- Timed_Task_Entry_Call (
3470 -- Task_Entry_Index! (I),
3476 -- where T is the task object, I is the entry index, P are the
3477 -- wrapped parameters, D is the delay amount, M is the delay
3478 -- mode and F is the status flag.
3481 Make_Procedure_Call_Statement (Loc,
3483 New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
3484 Parameter_Associations =>
3487 Make_Selected_Component (Loc, -- T._task_id
3488 Prefix => Make_Identifier (Loc, Name_uT),
3489 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3491 Make_Unchecked_Type_Conversion (Loc, -- entry index
3493 New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
3494 Expression => Make_Identifier (Loc, Name_uI)),
3496 Make_Identifier (Loc, Name_uP), -- parameter block
3497 Make_Identifier (Loc, Name_uD), -- delay
3498 Make_Identifier (Loc, Name_uM), -- delay mode
3499 Make_Identifier (Loc, Name_uF)))); -- status flag
3503 -- Ensure that the statements list is non-empty
3505 Append_To (Stmts, Make_Null_Statement (Loc));
3509 Make_Subprogram_Body (Loc,
3511 Make_Disp_Timed_Select_Spec (Typ),
3514 Handled_Statement_Sequence =>
3515 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
3516 end Make_Disp_Timed_Select_Body;
3518 ---------------------------------
3519 -- Make_Disp_Timed_Select_Spec --
3520 ---------------------------------
3522 function Make_Disp_Timed_Select_Spec
3523 (Typ : Entity_Id) return Node_Id
3525 Loc : constant Source_Ptr := Sloc (Typ);
3526 Def_Id : constant Node_Id :=
3527 Make_Defining_Identifier (Loc,
3528 Name_uDisp_Timed_Select);
3529 Params : constant List_Id := New_List;
3532 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3534 -- T : in out Typ; -- Object parameter
3535 -- S : Integer; -- Primitive operation slot
3536 -- P : Address; -- Wrapped parameters
3537 -- D : Duration; -- Delay
3538 -- M : Integer; -- Delay Mode
3539 -- C : out Prim_Op_Kind; -- Call kind
3540 -- F : out Boolean; -- Status flag
3542 Append_List_To (Params, New_List (
3544 Make_Parameter_Specification (Loc,
3545 Defining_Identifier =>
3546 Make_Defining_Identifier (Loc, Name_uT),
3548 New_Reference_To (Typ, Loc),
3550 Out_Present => True),
3552 Make_Parameter_Specification (Loc,
3553 Defining_Identifier =>
3554 Make_Defining_Identifier (Loc, Name_uS),
3556 New_Reference_To (Standard_Integer, Loc)),
3558 Make_Parameter_Specification (Loc,
3559 Defining_Identifier =>
3560 Make_Defining_Identifier (Loc, Name_uP),
3562 New_Reference_To (RTE (RE_Address), Loc)),
3564 Make_Parameter_Specification (Loc,
3565 Defining_Identifier =>
3566 Make_Defining_Identifier (Loc, Name_uD),
3568 New_Reference_To (Standard_Duration, Loc)),
3570 Make_Parameter_Specification (Loc,
3571 Defining_Identifier =>
3572 Make_Defining_Identifier (Loc, Name_uM),
3574 New_Reference_To (Standard_Integer, Loc)),
3576 Make_Parameter_Specification (Loc,
3577 Defining_Identifier =>
3578 Make_Defining_Identifier (Loc, Name_uC),
3580 New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
3581 Out_Present => True)));
3584 Make_Parameter_Specification (Loc,
3585 Defining_Identifier =>
3586 Make_Defining_Identifier (Loc, Name_uF),
3588 New_Reference_To (Standard_Boolean, Loc),
3589 Out_Present => True));
3592 Make_Procedure_Specification (Loc,
3593 Defining_Unit_Name => Def_Id,
3594 Parameter_Specifications => Params);
3595 end Make_Disp_Timed_Select_Spec;
3601 -- The frontend supports two models for expanding dispatch tables
3602 -- associated with library-level defined tagged types: statically
3603 -- and non-statically allocated dispatch tables. In the former case
3604 -- the object containing the dispatch table is constant and it is
3605 -- initialized by means of a positional aggregate. In the latter case,
3606 -- the object containing the dispatch table is a variable which is
3607 -- initialized by means of assignments.
3609 -- In case of locally defined tagged types, the object containing the
3610 -- object containing the dispatch table is always a variable (instead
3611 -- of a constant). This is currently required to give support to late
3612 -- overriding of primitives. For example:
3614 -- procedure Example is
3616 -- type T1 is tagged null record;
3617 -- procedure Prim (O : T1);
3620 -- type T2 is new Pkg.T1 with null record;
3621 -- procedure Prim (X : T2) is -- late overriding
3627 function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is
3628 Loc : constant Source_Ptr := Sloc (Typ);
3630 Max_Predef_Prims : constant Int :=
3634 (Parent (RTE (RE_Max_Predef_Prims)))));
3636 DT_Decl : constant Elist_Id := New_Elmt_List;
3637 DT_Aggr : constant Elist_Id := New_Elmt_List;
3638 -- Entities marked with attribute Is_Dispatch_Table_Entity
3640 procedure Check_Premature_Freezing
3642 Tagged_Type : Entity_Id;
3644 -- Verify that all non-tagged types in the profile of a subprogram
3645 -- are frozen at the point the subprogram is frozen. This enforces
3646 -- the rule on RM 13.14 (14) as modified by AI05-019. At the point a
3647 -- subprogram is frozen, enough must be known about it to build the
3648 -- activation record for it, which requires at least that the size of
3649 -- all parameters be known. Controlling arguments are by-reference,
3650 -- and therefore the rule only applies to non-tagged types.
3651 -- Typical violation of the rule involves an object declaration that
3652 -- freezes a tagged type, when one of its primitive operations has a
3653 -- type in its profile whose full view has not been analyzed yet.
3654 -- More complex cases involve composite types that have one private
3655 -- unfrozen subcomponent.
3657 procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0);
3658 -- Export the dispatch table DT of tagged type Typ. Required to generate
3659 -- forward references and statically allocate the table. For primary
3660 -- dispatch tables Index is 0; for secondary dispatch tables the value
3661 -- of index must match the Suffix_Index value assigned to the table by
3662 -- Make_Tags when generating its unique external name, and it is used to
3663 -- retrieve from the Dispatch_Table_Wrappers list associated with Typ
3664 -- the external name generated by Import_DT.
3666 procedure Make_Secondary_DT
3670 Num_Iface_Prims : Nat;
3671 Iface_DT_Ptr : Entity_Id;
3672 Predef_Prims_Ptr : Entity_Id;
3673 Build_Thunks : Boolean;
3675 -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch
3676 -- Table of Typ associated with Iface. Each abstract interface of Typ
3677 -- has two secondary dispatch tables: one containing pointers to thunks
3678 -- and another containing pointers to the primitives covering the
3679 -- interface primitives. The former secondary table is generated when
3680 -- Build_Thunks is True, and provides common support for dispatching
3681 -- calls through interface types; the latter secondary table is
3682 -- generated when Build_Thunks is False, and provides support for
3683 -- Generic Dispatching Constructors that dispatch calls through
3684 -- interface types. When constructing this latter table the value of
3685 -- Suffix_Index is -1 to indicate that there is no need to export such
3686 -- table when building statically allocated dispatch tables; a positive
3687 -- value of Suffix_Index must match the Suffix_Index value assigned to
3688 -- this secondary dispatch table by Make_Tags when its unique external
3689 -- name was generated.
3691 ------------------------------
3692 -- Check_Premature_Freezing --
3693 ------------------------------
3695 procedure Check_Premature_Freezing
3697 Tagged_Type : Entity_Id;
3702 function Is_Actual_For_Formal_Incomplete_Type
3703 (T : Entity_Id) return Boolean;
3704 -- In Ada2012, if a nested generic has an incomplete formal type, the
3705 -- actual may be (and usually is) a private type whose completion
3706 -- appears later. It is safe to build the dispatch table in this
3707 -- case, gigi will have full views available.
3709 ------------------------------------------
3710 -- Is_Actual_For_Formal_Incomplete_Type --
3711 ------------------------------------------
3713 function Is_Actual_For_Formal_Incomplete_Type
3714 (T : Entity_Id) return Boolean
3716 Gen_Par : Entity_Id;
3720 if not Is_Generic_Instance (Current_Scope)
3721 or else not Used_As_Generic_Actual (T)
3726 Gen_Par := Generic_Parent (Parent (Current_Scope));
3731 (Generic_Formal_Declarations
3732 (Unit_Declaration_Node (Gen_Par)));
3733 while Present (F) loop
3734 if Ekind (Defining_Identifier (F)) = E_Incomplete_Type then
3742 end Is_Actual_For_Formal_Incomplete_Type;
3744 -- Start of processing for Check_Premature_Freezing
3748 and then Is_Private_Type (Typ)
3749 and then No (Full_View (Typ))
3750 and then not Is_Generic_Type (Typ)
3751 and then not Is_Tagged_Type (Typ)
3752 and then not Is_Frozen (Typ)
3754 Error_Msg_Sloc := Sloc (Subp);
3756 ("declaration must appear after completion of type &", N, Typ);
3758 ("\which is an untagged type in the profile of"
3759 & " primitive operation & declared#", N, Subp);
3762 Comp := Private_Component (Typ);
3764 if not Is_Tagged_Type (Typ)
3765 and then Present (Comp)
3766 and then not Is_Frozen (Comp)
3768 not Is_Actual_For_Formal_Incomplete_Type (Comp)
3770 Error_Msg_Sloc := Sloc (Subp);
3771 Error_Msg_Node_2 := Subp;
3772 Error_Msg_Name_1 := Chars (Tagged_Type);
3774 ("declaration must appear after completion of type &",
3777 ("\which is a component of untagged type& in the profile of"
3778 & " primitive & of type % that is frozen by the declaration ",
3782 end Check_Premature_Freezing;
3788 procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0)
3794 Set_Is_Statically_Allocated (DT);
3795 Set_Is_True_Constant (DT);
3796 Set_Is_Exported (DT);
3799 Elmt := First_Elmt (Dispatch_Table_Wrappers (Typ));
3800 while Count /= Index loop
3805 pragma Assert (Related_Type (Node (Elmt)) = Typ);
3808 (Entity => Node (Elmt),
3809 Has_Suffix => True);
3811 Set_Interface_Name (DT,
3812 Make_String_Literal (Loc,
3813 Strval => String_From_Name_Buffer));
3815 -- Ensure proper Sprint output of this implicit importation
3817 Set_Is_Internal (DT);
3821 -----------------------
3822 -- Make_Secondary_DT --
3823 -----------------------
3825 procedure Make_Secondary_DT
3829 Num_Iface_Prims : Nat;
3830 Iface_DT_Ptr : Entity_Id;
3831 Predef_Prims_Ptr : Entity_Id;
3832 Build_Thunks : Boolean;
3835 Loc : constant Source_Ptr := Sloc (Typ);
3836 Exporting_Table : constant Boolean :=
3837 Building_Static_DT (Typ)
3838 and then Suffix_Index > 0;
3839 Iface_DT : constant Entity_Id := Make_Temporary (Loc, 'T');
3840 Predef_Prims : constant Entity_Id := Make_Temporary (Loc, 'R');
3841 DT_Constr_List : List_Id;
3842 DT_Aggr_List : List_Id;
3843 Empty_DT : Boolean := False;
3844 Nb_Predef_Prims : Nat := 0;
3848 OSD_Aggr_List : List_Id;
3851 Prim_Elmt : Elmt_Id;
3852 Prim_Ops_Aggr_List : List_Id;
3855 -- Handle cases in which we do not generate statically allocated
3858 if not Building_Static_DT (Typ) then
3859 Set_Ekind (Predef_Prims, E_Variable);
3860 Set_Ekind (Iface_DT, E_Variable);
3862 -- Statically allocated dispatch tables and related entities are
3866 Set_Ekind (Predef_Prims, E_Constant);
3867 Set_Is_Statically_Allocated (Predef_Prims);
3868 Set_Is_True_Constant (Predef_Prims);
3870 Set_Ekind (Iface_DT, E_Constant);
3871 Set_Is_Statically_Allocated (Iface_DT);
3872 Set_Is_True_Constant (Iface_DT);
3875 -- Calculate the number of slots of the dispatch table. If the number
3876 -- of primitives of Typ is 0 we reserve a dummy single entry for its
3877 -- DT because at run time the pointer to this dummy entry will be
3880 if Num_Iface_Prims = 0 then
3884 Nb_Prim := Num_Iface_Prims;
3889 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
3890 -- (predef-prim-op-thunk-1'address,
3891 -- predef-prim-op-thunk-2'address,
3893 -- predef-prim-op-thunk-n'address);
3894 -- for Predef_Prims'Alignment use Address'Alignment
3896 -- Stage 1: Calculate the number of predefined primitives
3898 if not Building_Static_DT (Typ) then
3899 Nb_Predef_Prims := Max_Predef_Prims;
3901 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3902 while Present (Prim_Elmt) loop
3903 Prim := Node (Prim_Elmt);
3905 if Is_Predefined_Dispatching_Operation (Prim)
3906 and then not Is_Abstract_Subprogram (Prim)
3908 Pos := UI_To_Int (DT_Position (Prim));
3910 if Pos > Nb_Predef_Prims then
3911 Nb_Predef_Prims := Pos;
3915 Next_Elmt (Prim_Elmt);
3919 -- Stage 2: Create the thunks associated with the predefined
3920 -- primitives and save their entity to fill the aggregate.
3923 Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
3925 Thunk_Id : Entity_Id;
3926 Thunk_Code : Node_Id;
3929 Prim_Ops_Aggr_List := New_List;
3930 Prim_Table := (others => Empty);
3932 if Building_Static_DT (Typ) then
3933 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3934 while Present (Prim_Elmt) loop
3935 Prim := Node (Prim_Elmt);
3937 if Is_Predefined_Dispatching_Operation (Prim)
3938 and then not Is_Abstract_Subprogram (Prim)
3939 and then not Is_Eliminated (Prim)
3940 and then not Present (Prim_Table
3941 (UI_To_Int (DT_Position (Prim))))
3943 if not Build_Thunks then
3944 Prim_Table (UI_To_Int (DT_Position (Prim))) :=
3948 Expand_Interface_Thunk
3949 (Ultimate_Alias (Prim), Thunk_Id, Thunk_Code);
3951 if Present (Thunk_Id) then
3952 Append_To (Result, Thunk_Code);
3953 Prim_Table (UI_To_Int (DT_Position (Prim)))
3959 Next_Elmt (Prim_Elmt);
3963 for J in Prim_Table'Range loop
3964 if Present (Prim_Table (J)) then
3966 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
3967 Make_Attribute_Reference (Loc,
3968 Prefix => New_Reference_To (Prim_Table (J), Loc),
3969 Attribute_Name => Name_Unrestricted_Access));
3971 New_Node := Make_Null (Loc);
3974 Append_To (Prim_Ops_Aggr_List, New_Node);
3978 Make_Aggregate (Loc,
3979 Expressions => Prim_Ops_Aggr_List);
3981 -- Remember aggregates initializing dispatch tables
3983 Append_Elmt (New_Node, DT_Aggr);
3986 Make_Subtype_Declaration (Loc,
3987 Defining_Identifier => Make_Temporary (Loc, 'S'),
3988 Subtype_Indication =>
3989 New_Reference_To (RTE (RE_Address_Array), Loc));
3991 Append_To (Result, Decl);
3994 Make_Object_Declaration (Loc,
3995 Defining_Identifier => Predef_Prims,
3996 Constant_Present => Building_Static_DT (Typ),
3997 Aliased_Present => True,
3998 Object_Definition => New_Reference_To
3999 (Defining_Identifier (Decl), Loc),
4000 Expression => New_Node));
4003 Make_Attribute_Definition_Clause (Loc,
4004 Name => New_Reference_To (Predef_Prims, Loc),
4005 Chars => Name_Alignment,
4007 Make_Attribute_Reference (Loc,
4009 New_Reference_To (RTE (RE_Integer_Address), Loc),
4010 Attribute_Name => Name_Alignment)));
4015 -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
4016 -- (OSD_Table => (1 => <value>,
4020 -- Iface_DT : Dispatch_Table (Nb_Prims) :=
4021 -- ([ Signature => <sig-value> ],
4022 -- Tag_Kind => <tag_kind-value>,
4023 -- Predef_Prims => Predef_Prims'Address,
4024 -- Offset_To_Top => 0,
4025 -- OSD => OSD'Address,
4026 -- Prims_Ptr => (prim-op-1'address,
4027 -- prim-op-2'address,
4029 -- prim-op-n'address));
4030 -- for Iface_DT'Alignment use Address'Alignment;
4032 -- Stage 3: Initialize the discriminant and the record components
4034 DT_Constr_List := New_List;
4035 DT_Aggr_List := New_List;
4037 -- Nb_Prim. If the tagged type has no primitives we add a dummy
4038 -- slot whose address will be the tag of this type.
4041 New_Node := Make_Integer_Literal (Loc, 1);
4043 New_Node := Make_Integer_Literal (Loc, Nb_Prim);
4046 Append_To (DT_Constr_List, New_Node);
4047 Append_To (DT_Aggr_List, New_Copy (New_Node));
4051 if RTE_Record_Component_Available (RE_Signature) then
4052 Append_To (DT_Aggr_List,
4053 New_Reference_To (RTE (RE_Secondary_DT), Loc));
4058 if RTE_Record_Component_Available (RE_Tag_Kind) then
4059 Append_To (DT_Aggr_List, Tagged_Kind (Typ));
4064 Append_To (DT_Aggr_List,
4065 Make_Attribute_Reference (Loc,
4066 Prefix => New_Reference_To (Predef_Prims, Loc),
4067 Attribute_Name => Name_Address));
4069 -- Note: The correct value of Offset_To_Top will be set by the init
4072 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
4074 -- Generate the Object Specific Data table required to dispatch calls
4075 -- through synchronized interfaces.
4078 or else Is_Abstract_Type (Typ)
4079 or else Is_Controlled (Typ)
4080 or else Restriction_Active (No_Dispatching_Calls)
4081 or else not Is_Limited_Type (Typ)
4082 or else not Has_Interfaces (Typ)
4083 or else not Build_Thunks
4084 or else not RTE_Record_Component_Available (RE_OSD_Table)
4086 -- No OSD table required
4088 Append_To (DT_Aggr_List,
4089 New_Reference_To (RTE (RE_Null_Address), Loc));
4092 OSD_Aggr_List := New_List;
4095 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
4097 Prim_Alias : Entity_Id;
4098 Prim_Elmt : Elmt_Id;
4104 Prim_Table := (others => Empty);
4105 Prim_Alias := Empty;
4107 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4108 while Present (Prim_Elmt) loop
4109 Prim := Node (Prim_Elmt);
4111 if Present (Interface_Alias (Prim))
4112 and then Find_Dispatching_Type
4113 (Interface_Alias (Prim)) = Iface
4115 Prim_Alias := Interface_Alias (Prim);
4116 E := Ultimate_Alias (Prim);
4117 Pos := UI_To_Int (DT_Position (Prim_Alias));
4119 if Present (Prim_Table (Pos)) then
4120 pragma Assert (Prim_Table (Pos) = E);
4124 Prim_Table (Pos) := E;
4126 Append_To (OSD_Aggr_List,
4127 Make_Component_Association (Loc,
4128 Choices => New_List (
4129 Make_Integer_Literal (Loc,
4130 DT_Position (Prim_Alias))),
4132 Make_Integer_Literal (Loc,
4133 DT_Position (Alias (Prim)))));
4139 Next_Elmt (Prim_Elmt);
4141 pragma Assert (Count = Nb_Prim);
4144 OSD := Make_Temporary (Loc, 'I');
4147 Make_Object_Declaration (Loc,
4148 Defining_Identifier => OSD,
4149 Object_Definition =>
4150 Make_Subtype_Indication (Loc,
4152 New_Reference_To (RTE (RE_Object_Specific_Data), Loc),
4154 Make_Index_Or_Discriminant_Constraint (Loc,
4155 Constraints => New_List (
4156 Make_Integer_Literal (Loc, Nb_Prim)))),
4159 Make_Aggregate (Loc,
4160 Component_Associations => New_List (
4161 Make_Component_Association (Loc,
4162 Choices => New_List (
4164 (RTE_Record_Component (RE_OSD_Num_Prims), Loc)),
4166 Make_Integer_Literal (Loc, Nb_Prim)),
4168 Make_Component_Association (Loc,
4169 Choices => New_List (
4171 (RTE_Record_Component (RE_OSD_Table), Loc)),
4172 Expression => Make_Aggregate (Loc,
4173 Component_Associations => OSD_Aggr_List))))));
4176 Make_Attribute_Definition_Clause (Loc,
4177 Name => New_Reference_To (OSD, Loc),
4178 Chars => Name_Alignment,
4180 Make_Attribute_Reference (Loc,
4182 New_Reference_To (RTE (RE_Integer_Address), Loc),
4183 Attribute_Name => Name_Alignment)));
4185 -- In secondary dispatch tables the Typeinfo component contains
4186 -- the address of the Object Specific Data (see a-tags.ads)
4188 Append_To (DT_Aggr_List,
4189 Make_Attribute_Reference (Loc,
4190 Prefix => New_Reference_To (OSD, Loc),
4191 Attribute_Name => Name_Address));
4194 -- Initialize the table of primitive operations
4196 Prim_Ops_Aggr_List := New_List;
4199 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
4201 elsif Is_Abstract_Type (Typ)
4202 or else not Building_Static_DT (Typ)
4204 for J in 1 .. Nb_Prim loop
4205 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
4210 CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
4213 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
4214 Thunk_Code : Node_Id;
4215 Thunk_Id : Entity_Id;
4218 Prim_Table := (others => Empty);
4220 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4221 while Present (Prim_Elmt) loop
4222 Prim := Node (Prim_Elmt);
4223 E := Ultimate_Alias (Prim);
4224 Prim_Pos := UI_To_Int (DT_Position (E));
4226 -- Do not reference predefined primitives because they are
4227 -- located in a separate dispatch table; skip abstract and
4228 -- eliminated primitives; skip primitives located in the C++
4229 -- part of the dispatch table because their slot is set by
4232 if not Is_Predefined_Dispatching_Operation (Prim)
4233 and then Present (Interface_Alias (Prim))
4234 and then not Is_Abstract_Subprogram (Alias (Prim))
4235 and then not Is_Eliminated (Alias (Prim))
4236 and then (not Is_CPP_Class (Root_Type (Typ))
4237 or else Prim_Pos > CPP_Nb_Prims)
4238 and then Find_Dispatching_Type
4239 (Interface_Alias (Prim)) = Iface
4241 -- Generate the code of the thunk only if the abstract
4242 -- interface type is not an immediate ancestor of
4243 -- Tagged_Type. Otherwise the DT associated with the
4244 -- interface is the primary DT.
4246 and then not Is_Ancestor (Iface, Typ,
4247 Use_Full_View => True)
4249 if not Build_Thunks then
4251 UI_To_Int (DT_Position (Interface_Alias (Prim)));
4252 Prim_Table (Prim_Pos) := Alias (Prim);
4255 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
4257 if Present (Thunk_Id) then
4259 UI_To_Int (DT_Position (Interface_Alias (Prim)));
4261 Prim_Table (Prim_Pos) := Thunk_Id;
4262 Append_To (Result, Thunk_Code);
4267 Next_Elmt (Prim_Elmt);
4270 for J in Prim_Table'Range loop
4271 if Present (Prim_Table (J)) then
4273 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
4274 Make_Attribute_Reference (Loc,
4275 Prefix => New_Reference_To (Prim_Table (J), Loc),
4276 Attribute_Name => Name_Unrestricted_Access));
4279 New_Node := Make_Null (Loc);
4282 Append_To (Prim_Ops_Aggr_List, New_Node);
4288 Make_Aggregate (Loc,
4289 Expressions => Prim_Ops_Aggr_List);
4291 Append_To (DT_Aggr_List, New_Node);
4293 -- Remember aggregates initializing dispatch tables
4295 Append_Elmt (New_Node, DT_Aggr);
4297 -- Note: Secondary dispatch tables cannot be declared constant
4298 -- because the component Offset_To_Top is currently initialized
4299 -- by the IP routine.
4302 Make_Object_Declaration (Loc,
4303 Defining_Identifier => Iface_DT,
4304 Aliased_Present => True,
4305 Constant_Present => False,
4307 Object_Definition =>
4308 Make_Subtype_Indication (Loc,
4309 Subtype_Mark => New_Reference_To
4310 (RTE (RE_Dispatch_Table_Wrapper), Loc),
4311 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
4312 Constraints => DT_Constr_List)),
4315 Make_Aggregate (Loc,
4316 Expressions => DT_Aggr_List)));
4319 Make_Attribute_Definition_Clause (Loc,
4320 Name => New_Reference_To (Iface_DT, Loc),
4321 Chars => Name_Alignment,
4324 Make_Attribute_Reference (Loc,
4326 New_Reference_To (RTE (RE_Integer_Address), Loc),
4327 Attribute_Name => Name_Alignment)));
4329 if Exporting_Table then
4330 Export_DT (Typ, Iface_DT, Suffix_Index);
4332 -- Generate code to create the pointer to the dispatch table
4334 -- Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address);
4336 -- Note: This declaration is not added here if the table is exported
4337 -- because in such case Make_Tags has already added this declaration.
4341 Make_Object_Declaration (Loc,
4342 Defining_Identifier => Iface_DT_Ptr,
4343 Constant_Present => True,
4345 Object_Definition =>
4346 New_Reference_To (RTE (RE_Interface_Tag), Loc),
4349 Unchecked_Convert_To (RTE (RE_Interface_Tag),
4350 Make_Attribute_Reference (Loc,
4352 Make_Selected_Component (Loc,
4353 Prefix => New_Reference_To (Iface_DT, Loc),
4356 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
4357 Attribute_Name => Name_Address))));
4361 Make_Object_Declaration (Loc,
4362 Defining_Identifier => Predef_Prims_Ptr,
4363 Constant_Present => True,
4365 Object_Definition =>
4366 New_Reference_To (RTE (RE_Address), Loc),
4369 Make_Attribute_Reference (Loc,
4371 Make_Selected_Component (Loc,
4372 Prefix => New_Reference_To (Iface_DT, Loc),
4375 (RTE_Record_Component (RE_Predef_Prims), Loc)),
4376 Attribute_Name => Name_Address)));
4378 -- Remember entities containing dispatch tables
4380 Append_Elmt (Predef_Prims, DT_Decl);
4381 Append_Elmt (Iface_DT, DT_Decl);
4382 end Make_Secondary_DT;
4386 Elab_Code : constant List_Id := New_List;
4387 Result : constant List_Id := New_List;
4388 Tname : constant Name_Id := Chars (Typ);
4390 AI_Tag_Elmt : Elmt_Id;
4391 AI_Tag_Comp : Elmt_Id;
4392 DT_Aggr_List : List_Id;
4393 DT_Constr_List : List_Id;
4397 Iface_Table_Node : Node_Id;
4398 Name_ITable : Name_Id;
4399 Nb_Predef_Prims : Nat := 0;
4402 Num_Ifaces : Nat := 0;
4403 Parent_Typ : Entity_Id;
4405 Prim_Elmt : Elmt_Id;
4406 Prim_Ops_Aggr_List : List_Id;
4408 Typ_Comps : Elist_Id;
4409 Typ_Ifaces : Elist_Id;
4410 TSD_Aggr_List : List_Id;
4411 TSD_Tags_List : List_Id;
4413 -- The following name entries are used by Make_DT to generate a number
4414 -- of entities related to a tagged type. These entities may be generated
4415 -- in a scope other than that of the tagged type declaration, and if
4416 -- the entities for two tagged types with the same name happen to be
4417 -- generated in the same scope, we have to take care to use different
4418 -- names. This is achieved by means of a unique serial number appended
4419 -- to each generated entity name.
4421 Name_DT : constant Name_Id :=
4422 New_External_Name (Tname, 'T', Suffix_Index => -1);
4423 Name_Exname : constant Name_Id :=
4424 New_External_Name (Tname, 'E', Suffix_Index => -1);
4425 Name_HT_Link : constant Name_Id :=
4426 New_External_Name (Tname, 'H', Suffix_Index => -1);
4427 Name_Predef_Prims : constant Name_Id :=
4428 New_External_Name (Tname, 'R', Suffix_Index => -1);
4429 Name_SSD : constant Name_Id :=
4430 New_External_Name (Tname, 'S', Suffix_Index => -1);
4431 Name_TSD : constant Name_Id :=
4432 New_External_Name (Tname, 'B', Suffix_Index => -1);
4434 -- Entities built with above names
4436 DT : constant Entity_Id :=
4437 Make_Defining_Identifier (Loc, Name_DT);
4438 Exname : constant Entity_Id :=
4439 Make_Defining_Identifier (Loc, Name_Exname);
4440 HT_Link : constant Entity_Id :=
4441 Make_Defining_Identifier (Loc, Name_HT_Link);
4442 Predef_Prims : constant Entity_Id :=
4443 Make_Defining_Identifier (Loc, Name_Predef_Prims);
4444 SSD : constant Entity_Id :=
4445 Make_Defining_Identifier (Loc, Name_SSD);
4446 TSD : constant Entity_Id :=
4447 Make_Defining_Identifier (Loc, Name_TSD);
4449 -- Start of processing for Make_DT
4452 pragma Assert (Is_Frozen (Typ));
4454 -- Handle cases in which there is no need to build the dispatch table
4456 if Has_Dispatch_Table (Typ)
4457 or else No (Access_Disp_Table (Typ))
4458 or else Is_CPP_Class (Typ)
4459 or else Convention (Typ) = Convention_CIL
4460 or else Convention (Typ) = Convention_Java
4464 elsif No_Run_Time_Mode then
4465 Error_Msg_CRT ("tagged types", Typ);
4468 elsif not RTE_Available (RE_Tag) then
4470 Make_Object_Declaration (Loc,
4471 Defining_Identifier => Node (First_Elmt
4472 (Access_Disp_Table (Typ))),
4473 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
4474 Constant_Present => True,
4476 Unchecked_Convert_To (RTE (RE_Tag),
4477 New_Reference_To (RTE (RE_Null_Address), Loc))));
4479 Analyze_List (Result, Suppress => All_Checks);
4480 Error_Msg_CRT ("tagged types", Typ);
4484 -- Ensure that the value of Max_Predef_Prims defined in a-tags is
4485 -- correct. Valid values are 10 under configurable runtime or 16
4486 -- with full runtime.
4488 if RTE_Available (RE_Interface_Data) then
4489 if Max_Predef_Prims /= 16 then
4490 Error_Msg_N ("run-time library configuration error", Typ);
4494 if Max_Predef_Prims /= 10 then
4495 Error_Msg_N ("run-time library configuration error", Typ);
4496 Error_Msg_CRT ("tagged types", Typ);
4501 -- Initialize Parent_Typ handling private types
4503 Parent_Typ := Etype (Typ);
4505 if Present (Full_View (Parent_Typ)) then
4506 Parent_Typ := Full_View (Parent_Typ);
4509 -- Ensure that all the primitives are frozen. This is only required when
4510 -- building static dispatch tables --- the primitives must be frozen to
4511 -- be referenced (otherwise we have problems with the backend). It is
4512 -- not a requirement with nonstatic dispatch tables because in this case
4513 -- we generate now an empty dispatch table; the extra code required to
4514 -- register the primitives in the slots will be generated later --- when
4515 -- each primitive is frozen (see Freeze_Subprogram).
4517 if Building_Static_DT (Typ) then
4519 Save : constant Boolean := Freezing_Library_Level_Tagged_Type;
4521 Prim_Elmt : Elmt_Id;
4525 Freezing_Library_Level_Tagged_Type := True;
4527 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4528 while Present (Prim_Elmt) loop
4529 Prim := Node (Prim_Elmt);
4530 Frnodes := Freeze_Entity (Prim, Typ);
4536 F := First_Formal (Prim);
4537 while Present (F) loop
4538 Check_Premature_Freezing (Prim, Typ, Etype (F));
4542 Check_Premature_Freezing (Prim, Typ, Etype (Prim));
4545 if Present (Frnodes) then
4546 Append_List_To (Result, Frnodes);
4549 Next_Elmt (Prim_Elmt);
4552 Freezing_Library_Level_Tagged_Type := Save;
4556 -- Ada 2005 (AI-251): Build the secondary dispatch tables
4558 if Has_Interfaces (Typ) then
4559 Collect_Interface_Components (Typ, Typ_Comps);
4561 -- Each secondary dispatch table is assigned an unique positive
4562 -- suffix index; such value also corresponds with the location of
4563 -- its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
4565 -- Note: This value must be kept sync with the Suffix_Index values
4566 -- generated by Make_Tags
4570 Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
4572 AI_Tag_Comp := First_Elmt (Typ_Comps);
4573 while Present (AI_Tag_Comp) loop
4574 pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'P'));
4576 -- Build the secondary table containing pointers to thunks
4580 Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))),
4581 Suffix_Index => Suffix_Index,
4582 Num_Iface_Prims => UI_To_Int
4583 (DT_Entry_Count (Node (AI_Tag_Comp))),
4584 Iface_DT_Ptr => Node (AI_Tag_Elmt),
4585 Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
4586 Build_Thunks => True,
4589 -- Skip secondary dispatch table referencing thunks to predefined
4592 Next_Elmt (AI_Tag_Elmt);
4593 pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Y'));
4595 -- Secondary dispatch table referencing user-defined primitives
4596 -- covered by this interface.
4598 Next_Elmt (AI_Tag_Elmt);
4599 pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'D'));
4601 -- Build the secondary table containing pointers to primitives
4602 -- (used to give support to Generic Dispatching Constructors).
4607 (Related_Type (Node (AI_Tag_Comp))),
4609 Num_Iface_Prims => UI_To_Int
4610 (DT_Entry_Count (Node (AI_Tag_Comp))),
4611 Iface_DT_Ptr => Node (AI_Tag_Elmt),
4612 Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
4613 Build_Thunks => False,
4616 -- Skip secondary dispatch table referencing predefined primitives
4618 Next_Elmt (AI_Tag_Elmt);
4619 pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Z'));
4621 Suffix_Index := Suffix_Index + 1;
4622 Next_Elmt (AI_Tag_Elmt);
4623 Next_Elmt (AI_Tag_Comp);
4627 -- Get the _tag entity and number of primitives of its dispatch table
4629 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
4630 Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
4632 Set_Is_Statically_Allocated (DT, Is_Library_Level_Tagged_Type (Typ));
4633 Set_Is_Statically_Allocated (SSD, Is_Library_Level_Tagged_Type (Typ));
4634 Set_Is_Statically_Allocated (TSD, Is_Library_Level_Tagged_Type (Typ));
4635 Set_Is_Statically_Allocated (Predef_Prims,
4636 Is_Library_Level_Tagged_Type (Typ));
4638 -- In case of locally defined tagged type we declare the object
4639 -- containing the dispatch table by means of a variable. Its
4640 -- initialization is done later by means of an assignment. This is
4641 -- required to generate its External_Tag.
4643 if not Building_Static_DT (Typ) then
4646 -- DT : No_Dispatch_Table_Wrapper;
4647 -- for DT'Alignment use Address'Alignment;
4648 -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
4650 if not Has_DT (Typ) then
4652 Make_Object_Declaration (Loc,
4653 Defining_Identifier => DT,
4654 Aliased_Present => True,
4655 Constant_Present => False,
4656 Object_Definition =>
4658 (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
4661 Make_Attribute_Definition_Clause (Loc,
4662 Name => New_Reference_To (DT, Loc),
4663 Chars => Name_Alignment,
4665 Make_Attribute_Reference (Loc,
4667 New_Reference_To (RTE (RE_Integer_Address), Loc),
4668 Attribute_Name => Name_Alignment)));
4671 Make_Object_Declaration (Loc,
4672 Defining_Identifier => DT_Ptr,
4673 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
4674 Constant_Present => True,
4676 Unchecked_Convert_To (RTE (RE_Tag),
4677 Make_Attribute_Reference (Loc,
4679 Make_Selected_Component (Loc,
4680 Prefix => New_Reference_To (DT, Loc),
4683 (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
4684 Attribute_Name => Name_Address))));
4686 Set_Is_Statically_Allocated (DT_Ptr,
4687 Is_Library_Level_Tagged_Type (Typ));
4689 -- Generate the SCIL node for the previous object declaration
4690 -- because it has a tag initialization.
4692 if Generate_SCIL then
4694 Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
4695 Set_SCIL_Entity (New_Node, Typ);
4696 Set_SCIL_Node (Last (Result), New_Node);
4700 -- DT : Dispatch_Table_Wrapper (Nb_Prim);
4701 -- for DT'Alignment use Address'Alignment;
4702 -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
4705 -- If the tagged type has no primitives we add a dummy slot
4706 -- whose address will be the tag of this type.
4710 New_List (Make_Integer_Literal (Loc, 1));
4713 New_List (Make_Integer_Literal (Loc, Nb_Prim));
4717 Make_Object_Declaration (Loc,
4718 Defining_Identifier => DT,
4719 Aliased_Present => True,
4720 Constant_Present => False,
4721 Object_Definition =>
4722 Make_Subtype_Indication (Loc,
4724 New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc),
4725 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
4726 Constraints => DT_Constr_List))));
4729 Make_Attribute_Definition_Clause (Loc,
4730 Name => New_Reference_To (DT, Loc),
4731 Chars => Name_Alignment,
4733 Make_Attribute_Reference (Loc,
4735 New_Reference_To (RTE (RE_Integer_Address), Loc),
4736 Attribute_Name => Name_Alignment)));
4739 Make_Object_Declaration (Loc,
4740 Defining_Identifier => DT_Ptr,
4741 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
4742 Constant_Present => True,
4744 Unchecked_Convert_To (RTE (RE_Tag),
4745 Make_Attribute_Reference (Loc,
4747 Make_Selected_Component (Loc,
4748 Prefix => New_Reference_To (DT, Loc),
4751 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
4752 Attribute_Name => Name_Address))));
4754 Set_Is_Statically_Allocated (DT_Ptr,
4755 Is_Library_Level_Tagged_Type (Typ));
4757 -- Generate the SCIL node for the previous object declaration
4758 -- because it has a tag initialization.
4760 if Generate_SCIL then
4762 Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
4763 Set_SCIL_Entity (New_Node, Typ);
4764 Set_SCIL_Node (Last (Result), New_Node);
4768 Make_Object_Declaration (Loc,
4769 Defining_Identifier =>
4770 Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))),
4771 Constant_Present => True,
4772 Object_Definition => New_Reference_To
4773 (RTE (RE_Address), Loc),
4775 Make_Attribute_Reference (Loc,
4777 Make_Selected_Component (Loc,
4778 Prefix => New_Reference_To (DT, Loc),
4781 (RTE_Record_Component (RE_Predef_Prims), Loc)),
4782 Attribute_Name => Name_Address)));
4786 -- Generate: Exname : constant String := full_qualified_name (typ);
4787 -- The type itself may be an anonymous parent type, so use the first
4788 -- subtype to have a user-recognizable name.
4791 Make_Object_Declaration (Loc,
4792 Defining_Identifier => Exname,
4793 Constant_Present => True,
4794 Object_Definition => New_Reference_To (Standard_String, Loc),
4796 Make_String_Literal (Loc,
4797 Fully_Qualified_Name_String (First_Subtype (Typ)))));
4799 Set_Is_Statically_Allocated (Exname);
4800 Set_Is_True_Constant (Exname);
4802 -- Declare the object used by Ada.Tags.Register_Tag
4804 if RTE_Available (RE_Register_Tag) then
4806 Make_Object_Declaration (Loc,
4807 Defining_Identifier => HT_Link,
4808 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc)));
4811 -- Generate code to create the storage for the type specific data object
4812 -- with enough space to store the tags of the ancestors plus the tags
4813 -- of all the implemented interfaces (as described in a-tags.adb).
4815 -- TSD : Type_Specific_Data (I_Depth) :=
4816 -- (Idepth => I_Depth,
4817 -- Access_Level => Type_Access_Level (Typ),
4818 -- Expanded_Name => Cstring_Ptr!(Exname'Address))
4819 -- External_Tag => Cstring_Ptr!(Exname'Address))
4820 -- HT_Link => HT_Link'Address,
4821 -- Transportable => <<boolean-value>>,
4822 -- Type_Is_Abstract => <<boolean-value>>,
4823 -- Needs_Finalization => <<boolean-value>>,
4824 -- [ Size_Func => Size_Prim'Access ]
4825 -- [ Interfaces_Table => <<access-value>> ]
4826 -- [ SSD => SSD_Table'Address ]
4827 -- Tags_Table => (0 => null,
4830 -- for TSD'Alignment use Address'Alignment
4832 TSD_Aggr_List := New_List;
4834 -- Idepth: Count ancestors to compute the inheritance depth. For private
4835 -- extensions, always go to the full view in order to compute the real
4836 -- inheritance depth.
4839 Current_Typ : Entity_Id;
4840 Parent_Typ : Entity_Id;
4846 Parent_Typ := Etype (Current_Typ);
4848 if Is_Private_Type (Parent_Typ) then
4849 Parent_Typ := Full_View (Base_Type (Parent_Typ));
4852 exit when Parent_Typ = Current_Typ;
4854 I_Depth := I_Depth + 1;
4855 Current_Typ := Parent_Typ;
4859 Append_To (TSD_Aggr_List,
4860 Make_Integer_Literal (Loc, I_Depth));
4864 Append_To (TSD_Aggr_List,
4865 Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
4869 Append_To (TSD_Aggr_List,
4870 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4871 Make_Attribute_Reference (Loc,
4872 Prefix => New_Reference_To (Exname, Loc),
4873 Attribute_Name => Name_Address)));
4875 -- External_Tag of a local tagged type
4877 -- <typ>A : constant String :=
4878 -- "Internal tag at 16#tag-addr#: <full-name-of-typ>";
4880 -- The reason we generate this strange name is that we do not want to
4881 -- enter local tagged types in the global hash table used to compute
4882 -- the Internal_Tag attribute for two reasons:
4884 -- 1. It is hard to avoid a tasking race condition for entering the
4885 -- entry into the hash table.
4887 -- 2. It would cause a storage leak, unless we rig up considerable
4888 -- mechanism to remove the entry from the hash table on exit.
4890 -- So what we do is to generate the above external tag name, where the
4891 -- hex address is the address of the local dispatch table (i.e. exactly
4892 -- the value we want if Internal_Tag is computed from this string).
4894 -- Of course this value will only be valid if the tagged type is still
4895 -- in scope, but it clearly must be erroneous to compute the internal
4896 -- tag of a tagged type that is out of scope!
4898 -- We don't do this processing if an explicit external tag has been
4899 -- specified. That's an odd case for which we have already issued a
4900 -- warning, where we will not be able to compute the internal tag.
4902 if not Is_Library_Level_Entity (Typ)
4903 and then not Has_External_Tag_Rep_Clause (Typ)
4906 Exname : constant Entity_Id :=
4907 Make_Defining_Identifier (Loc,
4908 New_External_Name (Tname, 'A'));
4910 Full_Name : constant String_Id :=
4911 Fully_Qualified_Name_String (First_Subtype (Typ));
4912 Str1_Id : String_Id;
4913 Str2_Id : String_Id;
4917 -- Str1 = "Internal tag at 16#";
4920 Store_String_Chars ("Internal tag at 16#");
4921 Str1_Id := End_String;
4924 -- Str2 = "#: <type-full-name>";
4927 Store_String_Chars ("#: ");
4928 Store_String_Chars (Full_Name);
4929 Str2_Id := End_String;
4932 -- Exname : constant String :=
4933 -- Str1 & Address_Image (Tag) & Str2;
4935 if RTE_Available (RE_Address_Image) then
4937 Make_Object_Declaration (Loc,
4938 Defining_Identifier => Exname,
4939 Constant_Present => True,
4940 Object_Definition => New_Reference_To
4941 (Standard_String, Loc),
4943 Make_Op_Concat (Loc,
4945 Make_String_Literal (Loc, Str1_Id),
4947 Make_Op_Concat (Loc,
4949 Make_Function_Call (Loc,
4952 (RTE (RE_Address_Image), Loc),
4953 Parameter_Associations => New_List (
4954 Unchecked_Convert_To (RTE (RE_Address),
4955 New_Reference_To (DT_Ptr, Loc)))),
4957 Make_String_Literal (Loc, Str2_Id)))));
4961 Make_Object_Declaration (Loc,
4962 Defining_Identifier => Exname,
4963 Constant_Present => True,
4964 Object_Definition => New_Reference_To
4965 (Standard_String, Loc),
4967 Make_Op_Concat (Loc,
4969 Make_String_Literal (Loc, Str1_Id),
4971 Make_String_Literal (Loc, Str2_Id))));
4975 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4976 Make_Attribute_Reference (Loc,
4977 Prefix => New_Reference_To (Exname, Loc),
4978 Attribute_Name => Name_Address));
4981 -- External tag of a library-level tagged type: Check for a definition
4982 -- of External_Tag. The clause is considered only if it applies to this
4983 -- specific tagged type, as opposed to one of its ancestors.
4984 -- If the type is an unconstrained type extension, we are building the
4985 -- dispatch table of its anonymous base type, so the external tag, if
4986 -- any was specified, must be retrieved from the first subtype. Go to
4987 -- the full view in case the clause is in the private part.
4991 Def : constant Node_Id := Get_Attribute_Definition_Clause
4992 (Underlying_Type (First_Subtype (Typ)),
4993 Attribute_External_Tag);
4995 Old_Val : String_Id;
4996 New_Val : String_Id;
5000 if not Present (Def)
5001 or else Entity (Name (Def)) /= First_Subtype (Typ)
5004 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5005 Make_Attribute_Reference (Loc,
5006 Prefix => New_Reference_To (Exname, Loc),
5007 Attribute_Name => Name_Address));
5009 Old_Val := Strval (Expr_Value_S (Expression (Def)));
5011 -- For the rep clause "for <typ>'external_tag use y" generate:
5013 -- <typ>A : constant string := y;
5015 -- <typ>A'Address is used to set the External_Tag component
5018 -- Create a new nul terminated string if it is not already
5020 if String_Length (Old_Val) > 0
5022 Get_String_Char (Old_Val, String_Length (Old_Val)) = 0
5026 Start_String (Old_Val);
5027 Store_String_Char (Get_Char_Code (ASCII.NUL));
5028 New_Val := End_String;
5031 E := Make_Defining_Identifier (Loc,
5032 New_External_Name (Chars (Typ), 'A'));
5035 Make_Object_Declaration (Loc,
5036 Defining_Identifier => E,
5037 Constant_Present => True,
5038 Object_Definition =>
5039 New_Reference_To (Standard_String, Loc),
5041 Make_String_Literal (Loc, New_Val)));
5044 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5045 Make_Attribute_Reference (Loc,
5046 Prefix => New_Reference_To (E, Loc),
5047 Attribute_Name => Name_Address));
5052 Append_To (TSD_Aggr_List, New_Node);
5056 if RTE_Available (RE_Register_Tag) then
5057 Append_To (TSD_Aggr_List,
5058 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
5059 Make_Attribute_Reference (Loc,
5060 Prefix => New_Reference_To (HT_Link, Loc),
5061 Attribute_Name => Name_Address)));
5063 Append_To (TSD_Aggr_List,
5064 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
5065 New_Reference_To (RTE (RE_Null_Address), Loc)));
5068 -- Transportable: Set for types that can be used in remote calls
5069 -- with respect to E.4(18) legality rules.
5072 Transportable : Entity_Id;
5078 or else Is_Shared_Passive (Typ)
5080 ((Is_Remote_Types (Typ)
5081 or else Is_Remote_Call_Interface (Typ))
5082 and then Original_View_In_Visible_Part (Typ))
5083 or else not Comes_From_Source (Typ));
5085 Append_To (TSD_Aggr_List,
5086 New_Occurrence_Of (Transportable, Loc));
5089 -- Type_Is_Abstract (Ada 2012: AI05-0173). This functionality is
5090 -- not available in the HIE runtime.
5092 if RTE_Record_Component_Available (RE_Type_Is_Abstract) then
5094 Type_Is_Abstract : Entity_Id;
5098 Boolean_Literals (Is_Abstract_Type (Typ));
5100 Append_To (TSD_Aggr_List,
5101 New_Occurrence_Of (Type_Is_Abstract, Loc));
5105 -- Needs_Finalization: Set if the type is controlled or has controlled
5109 Needs_Fin : Entity_Id;
5112 Needs_Fin := Boolean_Literals (Needs_Finalization (Typ));
5113 Append_To (TSD_Aggr_List, New_Occurrence_Of (Needs_Fin, Loc));
5118 if RTE_Record_Component_Available (RE_Size_Func) then
5120 -- Initialize this field to Null_Address if we are not building
5121 -- static dispatch tables static or if the size function is not
5122 -- available. In the former case we cannot initialize this field
5123 -- until the function is frozen and registered in the dispatch
5124 -- table (see Register_Primitive).
5126 if not Building_Static_DT (Typ) or else not Has_DT (Typ) then
5127 Append_To (TSD_Aggr_List,
5128 Unchecked_Convert_To (RTE (RE_Size_Ptr),
5129 New_Reference_To (RTE (RE_Null_Address), Loc)));
5133 Prim_Elmt : Elmt_Id;
5135 Size_Comp : Node_Id;
5138 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5139 while Present (Prim_Elmt) loop
5140 Prim := Node (Prim_Elmt);
5142 if Chars (Prim) = Name_uSize then
5143 Prim := Ultimate_Alias (Prim);
5145 if Is_Abstract_Subprogram (Prim) then
5147 Unchecked_Convert_To (RTE (RE_Size_Ptr),
5148 New_Reference_To (RTE (RE_Null_Address), Loc));
5151 Unchecked_Convert_To (RTE (RE_Size_Ptr),
5152 Make_Attribute_Reference (Loc,
5153 Prefix => New_Reference_To (Prim, Loc),
5154 Attribute_Name => Name_Unrestricted_Access));
5160 Next_Elmt (Prim_Elmt);
5163 pragma Assert (Present (Size_Comp));
5164 Append_To (TSD_Aggr_List, Size_Comp);
5169 -- Interfaces_Table (required for AI-405)
5171 if RTE_Record_Component_Available (RE_Interfaces_Table) then
5173 -- Count the number of interface types implemented by Typ
5175 Collect_Interfaces (Typ, Typ_Ifaces);
5177 AI := First_Elmt (Typ_Ifaces);
5178 while Present (AI) loop
5179 Num_Ifaces := Num_Ifaces + 1;
5183 if Num_Ifaces = 0 then
5184 Iface_Table_Node := Make_Null (Loc);
5186 -- Generate the Interface_Table object
5190 TSD_Ifaces_List : constant List_Id := New_List;
5192 Sec_DT_Tag : Node_Id;
5195 AI := First_Elmt (Typ_Ifaces);
5196 while Present (AI) loop
5197 if Is_Ancestor (Node (AI), Typ, Use_Full_View => True) then
5199 New_Reference_To (DT_Ptr, Loc);
5203 (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
5204 pragma Assert (Has_Thunks (Node (Elmt)));
5206 while Is_Tag (Node (Elmt))
5208 Is_Ancestor (Node (AI), Related_Type (Node (Elmt)),
5209 Use_Full_View => True)
5211 pragma Assert (Has_Thunks (Node (Elmt)));
5213 pragma Assert (Has_Thunks (Node (Elmt)));
5215 pragma Assert (not Has_Thunks (Node (Elmt)));
5217 pragma Assert (not Has_Thunks (Node (Elmt)));
5221 pragma Assert (Ekind (Node (Elmt)) = E_Constant
5223 Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt)))));
5225 New_Reference_To (Node (Next_Elmt (Next_Elmt (Elmt))),
5229 Append_To (TSD_Ifaces_List,
5230 Make_Aggregate (Loc,
5231 Expressions => New_List (
5235 Unchecked_Convert_To (RTE (RE_Tag),
5237 (Node (First_Elmt (Access_Disp_Table (Node (AI)))),
5240 -- Static_Offset_To_Top
5242 New_Reference_To (Standard_True, Loc),
5244 -- Offset_To_Top_Value
5246 Make_Integer_Literal (Loc, 0),
5248 -- Offset_To_Top_Func
5254 Unchecked_Convert_To (RTE (RE_Tag), Sec_DT_Tag)
5261 Name_ITable := New_External_Name (Tname, 'I');
5262 ITable := Make_Defining_Identifier (Loc, Name_ITable);
5263 Set_Is_Statically_Allocated (ITable,
5264 Is_Library_Level_Tagged_Type (Typ));
5266 -- The table of interfaces is not constant; its slots are
5267 -- filled at run time by the IP routine using attribute
5268 -- 'Position to know the location of the tag components
5269 -- (and this attribute cannot be safely used before the
5270 -- object is initialized).
5273 Make_Object_Declaration (Loc,
5274 Defining_Identifier => ITable,
5275 Aliased_Present => True,
5276 Constant_Present => False,
5277 Object_Definition =>
5278 Make_Subtype_Indication (Loc,
5280 New_Reference_To (RTE (RE_Interface_Data), Loc),
5281 Constraint => Make_Index_Or_Discriminant_Constraint
5283 Constraints => New_List (
5284 Make_Integer_Literal (Loc, Num_Ifaces)))),
5286 Expression => Make_Aggregate (Loc,
5287 Expressions => New_List (
5288 Make_Integer_Literal (Loc, Num_Ifaces),
5289 Make_Aggregate (Loc,
5290 Expressions => TSD_Ifaces_List)))));
5293 Make_Attribute_Definition_Clause (Loc,
5294 Name => New_Reference_To (ITable, Loc),
5295 Chars => Name_Alignment,
5297 Make_Attribute_Reference (Loc,
5299 New_Reference_To (RTE (RE_Integer_Address), Loc),
5300 Attribute_Name => Name_Alignment)));
5303 Make_Attribute_Reference (Loc,
5304 Prefix => New_Reference_To (ITable, Loc),
5305 Attribute_Name => Name_Unchecked_Access);
5309 Append_To (TSD_Aggr_List, Iface_Table_Node);
5312 -- Generate the Select Specific Data table for synchronized types that
5313 -- implement synchronized interfaces. The size of the table is
5314 -- constrained by the number of non-predefined primitive operations.
5316 if RTE_Record_Component_Available (RE_SSD) then
5317 if Ada_Version >= Ada_2005
5318 and then Has_DT (Typ)
5319 and then Is_Concurrent_Record_Type (Typ)
5320 and then Has_Interfaces (Typ)
5321 and then Nb_Prim > 0
5322 and then not Is_Abstract_Type (Typ)
5323 and then not Is_Controlled (Typ)
5324 and then not Restriction_Active (No_Dispatching_Calls)
5325 and then not Restriction_Active (No_Select_Statements)
5328 Make_Object_Declaration (Loc,
5329 Defining_Identifier => SSD,
5330 Aliased_Present => True,
5331 Object_Definition =>
5332 Make_Subtype_Indication (Loc,
5333 Subtype_Mark => New_Reference_To (
5334 RTE (RE_Select_Specific_Data), Loc),
5336 Make_Index_Or_Discriminant_Constraint (Loc,
5337 Constraints => New_List (
5338 Make_Integer_Literal (Loc, Nb_Prim))))));
5341 Make_Attribute_Definition_Clause (Loc,
5342 Name => New_Reference_To (SSD, Loc),
5343 Chars => Name_Alignment,
5345 Make_Attribute_Reference (Loc,
5347 New_Reference_To (RTE (RE_Integer_Address), Loc),
5348 Attribute_Name => Name_Alignment)));
5350 -- This table is initialized by Make_Select_Specific_Data_Table,
5351 -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
5353 Append_To (TSD_Aggr_List,
5354 Make_Attribute_Reference (Loc,
5355 Prefix => New_Reference_To (SSD, Loc),
5356 Attribute_Name => Name_Unchecked_Access));
5358 Append_To (TSD_Aggr_List, Make_Null (Loc));
5362 -- Initialize the table of ancestor tags. In case of interface types
5363 -- this table is not needed.
5365 TSD_Tags_List := New_List;
5367 -- If we are not statically allocating the dispatch table then we must
5368 -- fill position 0 with null because we still have not generated the
5371 if not Building_Static_DT (Typ)
5372 or else Is_Interface (Typ)
5374 Append_To (TSD_Tags_List,
5375 Unchecked_Convert_To (RTE (RE_Tag),
5376 New_Reference_To (RTE (RE_Null_Address), Loc)));
5378 -- Otherwise we can safely reference the tag
5381 Append_To (TSD_Tags_List,
5382 New_Reference_To (DT_Ptr, Loc));
5385 -- Fill the rest of the table with the tags of the ancestors
5388 Current_Typ : Entity_Id;
5389 Parent_Typ : Entity_Id;
5397 Parent_Typ := Etype (Current_Typ);
5399 if Is_Private_Type (Parent_Typ) then
5400 Parent_Typ := Full_View (Base_Type (Parent_Typ));
5403 exit when Parent_Typ = Current_Typ;
5405 if Is_CPP_Class (Parent_Typ) then
5407 -- The tags defined in the C++ side will be inherited when
5408 -- the object is constructed (Exp_Ch3.Build_Init_Procedure)
5410 Append_To (TSD_Tags_List,
5411 Unchecked_Convert_To (RTE (RE_Tag),
5412 New_Reference_To (RTE (RE_Null_Address), Loc)));
5414 Append_To (TSD_Tags_List,
5416 (Node (First_Elmt (Access_Disp_Table (Parent_Typ))),
5421 Current_Typ := Parent_Typ;
5424 pragma Assert (Pos = I_Depth + 1);
5427 Append_To (TSD_Aggr_List,
5428 Make_Aggregate (Loc,
5429 Expressions => TSD_Tags_List));
5431 -- Build the TSD object
5434 Make_Object_Declaration (Loc,
5435 Defining_Identifier => TSD,
5436 Aliased_Present => True,
5437 Constant_Present => Building_Static_DT (Typ),
5438 Object_Definition =>
5439 Make_Subtype_Indication (Loc,
5440 Subtype_Mark => New_Reference_To (
5441 RTE (RE_Type_Specific_Data), Loc),
5443 Make_Index_Or_Discriminant_Constraint (Loc,
5444 Constraints => New_List (
5445 Make_Integer_Literal (Loc, I_Depth)))),
5447 Expression => Make_Aggregate (Loc,
5448 Expressions => TSD_Aggr_List)));
5450 Set_Is_True_Constant (TSD, Building_Static_DT (Typ));
5453 Make_Attribute_Definition_Clause (Loc,
5454 Name => New_Reference_To (TSD, Loc),
5455 Chars => Name_Alignment,
5457 Make_Attribute_Reference (Loc,
5458 Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
5459 Attribute_Name => Name_Alignment)));
5461 -- Initialize or declare the dispatch table object
5463 if not Has_DT (Typ) then
5464 DT_Constr_List := New_List;
5465 DT_Aggr_List := New_List;
5470 Make_Attribute_Reference (Loc,
5471 Prefix => New_Reference_To (TSD, Loc),
5472 Attribute_Name => Name_Address);
5474 Append_To (DT_Constr_List, New_Node);
5475 Append_To (DT_Aggr_List, New_Copy (New_Node));
5476 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
5478 -- In case of locally defined tagged types we have already declared
5479 -- and uninitialized object for the dispatch table, which is now
5480 -- initialized by means of the following assignment:
5482 -- DT := (TSD'Address, 0);
5484 if not Building_Static_DT (Typ) then
5486 Make_Assignment_Statement (Loc,
5487 Name => New_Reference_To (DT, Loc),
5488 Expression => Make_Aggregate (Loc,
5489 Expressions => DT_Aggr_List)));
5491 -- In case of library level tagged types we declare and export now
5492 -- the constant object containing the dummy dispatch table. There
5493 -- is no need to declare the tag here because it has been previously
5494 -- declared by Make_Tags
5496 -- DT : aliased constant No_Dispatch_Table :=
5497 -- (NDT_TSD => TSD'Address;
5498 -- NDT_Prims_Ptr => 0);
5499 -- for DT'Alignment use Address'Alignment;
5503 Make_Object_Declaration (Loc,
5504 Defining_Identifier => DT,
5505 Aliased_Present => True,
5506 Constant_Present => True,
5507 Object_Definition =>
5508 New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc),
5509 Expression => Make_Aggregate (Loc,
5510 Expressions => DT_Aggr_List)));
5513 Make_Attribute_Definition_Clause (Loc,
5514 Name => New_Reference_To (DT, Loc),
5515 Chars => Name_Alignment,
5517 Make_Attribute_Reference (Loc,
5519 New_Reference_To (RTE (RE_Integer_Address), Loc),
5520 Attribute_Name => Name_Alignment)));
5522 Export_DT (Typ, DT);
5525 -- Common case: Typ has a dispatch table
5529 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
5530 -- (predef-prim-op-1'address,
5531 -- predef-prim-op-2'address,
5533 -- predef-prim-op-n'address);
5534 -- for Predef_Prims'Alignment use Address'Alignment
5536 -- DT : Dispatch_Table (Nb_Prims) :=
5537 -- (Signature => <sig-value>,
5538 -- Tag_Kind => <tag_kind-value>,
5539 -- Predef_Prims => Predef_Prims'First'Address,
5540 -- Offset_To_Top => 0,
5541 -- TSD => TSD'Address;
5542 -- Prims_Ptr => (prim-op-1'address,
5543 -- prim-op-2'address,
5545 -- prim-op-n'address));
5546 -- for DT'Alignment use Address'Alignment
5553 if not Building_Static_DT (Typ) then
5554 Nb_Predef_Prims := Max_Predef_Prims;
5557 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5558 while Present (Prim_Elmt) loop
5559 Prim := Node (Prim_Elmt);
5561 if Is_Predefined_Dispatching_Operation (Prim)
5562 and then not Is_Abstract_Subprogram (Prim)
5564 Pos := UI_To_Int (DT_Position (Prim));
5566 if Pos > Nb_Predef_Prims then
5567 Nb_Predef_Prims := Pos;
5571 Next_Elmt (Prim_Elmt);
5577 (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
5582 Prim_Ops_Aggr_List := New_List;
5584 Prim_Table := (others => Empty);
5586 if Building_Static_DT (Typ) then
5587 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5588 while Present (Prim_Elmt) loop
5589 Prim := Node (Prim_Elmt);
5591 if Is_Predefined_Dispatching_Operation (Prim)
5592 and then not Is_Abstract_Subprogram (Prim)
5593 and then not Is_Eliminated (Prim)
5594 and then not Present (Prim_Table
5595 (UI_To_Int (DT_Position (Prim))))
5597 E := Ultimate_Alias (Prim);
5598 pragma Assert (not Is_Abstract_Subprogram (E));
5599 Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
5602 Next_Elmt (Prim_Elmt);
5606 for J in Prim_Table'Range loop
5607 if Present (Prim_Table (J)) then
5609 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
5610 Make_Attribute_Reference (Loc,
5611 Prefix => New_Reference_To (Prim_Table (J), Loc),
5612 Attribute_Name => Name_Unrestricted_Access));
5614 New_Node := Make_Null (Loc);
5617 Append_To (Prim_Ops_Aggr_List, New_Node);
5621 Make_Aggregate (Loc,
5622 Expressions => Prim_Ops_Aggr_List);
5625 Make_Subtype_Declaration (Loc,
5626 Defining_Identifier => Make_Temporary (Loc, 'S'),
5627 Subtype_Indication =>
5628 New_Reference_To (RTE (RE_Address_Array), Loc));
5630 Append_To (Result, Decl);
5633 Make_Object_Declaration (Loc,
5634 Defining_Identifier => Predef_Prims,
5635 Aliased_Present => True,
5636 Constant_Present => Building_Static_DT (Typ),
5637 Object_Definition => New_Reference_To
5638 (Defining_Identifier (Decl), Loc),
5639 Expression => New_Node));
5641 -- Remember aggregates initializing dispatch tables
5643 Append_Elmt (New_Node, DT_Aggr);
5646 Make_Attribute_Definition_Clause (Loc,
5647 Name => New_Reference_To (Predef_Prims, Loc),
5648 Chars => Name_Alignment,
5650 Make_Attribute_Reference (Loc,
5652 New_Reference_To (RTE (RE_Integer_Address), Loc),
5653 Attribute_Name => Name_Alignment)));
5657 -- Stage 1: Initialize the discriminant and the record components
5659 DT_Constr_List := New_List;
5660 DT_Aggr_List := New_List;
5662 -- Num_Prims. If the tagged type has no primitives we add a dummy
5663 -- slot whose address will be the tag of this type.
5666 New_Node := Make_Integer_Literal (Loc, 1);
5668 New_Node := Make_Integer_Literal (Loc, Nb_Prim);
5671 Append_To (DT_Constr_List, New_Node);
5672 Append_To (DT_Aggr_List, New_Copy (New_Node));
5676 if RTE_Record_Component_Available (RE_Signature) then
5677 Append_To (DT_Aggr_List,
5678 New_Reference_To (RTE (RE_Primary_DT), Loc));
5683 if RTE_Record_Component_Available (RE_Tag_Kind) then
5684 Append_To (DT_Aggr_List, Tagged_Kind (Typ));
5689 Append_To (DT_Aggr_List,
5690 Make_Attribute_Reference (Loc,
5691 Prefix => New_Reference_To (Predef_Prims, Loc),
5692 Attribute_Name => Name_Address));
5696 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
5700 Append_To (DT_Aggr_List,
5701 Make_Attribute_Reference (Loc,
5702 Prefix => New_Reference_To (TSD, Loc),
5703 Attribute_Name => Name_Address));
5705 -- Stage 2: Initialize the table of primitive operations
5707 Prim_Ops_Aggr_List := New_List;
5710 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
5712 elsif not Building_Static_DT (Typ) then
5713 for J in 1 .. Nb_Prim loop
5714 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
5719 CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
5722 Prim_Elmt : Elmt_Id;
5724 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
5727 Prim_Table := (others => Empty);
5729 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5730 while Present (Prim_Elmt) loop
5731 Prim := Node (Prim_Elmt);
5733 -- Retrieve the ultimate alias of the primitive for proper
5734 -- handling of renamings and eliminated primitives.
5736 E := Ultimate_Alias (Prim);
5737 Prim_Pos := UI_To_Int (DT_Position (E));
5739 -- Do not reference predefined primitives because they are
5740 -- located in a separate dispatch table; skip entities with
5741 -- attribute Interface_Alias because they are only required
5742 -- to build secondary dispatch tables; skip abstract and
5743 -- eliminated primitives; for derivations of CPP types skip
5744 -- primitives located in the C++ part of the dispatch table
5745 -- because their slot is initialized by the IC routine.
5747 if not Is_Predefined_Dispatching_Operation (Prim)
5748 and then not Is_Predefined_Dispatching_Operation (E)
5749 and then not Present (Interface_Alias (Prim))
5750 and then not Is_Abstract_Subprogram (E)
5751 and then not Is_Eliminated (E)
5752 and then (not Is_CPP_Class (Root_Type (Typ))
5753 or else Prim_Pos > CPP_Nb_Prims)
5756 (UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
5758 Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
5761 Next_Elmt (Prim_Elmt);
5764 for J in Prim_Table'Range loop
5765 if Present (Prim_Table (J)) then
5767 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
5768 Make_Attribute_Reference (Loc,
5769 Prefix => New_Reference_To (Prim_Table (J), Loc),
5770 Attribute_Name => Name_Unrestricted_Access));
5772 New_Node := Make_Null (Loc);
5775 Append_To (Prim_Ops_Aggr_List, New_Node);
5781 Make_Aggregate (Loc,
5782 Expressions => Prim_Ops_Aggr_List);
5784 Append_To (DT_Aggr_List, New_Node);
5786 -- Remember aggregates initializing dispatch tables
5788 Append_Elmt (New_Node, DT_Aggr);
5790 -- In case of locally defined tagged types we have already declared
5791 -- and uninitialized object for the dispatch table, which is now
5792 -- initialized by means of an assignment.
5794 if not Building_Static_DT (Typ) then
5796 Make_Assignment_Statement (Loc,
5797 Name => New_Reference_To (DT, Loc),
5798 Expression => Make_Aggregate (Loc,
5799 Expressions => DT_Aggr_List)));
5801 -- In case of library level tagged types we declare now and export
5802 -- the constant object containing the dispatch table.
5806 Make_Object_Declaration (Loc,
5807 Defining_Identifier => DT,
5808 Aliased_Present => True,
5809 Constant_Present => True,
5810 Object_Definition =>
5811 Make_Subtype_Indication (Loc,
5812 Subtype_Mark => New_Reference_To
5813 (RTE (RE_Dispatch_Table_Wrapper), Loc),
5814 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
5815 Constraints => DT_Constr_List)),
5816 Expression => Make_Aggregate (Loc,
5817 Expressions => DT_Aggr_List)));
5820 Make_Attribute_Definition_Clause (Loc,
5821 Name => New_Reference_To (DT, Loc),
5822 Chars => Name_Alignment,
5824 Make_Attribute_Reference (Loc,
5826 New_Reference_To (RTE (RE_Integer_Address), Loc),
5827 Attribute_Name => Name_Alignment)));
5829 Export_DT (Typ, DT);
5833 -- Initialize the table of ancestor tags if not building static
5836 if not Building_Static_DT (Typ)
5837 and then not Is_Interface (Typ)
5838 and then not Is_CPP_Class (Typ)
5841 Make_Assignment_Statement (Loc,
5843 Make_Indexed_Component (Loc,
5845 Make_Selected_Component (Loc,
5847 New_Reference_To (TSD, Loc),
5850 (RTE_Record_Component (RE_Tags_Table), Loc)),
5852 New_List (Make_Integer_Literal (Loc, 0))),
5856 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
5859 -- Inherit the dispatch tables of the parent. There is no need to
5860 -- inherit anything from the parent when building static dispatch tables
5861 -- because the whole dispatch table (including inherited primitives) has
5862 -- been already built.
5864 if Building_Static_DT (Typ) then
5867 -- If the ancestor is a CPP_Class type we inherit the dispatch tables
5868 -- in the init proc, and we don't need to fill them in here.
5870 elsif Is_CPP_Class (Parent_Typ) then
5873 -- Otherwise we fill in the dispatch tables here
5876 if Typ /= Parent_Typ
5877 and then not Is_Interface (Typ)
5878 and then not Restriction_Active (No_Dispatching_Calls)
5880 -- Inherit the dispatch table
5882 if not Is_Interface (Typ)
5883 and then not Is_Interface (Parent_Typ)
5884 and then not Is_CPP_Class (Parent_Typ)
5887 Nb_Prims : constant Int :=
5888 UI_To_Int (DT_Entry_Count
5889 (First_Tag_Component (Parent_Typ)));
5892 Append_To (Elab_Code,
5893 Build_Inherit_Predefined_Prims (Loc,
5899 (Access_Disp_Table (Parent_Typ)))), Loc),
5905 (Access_Disp_Table (Typ)))), Loc)));
5907 if Nb_Prims /= 0 then
5908 Append_To (Elab_Code,
5909 Build_Inherit_Prims (Loc,
5915 (Access_Disp_Table (Parent_Typ))), Loc),
5916 New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
5917 Num_Prims => Nb_Prims));
5922 -- Inherit the secondary dispatch tables of the ancestor
5924 if not Is_CPP_Class (Parent_Typ) then
5926 Sec_DT_Ancestor : Elmt_Id :=
5930 (Access_Disp_Table (Parent_Typ))));
5931 Sec_DT_Typ : Elmt_Id :=
5935 (Access_Disp_Table (Typ))));
5937 procedure Copy_Secondary_DTs (Typ : Entity_Id);
5938 -- Local procedure required to climb through the ancestors
5939 -- and copy the contents of all their secondary dispatch
5942 ------------------------
5943 -- Copy_Secondary_DTs --
5944 ------------------------
5946 procedure Copy_Secondary_DTs (Typ : Entity_Id) is
5951 -- Climb to the ancestor (if any) handling private types
5953 if Present (Full_View (Etype (Typ))) then
5954 if Full_View (Etype (Typ)) /= Typ then
5955 Copy_Secondary_DTs (Full_View (Etype (Typ)));
5958 elsif Etype (Typ) /= Typ then
5959 Copy_Secondary_DTs (Etype (Typ));
5962 if Present (Interfaces (Typ))
5963 and then not Is_Empty_Elmt_List (Interfaces (Typ))
5965 Iface := First_Elmt (Interfaces (Typ));
5966 E := First_Entity (Typ);
5968 and then Present (Node (Sec_DT_Ancestor))
5969 and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
5971 if Is_Tag (E) and then Chars (E) /= Name_uTag then
5973 Num_Prims : constant Int :=
5974 UI_To_Int (DT_Entry_Count (E));
5977 if not Is_Interface (Etype (Typ)) then
5979 -- Inherit first secondary dispatch table
5981 Append_To (Elab_Code,
5982 Build_Inherit_Predefined_Prims (Loc,
5984 Unchecked_Convert_To (RTE (RE_Tag),
5987 (Next_Elmt (Sec_DT_Ancestor)),
5990 Unchecked_Convert_To (RTE (RE_Tag),
5992 (Node (Next_Elmt (Sec_DT_Typ)),
5995 if Num_Prims /= 0 then
5996 Append_To (Elab_Code,
5997 Build_Inherit_Prims (Loc,
5998 Typ => Node (Iface),
6000 Unchecked_Convert_To
6003 (Node (Sec_DT_Ancestor),
6006 Unchecked_Convert_To
6009 (Node (Sec_DT_Typ), Loc)),
6010 Num_Prims => Num_Prims));
6014 Next_Elmt (Sec_DT_Ancestor);
6015 Next_Elmt (Sec_DT_Typ);
6017 -- Skip the secondary dispatch table of
6018 -- predefined primitives
6020 Next_Elmt (Sec_DT_Ancestor);
6021 Next_Elmt (Sec_DT_Typ);
6023 if not Is_Interface (Etype (Typ)) then
6025 -- Inherit second secondary dispatch table
6027 Append_To (Elab_Code,
6028 Build_Inherit_Predefined_Prims (Loc,
6030 Unchecked_Convert_To (RTE (RE_Tag),
6033 (Next_Elmt (Sec_DT_Ancestor)),
6036 Unchecked_Convert_To (RTE (RE_Tag),
6038 (Node (Next_Elmt (Sec_DT_Typ)),
6041 if Num_Prims /= 0 then
6042 Append_To (Elab_Code,
6043 Build_Inherit_Prims (Loc,
6044 Typ => Node (Iface),
6046 Unchecked_Convert_To
6049 (Node (Sec_DT_Ancestor),
6052 Unchecked_Convert_To
6055 (Node (Sec_DT_Typ), Loc)),
6056 Num_Prims => Num_Prims));
6061 Next_Elmt (Sec_DT_Ancestor);
6062 Next_Elmt (Sec_DT_Typ);
6064 -- Skip the secondary dispatch table of
6065 -- predefined primitives
6067 Next_Elmt (Sec_DT_Ancestor);
6068 Next_Elmt (Sec_DT_Typ);
6076 end Copy_Secondary_DTs;
6079 if Present (Node (Sec_DT_Ancestor))
6080 and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
6082 -- Handle private types
6084 if Present (Full_View (Typ)) then
6085 Copy_Secondary_DTs (Full_View (Typ));
6087 Copy_Secondary_DTs (Typ);
6095 -- If the type has a representation clause which specifies its external
6096 -- tag then generate code to check if the external tag of this type is
6097 -- the same as the external tag of some other declaration.
6099 -- Check_TSD (TSD'Unrestricted_Access);
6101 -- This check is a consequence of AI05-0113-1/06, so it officially
6102 -- applies to Ada 2005 (and Ada 2012). It might be argued that it is
6103 -- a desirable check to add in Ada 95 mode, but we hesitate to make
6104 -- this change, as it would be incompatible, and could conceivably
6105 -- cause a problem in existing Aa 95 code.
6107 -- We check for No_Run_Time_Mode here, because we do not want to pick
6108 -- up the RE_Check_TSD entity and call it in No_Run_Time mode.
6110 if not No_Run_Time_Mode
6111 and then Ada_Version >= Ada_2005
6112 and then Has_External_Tag_Rep_Clause (Typ)
6113 and then RTE_Available (RE_Check_TSD)
6114 and then not Debug_Flag_QQ
6116 Append_To (Elab_Code,
6117 Make_Procedure_Call_Statement (Loc,
6118 Name => New_Reference_To (RTE (RE_Check_TSD), Loc),
6119 Parameter_Associations => New_List (
6120 Make_Attribute_Reference (Loc,
6121 Prefix => New_Reference_To (TSD, Loc),
6122 Attribute_Name => Name_Unchecked_Access))));
6125 -- Generate code to register the Tag in the External_Tag hash table for
6126 -- the pure Ada type only.
6128 -- Register_Tag (Dt_Ptr);
6130 -- Skip this action in the following cases:
6131 -- 1) if Register_Tag is not available.
6132 -- 2) in No_Run_Time mode.
6133 -- 3) if Typ is not defined at the library level (this is required
6134 -- to avoid adding concurrency control to the hash table used
6135 -- by the run-time to register the tags).
6137 if not No_Run_Time_Mode
6138 and then Is_Library_Level_Entity (Typ)
6139 and then RTE_Available (RE_Register_Tag)
6141 Append_To (Elab_Code,
6142 Make_Procedure_Call_Statement (Loc,
6143 Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
6144 Parameter_Associations =>
6145 New_List (New_Reference_To (DT_Ptr, Loc))));
6148 if not Is_Empty_List (Elab_Code) then
6149 Append_List_To (Result, Elab_Code);
6152 -- Populate the two auxiliary tables used for dispatching asynchronous,
6153 -- conditional and timed selects for synchronized types that implement
6154 -- a limited interface. Skip this step in Ravenscar profile or when
6155 -- general dispatching is forbidden.
6157 if Ada_Version >= Ada_2005
6158 and then Is_Concurrent_Record_Type (Typ)
6159 and then Has_Interfaces (Typ)
6160 and then not Restriction_Active (No_Dispatching_Calls)
6161 and then not Restriction_Active (No_Select_Statements)
6163 Append_List_To (Result,
6164 Make_Select_Specific_Data_Table (Typ));
6167 -- Remember entities containing dispatch tables
6169 Append_Elmt (Predef_Prims, DT_Decl);
6170 Append_Elmt (DT, DT_Decl);
6172 Analyze_List (Result, Suppress => All_Checks);
6173 Set_Has_Dispatch_Table (Typ);
6175 -- Mark entities containing dispatch tables. Required by the backend to
6176 -- handle them properly.
6178 if Has_DT (Typ) then
6183 -- Ensure that entities Prim_Ptr and Predef_Prims_Table_Ptr have
6184 -- the decoration required by the backend
6186 Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr));
6187 Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr));
6189 -- Object declarations
6191 Elmt := First_Elmt (DT_Decl);
6192 while Present (Elmt) loop
6193 Set_Is_Dispatch_Table_Entity (Node (Elmt));
6194 pragma Assert (Ekind (Etype (Node (Elmt))) = E_Array_Subtype
6195 or else Ekind (Etype (Node (Elmt))) = E_Record_Subtype);
6196 Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
6200 -- Aggregates initializing dispatch tables
6202 Elmt := First_Elmt (DT_Aggr);
6203 while Present (Elmt) loop
6204 Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
6210 -- Register the tagged type in the call graph nodes table
6212 Register_CG_Node (Typ);
6221 function Make_VM_TSD (Typ : Entity_Id) return List_Id is
6222 Loc : constant Source_Ptr := Sloc (Typ);
6223 Result : constant List_Id := New_List;
6225 function Count_Primitives (Typ : Entity_Id) return Nat;
6226 -- Count the non-predefined primitive operations of Typ
6228 ----------------------
6229 -- Count_Primitives --
6230 ----------------------
6232 function Count_Primitives (Typ : Entity_Id) return Nat is
6234 Prim_Elmt : Elmt_Id;
6240 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6241 while Present (Prim_Elmt) loop
6242 Prim := Node (Prim_Elmt);
6244 if Is_Predefined_Dispatching_Operation (Prim)
6245 or else Is_Predefined_Dispatching_Alias (Prim)
6249 elsif Present (Interface_Alias (Prim)) then
6253 Nb_Prim := Nb_Prim + 1;
6256 Next_Elmt (Prim_Elmt);
6260 end Count_Primitives;
6266 function Make_OSD (Iface : Entity_Id) return Node_Id;
6267 -- Generate the Object Specific Data table required to dispatch calls
6268 -- through synchronized interfaces. Returns a node that references the
6269 -- generated OSD object.
6271 function Make_OSD (Iface : Entity_Id) return Node_Id is
6272 Nb_Prim : constant Nat := Count_Primitives (Iface);
6274 OSD_Aggr_List : List_Id;
6278 -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
6279 -- (OSD_Table => (1 => <value>,
6284 or else Is_Abstract_Type (Typ)
6285 or else Is_Controlled (Typ)
6286 or else Restriction_Active (No_Dispatching_Calls)
6287 or else not Is_Limited_Type (Typ)
6288 or else not Has_Interfaces (Typ)
6289 or else not RTE_Record_Component_Available (RE_OSD_Table)
6291 -- No OSD table required
6293 return Make_Null (Loc);
6296 OSD_Aggr_List := New_List;
6299 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
6301 Prim_Alias : Entity_Id;
6302 Prim_Elmt : Elmt_Id;
6308 Prim_Table := (others => Empty);
6309 Prim_Alias := Empty;
6311 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6312 while Present (Prim_Elmt) loop
6313 Prim := Node (Prim_Elmt);
6315 if Present (Interface_Alias (Prim))
6316 and then Find_Dispatching_Type
6317 (Interface_Alias (Prim)) = Iface
6319 Prim_Alias := Interface_Alias (Prim);
6320 E := Ultimate_Alias (Prim);
6321 Pos := UI_To_Int (DT_Position (Prim_Alias));
6323 if Present (Prim_Table (Pos)) then
6324 pragma Assert (Prim_Table (Pos) = E);
6328 Prim_Table (Pos) := E;
6330 Append_To (OSD_Aggr_List,
6331 Make_Component_Association (Loc,
6332 Choices => New_List (
6333 Make_Integer_Literal (Loc,
6334 DT_Position (Prim_Alias))),
6336 Make_Integer_Literal (Loc,
6337 DT_Position (Alias (Prim)))));
6343 Next_Elmt (Prim_Elmt);
6345 pragma Assert (Count = Nb_Prim);
6348 OSD := Make_Temporary (Loc, 'I');
6351 Make_Object_Declaration (Loc,
6352 Defining_Identifier => OSD,
6353 Aliased_Present => True,
6354 Constant_Present => True,
6355 Object_Definition =>
6356 Make_Subtype_Indication (Loc,
6358 New_Reference_To (RTE (RE_Object_Specific_Data), Loc),
6360 Make_Index_Or_Discriminant_Constraint (Loc,
6361 Constraints => New_List (
6362 Make_Integer_Literal (Loc, Nb_Prim)))),
6365 Make_Aggregate (Loc,
6366 Component_Associations => New_List (
6367 Make_Component_Association (Loc,
6368 Choices => New_List (
6370 (RTE_Record_Component (RE_OSD_Num_Prims), Loc)),
6372 Make_Integer_Literal (Loc, Nb_Prim)),
6374 Make_Component_Association (Loc,
6375 Choices => New_List (
6377 (RTE_Record_Component (RE_OSD_Table), Loc)),
6378 Expression => Make_Aggregate (Loc,
6379 Component_Associations => OSD_Aggr_List))))));
6382 Make_Attribute_Reference (Loc,
6383 Prefix => New_Reference_To (OSD, Loc),
6384 Attribute_Name => Name_Unchecked_Access);
6390 Nb_Prim : constant Nat := Count_Primitives (Typ);
6393 Iface_Table_Node : Node_Id;
6395 TSD_Aggr_List : List_Id;
6396 Typ_Ifaces : Elist_Id;
6397 TSD_Tags_List : List_Id;
6399 Tname : constant Name_Id := Chars (Typ);
6400 Name_SSD : constant Name_Id :=
6401 New_External_Name (Tname, 'S', Suffix_Index => -1);
6402 Name_TSD : constant Name_Id :=
6403 New_External_Name (Tname, 'B', Suffix_Index => -1);
6404 SSD : constant Entity_Id :=
6405 Make_Defining_Identifier (Loc, Name_SSD);
6406 TSD : constant Entity_Id :=
6407 Make_Defining_Identifier (Loc, Name_TSD);
6409 -- Generate code to create the storage for the type specific data object
6410 -- with enough space to store the tags of the ancestors plus the tags
6411 -- of all the implemented interfaces (as described in a-tags.ads).
6413 -- TSD : Type_Specific_Data (I_Depth) :=
6414 -- (Idepth => I_Depth,
6415 -- Tag_Kind => <tag_kind-value>,
6416 -- Access_Level => Type_Access_Level (Typ),
6418 -- Type_Is_Abstract => <<boolean-value>>,
6419 -- Type_Is_Library_Level => <<boolean-value>>,
6420 -- Interfaces_Table => <<access-value>>
6421 -- SSD => SSD_Table'Address
6422 -- Tags_Table => (0 => Typ'Tag,
6426 TSD_Aggr_List := New_List;
6428 -- Idepth: Count ancestors to compute the inheritance depth. For private
6429 -- extensions, always go to the full view in order to compute the real
6430 -- inheritance depth.
6433 Current_Typ : Entity_Id;
6434 Parent_Typ : Entity_Id;
6440 Parent_Typ := Etype (Current_Typ);
6442 if Is_Private_Type (Parent_Typ) then
6443 Parent_Typ := Full_View (Base_Type (Parent_Typ));
6446 exit when Parent_Typ = Current_Typ;
6448 I_Depth := I_Depth + 1;
6449 Current_Typ := Parent_Typ;
6455 Append_To (TSD_Aggr_List,
6456 Make_Integer_Literal (Loc, I_Depth));
6460 Append_To (TSD_Aggr_List, Tagged_Kind (Typ));
6464 Append_To (TSD_Aggr_List,
6465 Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
6469 Append_To (TSD_Aggr_List,
6472 -- Type_Is_Abstract (Ada 2012: AI05-0173)
6475 Type_Is_Abstract : Entity_Id;
6479 Boolean_Literals (Is_Abstract_Type (Typ));
6481 Append_To (TSD_Aggr_List,
6482 New_Occurrence_Of (Type_Is_Abstract, Loc));
6485 -- Type_Is_Library_Level
6488 Type_Is_Library_Level : Entity_Id;
6490 Type_Is_Library_Level :=
6491 Boolean_Literals (Is_Library_Level_Entity (Typ));
6492 Append_To (TSD_Aggr_List,
6493 New_Occurrence_Of (Type_Is_Library_Level, Loc));
6496 -- Interfaces_Table (required for AI-405)
6498 if RTE_Record_Component_Available (RE_Interfaces_Table) then
6500 -- Count the number of interface types implemented by Typ
6502 Collect_Interfaces (Typ, Typ_Ifaces);
6505 AI := First_Elmt (Typ_Ifaces);
6506 while Present (AI) loop
6507 Num_Ifaces := Num_Ifaces + 1;
6511 if Num_Ifaces = 0 then
6512 Iface_Table_Node := Make_Null (Loc);
6514 -- Generate the Interface_Table object
6518 TSD_Ifaces_List : constant List_Id := New_List;
6523 AI := First_Elmt (Typ_Ifaces);
6524 while Present (AI) loop
6527 Append_To (TSD_Ifaces_List,
6528 Make_Aggregate (Loc,
6529 Expressions => New_List (
6533 Make_Attribute_Reference (Loc,
6534 Prefix => New_Reference_To (Iface, Loc),
6535 Attribute_Name => Name_Tag),
6539 Make_OSD (Iface))));
6544 ITable := Make_Temporary (Loc, 'I');
6547 Make_Object_Declaration (Loc,
6548 Defining_Identifier => ITable,
6549 Aliased_Present => True,
6550 Constant_Present => True,
6551 Object_Definition =>
6552 Make_Subtype_Indication (Loc,
6554 New_Reference_To (RTE (RE_Interface_Data), Loc),
6555 Constraint => Make_Index_Or_Discriminant_Constraint
6557 Constraints => New_List (
6558 Make_Integer_Literal (Loc, Num_Ifaces)))),
6560 Expression => Make_Aggregate (Loc,
6561 Expressions => New_List (
6562 Make_Integer_Literal (Loc, Num_Ifaces),
6563 Make_Aggregate (Loc,
6564 Expressions => TSD_Ifaces_List)))));
6567 Make_Attribute_Reference (Loc,
6568 Prefix => New_Reference_To (ITable, Loc),
6569 Attribute_Name => Name_Unchecked_Access);
6573 Append_To (TSD_Aggr_List, Iface_Table_Node);
6576 -- Generate the Select Specific Data table for synchronized types that
6577 -- implement synchronized interfaces. The size of the table is
6578 -- constrained by the number of non-predefined primitive operations.
6580 if RTE_Record_Component_Available (RE_SSD) then
6581 if Ada_Version >= Ada_2005
6582 and then Has_DT (Typ)
6583 and then Is_Concurrent_Record_Type (Typ)
6584 and then Has_Interfaces (Typ)
6585 and then Nb_Prim > 0
6586 and then not Is_Abstract_Type (Typ)
6587 and then not Is_Controlled (Typ)
6588 and then not Restriction_Active (No_Dispatching_Calls)
6589 and then not Restriction_Active (No_Select_Statements)
6592 Make_Object_Declaration (Loc,
6593 Defining_Identifier => SSD,
6594 Aliased_Present => True,
6595 Object_Definition =>
6596 Make_Subtype_Indication (Loc,
6597 Subtype_Mark => New_Reference_To (
6598 RTE (RE_Select_Specific_Data), Loc),
6600 Make_Index_Or_Discriminant_Constraint (Loc,
6601 Constraints => New_List (
6602 Make_Integer_Literal (Loc, Nb_Prim))))));
6604 -- This table is initialized by Make_Select_Specific_Data_Table,
6605 -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
6607 Append_To (TSD_Aggr_List,
6608 Make_Attribute_Reference (Loc,
6609 Prefix => New_Reference_To (SSD, Loc),
6610 Attribute_Name => Name_Unchecked_Access));
6612 Append_To (TSD_Aggr_List, Make_Null (Loc));
6616 -- Initialize the table of ancestor tags. In case of interface types
6617 -- this table is not needed.
6619 TSD_Tags_List := New_List;
6621 -- Fill position 0 with Typ'Tag
6623 Append_To (TSD_Tags_List,
6624 Make_Attribute_Reference (Loc,
6625 Prefix => New_Reference_To (Typ, Loc),
6626 Attribute_Name => Name_Tag));
6628 -- Fill the rest of the table with the tags of the ancestors
6631 Current_Typ : Entity_Id;
6632 Parent_Typ : Entity_Id;
6640 Parent_Typ := Etype (Current_Typ);
6642 if Is_Private_Type (Parent_Typ) then
6643 Parent_Typ := Full_View (Base_Type (Parent_Typ));
6646 exit when Parent_Typ = Current_Typ;
6648 Append_To (TSD_Tags_List,
6649 Make_Attribute_Reference (Loc,
6650 Prefix => New_Reference_To (Parent_Typ, Loc),
6651 Attribute_Name => Name_Tag));
6654 Current_Typ := Parent_Typ;
6657 pragma Assert (Pos = I_Depth + 1);
6660 Append_To (TSD_Aggr_List,
6661 Make_Aggregate (Loc,
6662 Expressions => TSD_Tags_List));
6664 -- Build the TSD object
6667 Make_Object_Declaration (Loc,
6668 Defining_Identifier => TSD,
6669 Aliased_Present => True,
6670 Constant_Present => True,
6671 Object_Definition =>
6672 Make_Subtype_Indication (Loc,
6673 Subtype_Mark => New_Reference_To (
6674 RTE (RE_Type_Specific_Data), Loc),
6676 Make_Index_Or_Discriminant_Constraint (Loc,
6677 Constraints => New_List (
6678 Make_Integer_Literal (Loc, I_Depth)))),
6680 Expression => Make_Aggregate (Loc,
6681 Expressions => TSD_Aggr_List)));
6685 -- (TSD => TSD'Unrestricted_Access);
6687 if Ada_Version >= Ada_2005
6688 and then Is_Library_Level_Entity (Typ)
6689 and then Has_External_Tag_Rep_Clause (Typ)
6690 and then RTE_Available (RE_Check_TSD)
6691 and then not Debug_Flag_QQ
6694 Make_Procedure_Call_Statement (Loc,
6695 Name => New_Reference_To (RTE (RE_Check_TSD), Loc),
6696 Parameter_Associations => New_List (
6697 Make_Attribute_Reference (Loc,
6698 Prefix => New_Reference_To (TSD, Loc),
6699 Attribute_Name => Name_Unrestricted_Access))));
6703 -- Register_TSD (TSD'Unrestricted_Access);
6706 Make_Procedure_Call_Statement (Loc,
6707 Name => New_Reference_To (RTE (RE_Register_TSD), Loc),
6708 Parameter_Associations => New_List (
6709 Make_Attribute_Reference (Loc,
6710 Prefix => New_Reference_To (TSD, Loc),
6711 Attribute_Name => Name_Unrestricted_Access))));
6713 -- Populate the two auxiliary tables used for dispatching asynchronous,
6714 -- conditional and timed selects for synchronized types that implement
6715 -- a limited interface. Skip this step in Ravenscar profile or when
6716 -- general dispatching is forbidden.
6718 if Ada_Version >= Ada_2005
6719 and then Is_Concurrent_Record_Type (Typ)
6720 and then Has_Interfaces (Typ)
6721 and then not Restriction_Active (No_Dispatching_Calls)
6722 and then not Restriction_Active (No_Select_Statements)
6724 Append_List_To (Result,
6725 Make_Select_Specific_Data_Table (Typ));
6731 -------------------------------------
6732 -- Make_Select_Specific_Data_Table --
6733 -------------------------------------
6735 function Make_Select_Specific_Data_Table
6736 (Typ : Entity_Id) return List_Id
6738 Assignments : constant List_Id := New_List;
6739 Loc : constant Source_Ptr := Sloc (Typ);
6741 Conc_Typ : Entity_Id;
6744 Prim_Als : Entity_Id;
6745 Prim_Elmt : Elmt_Id;
6749 type Examined_Array is array (Int range <>) of Boolean;
6751 function Find_Entry_Index (E : Entity_Id) return Uint;
6752 -- Given an entry, find its index in the visible declarations of the
6753 -- corresponding concurrent type of Typ.
6755 ----------------------
6756 -- Find_Entry_Index --
6757 ----------------------
6759 function Find_Entry_Index (E : Entity_Id) return Uint is
6760 Index : Uint := Uint_1;
6761 Subp_Decl : Entity_Id;
6765 and then not Is_Empty_List (Decls)
6767 Subp_Decl := First (Decls);
6768 while Present (Subp_Decl) loop
6769 if Nkind (Subp_Decl) = N_Entry_Declaration then
6770 if Defining_Identifier (Subp_Decl) = E then
6782 end Find_Entry_Index;
6788 -- Start of processing for Make_Select_Specific_Data_Table
6791 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
6793 if Present (Corresponding_Concurrent_Type (Typ)) then
6794 Conc_Typ := Corresponding_Concurrent_Type (Typ);
6796 if Present (Full_View (Conc_Typ)) then
6797 Conc_Typ := Full_View (Conc_Typ);
6800 if Ekind (Conc_Typ) = E_Protected_Type then
6801 Decls := Visible_Declarations (Protected_Definition (
6802 Parent (Conc_Typ)));
6804 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
6805 Decls := Visible_Declarations (Task_Definition (
6806 Parent (Conc_Typ)));
6810 -- Count the non-predefined primitive operations
6812 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6813 while Present (Prim_Elmt) loop
6814 Prim := Node (Prim_Elmt);
6816 if not (Is_Predefined_Dispatching_Operation (Prim)
6817 or else Is_Predefined_Dispatching_Alias (Prim))
6819 Nb_Prim := Nb_Prim + 1;
6822 Next_Elmt (Prim_Elmt);
6826 Examined : Examined_Array (1 .. Nb_Prim) := (others => False);
6829 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6830 while Present (Prim_Elmt) loop
6831 Prim := Node (Prim_Elmt);
6833 -- Look for primitive overriding an abstract interface subprogram
6835 if Present (Interface_Alias (Prim))
6838 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
6839 Use_Full_View => True)
6840 and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
6842 Prim_Pos := DT_Position (Alias (Prim));
6843 pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
6844 Examined (UI_To_Int (Prim_Pos)) := True;
6846 -- Set the primitive operation kind regardless of subprogram
6848 -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
6850 if Tagged_Type_Expansion then
6853 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
6857 Make_Attribute_Reference (Loc,
6858 Prefix => New_Reference_To (Typ, Loc),
6859 Attribute_Name => Name_Tag);
6862 Append_To (Assignments,
6863 Make_Procedure_Call_Statement (Loc,
6864 Name => New_Reference_To (RTE (RE_Set_Prim_Op_Kind), Loc),
6865 Parameter_Associations => New_List (
6867 Make_Integer_Literal (Loc, Prim_Pos),
6868 Prim_Op_Kind (Alias (Prim), Typ))));
6870 -- Retrieve the root of the alias chain
6872 Prim_Als := Ultimate_Alias (Prim);
6874 -- In the case of an entry wrapper, set the entry index
6876 if Ekind (Prim) = E_Procedure
6877 and then Is_Primitive_Wrapper (Prim_Als)
6878 and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry
6881 -- Ada.Tags.Set_Entry_Index
6882 -- (DT_Ptr, <position>, <index>);
6884 if Tagged_Type_Expansion then
6887 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
6890 Make_Attribute_Reference (Loc,
6891 Prefix => New_Reference_To (Typ, Loc),
6892 Attribute_Name => Name_Tag);
6895 Append_To (Assignments,
6896 Make_Procedure_Call_Statement (Loc,
6898 New_Reference_To (RTE (RE_Set_Entry_Index), Loc),
6899 Parameter_Associations => New_List (
6901 Make_Integer_Literal (Loc, Prim_Pos),
6902 Make_Integer_Literal (Loc,
6903 Find_Entry_Index (Wrapped_Entity (Prim_Als))))));
6907 Next_Elmt (Prim_Elmt);
6912 end Make_Select_Specific_Data_Table;
6918 function Make_Tags (Typ : Entity_Id) return List_Id is
6919 Loc : constant Source_Ptr := Sloc (Typ);
6920 Result : constant List_Id := New_List;
6923 (Tag_Typ : Entity_Id;
6925 Is_Secondary_DT : Boolean);
6926 -- Import the dispatch table DT of tagged type Tag_Typ. Required to
6927 -- generate forward references and statically allocate the table. For
6928 -- primary dispatch tables that require no dispatch table generate:
6930 -- DT : static aliased constant Non_Dispatch_Table_Wrapper;
6931 -- pragma Import (Ada, DT);
6933 -- Otherwise generate:
6935 -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
6936 -- pragma Import (Ada, DT);
6943 (Tag_Typ : Entity_Id;
6945 Is_Secondary_DT : Boolean)
6947 DT_Constr_List : List_Id;
6951 Set_Is_Imported (DT);
6952 Set_Ekind (DT, E_Constant);
6953 Set_Related_Type (DT, Typ);
6955 -- The scope must be set now to call Get_External_Name
6957 Set_Scope (DT, Current_Scope);
6959 Get_External_Name (DT, True);
6960 Set_Interface_Name (DT,
6961 Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
6963 -- Ensure proper Sprint output of this implicit importation
6965 Set_Is_Internal (DT);
6967 -- Save this entity to allow Make_DT to generate its exportation
6969 Append_Elmt (DT, Dispatch_Table_Wrappers (Typ));
6971 -- No dispatch table required
6973 if not Is_Secondary_DT and then not Has_DT (Tag_Typ) then
6975 Make_Object_Declaration (Loc,
6976 Defining_Identifier => DT,
6977 Aliased_Present => True,
6978 Constant_Present => True,
6979 Object_Definition =>
6980 New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
6983 -- Calculate the number of primitives of the dispatch table and
6984 -- the size of the Type_Specific_Data record.
6987 UI_To_Int (DT_Entry_Count (First_Tag_Component (Tag_Typ)));
6989 -- If the tagged type has no primitives we add a dummy slot whose
6990 -- address will be the tag of this type.
6994 New_List (Make_Integer_Literal (Loc, 1));
6997 New_List (Make_Integer_Literal (Loc, Nb_Prim));
7001 Make_Object_Declaration (Loc,
7002 Defining_Identifier => DT,
7003 Aliased_Present => True,
7004 Constant_Present => True,
7005 Object_Definition =>
7006 Make_Subtype_Indication (Loc,
7008 New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc),
7009 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
7010 Constraints => DT_Constr_List))));
7016 Tname : constant Name_Id := Chars (Typ);
7017 AI_Tag_Comp : Elmt_Id;
7018 DT : Node_Id := Empty;
7020 Predef_Prims_Ptr : Node_Id;
7021 Iface_DT : Node_Id := Empty;
7022 Iface_DT_Ptr : Node_Id;
7026 Typ_Comps : Elist_Id;
7028 -- Start of processing for Make_Tags
7031 pragma Assert (No (Access_Disp_Table (Typ)));
7032 Set_Access_Disp_Table (Typ, New_Elmt_List);
7034 -- 1) Generate the primary tag entities
7036 -- Primary dispatch table containing user-defined primitives
7038 DT_Ptr := Make_Defining_Identifier (Loc, New_External_Name (Tname, 'P'));
7039 Set_Etype (DT_Ptr, RTE (RE_Tag));
7040 Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
7042 -- Minimum decoration
7044 Set_Ekind (DT_Ptr, E_Variable);
7045 Set_Related_Type (DT_Ptr, Typ);
7047 -- For CPP types there is no need to build the dispatch tables since
7048 -- they are imported from the C++ side. If the CPP type has an IP then
7049 -- we declare now the variable that will store the copy of the C++ tag.
7050 -- If the CPP type is an interface, we need the variable as well because
7051 -- it becomes the pointer to the corresponding secondary table.
7053 if Is_CPP_Class (Typ) then
7054 if Has_CPP_Constructors (Typ) or else Is_Interface (Typ) then
7056 Make_Object_Declaration (Loc,
7057 Defining_Identifier => DT_Ptr,
7058 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
7060 Unchecked_Convert_To (RTE (RE_Tag),
7061 New_Reference_To (RTE (RE_Null_Address), Loc))));
7063 Set_Is_Statically_Allocated (DT_Ptr,
7064 Is_Library_Level_Tagged_Type (Typ));
7070 -- Primary dispatch table containing predefined primitives
7073 Make_Defining_Identifier (Loc,
7074 Chars => New_External_Name (Tname, 'Y'));
7075 Set_Etype (Predef_Prims_Ptr, RTE (RE_Address));
7076 Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
7078 -- Import the forward declaration of the Dispatch Table wrapper
7079 -- record (Make_DT will take care of exporting it).
7081 if Building_Static_DT (Typ) then
7082 Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List);
7085 Make_Defining_Identifier (Loc,
7086 Chars => New_External_Name (Tname, 'T'));
7088 Import_DT (Typ, DT, Is_Secondary_DT => False);
7090 if Has_DT (Typ) then
7092 Make_Object_Declaration (Loc,
7093 Defining_Identifier => DT_Ptr,
7094 Constant_Present => True,
7095 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
7097 Unchecked_Convert_To (RTE (RE_Tag),
7098 Make_Attribute_Reference (Loc,
7100 Make_Selected_Component (Loc,
7101 Prefix => New_Reference_To (DT, Loc),
7104 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
7105 Attribute_Name => Name_Address))));
7107 -- Generate the SCIL node for the previous object declaration
7108 -- because it has a tag initialization.
7110 if Generate_SCIL then
7112 Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
7113 Set_SCIL_Entity (New_Node, Typ);
7114 Set_SCIL_Node (Last (Result), New_Node);
7118 Make_Object_Declaration (Loc,
7119 Defining_Identifier => Predef_Prims_Ptr,
7120 Constant_Present => True,
7121 Object_Definition => New_Reference_To
7122 (RTE (RE_Address), Loc),
7124 Make_Attribute_Reference (Loc,
7126 Make_Selected_Component (Loc,
7127 Prefix => New_Reference_To (DT, Loc),
7130 (RTE_Record_Component (RE_Predef_Prims), Loc)),
7131 Attribute_Name => Name_Address)));
7133 -- No dispatch table required
7137 Make_Object_Declaration (Loc,
7138 Defining_Identifier => DT_Ptr,
7139 Constant_Present => True,
7140 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
7142 Unchecked_Convert_To (RTE (RE_Tag),
7143 Make_Attribute_Reference (Loc,
7145 Make_Selected_Component (Loc,
7146 Prefix => New_Reference_To (DT, Loc),
7149 (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
7150 Attribute_Name => Name_Address))));
7153 Set_Is_True_Constant (DT_Ptr);
7154 Set_Is_Statically_Allocated (DT_Ptr);
7158 -- 2) Generate the secondary tag entities
7160 -- Collect the components associated with secondary dispatch tables
7162 if Has_Interfaces (Typ) then
7163 Collect_Interface_Components (Typ, Typ_Comps);
7165 -- For each interface type we build a unique external name associated
7166 -- with its secondary dispatch table. This name is used to declare an
7167 -- object that references this secondary dispatch table, whose value
7168 -- will be used for the elaboration of Typ objects, and also for the
7169 -- elaboration of objects of types derived from Typ that do not
7170 -- override the primitives of this interface type.
7174 -- Note: The value of Suffix_Index must be in sync with the
7175 -- Suffix_Index values of secondary dispatch tables generated
7178 if Is_CPP_Class (Typ) then
7179 AI_Tag_Comp := First_Elmt (Typ_Comps);
7180 while Present (AI_Tag_Comp) loop
7181 Get_Secondary_DT_External_Name
7182 (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
7183 Typ_Name := Name_Find;
7185 -- Declare variables that will store the copy of the C++
7189 Make_Defining_Identifier (Loc,
7190 Chars => New_External_Name (Typ_Name, 'P'));
7191 Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
7192 Set_Ekind (Iface_DT_Ptr, E_Variable);
7193 Set_Is_Tag (Iface_DT_Ptr);
7195 Set_Has_Thunks (Iface_DT_Ptr);
7197 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7198 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7201 Make_Object_Declaration (Loc,
7202 Defining_Identifier => Iface_DT_Ptr,
7203 Object_Definition => New_Reference_To
7204 (RTE (RE_Interface_Tag), Loc),
7206 Unchecked_Convert_To (RTE (RE_Interface_Tag),
7207 New_Reference_To (RTE (RE_Null_Address), Loc))));
7209 Set_Is_Statically_Allocated (Iface_DT_Ptr,
7210 Is_Library_Level_Tagged_Type (Typ));
7212 Next_Elmt (AI_Tag_Comp);
7215 -- This is not a CPP_Class type
7218 AI_Tag_Comp := First_Elmt (Typ_Comps);
7219 while Present (AI_Tag_Comp) loop
7220 Get_Secondary_DT_External_Name
7221 (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
7222 Typ_Name := Name_Find;
7224 if Building_Static_DT (Typ) then
7226 Make_Defining_Identifier (Loc,
7227 Chars => New_External_Name
7228 (Typ_Name, 'T', Suffix_Index => -1));
7230 (Tag_Typ => Related_Type (Node (AI_Tag_Comp)),
7232 Is_Secondary_DT => True);
7235 -- Secondary dispatch table referencing thunks to user-defined
7236 -- primitives covered by this interface.
7239 Make_Defining_Identifier (Loc,
7240 Chars => New_External_Name (Typ_Name, 'P'));
7241 Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
7242 Set_Ekind (Iface_DT_Ptr, E_Constant);
7243 Set_Is_Tag (Iface_DT_Ptr);
7244 Set_Has_Thunks (Iface_DT_Ptr);
7245 Set_Is_Statically_Allocated (Iface_DT_Ptr,
7246 Is_Library_Level_Tagged_Type (Typ));
7247 Set_Is_True_Constant (Iface_DT_Ptr);
7249 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7250 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7252 if Building_Static_DT (Typ) then
7254 Make_Object_Declaration (Loc,
7255 Defining_Identifier => Iface_DT_Ptr,
7256 Constant_Present => True,
7257 Object_Definition => New_Reference_To
7258 (RTE (RE_Interface_Tag), Loc),
7260 Unchecked_Convert_To (RTE (RE_Interface_Tag),
7261 Make_Attribute_Reference (Loc,
7263 Make_Selected_Component (Loc,
7264 Prefix => New_Reference_To (Iface_DT, Loc),
7267 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
7268 Attribute_Name => Name_Address))));
7271 -- Secondary dispatch table referencing thunks to predefined
7275 Make_Defining_Identifier (Loc,
7276 Chars => New_External_Name (Typ_Name, 'Y'));
7277 Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
7278 Set_Ekind (Iface_DT_Ptr, E_Constant);
7279 Set_Is_Tag (Iface_DT_Ptr);
7280 Set_Has_Thunks (Iface_DT_Ptr);
7281 Set_Is_Statically_Allocated (Iface_DT_Ptr,
7282 Is_Library_Level_Tagged_Type (Typ));
7283 Set_Is_True_Constant (Iface_DT_Ptr);
7285 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7286 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7288 -- Secondary dispatch table referencing user-defined primitives
7289 -- covered by this interface.
7292 Make_Defining_Identifier (Loc,
7293 Chars => New_External_Name (Typ_Name, 'D'));
7294 Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
7295 Set_Ekind (Iface_DT_Ptr, E_Constant);
7296 Set_Is_Tag (Iface_DT_Ptr);
7297 Set_Is_Statically_Allocated (Iface_DT_Ptr,
7298 Is_Library_Level_Tagged_Type (Typ));
7299 Set_Is_True_Constant (Iface_DT_Ptr);
7301 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7302 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7304 -- Secondary dispatch table referencing predefined primitives
7307 Make_Defining_Identifier (Loc,
7308 Chars => New_External_Name (Typ_Name, 'Z'));
7309 Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
7310 Set_Ekind (Iface_DT_Ptr, E_Constant);
7311 Set_Is_Tag (Iface_DT_Ptr);
7312 Set_Is_Statically_Allocated (Iface_DT_Ptr,
7313 Is_Library_Level_Tagged_Type (Typ));
7314 Set_Is_True_Constant (Iface_DT_Ptr);
7316 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7317 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7319 Next_Elmt (AI_Tag_Comp);
7324 -- 3) At the end of Access_Disp_Table, if the type has user-defined
7325 -- primitives, we add the entity of an access type declaration that
7326 -- is used by Build_Get_Prim_Op_Address to expand dispatching calls
7327 -- through the primary dispatch table.
7329 if UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))) = 0 then
7330 Analyze_List (Result);
7333 -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
7334 -- type Typ_DT_Acc is access Typ_DT;
7338 Name_DT_Prims : constant Name_Id :=
7339 New_External_Name (Tname, 'G');
7340 Name_DT_Prims_Acc : constant Name_Id :=
7341 New_External_Name (Tname, 'H');
7342 DT_Prims : constant Entity_Id :=
7343 Make_Defining_Identifier (Loc,
7345 DT_Prims_Acc : constant Entity_Id :=
7346 Make_Defining_Identifier (Loc,
7350 Make_Full_Type_Declaration (Loc,
7351 Defining_Identifier => DT_Prims,
7353 Make_Constrained_Array_Definition (Loc,
7354 Discrete_Subtype_Definitions => New_List (
7356 Low_Bound => Make_Integer_Literal (Loc, 1),
7357 High_Bound => Make_Integer_Literal (Loc,
7359 (First_Tag_Component (Typ))))),
7360 Component_Definition =>
7361 Make_Component_Definition (Loc,
7362 Subtype_Indication =>
7363 New_Reference_To (RTE (RE_Prim_Ptr), Loc)))));
7366 Make_Full_Type_Declaration (Loc,
7367 Defining_Identifier => DT_Prims_Acc,
7369 Make_Access_To_Object_Definition (Loc,
7370 Subtype_Indication =>
7371 New_Occurrence_Of (DT_Prims, Loc))));
7373 Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
7375 -- Analyze the resulting list and suppress the generation of the
7376 -- Init_Proc associated with the above array declaration because
7377 -- this type is never used in object declarations. It is only used
7378 -- to simplify the expansion associated with dispatching calls.
7380 Analyze_List (Result);
7381 Set_Suppress_Initialization (Base_Type (DT_Prims));
7383 -- Disable backend optimizations based on assumptions about the
7384 -- aliasing status of objects designated by the access to the
7385 -- dispatch table. Required to handle dispatch tables imported
7388 Set_No_Strict_Aliasing (Base_Type (DT_Prims_Acc));
7390 -- Add the freezing nodes of these declarations; required to avoid
7391 -- generating these freezing nodes in wrong scopes (for example in
7392 -- the IC routine of a derivation of Typ).
7393 -- What is an "IC routine"? Is "init_proc" meant here???
7395 Append_List_To (Result, Freeze_Entity (DT_Prims, Typ));
7396 Append_List_To (Result, Freeze_Entity (DT_Prims_Acc, Typ));
7398 -- Mark entity of dispatch table. Required by the back end to
7399 -- handle them properly.
7401 Set_Is_Dispatch_Table_Entity (DT_Prims);
7405 -- Mark entities of dispatch table. Required by the back end to handle
7408 if Present (DT) then
7409 Set_Is_Dispatch_Table_Entity (DT);
7410 Set_Is_Dispatch_Table_Entity (Etype (DT));
7413 if Present (Iface_DT) then
7414 Set_Is_Dispatch_Table_Entity (Iface_DT);
7415 Set_Is_Dispatch_Table_Entity (Etype (Iface_DT));
7418 if Is_CPP_Class (Root_Type (Typ)) then
7419 Set_Ekind (DT_Ptr, E_Variable);
7421 Set_Ekind (DT_Ptr, E_Constant);
7424 Set_Is_Tag (DT_Ptr);
7425 Set_Related_Type (DT_Ptr, Typ);
7434 function New_Value (From : Node_Id) return Node_Id is
7435 Res : constant Node_Id := Duplicate_Subexpr (From);
7437 if Is_Access_Type (Etype (From)) then
7439 Make_Explicit_Dereference (Sloc (From),
7446 -----------------------------------
7447 -- Original_View_In_Visible_Part --
7448 -----------------------------------
7450 function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
7451 Scop : constant Entity_Id := Scope (Typ);
7454 -- The scope must be a package
7456 if not Is_Package_Or_Generic_Package (Scop) then
7460 -- A type with a private declaration has a private view declared in
7461 -- the visible part.
7463 if Has_Private_Declaration (Typ) then
7467 return List_Containing (Parent (Typ)) =
7468 Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
7469 end Original_View_In_Visible_Part;
7475 function Prim_Op_Kind
7477 Typ : Entity_Id) return Node_Id
7479 Full_Typ : Entity_Id := Typ;
7480 Loc : constant Source_Ptr := Sloc (Prim);
7481 Prim_Op : Entity_Id;
7484 -- Retrieve the original primitive operation
7486 Prim_Op := Ultimate_Alias (Prim);
7488 if Ekind (Typ) = E_Record_Type
7489 and then Present (Corresponding_Concurrent_Type (Typ))
7491 Full_Typ := Corresponding_Concurrent_Type (Typ);
7494 -- When a private tagged type is completed by a concurrent type,
7495 -- retrieve the full view.
7497 if Is_Private_Type (Full_Typ) then
7498 Full_Typ := Full_View (Full_Typ);
7501 if Ekind (Prim_Op) = E_Function then
7503 -- Protected function
7505 if Ekind (Full_Typ) = E_Protected_Type then
7506 return New_Reference_To (RTE (RE_POK_Protected_Function), Loc);
7510 elsif Ekind (Full_Typ) = E_Task_Type then
7511 return New_Reference_To (RTE (RE_POK_Task_Function), Loc);
7516 return New_Reference_To (RTE (RE_POK_Function), Loc);
7520 pragma Assert (Ekind (Prim_Op) = E_Procedure);
7522 if Ekind (Full_Typ) = E_Protected_Type then
7526 if Is_Primitive_Wrapper (Prim_Op)
7527 and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
7529 return New_Reference_To (RTE (RE_POK_Protected_Entry), Loc);
7531 -- Protected procedure
7534 return New_Reference_To (RTE (RE_POK_Protected_Procedure), Loc);
7537 elsif Ekind (Full_Typ) = E_Task_Type then
7541 if Is_Primitive_Wrapper (Prim_Op)
7542 and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
7544 return New_Reference_To (RTE (RE_POK_Task_Entry), Loc);
7546 -- Task "procedure". These are the internally Expander-generated
7547 -- procedures (task body for instance).
7550 return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc);
7553 -- Regular procedure
7556 return New_Reference_To (RTE (RE_POK_Procedure), Loc);
7561 ------------------------
7562 -- Register_Primitive --
7563 ------------------------
7565 function Register_Primitive
7567 Prim : Entity_Id) return List_Id
7570 Iface_Prim : Entity_Id;
7571 Iface_Typ : Entity_Id;
7572 Iface_DT_Ptr : Entity_Id;
7573 Iface_DT_Elmt : Elmt_Id;
7574 L : constant List_Id := New_List;
7577 Tag_Typ : Entity_Id;
7578 Thunk_Id : Entity_Id;
7579 Thunk_Code : Node_Id;
7582 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
7583 pragma Assert (VM_Target = No_VM);
7585 -- Do not register in the dispatch table eliminated primitives
7587 if not RTE_Available (RE_Tag)
7588 or else Is_Eliminated (Ultimate_Alias (Prim))
7593 if not Present (Interface_Alias (Prim)) then
7594 Tag_Typ := Scope (DTC_Entity (Prim));
7595 Pos := DT_Position (Prim);
7596 Tag := First_Tag_Component (Tag_Typ);
7598 if Is_Predefined_Dispatching_Operation (Prim)
7599 or else Is_Predefined_Dispatching_Alias (Prim)
7602 Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ))));
7605 Build_Set_Predefined_Prim_Op_Address (Loc,
7606 Tag_Node => New_Reference_To (DT_Ptr, Loc),
7609 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7610 Make_Attribute_Reference (Loc,
7611 Prefix => New_Reference_To (Prim, Loc),
7612 Attribute_Name => Name_Unrestricted_Access))));
7614 -- Register copy of the pointer to the 'size primitive in the TSD
7616 if Chars (Prim) = Name_uSize
7617 and then RTE_Record_Component_Available (RE_Size_Func)
7619 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
7621 Build_Set_Size_Function (Loc,
7622 Tag_Node => New_Reference_To (DT_Ptr, Loc),
7623 Size_Func => Prim));
7627 pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
7629 -- Skip registration of primitives located in the C++ part of the
7630 -- dispatch table. Their slot is set by the IC routine.
7632 if not Is_CPP_Class (Root_Type (Tag_Typ))
7633 or else Pos > CPP_Num_Prims (Tag_Typ)
7635 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
7637 Build_Set_Prim_Op_Address (Loc,
7639 Tag_Node => New_Reference_To (DT_Ptr, Loc),
7642 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7643 Make_Attribute_Reference (Loc,
7644 Prefix => New_Reference_To (Prim, Loc),
7645 Attribute_Name => Name_Unrestricted_Access))));
7649 -- Ada 2005 (AI-251): Primitive associated with an interface type
7650 -- Generate the code of the thunk only if the interface type is not an
7651 -- immediate ancestor of Typ; otherwise the dispatch table associated
7652 -- with the interface is the primary dispatch table and we have nothing
7656 Tag_Typ := Find_Dispatching_Type (Alias (Prim));
7657 Iface_Typ := Find_Dispatching_Type (Interface_Alias (Prim));
7659 pragma Assert (Is_Interface (Iface_Typ));
7661 -- No action needed for interfaces that are ancestors of Typ because
7662 -- their primitives are located in the primary dispatch table.
7664 if Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True) then
7667 -- No action needed for primitives located in the C++ part of the
7668 -- dispatch table. Their slot is set by the IC routine.
7670 elsif Is_CPP_Class (Root_Type (Tag_Typ))
7671 and then DT_Position (Alias (Prim)) <= CPP_Num_Prims (Tag_Typ)
7672 and then not Is_Predefined_Dispatching_Operation (Prim)
7673 and then not Is_Predefined_Dispatching_Alias (Prim)
7678 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
7680 if not Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True)
7681 and then Present (Thunk_Code)
7683 -- Generate the code necessary to fill the appropriate entry of
7684 -- the secondary dispatch table of Prim's controlling type with
7685 -- Thunk_Id's address.
7687 Iface_DT_Elmt := Find_Interface_ADT (Tag_Typ, Iface_Typ);
7688 Iface_DT_Ptr := Node (Iface_DT_Elmt);
7689 pragma Assert (Has_Thunks (Iface_DT_Ptr));
7691 Iface_Prim := Interface_Alias (Prim);
7692 Pos := DT_Position (Iface_Prim);
7693 Tag := First_Tag_Component (Iface_Typ);
7695 Prepend_To (L, Thunk_Code);
7697 if Is_Predefined_Dispatching_Operation (Prim)
7698 or else Is_Predefined_Dispatching_Alias (Prim)
7701 Build_Set_Predefined_Prim_Op_Address (Loc,
7703 New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
7706 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7707 Make_Attribute_Reference (Loc,
7708 Prefix => New_Reference_To (Thunk_Id, Loc),
7709 Attribute_Name => Name_Unrestricted_Access))));
7711 Next_Elmt (Iface_DT_Elmt);
7712 Next_Elmt (Iface_DT_Elmt);
7713 Iface_DT_Ptr := Node (Iface_DT_Elmt);
7714 pragma Assert (not Has_Thunks (Iface_DT_Ptr));
7717 Build_Set_Predefined_Prim_Op_Address (Loc,
7719 New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
7722 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7723 Make_Attribute_Reference (Loc,
7724 Prefix => New_Reference_To (Alias (Prim), Loc),
7725 Attribute_Name => Name_Unrestricted_Access))));
7728 pragma Assert (Pos /= Uint_0
7729 and then Pos <= DT_Entry_Count (Tag));
7732 Build_Set_Prim_Op_Address (Loc,
7734 Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
7737 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7738 Make_Attribute_Reference (Loc,
7739 Prefix => New_Reference_To (Thunk_Id, Loc),
7740 Attribute_Name => Name_Unrestricted_Access))));
7742 Next_Elmt (Iface_DT_Elmt);
7743 Next_Elmt (Iface_DT_Elmt);
7744 Iface_DT_Ptr := Node (Iface_DT_Elmt);
7745 pragma Assert (not Has_Thunks (Iface_DT_Ptr));
7748 Build_Set_Prim_Op_Address (Loc,
7750 Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
7753 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7754 Make_Attribute_Reference (Loc,
7755 Prefix => New_Reference_To (Alias (Prim), Loc),
7756 Attribute_Name => Name_Unrestricted_Access))));
7763 end Register_Primitive;
7765 -------------------------
7766 -- Set_All_DT_Position --
7767 -------------------------
7769 procedure Set_All_DT_Position (Typ : Entity_Id) is
7771 function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean;
7772 -- Returns True if Prim is located in the dispatch table of
7773 -- predefined primitives
7775 procedure Validate_Position (Prim : Entity_Id);
7776 -- Check that the position assigned to Prim is completely safe
7777 -- (it has not been assigned to a previously defined primitive
7778 -- operation of Typ)
7780 ------------------------
7781 -- In_Predef_Prims_DT --
7782 ------------------------
7784 function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean is
7788 -- Predefined primitives
7790 if Is_Predefined_Dispatching_Operation (Prim) then
7793 -- Renamings of predefined primitives
7795 elsif Present (Alias (Prim))
7796 and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim))
7798 if Chars (Ultimate_Alias (Prim)) /= Name_Op_Eq then
7801 -- User-defined renamings of predefined equality have their own
7802 -- slot in the primary dispatch table
7806 while Present (Alias (E)) loop
7807 if Comes_From_Source (E) then
7814 return not Comes_From_Source (E);
7817 -- User-defined primitives
7822 end In_Predef_Prims_DT;
7824 -----------------------
7825 -- Validate_Position --
7826 -----------------------
7828 procedure Validate_Position (Prim : Entity_Id) is
7833 -- Aliased primitives are safe
7835 if Present (Alias (Prim)) then
7839 Op_Elmt := First_Elmt (Primitive_Operations (Typ));
7840 while Present (Op_Elmt) loop
7841 Op := Node (Op_Elmt);
7843 -- No need to check against itself
7848 -- Primitive operations covering abstract interfaces are
7851 elsif Present (Interface_Alias (Op)) then
7854 -- Predefined dispatching operations are completely safe. They
7855 -- are allocated at fixed positions in a separate table.
7857 elsif Is_Predefined_Dispatching_Operation (Op)
7858 or else Is_Predefined_Dispatching_Alias (Op)
7862 -- Aliased subprograms are safe
7864 elsif Present (Alias (Op)) then
7867 elsif DT_Position (Op) = DT_Position (Prim)
7868 and then not Is_Predefined_Dispatching_Operation (Op)
7869 and then not Is_Predefined_Dispatching_Operation (Prim)
7870 and then not Is_Predefined_Dispatching_Alias (Op)
7871 and then not Is_Predefined_Dispatching_Alias (Prim)
7874 -- Handle aliased subprograms
7883 if Present (Overridden_Operation (Op_1)) then
7884 Op_1 := Overridden_Operation (Op_1);
7885 elsif Present (Alias (Op_1)) then
7886 Op_1 := Alias (Op_1);
7894 if Present (Overridden_Operation (Op_2)) then
7895 Op_2 := Overridden_Operation (Op_2);
7896 elsif Present (Alias (Op_2)) then
7897 Op_2 := Alias (Op_2);
7903 if Op_1 /= Op_2 then
7904 raise Program_Error;
7909 Next_Elmt (Op_Elmt);
7911 end Validate_Position;
7915 Parent_Typ : constant Entity_Id := Etype (Typ);
7916 First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
7917 The_Tag : constant Entity_Id := First_Tag_Component (Typ);
7919 Adjusted : Boolean := False;
7920 Finalized : Boolean := False;
7926 Prim_Elmt : Elmt_Id;
7928 -- Start of processing for Set_All_DT_Position
7931 pragma Assert (Present (First_Tag_Component (Typ)));
7933 -- Set the DT_Position for each primitive operation. Perform some sanity
7934 -- checks to avoid building inconsistent dispatch tables.
7936 -- First stage: Set the DTC entity of all the primitive operations. This
7937 -- is required to properly read the DT_Position attribute in the latter
7940 Prim_Elmt := First_Prim;
7942 while Present (Prim_Elmt) loop
7943 Prim := Node (Prim_Elmt);
7945 -- Predefined primitives have a separate dispatch table
7947 if not In_Predef_Prims_DT (Prim) then
7948 Count_Prim := Count_Prim + 1;
7951 Set_DTC_Entity_Value (Typ, Prim);
7953 -- Clear any previous value of the DT_Position attribute. In this
7954 -- way we ensure that the final position of all the primitives is
7955 -- established by the following stages of this algorithm.
7957 Set_DT_Position (Prim, No_Uint);
7959 Next_Elmt (Prim_Elmt);
7963 Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean :=
7968 procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id);
7969 -- Called if Typ is declared in a nested package or a public child
7970 -- package to handle inherited primitives that were inherited by Typ
7971 -- in the visible part, but whose declaration was deferred because
7972 -- the parent operation was private and not visible at that point.
7974 procedure Set_Fixed_Prim (Pos : Nat);
7975 -- Sets to true an element of the Fixed_Prim table to indicate
7976 -- that this entry of the dispatch table of Typ is occupied.
7978 ------------------------------------------
7979 -- Handle_Inherited_Private_Subprograms --
7980 ------------------------------------------
7982 procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id) is
7985 Op_Elmt_2 : Elmt_Id;
7986 Prim_Op : Entity_Id;
7987 Parent_Subp : Entity_Id;
7990 Op_List := Primitive_Operations (Typ);
7992 Op_Elmt := First_Elmt (Op_List);
7993 while Present (Op_Elmt) loop
7994 Prim_Op := Node (Op_Elmt);
7996 -- Search primitives that are implicit operations with an
7997 -- internal name whose parent operation has a normal name.
7999 if Present (Alias (Prim_Op))
8000 and then Find_Dispatching_Type (Alias (Prim_Op)) /= Typ
8001 and then not Comes_From_Source (Prim_Op)
8002 and then Is_Internal_Name (Chars (Prim_Op))
8003 and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
8005 Parent_Subp := Alias (Prim_Op);
8007 -- Check if the type has an explicit overriding for this
8010 Op_Elmt_2 := Next_Elmt (Op_Elmt);
8011 while Present (Op_Elmt_2) loop
8012 if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
8013 and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
8015 Set_DT_Position (Prim_Op, DT_Position (Parent_Subp));
8016 Set_DT_Position (Node (Op_Elmt_2),
8017 DT_Position (Parent_Subp));
8018 Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op)));
8020 goto Next_Primitive;
8023 Next_Elmt (Op_Elmt_2);
8028 Next_Elmt (Op_Elmt);
8030 end Handle_Inherited_Private_Subprograms;
8032 --------------------
8033 -- Set_Fixed_Prim --
8034 --------------------
8036 procedure Set_Fixed_Prim (Pos : Nat) is
8038 pragma Assert (Pos <= Count_Prim);
8039 Fixed_Prim (Pos) := True;
8041 when Constraint_Error =>
8042 raise Program_Error;
8046 -- In case of nested packages and public child package it may be
8047 -- necessary a special management on inherited subprograms so that
8048 -- the dispatch table is properly filled.
8050 if Ekind (Scope (Scope (Typ))) = E_Package
8051 and then Scope (Scope (Typ)) /= Standard_Standard
8052 and then ((Is_Derived_Type (Typ) and then not Is_Private_Type (Typ))
8054 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration
8055 and then Is_Generic_Type (Typ)))
8056 and then In_Open_Scopes (Scope (Etype (Typ)))
8057 and then Is_Base_Type (Typ)
8059 Handle_Inherited_Private_Subprograms (Typ);
8062 -- Second stage: Register fixed entries
8065 Prim_Elmt := First_Prim;
8066 while Present (Prim_Elmt) loop
8067 Prim := Node (Prim_Elmt);
8069 -- Predefined primitives have a separate table and all its
8070 -- entries are at predefined fixed positions.
8072 if In_Predef_Prims_DT (Prim) then
8073 if Is_Predefined_Dispatching_Operation (Prim) then
8074 Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
8076 else pragma Assert (Present (Alias (Prim)));
8077 Set_DT_Position (Prim,
8078 Default_Prim_Op_Position (Ultimate_Alias (Prim)));
8081 -- Overriding primitives of ancestor abstract interfaces
8083 elsif Present (Interface_Alias (Prim))
8084 and then Is_Ancestor
8085 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
8086 Use_Full_View => True)
8088 pragma Assert (DT_Position (Prim) = No_Uint
8089 and then Present (DTC_Entity (Interface_Alias (Prim))));
8091 E := Interface_Alias (Prim);
8092 Set_DT_Position (Prim, DT_Position (E));
8095 (DT_Position (Alias (Prim)) = No_Uint
8096 or else DT_Position (Alias (Prim)) = DT_Position (E));
8097 Set_DT_Position (Alias (Prim), DT_Position (E));
8098 Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
8100 -- Overriding primitives must use the same entry as the
8101 -- overridden primitive.
8103 elsif not Present (Interface_Alias (Prim))
8104 and then Present (Alias (Prim))
8105 and then Chars (Prim) = Chars (Alias (Prim))
8106 and then Find_Dispatching_Type (Alias (Prim)) /= Typ
8107 and then Is_Ancestor
8108 (Find_Dispatching_Type (Alias (Prim)), Typ,
8109 Use_Full_View => True)
8110 and then Present (DTC_Entity (Alias (Prim)))
8113 Set_DT_Position (Prim, DT_Position (E));
8115 if not Is_Predefined_Dispatching_Alias (E) then
8116 Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
8120 Next_Elmt (Prim_Elmt);
8123 -- Third stage: Fix the position of all the new primitives.
8124 -- Entries associated with primitives covering interfaces
8125 -- are handled in a latter round.
8127 Prim_Elmt := First_Prim;
8128 while Present (Prim_Elmt) loop
8129 Prim := Node (Prim_Elmt);
8131 -- Skip primitives previously set entries
8133 if DT_Position (Prim) /= No_Uint then
8136 -- Primitives covering interface primitives are handled later
8138 elsif Present (Interface_Alias (Prim)) then
8142 -- Take the next available position in the DT
8145 Nb_Prim := Nb_Prim + 1;
8146 pragma Assert (Nb_Prim <= Count_Prim);
8147 exit when not Fixed_Prim (Nb_Prim);
8150 Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
8151 Set_Fixed_Prim (Nb_Prim);
8154 Next_Elmt (Prim_Elmt);
8158 -- Fourth stage: Complete the decoration of primitives covering
8159 -- interfaces (that is, propagate the DT_Position attribute
8160 -- from the aliased primitive)
8162 Prim_Elmt := First_Prim;
8163 while Present (Prim_Elmt) loop
8164 Prim := Node (Prim_Elmt);
8166 if DT_Position (Prim) = No_Uint
8167 and then Present (Interface_Alias (Prim))
8169 pragma Assert (Present (Alias (Prim))
8170 and then Find_Dispatching_Type (Alias (Prim)) = Typ);
8172 -- Check if this entry will be placed in the primary DT
8175 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
8176 Use_Full_View => True)
8178 pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
8179 Set_DT_Position (Prim, DT_Position (Alias (Prim)));
8181 -- Otherwise it will be placed in the secondary DT
8185 (DT_Position (Interface_Alias (Prim)) /= No_Uint);
8186 Set_DT_Position (Prim,
8187 DT_Position (Interface_Alias (Prim)));
8191 Next_Elmt (Prim_Elmt);
8194 -- Generate listing showing the contents of the dispatch tables.
8195 -- This action is done before some further static checks because
8196 -- in case of critical errors caused by a wrong dispatch table
8197 -- we need to see the contents of such table.
8199 if Debug_Flag_ZZ then
8203 -- Final stage: Ensure that the table is correct plus some further
8204 -- verifications concerning the primitives.
8206 Prim_Elmt := First_Prim;
8208 while Present (Prim_Elmt) loop
8209 Prim := Node (Prim_Elmt);
8211 -- At this point all the primitives MUST have a position
8212 -- in the dispatch table.
8214 if DT_Position (Prim) = No_Uint then
8215 raise Program_Error;
8218 -- Calculate real size of the dispatch table
8220 if not In_Predef_Prims_DT (Prim)
8221 and then UI_To_Int (DT_Position (Prim)) > DT_Length
8223 DT_Length := UI_To_Int (DT_Position (Prim));
8226 -- Ensure that the assigned position to non-predefined
8227 -- dispatching operations in the dispatch table is correct.
8229 if not Is_Predefined_Dispatching_Operation (Prim)
8230 and then not Is_Predefined_Dispatching_Alias (Prim)
8232 Validate_Position (Prim);
8235 if Chars (Prim) = Name_Finalize then
8239 if Chars (Prim) = Name_Adjust then
8243 -- An abstract operation cannot be declared in the private part for a
8244 -- visible abstract type, because it can't be overridden outside this
8245 -- package hierarchy. For explicit declarations this is checked at
8246 -- the point of declaration, but for inherited operations it must be
8247 -- done when building the dispatch table.
8249 -- Ada 2005 (AI-251): Primitives associated with interfaces are
8250 -- excluded from this check because interfaces must be visible in
8251 -- the public and private part (RM 7.3 (7.3/2))
8253 -- We disable this check in CodePeer mode, to accommodate legacy
8256 if not CodePeer_Mode
8257 and then Is_Abstract_Type (Typ)
8258 and then Is_Abstract_Subprogram (Prim)
8259 and then Present (Alias (Prim))
8260 and then not Is_Interface
8261 (Find_Dispatching_Type (Ultimate_Alias (Prim)))
8262 and then not Present (Interface_Alias (Prim))
8263 and then Is_Derived_Type (Typ)
8264 and then In_Private_Part (Current_Scope)
8266 List_Containing (Parent (Prim)) =
8267 Private_Declarations
8268 (Specification (Unit_Declaration_Node (Current_Scope)))
8269 and then Original_View_In_Visible_Part (Typ)
8271 -- We exclude Input and Output stream operations because
8272 -- Limited_Controlled inherits useless Input and Output
8273 -- stream operations from Root_Controlled, which can
8274 -- never be overridden.
8276 if not Is_TSS (Prim, TSS_Stream_Input)
8278 not Is_TSS (Prim, TSS_Stream_Output)
8281 ("abstract inherited private operation&" &
8282 " must be overridden (RM 3.9.3(10))",
8283 Parent (Typ), Prim);
8287 Next_Elmt (Prim_Elmt);
8292 if Is_Controlled (Typ) then
8293 if not Finalized then
8295 ("controlled type has no explicit Finalize method?", Typ);
8297 elsif not Adjusted then
8299 ("controlled type has no explicit Adjust method?", Typ);
8303 -- Set the final size of the Dispatch Table
8305 Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
8307 -- The derived type must have at least as many components as its parent
8308 -- (for root types Etype points to itself and the test cannot fail).
8310 if DT_Entry_Count (The_Tag) <
8311 DT_Entry_Count (First_Tag_Component (Parent_Typ))
8313 raise Program_Error;
8315 end Set_All_DT_Position;
8317 --------------------------
8318 -- Set_CPP_Constructors --
8319 --------------------------
8321 procedure Set_CPP_Constructors (Typ : Entity_Id) is
8323 procedure Set_CPP_Constructors_Old (Typ : Entity_Id);
8324 -- For backward compatibility this routine handles CPP constructors
8325 -- of non-tagged types.
8327 procedure Set_CPP_Constructors_Old (Typ : Entity_Id) is
8331 Found : Boolean := False;
8336 -- Look for the constructor entities
8338 E := Next_Entity (Typ);
8339 while Present (E) loop
8340 if Ekind (E) = E_Function
8341 and then Is_Constructor (E)
8343 -- Create the init procedure
8347 Init := Make_Defining_Identifier (Loc,
8348 Make_Init_Proc_Name (Typ));
8351 Make_Parameter_Specification (Loc,
8352 Defining_Identifier =>
8353 Make_Defining_Identifier (Loc, Name_X),
8355 New_Reference_To (Typ, Loc)));
8357 if Present (Parameter_Specifications (Parent (E))) then
8358 P := First (Parameter_Specifications (Parent (E)));
8359 while Present (P) loop
8361 Make_Parameter_Specification (Loc,
8362 Defining_Identifier =>
8363 Make_Defining_Identifier (Loc,
8364 Chars (Defining_Identifier (P))),
8366 New_Copy_Tree (Parameter_Type (P))));
8372 Make_Subprogram_Declaration (Loc,
8373 Make_Procedure_Specification (Loc,
8374 Defining_Unit_Name => Init,
8375 Parameter_Specifications => Parms)));
8377 Set_Init_Proc (Typ, Init);
8378 Set_Is_Imported (Init);
8379 Set_Interface_Name (Init, Interface_Name (E));
8380 Set_Convention (Init, Convention_C);
8381 Set_Is_Public (Init);
8382 Set_Has_Completion (Init);
8388 -- If there are no constructors, mark the type as abstract since we
8389 -- won't be able to declare objects of that type.
8392 Set_Is_Abstract_Type (Typ);
8394 end Set_CPP_Constructors_Old;
8400 Found : Boolean := False;
8404 Constructor_Decl_Node : Node_Id;
8405 Constructor_Id : Entity_Id;
8406 Wrapper_Id : Entity_Id;
8407 Wrapper_Body_Node : Node_Id;
8409 Body_Stmts : List_Id;
8410 Init_Tags_List : List_Id;
8413 pragma Assert (Is_CPP_Class (Typ));
8415 -- For backward compatibility the compiler accepts C++ classes
8416 -- imported through non-tagged record types. In such case the
8417 -- wrapper of the C++ constructor is useless because the _tag
8418 -- component is not available.
8421 -- type Root is limited record ...
8422 -- pragma Import (CPP, Root);
8423 -- function New_Root return Root;
8424 -- pragma CPP_Constructor (New_Root, ... );
8426 if not Is_Tagged_Type (Typ) then
8427 Set_CPP_Constructors_Old (Typ);
8431 -- Look for the constructor entities
8433 E := Next_Entity (Typ);
8434 while Present (E) loop
8435 if Ekind (E) = E_Function
8436 and then Is_Constructor (E)
8441 -- Generate the declaration of the imported C++ constructor
8445 Make_Parameter_Specification (Loc,
8446 Defining_Identifier =>
8447 Make_Defining_Identifier (Loc, Name_uInit),
8449 New_Reference_To (Typ, Loc)));
8451 if Present (Parameter_Specifications (Parent (E))) then
8452 P := First (Parameter_Specifications (Parent (E)));
8453 while Present (P) loop
8455 Make_Parameter_Specification (Loc,
8456 Defining_Identifier =>
8457 Make_Defining_Identifier (Loc,
8458 Chars (Defining_Identifier (P))),
8459 Parameter_Type => New_Copy_Tree (Parameter_Type (P))));
8464 Constructor_Id := Make_Temporary (Loc, 'P');
8466 Constructor_Decl_Node :=
8467 Make_Subprogram_Declaration (Loc,
8468 Make_Procedure_Specification (Loc,
8469 Defining_Unit_Name => Constructor_Id,
8470 Parameter_Specifications => Parms));
8472 Set_Is_Imported (Constructor_Id);
8473 Set_Interface_Name (Constructor_Id, Interface_Name (E));
8474 Set_Convention (Constructor_Id, Convention_C);
8475 Set_Is_Public (Constructor_Id);
8476 Set_Has_Completion (Constructor_Id);
8478 -- Build the wrapper of this constructor
8482 Make_Parameter_Specification (Loc,
8483 Defining_Identifier =>
8484 Make_Defining_Identifier (Loc, Name_uInit),
8486 New_Reference_To (Typ, Loc)));
8488 if Present (Parameter_Specifications (Parent (E))) then
8489 P := First (Parameter_Specifications (Parent (E)));
8490 while Present (P) loop
8492 Make_Parameter_Specification (Loc,
8493 Defining_Identifier =>
8494 Make_Defining_Identifier (Loc,
8495 Chars (Defining_Identifier (P))),
8496 Parameter_Type => New_Copy_Tree (Parameter_Type (P))));
8501 Body_Stmts := New_List;
8503 -- Invoke the C++ constructor
8505 Actuals := New_List;
8508 while Present (P) loop
8510 New_Reference_To (Defining_Identifier (P), Loc));
8514 Append_To (Body_Stmts,
8515 Make_Procedure_Call_Statement (Loc,
8516 Name => New_Reference_To (Constructor_Id, Loc),
8517 Parameter_Associations => Actuals));
8519 -- Initialize copies of C++ primary and secondary tags
8521 Init_Tags_List := New_List;
8528 Tag_Elmt := First_Elmt (Access_Disp_Table (Typ));
8529 Tag_Comp := First_Tag_Component (Typ);
8531 while Present (Tag_Elmt)
8532 and then Is_Tag (Node (Tag_Elmt))
8534 -- Skip the following assertion with primary tags because
8535 -- Related_Type is not set on primary tag components
8537 pragma Assert (Tag_Comp = First_Tag_Component (Typ)
8538 or else Related_Type (Node (Tag_Elmt))
8539 = Related_Type (Tag_Comp));
8541 Append_To (Init_Tags_List,
8542 Make_Assignment_Statement (Loc,
8544 New_Reference_To (Node (Tag_Elmt), Loc),
8546 Make_Selected_Component (Loc,
8548 Make_Identifier (Loc, Name_uInit),
8550 New_Reference_To (Tag_Comp, Loc))));
8552 Tag_Comp := Next_Tag_Component (Tag_Comp);
8553 Next_Elmt (Tag_Elmt);
8557 Append_To (Body_Stmts,
8558 Make_If_Statement (Loc,
8563 (Node (First_Elmt (Access_Disp_Table (Typ))),
8566 Unchecked_Convert_To (RTE (RE_Tag),
8567 New_Reference_To (RTE (RE_Null_Address), Loc))),
8568 Then_Statements => Init_Tags_List));
8570 Wrapper_Id := Make_Defining_Identifier (Loc,
8571 Make_Init_Proc_Name (Typ));
8573 Wrapper_Body_Node :=
8574 Make_Subprogram_Body (Loc,
8576 Make_Procedure_Specification (Loc,
8577 Defining_Unit_Name => Wrapper_Id,
8578 Parameter_Specifications => Parms),
8579 Declarations => New_List (Constructor_Decl_Node),
8580 Handled_Statement_Sequence =>
8581 Make_Handled_Sequence_Of_Statements (Loc,
8582 Statements => Body_Stmts,
8583 Exception_Handlers => No_List));
8585 Discard_Node (Wrapper_Body_Node);
8586 Set_Init_Proc (Typ, Wrapper_Id);
8592 -- If there are no constructors, mark the type as abstract since we
8593 -- won't be able to declare objects of that type.
8596 Set_Is_Abstract_Type (Typ);
8599 -- If the CPP type has constructors then it must import also the default
8600 -- C++ constructor. It is required for default initialization of objects
8601 -- of the type. It is also required to elaborate objects of Ada types
8602 -- that are defined as derivations of this CPP type.
8604 if Has_CPP_Constructors (Typ)
8605 and then No (Init_Proc (Typ))
8607 Error_Msg_N ("?default constructor must be imported from C++", Typ);
8609 end Set_CPP_Constructors;
8611 --------------------------
8612 -- Set_DTC_Entity_Value --
8613 --------------------------
8615 procedure Set_DTC_Entity_Value
8616 (Tagged_Type : Entity_Id;
8620 if Present (Interface_Alias (Prim))
8621 and then Is_Interface
8622 (Find_Dispatching_Type (Interface_Alias (Prim)))
8624 Set_DTC_Entity (Prim,
8627 Iface => Find_Dispatching_Type (Interface_Alias (Prim))));
8629 Set_DTC_Entity (Prim,
8630 First_Tag_Component (Tagged_Type));
8632 end Set_DTC_Entity_Value;
8638 function Tagged_Kind (T : Entity_Id) return Node_Id is
8639 Conc_Typ : Entity_Id;
8640 Loc : constant Source_Ptr := Sloc (T);
8644 (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind));
8648 if Is_Abstract_Type (T) then
8649 if Is_Limited_Record (T) then
8650 return New_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc);
8652 return New_Reference_To (RTE (RE_TK_Abstract_Tagged), Loc);
8657 elsif Is_Concurrent_Record_Type (T) then
8658 Conc_Typ := Corresponding_Concurrent_Type (T);
8660 if Present (Full_View (Conc_Typ)) then
8661 Conc_Typ := Full_View (Conc_Typ);
8664 if Ekind (Conc_Typ) = E_Protected_Type then
8665 return New_Reference_To (RTE (RE_TK_Protected), Loc);
8667 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
8668 return New_Reference_To (RTE (RE_TK_Task), Loc);
8671 -- Regular tagged kinds
8674 if Is_Limited_Record (T) then
8675 return New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc);
8677 return New_Reference_To (RTE (RE_TK_Tagged), Loc);
8686 procedure Write_DT (Typ : Entity_Id) is
8691 -- Protect this procedure against wrong usage. Required because it will
8692 -- be used directly from GDB
8694 if not (Typ <= Last_Node_Id)
8695 or else not Is_Tagged_Type (Typ)
8697 Write_Str ("wrong usage: Write_DT must be used with tagged types");
8702 Write_Int (Int (Typ));
8704 Write_Name (Chars (Typ));
8706 if Is_Interface (Typ) then
8707 Write_Str (" is interface");
8712 Elmt := First_Elmt (Primitive_Operations (Typ));
8713 while Present (Elmt) loop
8714 Prim := Node (Elmt);
8717 -- Indicate if this primitive will be allocated in the primary
8718 -- dispatch table or in a secondary dispatch table associated
8719 -- with an abstract interface type
8721 if Present (DTC_Entity (Prim)) then
8722 if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
8729 -- Output the node of this primitive operation and its name
8731 Write_Int (Int (Prim));
8734 if Is_Predefined_Dispatching_Operation (Prim) then
8735 Write_Str ("(predefined) ");
8738 -- Prefix the name of the primitive with its corresponding tagged
8739 -- type to facilitate seeing inherited primitives.
8741 if Present (Alias (Prim)) then
8743 (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim))));
8745 Write_Name (Chars (Typ));
8749 Write_Name (Chars (Prim));
8751 -- Indicate if this primitive has an aliased primitive
8753 if Present (Alias (Prim)) then
8754 Write_Str (" (alias = ");
8755 Write_Int (Int (Alias (Prim)));
8757 -- If the DTC_Entity attribute is already set we can also output
8758 -- the name of the interface covered by this primitive (if any).
8760 if Present (DTC_Entity (Alias (Prim)))
8761 and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
8763 Write_Str (" from interface ");
8764 Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
8767 if Present (Interface_Alias (Prim)) then
8768 Write_Str (", AI_Alias of ");
8770 if Is_Null_Interface_Primitive (Interface_Alias (Prim)) then
8771 Write_Str ("null primitive ");
8775 (Chars (Find_Dispatching_Type (Interface_Alias (Prim))));
8777 Write_Int (Int (Interface_Alias (Prim)));
8783 -- Display the final position of this primitive in its associated
8784 -- (primary or secondary) dispatch table
8786 if Present (DTC_Entity (Prim))
8787 and then DT_Position (Prim) /= No_Uint
8789 Write_Str (" at #");
8790 Write_Int (UI_To_Int (DT_Position (Prim)));
8793 if Is_Abstract_Subprogram (Prim) then
8794 Write_Str (" is abstract;");
8796 -- Check if this is a null primitive
8798 elsif Comes_From_Source (Prim)
8799 and then Ekind (Prim) = E_Procedure
8800 and then Null_Present (Parent (Prim))
8802 Write_Str (" is null;");
8805 if Is_Eliminated (Ultimate_Alias (Prim)) then
8806 Write_Str (" (eliminated)");
8809 if Is_Imported (Prim)
8810 and then Convention (Prim) = Convention_CPP
8812 Write_Str (" (C++)");