1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, 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_Ch7; use Exp_Ch7;
34 with Exp_Dbug; use Exp_Dbug;
35 with Exp_Tss; use Exp_Tss;
36 with Exp_Util; use Exp_Util;
37 with Freeze; use Freeze;
38 with Itypes; use Itypes;
39 with Nlists; use Nlists;
40 with Nmake; use Nmake;
41 with Namet; use Namet;
43 with Output; use Output;
44 with Restrict; use Restrict;
45 with Rident; use Rident;
46 with Rtsfind; use Rtsfind;
48 with Sem_Ch6; use Sem_Ch6;
49 with Sem_Ch7; use Sem_Ch7;
50 with Sem_Ch8; use Sem_Ch8;
51 with Sem_Disp; use Sem_Disp;
52 with Sem_Eval; use Sem_Eval;
53 with Sem_Res; use Sem_Res;
54 with Sem_Type; use Sem_Type;
55 with Sem_Util; use Sem_Util;
56 with Sinfo; use Sinfo;
57 with Snames; use Snames;
58 with Stand; use Stand;
59 with Stringt; use Stringt;
60 with Targparm; use Targparm;
61 with Tbuild; use Tbuild;
62 with Uintp; use Uintp;
64 package body Exp_Disp is
66 -----------------------
67 -- Local Subprograms --
68 -----------------------
70 function Default_Prim_Op_Position (E : Entity_Id) return Uint;
71 -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
72 -- of the default primitive operations.
74 function Has_DT (Typ : Entity_Id) return Boolean;
75 pragma Inline (Has_DT);
76 -- Returns true if we generate a dispatch table for tagged type Typ
78 function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean;
79 -- Returns true if Prim is not a predefined dispatching primitive but it is
80 -- an alias of a predefined dispatching primitive (i.e. through a renaming)
82 function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
83 -- Check if the type has a private view or if the public view appears
84 -- in the visible part of a package spec.
88 Typ : Entity_Id) return Node_Id;
89 -- Ada 2005 (AI-345): Determine the primitive operation kind of Prim
90 -- according to its type Typ. Return a reference to an RE_Prim_Op_Kind
93 function Tagged_Kind (T : Entity_Id) return Node_Id;
94 -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
95 -- to an RE_Tagged_Kind enumeration value.
97 ------------------------
98 -- Building_Static_DT --
99 ------------------------
101 function Building_Static_DT (Typ : Entity_Id) return Boolean is
102 Root_Typ : Entity_Id := Root_Type (Typ);
105 -- Handle private types
107 if Present (Full_View (Root_Typ)) then
108 Root_Typ := Full_View (Root_Typ);
111 return Static_Dispatch_Tables
112 and then Is_Library_Level_Tagged_Type (Typ)
114 -- If the type is derived from a CPP class we cannot statically
115 -- build the dispatch tables because we must inherit primitives
116 -- from the CPP side.
118 and then not Is_CPP_Class (Root_Typ);
119 end Building_Static_DT;
121 ----------------------------------
122 -- Build_Static_Dispatch_Tables --
123 ----------------------------------
125 procedure Build_Static_Dispatch_Tables (N : Entity_Id) is
126 Target_List : List_Id;
128 procedure Build_Dispatch_Tables (List : List_Id);
129 -- Build the static dispatch table of tagged types found in the list of
130 -- declarations. The generated nodes are added at the end of Target_List
132 procedure Build_Package_Dispatch_Tables (N : Node_Id);
133 -- Build static dispatch tables associated with package declaration N
135 ---------------------------
136 -- Build_Dispatch_Tables --
137 ---------------------------
139 procedure Build_Dispatch_Tables (List : List_Id) is
144 while Present (D) loop
146 -- Handle nested packages and package bodies recursively. The
147 -- generated code is placed on the Target_List established for
148 -- the enclosing compilation unit.
150 if Nkind (D) = N_Package_Declaration then
151 Build_Package_Dispatch_Tables (D);
153 elsif Nkind (D) = N_Package_Body then
154 Build_Dispatch_Tables (Declarations (D));
156 elsif Nkind (D) = N_Package_Body_Stub
157 and then Present (Library_Unit (D))
159 Build_Dispatch_Tables
160 (Declarations (Proper_Body (Unit (Library_Unit (D)))));
162 -- Handle full type declarations and derivations of library
163 -- level tagged types
165 elsif (Nkind (D) = N_Full_Type_Declaration
166 or else Nkind (D) = N_Derived_Type_Definition)
167 and then Is_Library_Level_Tagged_Type (Defining_Entity (D))
168 and then Ekind (Defining_Entity (D)) /= E_Record_Subtype
169 and then not Is_Private_Type (Defining_Entity (D))
171 Insert_List_After_And_Analyze (Last (Target_List),
172 Make_DT (Defining_Entity (D)));
174 -- Handle private types of library level tagged types. We must
175 -- exchange the private and full-view to ensure the correct
176 -- expansion. If the full view is a synchronized type ignore
177 -- the type because the table will be built for the corresponding
178 -- record type, that has its own declaration.
180 elsif (Nkind (D) = N_Private_Type_Declaration
181 or else Nkind (D) = N_Private_Extension_Declaration)
182 and then Present (Full_View (Defining_Entity (D)))
185 E1 : constant Entity_Id := Defining_Entity (D);
186 E2 : constant Entity_Id := Full_View (E1);
189 if Is_Library_Level_Tagged_Type (E2)
190 and then Ekind (E2) /= E_Record_Subtype
191 and then not Is_Concurrent_Type (E2)
193 Exchange_Declarations (E1);
194 Insert_List_After_And_Analyze (Last (Target_List),
196 Exchange_Declarations (E2);
203 end Build_Dispatch_Tables;
205 -----------------------------------
206 -- Build_Package_Dispatch_Tables --
207 -----------------------------------
209 procedure Build_Package_Dispatch_Tables (N : Node_Id) is
210 Spec : constant Node_Id := Specification (N);
211 Id : constant Entity_Id := Defining_Entity (N);
212 Vis_Decls : constant List_Id := Visible_Declarations (Spec);
213 Priv_Decls : constant List_Id := Private_Declarations (Spec);
218 if Present (Priv_Decls) then
219 Build_Dispatch_Tables (Vis_Decls);
220 Build_Dispatch_Tables (Priv_Decls);
222 elsif Present (Vis_Decls) then
223 Build_Dispatch_Tables (Vis_Decls);
227 end Build_Package_Dispatch_Tables;
229 -- Start of processing for Build_Static_Dispatch_Tables
232 if not Expander_Active
233 or else VM_Target /= No_VM
238 if Nkind (N) = N_Package_Declaration then
240 Spec : constant Node_Id := Specification (N);
241 Vis_Decls : constant List_Id := Visible_Declarations (Spec);
242 Priv_Decls : constant List_Id := Private_Declarations (Spec);
245 if Present (Priv_Decls)
246 and then Is_Non_Empty_List (Priv_Decls)
248 Target_List := Priv_Decls;
250 elsif not Present (Vis_Decls) then
251 Target_List := New_List;
252 Set_Private_Declarations (Spec, Target_List);
254 Target_List := Vis_Decls;
257 Build_Package_Dispatch_Tables (N);
260 else pragma Assert (Nkind (N) = N_Package_Body);
261 Target_List := Declarations (N);
262 Build_Dispatch_Tables (Target_List);
264 end Build_Static_Dispatch_Tables;
266 ------------------------------
267 -- Default_Prim_Op_Position --
268 ------------------------------
270 function Default_Prim_Op_Position (E : Entity_Id) return Uint is
271 TSS_Name : TSS_Name_Type;
274 Get_Name_String (Chars (E));
277 (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
279 if Chars (E) = Name_uSize then
282 elsif Chars (E) = Name_uAlignment then
285 elsif TSS_Name = TSS_Stream_Read then
288 elsif TSS_Name = TSS_Stream_Write then
291 elsif TSS_Name = TSS_Stream_Input then
294 elsif TSS_Name = TSS_Stream_Output then
297 elsif Chars (E) = Name_Op_Eq then
300 elsif Chars (E) = Name_uAssign then
303 elsif TSS_Name = TSS_Deep_Adjust then
306 elsif TSS_Name = TSS_Deep_Finalize then
309 elsif Ada_Version >= Ada_05 then
310 if Chars (E) = Name_uDisp_Asynchronous_Select then
313 elsif Chars (E) = Name_uDisp_Conditional_Select then
316 elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
319 elsif Chars (E) = Name_uDisp_Get_Task_Id then
322 elsif Chars (E) = Name_uDisp_Requeue then
325 elsif Chars (E) = Name_uDisp_Timed_Select then
331 end Default_Prim_Op_Position;
333 -----------------------------
334 -- Expand_Dispatching_Call --
335 -----------------------------
337 procedure Expand_Dispatching_Call (Call_Node : Node_Id) is
338 Loc : constant Source_Ptr := Sloc (Call_Node);
339 Call_Typ : constant Entity_Id := Etype (Call_Node);
341 Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node);
342 Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
343 Param_List : constant List_Id := Parameter_Associations (Call_Node);
348 New_Call_Name : Node_Id;
349 New_Params : List_Id := No_List;
352 Subp_Ptr_Typ : Entity_Id;
353 Subp_Typ : Entity_Id;
355 Eq_Prim_Op : Entity_Id := Empty;
356 Controlling_Tag : Node_Id;
358 function New_Value (From : Node_Id) return Node_Id;
359 -- From is the original Expression. New_Value is equivalent to a call
360 -- to Duplicate_Subexpr with an explicit dereference when From is an
367 function New_Value (From : Node_Id) return Node_Id is
368 Res : constant Node_Id := Duplicate_Subexpr (From);
370 if Is_Access_Type (Etype (From)) then
372 Make_Explicit_Dereference (Sloc (From),
379 -- Start of processing for Expand_Dispatching_Call
382 if No_Run_Time_Mode then
383 Error_Msg_CRT ("tagged types", Call_Node);
387 -- Expand_Dispatching_Call is called directly from the semantics,
388 -- so we need a check to see whether expansion is active before
389 -- proceeding. In addition, there is no need to expand the call
390 -- if we are compiling under restriction No_Dispatching_Calls;
391 -- the semantic analyzer has previously notified the violation
392 -- of this restriction.
394 if not Expander_Active
395 or else Restriction_Active (No_Dispatching_Calls)
400 -- Set subprogram. If this is an inherited operation that was
401 -- overridden, the body that is being called is its alias.
403 Subp := Entity (Name (Call_Node));
405 if Present (Alias (Subp))
406 and then Is_Inherited_Operation (Subp)
407 and then No (DTC_Entity (Subp))
409 Subp := Alias (Subp);
412 -- Definition of the class-wide type and the tagged type
414 -- If the controlling argument is itself a tag rather than a tagged
415 -- object, then use the class-wide type associated with the subprogram's
416 -- controlling type. This case can occur when a call to an inherited
417 -- primitive has an actual that originated from a default parameter
418 -- given by a tag-indeterminate call and when there is no other
419 -- controlling argument providing the tag (AI-239 requires dispatching).
420 -- This capability of dispatching directly by tag is also needed by the
421 -- implementation of AI-260 (for the generic dispatching constructors).
423 if Ctrl_Typ = RTE (RE_Tag)
424 or else (RTE_Available (RE_Interface_Tag)
425 and then Ctrl_Typ = RTE (RE_Interface_Tag))
427 CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
429 -- Class_Wide_Type is applied to the expressions used to initialize
430 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
431 -- there are cases where the controlling type is resolved to a specific
432 -- type (such as for designated types of arguments such as CW'Access).
434 elsif Is_Access_Type (Ctrl_Typ) then
435 CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ));
438 CW_Typ := Class_Wide_Type (Ctrl_Typ);
441 Typ := Root_Type (CW_Typ);
443 if Ekind (Typ) = E_Incomplete_Type then
444 Typ := Non_Limited_View (Typ);
447 if not Is_Limited_Type (Typ) then
448 Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
451 -- Dispatching call to C++ primitive. Create a new parameter list
452 -- with no tag checks.
454 if Is_CPP_Class (Typ) then
455 New_Params := New_List;
456 Param := First_Actual (Call_Node);
457 while Present (Param) loop
458 Append_To (New_Params, Relocate_Node (Param));
462 -- Dispatching call to Ada primitive
464 elsif Present (Param_List) then
466 -- Generate the Tag checks when appropriate
468 New_Params := New_List;
469 Param := First_Actual (Call_Node);
470 while Present (Param) loop
472 -- No tag check with itself
474 if Param = Ctrl_Arg then
475 Append_To (New_Params,
476 Duplicate_Subexpr_Move_Checks (Param));
478 -- No tag check for parameter whose type is neither tagged nor
479 -- access to tagged (for access parameters)
481 elsif No (Find_Controlling_Arg (Param)) then
482 Append_To (New_Params, Relocate_Node (Param));
484 -- No tag check for function dispatching on result if the
485 -- Tag given by the context is this one
487 elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
488 Append_To (New_Params, Relocate_Node (Param));
490 -- "=" is the only dispatching operation allowed to get
491 -- operands with incompatible tags (it just returns false).
492 -- We use Duplicate_Subexpr_Move_Checks instead of calling
493 -- Relocate_Node because the value will be duplicated to
496 elsif Subp = Eq_Prim_Op then
497 Append_To (New_Params,
498 Duplicate_Subexpr_Move_Checks (Param));
500 -- No check in presence of suppress flags
502 elsif Tag_Checks_Suppressed (Etype (Param))
503 or else (Is_Access_Type (Etype (Param))
504 and then Tag_Checks_Suppressed
505 (Designated_Type (Etype (Param))))
507 Append_To (New_Params, Relocate_Node (Param));
509 -- Optimization: no tag checks if the parameters are identical
511 elsif Is_Entity_Name (Param)
512 and then Is_Entity_Name (Ctrl_Arg)
513 and then Entity (Param) = Entity (Ctrl_Arg)
515 Append_To (New_Params, Relocate_Node (Param));
517 -- Now we need to generate the Tag check
520 -- Generate code for tag equality check
521 -- Perhaps should have Checks.Apply_Tag_Equality_Check???
523 Insert_Action (Ctrl_Arg,
524 Make_Implicit_If_Statement (Call_Node,
528 Make_Selected_Component (Loc,
529 Prefix => New_Value (Ctrl_Arg),
532 (First_Tag_Component (Typ), Loc)),
535 Make_Selected_Component (Loc,
537 Unchecked_Convert_To (Typ, New_Value (Param)),
540 (First_Tag_Component (Typ), Loc))),
543 New_List (New_Constraint_Error (Loc))));
545 Append_To (New_Params, Relocate_Node (Param));
552 -- Generate the appropriate subprogram pointer type
554 if Etype (Subp) = Typ then
557 Res_Typ := Etype (Subp);
560 Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
561 Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
562 Set_Etype (Subp_Typ, Res_Typ);
563 Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
565 -- Create a new list of parameters which is a copy of the old formal
566 -- list including the creation of a new set of matching entities.
569 Old_Formal : Entity_Id := First_Formal (Subp);
570 New_Formal : Entity_Id;
571 Extra : Entity_Id := Empty;
574 if Present (Old_Formal) then
575 New_Formal := New_Copy (Old_Formal);
576 Set_First_Entity (Subp_Typ, New_Formal);
577 Param := First_Actual (Call_Node);
580 Set_Scope (New_Formal, Subp_Typ);
582 -- Change all the controlling argument types to be class-wide
583 -- to avoid a recursion in dispatching.
585 if Is_Controlling_Formal (New_Formal) then
586 Set_Etype (New_Formal, Etype (Param));
589 -- If the type of the formal is an itype, there was code here
590 -- introduced in 1998 in revision 1.46, to create a new itype
591 -- by copy. This seems useless, and in fact leads to semantic
592 -- errors when the itype is the completion of a type derived
593 -- from a private type.
596 Next_Formal (Old_Formal);
597 exit when No (Old_Formal);
599 Set_Next_Entity (New_Formal, New_Copy (Old_Formal));
600 Next_Entity (New_Formal);
604 Set_Next_Entity (New_Formal, Empty);
605 Set_Last_Entity (Subp_Typ, Extra);
608 -- Now that the explicit formals have been duplicated, any extra
609 -- formals needed by the subprogram must be created.
611 if Present (Extra) then
612 Set_Extra_Formal (Extra, Empty);
615 Create_Extra_Formals (Subp_Typ);
618 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
619 Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
620 Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ));
622 -- If the controlling argument is a value of type Ada.Tag or an abstract
623 -- interface class-wide type then use it directly. Otherwise, the tag
624 -- must be extracted from the controlling object.
626 if Ctrl_Typ = RTE (RE_Tag)
627 or else (RTE_Available (RE_Interface_Tag)
628 and then Ctrl_Typ = RTE (RE_Interface_Tag))
630 Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
632 -- Extract the tag from an unchecked type conversion. Done to avoid
633 -- the expansion of additional code just to obtain the value of such
634 -- tag because the current management of interface type conversions
635 -- generates in some cases this unchecked type conversion with the
636 -- tag of the object (see Expand_Interface_Conversion).
638 elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion
640 (Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag)
642 (RTE_Available (RE_Interface_Tag)
644 Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag)))
646 Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg));
648 -- Ada 2005 (AI-251): Abstract interface class-wide type
650 elsif Is_Interface (Ctrl_Typ)
651 and then Is_Class_Wide_Type (Ctrl_Typ)
653 Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
657 Make_Selected_Component (Loc,
658 Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
659 Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc));
662 -- Handle dispatching calls to predefined primitives
664 if Is_Predefined_Dispatching_Operation (Subp)
665 or else Is_Predefined_Dispatching_Alias (Subp)
668 Unchecked_Convert_To (Subp_Ptr_Typ,
669 Build_Get_Predefined_Prim_Op_Address (Loc,
670 Tag_Node => Controlling_Tag,
671 Position => DT_Position (Subp)));
673 -- Handle dispatching calls to user-defined primitives
677 Unchecked_Convert_To (Subp_Ptr_Typ,
678 Build_Get_Prim_Op_Address (Loc,
679 Typ => Find_Dispatching_Type (Subp),
680 Tag_Node => Controlling_Tag,
681 Position => DT_Position (Subp)));
684 if Nkind (Call_Node) = N_Function_Call then
687 Make_Function_Call (Loc,
688 Name => New_Call_Name,
689 Parameter_Associations => New_Params);
691 -- If this is a dispatching "=", we must first compare the tags so
692 -- we generate: x.tag = y.tag and then x = y
694 if Subp = Eq_Prim_Op then
695 Param := First_Actual (Call_Node);
701 Make_Selected_Component (Loc,
702 Prefix => New_Value (Param),
704 New_Reference_To (First_Tag_Component (Typ),
708 Make_Selected_Component (Loc,
710 Unchecked_Convert_To (Typ,
711 New_Value (Next_Actual (Param))),
713 New_Reference_To (First_Tag_Component (Typ),
715 Right_Opnd => New_Call);
720 Make_Procedure_Call_Statement (Loc,
721 Name => New_Call_Name,
722 Parameter_Associations => New_Params);
725 Rewrite (Call_Node, New_Call);
727 -- Suppress all checks during the analysis of the expanded code
728 -- to avoid the generation of spurious warnings under ZFP run-time.
730 Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks);
731 end Expand_Dispatching_Call;
733 ---------------------------------
734 -- Expand_Interface_Conversion --
735 ---------------------------------
737 procedure Expand_Interface_Conversion
739 Is_Static : Boolean := True)
741 Loc : constant Source_Ptr := Sloc (N);
742 Etyp : constant Entity_Id := Etype (N);
743 Operand : constant Node_Id := Expression (N);
744 Operand_Typ : Entity_Id := Etype (Operand);
746 Iface_Typ : Entity_Id := Etype (N);
747 Iface_Tag : Entity_Id;
750 -- Ada 2005 (AI-345): Handle synchronized interface type derivations
752 if Is_Concurrent_Type (Operand_Typ) then
753 Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
756 -- Handle access to class-wide interface types
758 if Is_Access_Type (Iface_Typ) then
759 Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ));
762 -- Handle class-wide interface types. This conversion can appear
763 -- explicitly in the source code. Example: I'Class (Obj)
765 if Is_Class_Wide_Type (Iface_Typ) then
766 Iface_Typ := Root_Type (Iface_Typ);
769 -- If the target type is a tagged synchronized type, the dispatch table
770 -- info is in the correspondoing record type.
772 if Is_Concurrent_Type (Iface_Typ) then
773 Iface_Typ := Corresponding_Record_Type (Iface_Typ);
776 -- Freeze the entity associated with the target interface to have
777 -- available the attribute Access_Disp_Table.
779 Freeze_Before (N, Iface_Typ);
781 pragma Assert (not Is_Static
782 or else (not Is_Class_Wide_Type (Iface_Typ)
783 and then Is_Interface (Iface_Typ)));
785 if VM_Target /= No_VM then
787 -- For VM, just do a conversion ???
789 Rewrite (N, Unchecked_Convert_To (Etype (N), N));
794 if not Is_Static then
796 -- Give error if configurable run time and Displace not available
798 if not RTE_Available (RE_Displace) then
799 Error_Msg_CRT ("dynamic interface conversion", N);
803 -- Handle conversion of access-to-class-wide interface types. Target
804 -- can be an access to an object or an access to another class-wide
805 -- interface (see -1- and -2- in the following example):
807 -- type Iface1_Ref is access all Iface1'Class;
808 -- type Iface2_Ref is access all Iface1'Class;
810 -- Acc1 : Iface1_Ref := new ...
811 -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1
812 -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
814 if Is_Access_Type (Operand_Typ) then
816 Unchecked_Convert_To (Etype (N),
817 Make_Function_Call (Loc,
818 Name => New_Reference_To (RTE (RE_Displace), Loc),
819 Parameter_Associations => New_List (
821 Unchecked_Convert_To (RTE (RE_Address),
822 Relocate_Node (Expression (N))),
825 (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
833 Make_Function_Call (Loc,
834 Name => New_Reference_To (RTE (RE_Displace), Loc),
835 Parameter_Associations => New_List (
836 Make_Attribute_Reference (Loc,
837 Prefix => Relocate_Node (Expression (N)),
838 Attribute_Name => Name_Address),
841 (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
846 -- If the target is a class-wide interface we change the type of the
847 -- data returned by IW_Convert to indicate that this is a dispatching
851 New_Itype : Entity_Id;
854 New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
855 Set_Etype (New_Itype, New_Itype);
856 Set_Directly_Designated_Type (New_Itype, Etyp);
859 Make_Explicit_Dereference (Loc,
861 Unchecked_Convert_To (New_Itype, Relocate_Node (N))));
863 Freeze_Itype (New_Itype, N);
869 Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
870 pragma Assert (Iface_Tag /= Empty);
872 -- Keep separate access types to interfaces because one internal
873 -- function is used to handle the null value (see following comment)
875 if not Is_Access_Type (Etype (N)) then
877 Unchecked_Convert_To (Etype (N),
878 Make_Selected_Component (Loc,
879 Prefix => Relocate_Node (Expression (N)),
881 New_Occurrence_Of (Iface_Tag, Loc))));
884 -- Build internal function to handle the case in which the
885 -- actual is null. If the actual is null returns null because
886 -- no displacement is required; otherwise performs a type
887 -- conversion that will be expanded in the code that returns
888 -- the value of the displaced actual. That is:
890 -- function Func (O : Address) return Iface_Typ is
891 -- type Op_Typ is access all Operand_Typ;
892 -- Aux : Op_Typ := To_Op_Typ (O);
894 -- if O = Null_Address then
897 -- return Iface_Typ!(Aux.Iface_Tag'Address);
902 Desig_Typ : Entity_Id;
904 New_Typ_Decl : Node_Id;
908 Desig_Typ := Etype (Expression (N));
910 if Is_Access_Type (Desig_Typ) then
911 Desig_Typ := Directly_Designated_Type (Desig_Typ);
914 if Is_Concurrent_Type (Desig_Typ) then
915 Desig_Typ := Base_Type (Corresponding_Record_Type (Desig_Typ));
919 Make_Full_Type_Declaration (Loc,
920 Defining_Identifier =>
921 Make_Defining_Identifier (Loc, New_Internal_Name ('T')),
923 Make_Access_To_Object_Definition (Loc,
925 Null_Exclusion_Present => False,
926 Constant_Present => False,
927 Subtype_Indication =>
928 New_Reference_To (Desig_Typ, Loc)));
931 Make_Simple_Return_Statement (Loc,
932 Unchecked_Convert_To (Etype (N),
933 Make_Attribute_Reference (Loc,
935 Make_Selected_Component (Loc,
938 (Defining_Identifier (New_Typ_Decl),
939 Make_Identifier (Loc, Name_uO)),
941 New_Occurrence_Of (Iface_Tag, Loc)),
942 Attribute_Name => Name_Address))));
944 -- If the type is null-excluding, no need for the null branch.
945 -- Otherwise we need to check for it and return null.
947 if not Can_Never_Be_Null (Etype (N)) then
949 Make_If_Statement (Loc,
952 Left_Opnd => Make_Identifier (Loc, Name_uO),
953 Right_Opnd => New_Reference_To
954 (RTE (RE_Null_Address), Loc)),
956 Then_Statements => New_List (
957 Make_Simple_Return_Statement (Loc,
959 Else_Statements => Stats));
963 Make_Defining_Identifier (Loc,
964 New_Internal_Name ('F'));
967 Make_Subprogram_Body (Loc,
969 Make_Function_Specification (Loc,
970 Defining_Unit_Name => Fent,
972 Parameter_Specifications => New_List (
973 Make_Parameter_Specification (Loc,
974 Defining_Identifier =>
975 Make_Defining_Identifier (Loc, Name_uO),
977 New_Reference_To (RTE (RE_Address), Loc))),
980 New_Reference_To (Etype (N), Loc)),
982 Declarations => New_List (New_Typ_Decl),
984 Handled_Statement_Sequence =>
985 Make_Handled_Sequence_Of_Statements (Loc, Stats));
987 -- Place function body before the expression containing the
988 -- conversion. We suppress all checks because the body of the
989 -- internally generated function already takes care of the case
990 -- in which the actual is null; therefore there is no need to
991 -- double check that the pointer is not null when the program
992 -- executes the alternative that performs the type conversion).
994 Insert_Action (N, Func, Suppress => All_Checks);
996 if Is_Access_Type (Etype (Expression (N))) then
998 -- Generate: Func (Address!(Expression))
1001 Make_Function_Call (Loc,
1002 Name => New_Reference_To (Fent, Loc),
1003 Parameter_Associations => New_List (
1004 Unchecked_Convert_To (RTE (RE_Address),
1005 Relocate_Node (Expression (N))))));
1008 -- Generate: Func (Operand_Typ!(Expression)'Address)
1011 Make_Function_Call (Loc,
1012 Name => New_Reference_To (Fent, Loc),
1013 Parameter_Associations => New_List (
1014 Make_Attribute_Reference (Loc,
1015 Prefix => Unchecked_Convert_To (Operand_Typ,
1016 Relocate_Node (Expression (N))),
1017 Attribute_Name => Name_Address))));
1023 end Expand_Interface_Conversion;
1025 ------------------------------
1026 -- Expand_Interface_Actuals --
1027 ------------------------------
1029 procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
1031 Actual_Dup : Node_Id;
1032 Actual_Typ : Entity_Id;
1034 Conversion : Node_Id;
1036 Formal_Typ : Entity_Id;
1038 Formal_DDT : Entity_Id;
1039 Actual_DDT : Entity_Id;
1042 -- This subprogram is called directly from the semantics, so we need a
1043 -- check to see whether expansion is active before proceeding.
1045 if not Expander_Active then
1049 -- Call using access to subprogram with explicit dereference
1051 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
1052 Subp := Etype (Name (Call_Node));
1054 -- Call using selected component
1056 elsif Nkind (Name (Call_Node)) = N_Selected_Component then
1057 Subp := Entity (Selector_Name (Name (Call_Node)));
1059 -- Call using direct name
1062 Subp := Entity (Name (Call_Node));
1065 -- Ada 2005 (AI-251): Look for interface type formals to force "this"
1068 Formal := First_Formal (Subp);
1069 Actual := First_Actual (Call_Node);
1070 while Present (Formal) loop
1071 Formal_Typ := Etype (Formal);
1073 if Ekind (Formal_Typ) = E_Record_Type_With_Private then
1074 Formal_Typ := Full_View (Formal_Typ);
1077 if Is_Access_Type (Formal_Typ) then
1078 Formal_DDT := Directly_Designated_Type (Formal_Typ);
1081 Actual_Typ := Etype (Actual);
1083 if Is_Access_Type (Actual_Typ) then
1084 Actual_DDT := Directly_Designated_Type (Actual_Typ);
1087 if Is_Interface (Formal_Typ)
1088 and then Is_Class_Wide_Type (Formal_Typ)
1090 -- No need to displace the pointer if the type of the actual
1091 -- coindices with the type of the formal.
1093 if Actual_Typ = Formal_Typ then
1096 -- No need to displace the pointer if the interface type is
1097 -- a parent of the type of the actual because in this case the
1098 -- interface primitives are located in the primary dispatch table.
1100 elsif Is_Ancestor (Formal_Typ, Actual_Typ) then
1103 -- Implicit conversion to the class-wide formal type to force
1104 -- the displacement of the pointer.
1107 Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
1108 Rewrite (Actual, Conversion);
1109 Analyze_And_Resolve (Actual, Formal_Typ);
1112 -- Access to class-wide interface type
1114 elsif Is_Access_Type (Formal_Typ)
1115 and then Is_Interface (Formal_DDT)
1116 and then Is_Class_Wide_Type (Formal_DDT)
1117 and then Interface_Present_In_Ancestor
1119 Iface => Etype (Formal_DDT))
1121 -- Handle attributes 'Access and 'Unchecked_Access
1123 if Nkind (Actual) = N_Attribute_Reference
1125 (Attribute_Name (Actual) = Name_Access
1126 or else Attribute_Name (Actual) = Name_Unchecked_Access)
1128 -- This case must have been handled by the analysis and
1129 -- expansion of 'Access. The only exception is when types
1130 -- match and no further expansion is required.
1132 pragma Assert (Base_Type (Etype (Prefix (Actual)))
1133 = Base_Type (Formal_DDT));
1136 -- No need to displace the pointer if the type of the actual
1137 -- coincides with the type of the formal.
1139 elsif Actual_DDT = Formal_DDT then
1142 -- No need to displace the pointer if the interface type is
1143 -- a parent of the type of the actual because in this case the
1144 -- interface primitives are located in the primary dispatch table.
1146 elsif Is_Ancestor (Formal_DDT, Actual_DDT) then
1150 Actual_Dup := Relocate_Node (Actual);
1152 if From_With_Type (Actual_Typ) then
1154 -- If the type of the actual parameter comes from a limited
1155 -- with-clause and the non-limited view is already available
1156 -- we replace the anonymous access type by a duplicate
1157 -- declaration whose designated type is the non-limited view
1159 if Ekind (Actual_DDT) = E_Incomplete_Type
1160 and then Present (Non_Limited_View (Actual_DDT))
1162 Anon := New_Copy (Actual_Typ);
1164 if Is_Itype (Anon) then
1165 Set_Scope (Anon, Current_Scope);
1168 Set_Directly_Designated_Type (Anon,
1169 Non_Limited_View (Actual_DDT));
1170 Set_Etype (Actual_Dup, Anon);
1172 elsif Is_Class_Wide_Type (Actual_DDT)
1173 and then Ekind (Etype (Actual_DDT)) = E_Incomplete_Type
1174 and then Present (Non_Limited_View (Etype (Actual_DDT)))
1176 Anon := New_Copy (Actual_Typ);
1178 if Is_Itype (Anon) then
1179 Set_Scope (Anon, Current_Scope);
1182 Set_Directly_Designated_Type (Anon,
1183 New_Copy (Actual_DDT));
1184 Set_Class_Wide_Type (Directly_Designated_Type (Anon),
1185 New_Copy (Class_Wide_Type (Actual_DDT)));
1186 Set_Etype (Directly_Designated_Type (Anon),
1187 Non_Limited_View (Etype (Actual_DDT)));
1189 Class_Wide_Type (Directly_Designated_Type (Anon)),
1190 Non_Limited_View (Etype (Actual_DDT)));
1191 Set_Etype (Actual_Dup, Anon);
1195 Conversion := Convert_To (Formal_Typ, Actual_Dup);
1196 Rewrite (Actual, Conversion);
1197 Analyze_And_Resolve (Actual, Formal_Typ);
1201 Next_Actual (Actual);
1202 Next_Formal (Formal);
1204 end Expand_Interface_Actuals;
1206 ----------------------------
1207 -- Expand_Interface_Thunk --
1208 ----------------------------
1210 procedure Expand_Interface_Thunk
1212 Thunk_Id : out Entity_Id;
1213 Thunk_Code : out Node_Id)
1215 Loc : constant Source_Ptr := Sloc (Prim);
1216 Actuals : constant List_Id := New_List;
1217 Decl : constant List_Id := New_List;
1218 Formals : constant List_Id := New_List;
1220 Controlling_Typ : Entity_Id;
1225 Offset_To_Top : Node_Id;
1227 Target_Formal : Entity_Id;
1231 Thunk_Code := Empty;
1233 -- Traverse the list of alias to find the final target
1236 while Present (Alias (Target)) loop
1237 Target := Alias (Target);
1240 -- In case of primitives that are functions without formals and
1241 -- a controlling result there is no need to build the thunk.
1243 if not Present (First_Formal (Target)) then
1244 pragma Assert (Ekind (Target) = E_Function
1245 and then Has_Controlling_Result (Target));
1249 -- Duplicate the formals
1251 Formal := First_Formal (Target);
1252 while Present (Formal) loop
1254 Make_Parameter_Specification (Loc,
1255 Defining_Identifier =>
1256 Make_Defining_Identifier (Sloc (Formal),
1257 Chars => Chars (Formal)),
1258 In_Present => In_Present (Parent (Formal)),
1259 Out_Present => Out_Present (Parent (Formal)),
1261 New_Reference_To (Etype (Formal), Loc),
1262 Expression => New_Copy_Tree (Expression (Parent (Formal)))));
1264 Next_Formal (Formal);
1267 Controlling_Typ := Find_Dispatching_Type (Target);
1269 Target_Formal := First_Formal (Target);
1270 Formal := First (Formals);
1271 while Present (Formal) loop
1272 if Ekind (Target_Formal) = E_In_Parameter
1273 and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
1274 and then Directly_Designated_Type (Etype (Target_Formal))
1279 -- type T is access all <<type of the target formal>>
1280 -- S : Storage_Offset := Storage_Offset!(Formal)
1281 -- - Offset_To_Top (address!(Formal))
1284 Make_Full_Type_Declaration (Loc,
1285 Defining_Identifier =>
1286 Make_Defining_Identifier (Loc,
1287 New_Internal_Name ('T')),
1289 Make_Access_To_Object_Definition (Loc,
1290 All_Present => True,
1291 Null_Exclusion_Present => False,
1292 Constant_Present => False,
1293 Subtype_Indication =>
1295 (Directly_Designated_Type
1296 (Etype (Target_Formal)), Loc)));
1299 Unchecked_Convert_To (RTE (RE_Address),
1300 New_Reference_To (Defining_Identifier (Formal), Loc));
1302 if not RTE_Available (RE_Offset_To_Top) then
1304 Build_Offset_To_Top (Loc, New_Arg);
1307 Make_Function_Call (Loc,
1308 Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
1309 Parameter_Associations => New_List (New_Arg));
1313 Make_Object_Declaration (Loc,
1314 Defining_Identifier =>
1315 Make_Defining_Identifier (Loc,
1316 New_Internal_Name ('S')),
1317 Constant_Present => True,
1318 Object_Definition =>
1319 New_Reference_To (RTE (RE_Storage_Offset), Loc),
1321 Make_Op_Subtract (Loc,
1323 Unchecked_Convert_To
1324 (RTE (RE_Storage_Offset),
1325 New_Reference_To (Defining_Identifier (Formal), Loc)),
1329 Append_To (Decl, Decl_2);
1330 Append_To (Decl, Decl_1);
1332 -- Reference the new actual. Generate:
1336 Unchecked_Convert_To
1337 (Defining_Identifier (Decl_2),
1338 New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1340 elsif Etype (Target_Formal) = Controlling_Typ then
1343 -- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
1344 -- - Offset_To_Top (Formal'Address)
1345 -- S2 : Addr_Ptr := Addr_Ptr!(S1)
1348 Make_Attribute_Reference (Loc,
1350 New_Reference_To (Defining_Identifier (Formal), Loc),
1354 if not RTE_Available (RE_Offset_To_Top) then
1356 Build_Offset_To_Top (Loc, New_Arg);
1359 Make_Function_Call (Loc,
1360 Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
1361 Parameter_Associations => New_List (New_Arg));
1365 Make_Object_Declaration (Loc,
1366 Defining_Identifier =>
1367 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
1368 Constant_Present => True,
1369 Object_Definition =>
1370 New_Reference_To (RTE (RE_Storage_Offset), Loc),
1372 Make_Op_Subtract (Loc,
1374 Unchecked_Convert_To
1375 (RTE (RE_Storage_Offset),
1376 Make_Attribute_Reference (Loc,
1379 (Defining_Identifier (Formal), Loc),
1380 Attribute_Name => Name_Address)),
1385 Make_Object_Declaration (Loc,
1386 Defining_Identifier =>
1387 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
1388 Constant_Present => True,
1389 Object_Definition => New_Reference_To (RTE (RE_Addr_Ptr), Loc),
1391 Unchecked_Convert_To
1393 New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1395 Append_To (Decl, Decl_1);
1396 Append_To (Decl, Decl_2);
1398 -- Reference the new actual. Generate:
1399 -- Target_Formal (S2.all)
1402 Unchecked_Convert_To
1403 (Etype (Target_Formal),
1404 Make_Explicit_Dereference (Loc,
1405 New_Reference_To (Defining_Identifier (Decl_2), Loc))));
1407 -- No special management required for this actual
1411 New_Reference_To (Defining_Identifier (Formal), Loc));
1414 Next_Formal (Target_Formal);
1419 Make_Defining_Identifier (Loc,
1420 Chars => New_Internal_Name ('T'));
1422 Set_Is_Thunk (Thunk_Id);
1424 if Ekind (Target) = E_Procedure then
1426 Make_Subprogram_Body (Loc,
1428 Make_Procedure_Specification (Loc,
1429 Defining_Unit_Name => Thunk_Id,
1430 Parameter_Specifications => Formals),
1431 Declarations => Decl,
1432 Handled_Statement_Sequence =>
1433 Make_Handled_Sequence_Of_Statements (Loc,
1434 Statements => New_List (
1435 Make_Procedure_Call_Statement (Loc,
1436 Name => New_Occurrence_Of (Target, Loc),
1437 Parameter_Associations => Actuals))));
1439 else pragma Assert (Ekind (Target) = E_Function);
1442 Make_Subprogram_Body (Loc,
1444 Make_Function_Specification (Loc,
1445 Defining_Unit_Name => Thunk_Id,
1446 Parameter_Specifications => Formals,
1447 Result_Definition =>
1448 New_Copy (Result_Definition (Parent (Target)))),
1449 Declarations => Decl,
1450 Handled_Statement_Sequence =>
1451 Make_Handled_Sequence_Of_Statements (Loc,
1452 Statements => New_List (
1453 Make_Simple_Return_Statement (Loc,
1454 Make_Function_Call (Loc,
1455 Name => New_Occurrence_Of (Target, Loc),
1456 Parameter_Associations => Actuals)))));
1458 end Expand_Interface_Thunk;
1464 function Has_DT (Typ : Entity_Id) return Boolean is
1466 return not Is_Interface (Typ)
1467 and then not Restriction_Active (No_Dispatching_Calls);
1470 -----------------------------------------
1471 -- Is_Predefined_Dispatching_Operation --
1472 -----------------------------------------
1474 function Is_Predefined_Dispatching_Operation
1475 (E : Entity_Id) return Boolean
1477 TSS_Name : TSS_Name_Type;
1480 if not Is_Dispatching_Operation (E) then
1484 Get_Name_String (Chars (E));
1486 -- Most predefined primitives have internally generated names. Equality
1487 -- must be treated differently; the predefined operation is recognized
1488 -- as a homogeneous binary operator that returns Boolean.
1490 if Name_Len > TSS_Name_Type'Last then
1491 TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
1493 if Chars (E) = Name_uSize
1494 or else Chars (E) = Name_uAlignment
1495 or else TSS_Name = TSS_Stream_Read
1496 or else TSS_Name = TSS_Stream_Write
1497 or else TSS_Name = TSS_Stream_Input
1498 or else TSS_Name = TSS_Stream_Output
1500 (Chars (E) = Name_Op_Eq
1501 and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
1502 or else Chars (E) = Name_uAssign
1503 or else TSS_Name = TSS_Deep_Adjust
1504 or else TSS_Name = TSS_Deep_Finalize
1505 or else Is_Predefined_Interface_Primitive (E)
1512 end Is_Predefined_Dispatching_Operation;
1514 -------------------------------------
1515 -- Is_Predefined_Dispatching_Alias --
1516 -------------------------------------
1518 function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean
1523 if not Is_Predefined_Dispatching_Operation (Prim)
1524 and then Present (Alias (Prim))
1527 while Present (Alias (E)) loop
1531 if Is_Predefined_Dispatching_Operation (E) then
1537 end Is_Predefined_Dispatching_Alias;
1539 ---------------------------------------
1540 -- Is_Predefined_Interface_Primitive --
1541 ---------------------------------------
1543 function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is
1545 return Ada_Version >= Ada_05
1546 and then (Chars (E) = Name_uDisp_Asynchronous_Select or else
1547 Chars (E) = Name_uDisp_Conditional_Select or else
1548 Chars (E) = Name_uDisp_Get_Prim_Op_Kind or else
1549 Chars (E) = Name_uDisp_Get_Task_Id or else
1550 Chars (E) = Name_uDisp_Requeue or else
1551 Chars (E) = Name_uDisp_Timed_Select);
1552 end Is_Predefined_Interface_Primitive;
1554 ----------------------------------------
1555 -- Make_Disp_Asynchronous_Select_Body --
1556 ----------------------------------------
1558 -- For interface types, generate:
1560 -- procedure _Disp_Asynchronous_Select
1561 -- (T : in out <Typ>;
1563 -- P : System.Address;
1564 -- B : out System.Storage_Elements.Dummy_Communication_Block;
1569 -- end _Disp_Asynchronous_Select;
1571 -- For protected types, generate:
1573 -- procedure _Disp_Asynchronous_Select
1574 -- (T : in out <Typ>;
1576 -- P : System.Address;
1577 -- B : out System.Storage_Elements.Dummy_Communication_Block;
1581 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
1582 -- Bnn : System.Tasking.Protected_Objects.Operations.
1583 -- Communication_Block;
1585 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
1586 -- (T._object'Access,
1587 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
1589 -- System.Tasking.Asynchronous_Call,
1591 -- B := System.Storage_Elements.Dummy_Communication_Block (Bnn);
1592 -- end _Disp_Asynchronous_Select;
1594 -- For task types, generate:
1596 -- procedure _Disp_Asynchronous_Select
1597 -- (T : in out <Typ>;
1599 -- P : System.Address;
1600 -- B : out System.Storage_Elements.Dummy_Communication_Block;
1604 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
1606 -- System.Tasking.Rendezvous.Task_Entry_Call
1608 -- System.Tasking.Task_Entry_Index (I),
1610 -- System.Tasking.Asynchronous_Call,
1612 -- end _Disp_Asynchronous_Select;
1614 function Make_Disp_Asynchronous_Select_Body
1615 (Typ : Entity_Id) return Node_Id
1617 Com_Block : Entity_Id;
1618 Conc_Typ : Entity_Id := Empty;
1619 Decls : constant List_Id := New_List;
1621 Loc : constant Source_Ptr := Sloc (Typ);
1623 Stmts : constant List_Id := New_List;
1626 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1628 -- Null body is generated for interface types
1630 if Is_Interface (Typ) then
1632 Make_Subprogram_Body (Loc,
1634 Make_Disp_Asynchronous_Select_Spec (Typ),
1637 Handled_Statement_Sequence =>
1638 Make_Handled_Sequence_Of_Statements (Loc,
1639 New_List (Make_Null_Statement (Loc))));
1642 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
1644 if Is_Concurrent_Record_Type (Typ) then
1645 Conc_Typ := Corresponding_Concurrent_Type (Typ);
1649 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
1651 -- where I will be used to capture the entry index of the primitive
1652 -- wrapper at position S.
1655 Make_Object_Declaration (Loc,
1656 Defining_Identifier =>
1657 Make_Defining_Identifier (Loc, Name_uI),
1658 Object_Definition =>
1659 New_Reference_To (Standard_Integer, Loc),
1661 Make_Function_Call (Loc,
1663 New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
1664 Parameter_Associations =>
1666 Unchecked_Convert_To (RTE (RE_Tag),
1667 New_Reference_To (DT_Ptr, Loc)),
1668 Make_Identifier (Loc, Name_uS)))));
1670 if Ekind (Conc_Typ) = E_Protected_Type then
1673 -- Bnn : Communication_Block;
1676 Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
1679 Make_Object_Declaration (Loc,
1680 Defining_Identifier =>
1682 Object_Definition =>
1683 New_Reference_To (RTE (RE_Communication_Block), Loc)));
1685 -- Build T._object'Access for calls below
1688 Make_Attribute_Reference (Loc,
1689 Attribute_Name => Name_Unchecked_Access,
1691 Make_Selected_Component (Loc,
1692 Prefix => Make_Identifier (Loc, Name_uT),
1693 Selector_Name => Make_Identifier (Loc, Name_uObject)));
1695 case Corresponding_Runtime_Package (Conc_Typ) is
1696 when System_Tasking_Protected_Objects_Entries =>
1699 -- Protected_Entry_Call
1700 -- (T._object'Access, -- Object
1701 -- Protected_Entry_Index! (I), -- E
1702 -- P, -- Uninterpreted_Data
1703 -- Asynchronous_Call, -- Mode
1704 -- Bnn); -- Communication_Block
1706 -- where T is the protected object, I is the entry index, P
1707 -- is the wrapped parameters and B is the name of the
1708 -- communication block.
1711 Make_Procedure_Call_Statement (Loc,
1713 New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
1714 Parameter_Associations =>
1718 Make_Unchecked_Type_Conversion (Loc, -- entry index
1721 (RTE (RE_Protected_Entry_Index), Loc),
1722 Expression => Make_Identifier (Loc, Name_uI)),
1724 Make_Identifier (Loc, Name_uP), -- parameter block
1725 New_Reference_To ( -- Asynchronous_Call
1726 RTE (RE_Asynchronous_Call), Loc),
1728 New_Reference_To (Com_Block, Loc)))); -- comm block
1730 when System_Tasking_Protected_Objects_Single_Entry =>
1733 -- procedure Protected_Single_Entry_Call
1734 -- (Object : Protection_Entry_Access;
1735 -- Uninterpreted_Data : System.Address;
1736 -- Mode : Call_Modes);
1739 Make_Procedure_Call_Statement (Loc,
1742 (RTE (RE_Protected_Single_Entry_Call), Loc),
1743 Parameter_Associations =>
1747 Make_Attribute_Reference (Loc,
1748 Prefix => Make_Identifier (Loc, Name_uP),
1749 Attribute_Name => Name_Address),
1752 (RTE (RE_Asynchronous_Call), Loc))));
1755 raise Program_Error;
1759 -- B := Dummy_Communication_Block (Bnn);
1762 Make_Assignment_Statement (Loc,
1764 Make_Identifier (Loc, Name_uB),
1766 Make_Unchecked_Type_Conversion (Loc,
1769 RTE (RE_Dummy_Communication_Block), Loc),
1771 New_Reference_To (Com_Block, Loc))));
1774 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
1778 -- (T._task_id, -- Acceptor
1779 -- Task_Entry_Index! (I), -- E
1780 -- P, -- Uninterpreted_Data
1781 -- Asynchronous_Call, -- Mode
1782 -- F); -- Rendezvous_Successful
1784 -- where T is the task object, I is the entry index, P is the
1785 -- wrapped parameters and F is the status flag.
1788 Make_Procedure_Call_Statement (Loc,
1790 New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
1791 Parameter_Associations =>
1793 Make_Selected_Component (Loc, -- T._task_id
1795 Make_Identifier (Loc, Name_uT),
1797 Make_Identifier (Loc, Name_uTask_Id)),
1799 Make_Unchecked_Type_Conversion (Loc, -- entry index
1801 New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
1803 Make_Identifier (Loc, Name_uI)),
1805 Make_Identifier (Loc, Name_uP), -- parameter block
1806 New_Reference_To ( -- Asynchronous_Call
1807 RTE (RE_Asynchronous_Call), Loc),
1808 Make_Identifier (Loc, Name_uF)))); -- status flag
1813 Make_Subprogram_Body (Loc,
1815 Make_Disp_Asynchronous_Select_Spec (Typ),
1818 Handled_Statement_Sequence =>
1819 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
1820 end Make_Disp_Asynchronous_Select_Body;
1822 ----------------------------------------
1823 -- Make_Disp_Asynchronous_Select_Spec --
1824 ----------------------------------------
1826 function Make_Disp_Asynchronous_Select_Spec
1827 (Typ : Entity_Id) return Node_Id
1829 Loc : constant Source_Ptr := Sloc (Typ);
1830 Def_Id : constant Node_Id :=
1831 Make_Defining_Identifier (Loc,
1832 Name_uDisp_Asynchronous_Select);
1833 Params : constant List_Id := New_List;
1836 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1838 -- T : in out Typ; -- Object parameter
1839 -- S : Integer; -- Primitive operation slot
1840 -- P : Address; -- Wrapped parameters
1841 -- B : out Dummy_Communication_Block; -- Communication block dummy
1842 -- F : out Boolean; -- Status flag
1844 Append_List_To (Params, New_List (
1846 Make_Parameter_Specification (Loc,
1847 Defining_Identifier =>
1848 Make_Defining_Identifier (Loc, Name_uT),
1850 New_Reference_To (Typ, Loc),
1852 Out_Present => True),
1854 Make_Parameter_Specification (Loc,
1855 Defining_Identifier =>
1856 Make_Defining_Identifier (Loc, Name_uS),
1858 New_Reference_To (Standard_Integer, Loc)),
1860 Make_Parameter_Specification (Loc,
1861 Defining_Identifier =>
1862 Make_Defining_Identifier (Loc, Name_uP),
1864 New_Reference_To (RTE (RE_Address), Loc)),
1866 Make_Parameter_Specification (Loc,
1867 Defining_Identifier =>
1868 Make_Defining_Identifier (Loc, Name_uB),
1870 New_Reference_To (RTE (RE_Dummy_Communication_Block), Loc),
1871 Out_Present => True),
1873 Make_Parameter_Specification (Loc,
1874 Defining_Identifier =>
1875 Make_Defining_Identifier (Loc, Name_uF),
1877 New_Reference_To (Standard_Boolean, Loc),
1878 Out_Present => True)));
1881 Make_Procedure_Specification (Loc,
1882 Defining_Unit_Name => Def_Id,
1883 Parameter_Specifications => Params);
1884 end Make_Disp_Asynchronous_Select_Spec;
1886 ---------------------------------------
1887 -- Make_Disp_Conditional_Select_Body --
1888 ---------------------------------------
1890 -- For interface types, generate:
1892 -- procedure _Disp_Conditional_Select
1893 -- (T : in out <Typ>;
1895 -- P : System.Address;
1896 -- C : out Ada.Tags.Prim_Op_Kind;
1901 -- end _Disp_Conditional_Select;
1903 -- For protected types, generate:
1905 -- procedure _Disp_Conditional_Select
1906 -- (T : in out <Typ>;
1908 -- P : System.Address;
1909 -- C : out Ada.Tags.Prim_Op_Kind;
1913 -- Bnn : System.Tasking.Protected_Objects.Operations.
1914 -- Communication_Block;
1917 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S));
1919 -- if C = Ada.Tags.POK_Procedure
1920 -- or else C = Ada.Tags.POK_Protected_Procedure
1921 -- or else C = Ada.Tags.POK_Task_Procedure
1927 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
1928 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
1929 -- (T.object'Access,
1930 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
1932 -- System.Tasking.Conditional_Call,
1934 -- F := not Cancelled (Bnn);
1935 -- end _Disp_Conditional_Select;
1937 -- For task types, generate:
1939 -- procedure _Disp_Conditional_Select
1940 -- (T : in out <Typ>;
1942 -- P : System.Address;
1943 -- C : out Ada.Tags.Prim_Op_Kind;
1949 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
1950 -- System.Tasking.Rendezvous.Task_Entry_Call
1952 -- System.Tasking.Task_Entry_Index (I),
1954 -- System.Tasking.Conditional_Call,
1956 -- end _Disp_Conditional_Select;
1958 function Make_Disp_Conditional_Select_Body
1959 (Typ : Entity_Id) return Node_Id
1961 Loc : constant Source_Ptr := Sloc (Typ);
1962 Blk_Nam : Entity_Id;
1963 Conc_Typ : Entity_Id := Empty;
1964 Decls : constant List_Id := New_List;
1967 Stmts : constant List_Id := New_List;
1970 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1972 -- Null body is generated for interface types
1974 if Is_Interface (Typ) then
1976 Make_Subprogram_Body (Loc,
1978 Make_Disp_Conditional_Select_Spec (Typ),
1981 Handled_Statement_Sequence =>
1982 Make_Handled_Sequence_Of_Statements (Loc,
1983 New_List (Make_Null_Statement (Loc))));
1986 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
1988 if Is_Concurrent_Record_Type (Typ) then
1989 Conc_Typ := Corresponding_Concurrent_Type (Typ);
1994 -- where I will be used to capture the entry index of the primitive
1995 -- wrapper at position S.
1998 Make_Object_Declaration (Loc,
1999 Defining_Identifier =>
2000 Make_Defining_Identifier (Loc, Name_uI),
2001 Object_Definition =>
2002 New_Reference_To (Standard_Integer, Loc)));
2005 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S);
2007 -- if C = POK_Procedure
2008 -- or else C = POK_Protected_Procedure
2009 -- or else C = POK_Task_Procedure;
2015 Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts);
2018 -- Bnn : Communication_Block;
2020 -- where Bnn is the name of the communication block used in the
2021 -- call to Protected_Entry_Call.
2023 Blk_Nam := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
2026 Make_Object_Declaration (Loc,
2027 Defining_Identifier =>
2029 Object_Definition =>
2030 New_Reference_To (RTE (RE_Communication_Block), Loc)));
2033 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2035 -- I is the entry index and S is the dispatch table slot
2038 Make_Assignment_Statement (Loc,
2040 Make_Identifier (Loc, Name_uI),
2042 Make_Function_Call (Loc,
2044 New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
2045 Parameter_Associations =>
2047 Unchecked_Convert_To (RTE (RE_Tag),
2048 New_Reference_To (DT_Ptr, Loc)),
2049 Make_Identifier (Loc, Name_uS)))));
2051 if Ekind (Conc_Typ) = E_Protected_Type then
2053 Obj_Ref := -- T._object'Access
2054 Make_Attribute_Reference (Loc,
2055 Attribute_Name => Name_Unchecked_Access,
2057 Make_Selected_Component (Loc,
2058 Prefix => Make_Identifier (Loc, Name_uT),
2059 Selector_Name => Make_Identifier (Loc, Name_uObject)));
2061 case Corresponding_Runtime_Package (Conc_Typ) is
2062 when System_Tasking_Protected_Objects_Entries =>
2065 -- Protected_Entry_Call
2066 -- (T._object'Access, -- Object
2067 -- Protected_Entry_Index! (I), -- E
2068 -- P, -- Uninterpreted_Data
2069 -- Conditional_Call, -- Mode
2072 -- where T is the protected object, I is the entry index, P
2073 -- are the wrapped parameters and Bnn is the name of the
2074 -- communication block.
2077 Make_Procedure_Call_Statement (Loc,
2079 New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
2080 Parameter_Associations =>
2084 Make_Unchecked_Type_Conversion (Loc, -- entry index
2087 (RTE (RE_Protected_Entry_Index), Loc),
2088 Expression => Make_Identifier (Loc, Name_uI)),
2090 Make_Identifier (Loc, Name_uP), -- parameter block
2092 New_Reference_To ( -- Conditional_Call
2093 RTE (RE_Conditional_Call), Loc),
2094 New_Reference_To ( -- Bnn
2097 when System_Tasking_Protected_Objects_Single_Entry =>
2099 -- If we are compiling for a restricted run-time, the call
2100 -- uses the simpler form.
2103 Make_Procedure_Call_Statement (Loc,
2106 (RTE (RE_Protected_Single_Entry_Call), Loc),
2107 Parameter_Associations =>
2111 Make_Attribute_Reference (Loc,
2112 Prefix => Make_Identifier (Loc, Name_uP),
2113 Attribute_Name => Name_Address),
2116 (RTE (RE_Conditional_Call), Loc))));
2118 raise Program_Error;
2122 -- F := not Cancelled (Bnn);
2124 -- where F is the success flag. The status of Cancelled is negated
2125 -- in order to match the behaviour of the version for task types.
2128 Make_Assignment_Statement (Loc,
2130 Make_Identifier (Loc, Name_uF),
2134 Make_Function_Call (Loc,
2136 New_Reference_To (RTE (RE_Cancelled), Loc),
2137 Parameter_Associations =>
2139 New_Reference_To (Blk_Nam, Loc))))));
2141 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2145 -- (T._task_id, -- Acceptor
2146 -- Task_Entry_Index! (I), -- E
2147 -- P, -- Uninterpreted_Data
2148 -- Conditional_Call, -- Mode
2149 -- F); -- Rendezvous_Successful
2151 -- where T is the task object, I is the entry index, P are the
2152 -- wrapped parameters and F is the status flag.
2155 Make_Procedure_Call_Statement (Loc,
2157 New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
2158 Parameter_Associations =>
2161 Make_Selected_Component (Loc, -- T._task_id
2163 Make_Identifier (Loc, Name_uT),
2165 Make_Identifier (Loc, Name_uTask_Id)),
2167 Make_Unchecked_Type_Conversion (Loc, -- entry index
2169 New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
2171 Make_Identifier (Loc, Name_uI)),
2173 Make_Identifier (Loc, Name_uP), -- parameter block
2174 New_Reference_To ( -- Conditional_Call
2175 RTE (RE_Conditional_Call), Loc),
2176 Make_Identifier (Loc, Name_uF)))); -- status flag
2181 Make_Subprogram_Body (Loc,
2183 Make_Disp_Conditional_Select_Spec (Typ),
2186 Handled_Statement_Sequence =>
2187 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2188 end Make_Disp_Conditional_Select_Body;
2190 ---------------------------------------
2191 -- Make_Disp_Conditional_Select_Spec --
2192 ---------------------------------------
2194 function Make_Disp_Conditional_Select_Spec
2195 (Typ : Entity_Id) return Node_Id
2197 Loc : constant Source_Ptr := Sloc (Typ);
2198 Def_Id : constant Node_Id :=
2199 Make_Defining_Identifier (Loc,
2200 Name_uDisp_Conditional_Select);
2201 Params : constant List_Id := New_List;
2204 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2206 -- T : in out Typ; -- Object parameter
2207 -- S : Integer; -- Primitive operation slot
2208 -- P : Address; -- Wrapped parameters
2209 -- C : out Prim_Op_Kind; -- Call kind
2210 -- F : out Boolean; -- Status flag
2212 Append_List_To (Params, New_List (
2214 Make_Parameter_Specification (Loc,
2215 Defining_Identifier =>
2216 Make_Defining_Identifier (Loc, Name_uT),
2218 New_Reference_To (Typ, Loc),
2220 Out_Present => True),
2222 Make_Parameter_Specification (Loc,
2223 Defining_Identifier =>
2224 Make_Defining_Identifier (Loc, Name_uS),
2226 New_Reference_To (Standard_Integer, Loc)),
2228 Make_Parameter_Specification (Loc,
2229 Defining_Identifier =>
2230 Make_Defining_Identifier (Loc, Name_uP),
2232 New_Reference_To (RTE (RE_Address), Loc)),
2234 Make_Parameter_Specification (Loc,
2235 Defining_Identifier =>
2236 Make_Defining_Identifier (Loc, Name_uC),
2238 New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
2239 Out_Present => True),
2241 Make_Parameter_Specification (Loc,
2242 Defining_Identifier =>
2243 Make_Defining_Identifier (Loc, Name_uF),
2245 New_Reference_To (Standard_Boolean, Loc),
2246 Out_Present => True)));
2249 Make_Procedure_Specification (Loc,
2250 Defining_Unit_Name => Def_Id,
2251 Parameter_Specifications => Params);
2252 end Make_Disp_Conditional_Select_Spec;
2254 -------------------------------------
2255 -- Make_Disp_Get_Prim_Op_Kind_Body --
2256 -------------------------------------
2258 function Make_Disp_Get_Prim_Op_Kind_Body
2259 (Typ : Entity_Id) return Node_Id
2261 Loc : constant Source_Ptr := Sloc (Typ);
2265 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2267 if Is_Interface (Typ) then
2269 Make_Subprogram_Body (Loc,
2271 Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2274 Handled_Statement_Sequence =>
2275 Make_Handled_Sequence_Of_Statements (Loc,
2276 New_List (Make_Null_Statement (Loc))));
2279 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
2282 -- C := get_prim_op_kind (tag! (<type>VP), S);
2284 -- where C is the out parameter capturing the call kind and S is the
2285 -- dispatch table slot number.
2288 Make_Subprogram_Body (Loc,
2290 Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2293 Handled_Statement_Sequence =>
2294 Make_Handled_Sequence_Of_Statements (Loc,
2296 Make_Assignment_Statement (Loc,
2298 Make_Identifier (Loc, Name_uC),
2300 Make_Function_Call (Loc,
2302 New_Reference_To (RTE (RE_Get_Prim_Op_Kind), Loc),
2303 Parameter_Associations => New_List (
2304 Unchecked_Convert_To (RTE (RE_Tag),
2305 New_Reference_To (DT_Ptr, Loc)),
2306 Make_Identifier (Loc, Name_uS)))))));
2307 end Make_Disp_Get_Prim_Op_Kind_Body;
2309 -------------------------------------
2310 -- Make_Disp_Get_Prim_Op_Kind_Spec --
2311 -------------------------------------
2313 function Make_Disp_Get_Prim_Op_Kind_Spec
2314 (Typ : Entity_Id) return Node_Id
2316 Loc : constant Source_Ptr := Sloc (Typ);
2317 Def_Id : constant Node_Id :=
2318 Make_Defining_Identifier (Loc,
2319 Name_uDisp_Get_Prim_Op_Kind);
2320 Params : constant List_Id := New_List;
2323 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2325 -- T : in out Typ; -- Object parameter
2326 -- S : Integer; -- Primitive operation slot
2327 -- C : out Prim_Op_Kind; -- Call kind
2329 Append_List_To (Params, New_List (
2331 Make_Parameter_Specification (Loc,
2332 Defining_Identifier =>
2333 Make_Defining_Identifier (Loc, Name_uT),
2335 New_Reference_To (Typ, Loc),
2337 Out_Present => True),
2339 Make_Parameter_Specification (Loc,
2340 Defining_Identifier =>
2341 Make_Defining_Identifier (Loc, Name_uS),
2343 New_Reference_To (Standard_Integer, Loc)),
2345 Make_Parameter_Specification (Loc,
2346 Defining_Identifier =>
2347 Make_Defining_Identifier (Loc, Name_uC),
2349 New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
2350 Out_Present => True)));
2353 Make_Procedure_Specification (Loc,
2354 Defining_Unit_Name => Def_Id,
2355 Parameter_Specifications => Params);
2356 end Make_Disp_Get_Prim_Op_Kind_Spec;
2358 --------------------------------
2359 -- Make_Disp_Get_Task_Id_Body --
2360 --------------------------------
2362 function Make_Disp_Get_Task_Id_Body
2363 (Typ : Entity_Id) return Node_Id
2365 Loc : constant Source_Ptr := Sloc (Typ);
2369 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2371 if Is_Concurrent_Record_Type (Typ)
2372 and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type
2375 -- return To_Address (_T._task_id);
2378 Make_Simple_Return_Statement (Loc,
2380 Make_Unchecked_Type_Conversion (Loc,
2382 New_Reference_To (RTE (RE_Address), Loc),
2384 Make_Selected_Component (Loc,
2386 Make_Identifier (Loc, Name_uT),
2388 Make_Identifier (Loc, Name_uTask_Id))));
2390 -- A null body is constructed for non-task types
2394 -- return Null_Address;
2397 Make_Simple_Return_Statement (Loc,
2399 New_Reference_To (RTE (RE_Null_Address), Loc));
2403 Make_Subprogram_Body (Loc,
2405 Make_Disp_Get_Task_Id_Spec (Typ),
2408 Handled_Statement_Sequence =>
2409 Make_Handled_Sequence_Of_Statements (Loc,
2411 end Make_Disp_Get_Task_Id_Body;
2413 --------------------------------
2414 -- Make_Disp_Get_Task_Id_Spec --
2415 --------------------------------
2417 function Make_Disp_Get_Task_Id_Spec
2418 (Typ : Entity_Id) return Node_Id
2420 Loc : constant Source_Ptr := Sloc (Typ);
2423 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2426 Make_Function_Specification (Loc,
2427 Defining_Unit_Name =>
2428 Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id),
2429 Parameter_Specifications => New_List (
2430 Make_Parameter_Specification (Loc,
2431 Defining_Identifier =>
2432 Make_Defining_Identifier (Loc, Name_uT),
2434 New_Reference_To (Typ, Loc))),
2435 Result_Definition =>
2436 New_Reference_To (RTE (RE_Address), Loc));
2437 end Make_Disp_Get_Task_Id_Spec;
2439 ----------------------------
2440 -- Make_Disp_Requeue_Body --
2441 ----------------------------
2443 function Make_Disp_Requeue_Body
2444 (Typ : Entity_Id) return Node_Id
2446 Loc : constant Source_Ptr := Sloc (Typ);
2447 Conc_Typ : Entity_Id := Empty;
2448 Stmts : constant List_Id := New_List;
2451 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2453 -- Null body is generated for interface types and non-concurrent
2456 if Is_Interface (Typ)
2457 or else not Is_Concurrent_Record_Type (Typ)
2460 Make_Subprogram_Body (Loc,
2462 Make_Disp_Requeue_Spec (Typ),
2465 Handled_Statement_Sequence =>
2466 Make_Handled_Sequence_Of_Statements (Loc,
2467 New_List (Make_Null_Statement (Loc))));
2470 Conc_Typ := Corresponding_Concurrent_Type (Typ);
2472 if Ekind (Conc_Typ) = E_Protected_Type then
2474 -- Generate statements:
2476 -- System.Tasking.Protected_Objects.Operations.
2477 -- Requeue_Protected_Entry
2478 -- (Protection_Entries_Access (P),
2479 -- O._object'Unchecked_Access,
2480 -- Protected_Entry_Index (I),
2483 -- System.Tasking.Protected_Objects.Operations.
2484 -- Requeue_Task_To_Protected_Entry
2485 -- (O._object'Unchecked_Access,
2486 -- Protected_Entry_Index (I),
2490 if Restriction_Active (No_Entry_Queue) then
2491 Append_To (Stmts, Make_Null_Statement (Loc));
2494 Make_If_Statement (Loc,
2496 Make_Identifier (Loc, Name_uF),
2501 -- Call to Requeue_Protected_Entry
2503 Make_Procedure_Call_Statement (Loc,
2506 RTE (RE_Requeue_Protected_Entry), Loc),
2507 Parameter_Associations =>
2510 Make_Unchecked_Type_Conversion (Loc, -- PEA (P)
2513 RTE (RE_Protection_Entries_Access), Loc),
2515 Make_Identifier (Loc, Name_uP)),
2517 Make_Attribute_Reference (Loc, -- O._object'Acc
2519 Name_Unchecked_Access,
2521 Make_Selected_Component (Loc,
2523 Make_Identifier (Loc, Name_uO),
2525 Make_Identifier (Loc, Name_uObject))),
2527 Make_Unchecked_Type_Conversion (Loc, -- entry index
2530 RTE (RE_Protected_Entry_Index), Loc),
2532 Make_Identifier (Loc, Name_uI)),
2534 Make_Identifier (Loc, Name_uA)))), -- abort status
2539 -- Call to Requeue_Task_To_Protected_Entry
2541 Make_Procedure_Call_Statement (Loc,
2544 RTE (RE_Requeue_Task_To_Protected_Entry), Loc),
2545 Parameter_Associations =>
2548 Make_Attribute_Reference (Loc, -- O._object'Acc
2550 Name_Unchecked_Access,
2552 Make_Selected_Component (Loc,
2554 Make_Identifier (Loc, Name_uO),
2556 Make_Identifier (Loc, Name_uObject))),
2558 Make_Unchecked_Type_Conversion (Loc, -- entry index
2561 RTE (RE_Protected_Entry_Index), Loc),
2563 Make_Identifier (Loc, Name_uI)),
2565 Make_Identifier (Loc, Name_uA)))))); -- abort status
2568 pragma Assert (Is_Task_Type (Conc_Typ));
2572 -- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry
2573 -- (Protection_Entries_Access (P),
2575 -- Task_Entry_Index (I),
2578 -- System.Tasking.Rendezvous.Requeue_Task_Entry
2580 -- Task_Entry_Index (I),
2585 Make_If_Statement (Loc,
2587 Make_Identifier (Loc, Name_uF),
2592 -- Call to Requeue_Protected_To_Task_Entry
2594 Make_Procedure_Call_Statement (Loc,
2597 RTE (RE_Requeue_Protected_To_Task_Entry), Loc),
2599 Parameter_Associations =>
2602 Make_Unchecked_Type_Conversion (Loc, -- PEA (P)
2605 RTE (RE_Protection_Entries_Access), Loc),
2607 Make_Identifier (Loc, Name_uP)),
2609 Make_Selected_Component (Loc, -- O._task_id
2611 Make_Identifier (Loc, Name_uO),
2613 Make_Identifier (Loc, Name_uTask_Id)),
2615 Make_Unchecked_Type_Conversion (Loc, -- entry index
2618 RTE (RE_Task_Entry_Index), Loc),
2620 Make_Identifier (Loc, Name_uI)),
2622 Make_Identifier (Loc, Name_uA)))), -- abort status
2627 -- Call to Requeue_Task_Entry
2629 Make_Procedure_Call_Statement (Loc,
2631 New_Reference_To (RTE (RE_Requeue_Task_Entry), Loc),
2633 Parameter_Associations =>
2636 Make_Selected_Component (Loc, -- O._task_id
2638 Make_Identifier (Loc, Name_uO),
2640 Make_Identifier (Loc, Name_uTask_Id)),
2642 Make_Unchecked_Type_Conversion (Loc, -- entry index
2645 RTE (RE_Task_Entry_Index), Loc),
2647 Make_Identifier (Loc, Name_uI)),
2649 Make_Identifier (Loc, Name_uA)))))); -- abort status
2652 -- Even though no declarations are needed in both cases, we allocate
2653 -- a list for entities added by Freeze.
2656 Make_Subprogram_Body (Loc,
2658 Make_Disp_Requeue_Spec (Typ),
2661 Handled_Statement_Sequence =>
2662 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2663 end Make_Disp_Requeue_Body;
2665 ----------------------------
2666 -- Make_Disp_Requeue_Spec --
2667 ----------------------------
2669 function Make_Disp_Requeue_Spec
2670 (Typ : Entity_Id) return Node_Id
2672 Loc : constant Source_Ptr := Sloc (Typ);
2675 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2677 -- O : in out Typ; - Object parameter
2678 -- F : Boolean; - Protected (True) / task (False) flag
2679 -- P : Address; - Protection_Entries_Access value
2680 -- I : Entry_Index - Index of entry call
2681 -- A : Boolean - Abort flag
2683 -- Note that the Protection_Entries_Access value is represented as a
2684 -- System.Address in order to avoid dragging in the tasking runtime
2685 -- when compiling sources without tasking constructs.
2688 Make_Procedure_Specification (Loc,
2689 Defining_Unit_Name =>
2690 Make_Defining_Identifier (Loc, Name_uDisp_Requeue),
2692 Parameter_Specifications =>
2695 Make_Parameter_Specification (Loc, -- O
2696 Defining_Identifier =>
2697 Make_Defining_Identifier (Loc, Name_uO),
2699 New_Reference_To (Typ, Loc),
2701 Out_Present => True),
2703 Make_Parameter_Specification (Loc, -- F
2704 Defining_Identifier =>
2705 Make_Defining_Identifier (Loc, Name_uF),
2707 New_Reference_To (Standard_Boolean, Loc)),
2709 Make_Parameter_Specification (Loc, -- P
2710 Defining_Identifier =>
2711 Make_Defining_Identifier (Loc, Name_uP),
2713 New_Reference_To (RTE (RE_Address), Loc)),
2715 Make_Parameter_Specification (Loc, -- I
2716 Defining_Identifier =>
2717 Make_Defining_Identifier (Loc, Name_uI),
2719 New_Reference_To (Standard_Integer, Loc)),
2721 Make_Parameter_Specification (Loc, -- A
2722 Defining_Identifier =>
2723 Make_Defining_Identifier (Loc, Name_uA),
2725 New_Reference_To (Standard_Boolean, Loc))));
2726 end Make_Disp_Requeue_Spec;
2728 ---------------------------------
2729 -- Make_Disp_Timed_Select_Body --
2730 ---------------------------------
2732 -- For interface types, generate:
2734 -- procedure _Disp_Timed_Select
2735 -- (T : in out <Typ>;
2737 -- P : System.Address;
2740 -- C : out Ada.Tags.Prim_Op_Kind;
2745 -- end _Disp_Timed_Select;
2747 -- For protected types, generate:
2749 -- procedure _Disp_Timed_Select
2750 -- (T : in out <Typ>;
2752 -- P : System.Address;
2755 -- C : out Ada.Tags.Prim_Op_Kind;
2761 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S);
2763 -- if C = Ada.Tags.POK_Procedure
2764 -- or else C = Ada.Tags.POK_Protected_Procedure
2765 -- or else C = Ada.Tags.POK_Task_Procedure
2771 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
2772 -- System.Tasking.Protected_Objects.Operations.
2773 -- Timed_Protected_Entry_Call
2774 -- (T._object'Access,
2775 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2780 -- end _Disp_Timed_Select;
2782 -- For task types, generate:
2784 -- procedure _Disp_Timed_Select
2785 -- (T : in out <Typ>;
2787 -- P : System.Address;
2790 -- C : out Ada.Tags.Prim_Op_Kind;
2796 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
2797 -- System.Tasking.Rendezvous.Timed_Task_Entry_Call
2799 -- System.Tasking.Task_Entry_Index (I),
2804 -- end _Disp_Time_Select;
2806 function Make_Disp_Timed_Select_Body
2807 (Typ : Entity_Id) return Node_Id
2809 Loc : constant Source_Ptr := Sloc (Typ);
2810 Conc_Typ : Entity_Id := Empty;
2811 Decls : constant List_Id := New_List;
2814 Stmts : constant List_Id := New_List;
2817 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2819 -- Null body is generated for interface types
2821 if Is_Interface (Typ) then
2823 Make_Subprogram_Body (Loc,
2825 Make_Disp_Timed_Select_Spec (Typ),
2828 Handled_Statement_Sequence =>
2829 Make_Handled_Sequence_Of_Statements (Loc,
2830 New_List (Make_Null_Statement (Loc))));
2833 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
2835 if Is_Concurrent_Record_Type (Typ) then
2836 Conc_Typ := Corresponding_Concurrent_Type (Typ);
2841 -- where I will be used to capture the entry index of the primitive
2842 -- wrapper at position S.
2845 Make_Object_Declaration (Loc,
2846 Defining_Identifier =>
2847 Make_Defining_Identifier (Loc, Name_uI),
2848 Object_Definition =>
2849 New_Reference_To (Standard_Integer, Loc)));
2852 -- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
2854 -- if C = POK_Procedure
2855 -- or else C = POK_Protected_Procedure
2856 -- or else C = POK_Task_Procedure;
2862 Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts);
2865 -- I := Get_Entry_Index (tag! (<type>VP), S);
2867 -- I is the entry index and S is the dispatch table slot
2870 Make_Assignment_Statement (Loc,
2872 Make_Identifier (Loc, Name_uI),
2874 Make_Function_Call (Loc,
2876 New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
2877 Parameter_Associations =>
2879 Unchecked_Convert_To (RTE (RE_Tag),
2880 New_Reference_To (DT_Ptr, Loc)),
2881 Make_Identifier (Loc, Name_uS)))));
2885 if Ekind (Conc_Typ) = E_Protected_Type then
2887 -- Build T._object'Access
2890 Make_Attribute_Reference (Loc,
2891 Attribute_Name => Name_Unchecked_Access,
2893 Make_Selected_Component (Loc,
2894 Prefix => Make_Identifier (Loc, Name_uT),
2895 Selector_Name => Make_Identifier (Loc, Name_uObject)));
2897 -- Normal case, No_Entry_Queue restriction not active. In this
2898 -- case we generate:
2900 -- Timed_Protected_Entry_Call
2901 -- (T._object'access,
2902 -- Protected_Entry_Index! (I),
2905 -- where T is the protected object, I is the entry index, P are
2906 -- the wrapped parameters, D is the delay amount, M is the delay
2907 -- mode and F is the status flag.
2909 case Corresponding_Runtime_Package (Conc_Typ) is
2910 when System_Tasking_Protected_Objects_Entries =>
2912 Make_Procedure_Call_Statement (Loc,
2915 (RTE (RE_Timed_Protected_Entry_Call), Loc),
2916 Parameter_Associations =>
2920 Make_Unchecked_Type_Conversion (Loc, -- entry index
2923 (RTE (RE_Protected_Entry_Index), Loc),
2925 Make_Identifier (Loc, Name_uI)),
2927 Make_Identifier (Loc, Name_uP), -- parameter block
2928 Make_Identifier (Loc, Name_uD), -- delay
2929 Make_Identifier (Loc, Name_uM), -- delay mode
2930 Make_Identifier (Loc, Name_uF)))); -- status flag
2932 when System_Tasking_Protected_Objects_Single_Entry =>
2935 -- Timed_Protected_Single_Entry_Call
2936 -- (T._object'access, P, D, M, F);
2938 -- where T is the protected object, P is the wrapped
2939 -- parameters, D is the delay amount, M is the delay mode, F
2940 -- is the status flag.
2943 Make_Procedure_Call_Statement (Loc,
2946 (RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
2947 Parameter_Associations =>
2950 Make_Identifier (Loc, Name_uP), -- parameter block
2951 Make_Identifier (Loc, Name_uD), -- delay
2952 Make_Identifier (Loc, Name_uM), -- delay mode
2953 Make_Identifier (Loc, Name_uF)))); -- status flag
2956 raise Program_Error;
2962 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2965 -- Timed_Task_Entry_Call (
2967 -- Task_Entry_Index! (I),
2973 -- where T is the task object, I is the entry index, P are the
2974 -- wrapped parameters, D is the delay amount, M is the delay
2975 -- mode and F is the status flag.
2978 Make_Procedure_Call_Statement (Loc,
2980 New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
2981 Parameter_Associations =>
2984 Make_Selected_Component (Loc, -- T._task_id
2986 Make_Identifier (Loc, Name_uT),
2988 Make_Identifier (Loc, Name_uTask_Id)),
2990 Make_Unchecked_Type_Conversion (Loc, -- entry index
2992 New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
2994 Make_Identifier (Loc, Name_uI)),
2996 Make_Identifier (Loc, Name_uP), -- parameter block
2997 Make_Identifier (Loc, Name_uD), -- delay
2998 Make_Identifier (Loc, Name_uM), -- delay mode
2999 Make_Identifier (Loc, Name_uF)))); -- status flag
3004 Make_Subprogram_Body (Loc,
3006 Make_Disp_Timed_Select_Spec (Typ),
3009 Handled_Statement_Sequence =>
3010 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
3011 end Make_Disp_Timed_Select_Body;
3013 ---------------------------------
3014 -- Make_Disp_Timed_Select_Spec --
3015 ---------------------------------
3017 function Make_Disp_Timed_Select_Spec
3018 (Typ : Entity_Id) return Node_Id
3020 Loc : constant Source_Ptr := Sloc (Typ);
3021 Def_Id : constant Node_Id :=
3022 Make_Defining_Identifier (Loc,
3023 Name_uDisp_Timed_Select);
3024 Params : constant List_Id := New_List;
3027 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3029 -- T : in out Typ; -- Object parameter
3030 -- S : Integer; -- Primitive operation slot
3031 -- P : Address; -- Wrapped parameters
3032 -- D : Duration; -- Delay
3033 -- M : Integer; -- Delay Mode
3034 -- C : out Prim_Op_Kind; -- Call kind
3035 -- F : out Boolean; -- Status flag
3037 Append_List_To (Params, New_List (
3039 Make_Parameter_Specification (Loc,
3040 Defining_Identifier =>
3041 Make_Defining_Identifier (Loc, Name_uT),
3043 New_Reference_To (Typ, Loc),
3045 Out_Present => True),
3047 Make_Parameter_Specification (Loc,
3048 Defining_Identifier =>
3049 Make_Defining_Identifier (Loc, Name_uS),
3051 New_Reference_To (Standard_Integer, Loc)),
3053 Make_Parameter_Specification (Loc,
3054 Defining_Identifier =>
3055 Make_Defining_Identifier (Loc, Name_uP),
3057 New_Reference_To (RTE (RE_Address), Loc)),
3059 Make_Parameter_Specification (Loc,
3060 Defining_Identifier =>
3061 Make_Defining_Identifier (Loc, Name_uD),
3063 New_Reference_To (Standard_Duration, Loc)),
3065 Make_Parameter_Specification (Loc,
3066 Defining_Identifier =>
3067 Make_Defining_Identifier (Loc, Name_uM),
3069 New_Reference_To (Standard_Integer, Loc)),
3071 Make_Parameter_Specification (Loc,
3072 Defining_Identifier =>
3073 Make_Defining_Identifier (Loc, Name_uC),
3075 New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
3076 Out_Present => True)));
3079 Make_Parameter_Specification (Loc,
3080 Defining_Identifier =>
3081 Make_Defining_Identifier (Loc, Name_uF),
3083 New_Reference_To (Standard_Boolean, Loc),
3084 Out_Present => True));
3087 Make_Procedure_Specification (Loc,
3088 Defining_Unit_Name => Def_Id,
3089 Parameter_Specifications => Params);
3090 end Make_Disp_Timed_Select_Spec;
3096 -- The frontend supports two models for expanding dispatch tables
3097 -- associated with library-level defined tagged types: statically
3098 -- and non-statically allocated dispatch tables. In the former case
3099 -- the object containing the dispatch table is constant and it is
3100 -- initialized by means of a positional aggregate. In the latter case,
3101 -- the object containing the dispatch table is a variable which is
3102 -- initialized by means of assignments.
3104 -- In case of locally defined tagged types, the object containing the
3105 -- object containing the dispatch table is always a variable (instead
3106 -- of a constant). This is currently required to give support to late
3107 -- overriding of primitives. For example:
3109 -- procedure Example is
3111 -- type T1 is tagged null record;
3112 -- procedure Prim (O : T1);
3115 -- type T2 is new Pkg.T1 with null record;
3116 -- procedure Prim (X : T2) is -- late overriding
3122 function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is
3123 Loc : constant Source_Ptr := Sloc (Typ);
3125 Max_Predef_Prims : constant Int :=
3129 (Parent (RTE (RE_Max_Predef_Prims)))));
3131 DT_Decl : constant Elist_Id := New_Elmt_List;
3132 DT_Aggr : constant Elist_Id := New_Elmt_List;
3133 -- Entities marked with attribute Is_Dispatch_Table_Entity
3135 procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id);
3136 -- Verify that all non-tagged types in the profile of a subprogram
3137 -- are frozen at the point the subprogram is frozen. This enforces
3138 -- the rule on RM 13.14 (14) as modified by AI05-019. At the point a
3139 -- subprogram is frozen, enough must be known about it to build the
3140 -- activation record for it, which requires at least that the size of
3141 -- all parameters be known. Controlling arguments are by-reference,
3142 -- and therefore the rule only applies to non-tagged types.
3143 -- Typical violation of the rule involves an object declaration that
3144 -- freezes a tagged type, when one of its primitive operations has a
3145 -- type in its profile whose full view has not been analyzed yet.
3147 procedure Export_DT (Typ : Entity_Id; DT : Entity_Id);
3148 -- Export the dispatch table entity DT of tagged type Typ. Required to
3149 -- generate forward references and statically allocate the table.
3151 procedure Make_Secondary_DT
3154 Num_Iface_Prims : Nat;
3155 Iface_DT_Ptr : Entity_Id;
3156 Predef_Prims_Ptr : Entity_Id;
3157 Build_Thunks : Boolean;
3159 -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch
3160 -- Table of Typ associated with Iface. Each abstract interface of Typ
3161 -- has two secondary dispatch tables: one containing pointers to thunks
3162 -- and another containing pointers to the primitives covering the
3163 -- interface primitives. The former secondary table is generated when
3164 -- Build_Thunks is True, and provides common support for dispatching
3165 -- calls through interface types; the latter secondary table is
3166 -- generated when Build_Thunks is False, and provides support for
3167 -- Generic Dispatching Constructors that dispatch calls through
3170 ------------------------------
3171 -- Check_Premature_Freezing --
3172 ------------------------------
3174 procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id) is
3177 and then Is_Private_Type (Typ)
3178 and then No (Full_View (Typ))
3179 and then not Is_Generic_Type (Typ)
3180 and then not Is_Tagged_Type (Typ)
3181 and then not Is_Frozen (Typ)
3183 Error_Msg_Sloc := Sloc (Subp);
3185 ("declaration must appear after completion of type &", N, Typ);
3187 ("\which is an untagged type in the profile of"
3188 & " primitive operation & declared#",
3191 end Check_Premature_Freezing;
3197 procedure Export_DT (Typ : Entity_Id; DT : Entity_Id) is
3199 Set_Is_Statically_Allocated (DT);
3200 Set_Is_True_Constant (DT);
3201 Set_Is_Exported (DT);
3203 pragma Assert (Present (Dispatch_Table_Wrapper (Typ)));
3204 Get_External_Name (Dispatch_Table_Wrapper (Typ), True);
3205 Set_Interface_Name (DT,
3206 Make_String_Literal (Loc,
3207 Strval => String_From_Name_Buffer));
3209 -- Ensure proper Sprint output of this implicit importation
3211 Set_Is_Internal (DT);
3215 -----------------------
3216 -- Make_Secondary_DT --
3217 -----------------------
3219 procedure Make_Secondary_DT
3222 Num_Iface_Prims : Nat;
3223 Iface_DT_Ptr : Entity_Id;
3224 Predef_Prims_Ptr : Entity_Id;
3225 Build_Thunks : Boolean;
3228 Loc : constant Source_Ptr := Sloc (Typ);
3229 Name_DT : constant Name_Id := New_Internal_Name ('T');
3230 Iface_DT : constant Entity_Id :=
3231 Make_Defining_Identifier (Loc, Name_DT);
3232 Name_Predef_Prims : constant Name_Id := New_Internal_Name ('R');
3233 Predef_Prims : constant Entity_Id :=
3234 Make_Defining_Identifier (Loc,
3236 DT_Constr_List : List_Id;
3237 DT_Aggr_List : List_Id;
3238 Empty_DT : Boolean := False;
3239 Nb_Predef_Prims : Nat := 0;
3243 OSD_Aggr_List : List_Id;
3246 Prim_Elmt : Elmt_Id;
3247 Prim_Ops_Aggr_List : List_Id;
3250 -- Handle cases in which we do not generate statically allocated
3253 if not Building_Static_DT (Typ) then
3254 Set_Ekind (Predef_Prims, E_Variable);
3255 Set_Ekind (Iface_DT, E_Variable);
3257 -- Statically allocated dispatch tables and related entities are
3261 Set_Ekind (Predef_Prims, E_Constant);
3262 Set_Is_Statically_Allocated (Predef_Prims);
3263 Set_Is_True_Constant (Predef_Prims);
3265 Set_Ekind (Iface_DT, E_Constant);
3266 Set_Is_Statically_Allocated (Iface_DT);
3267 Set_Is_True_Constant (Iface_DT);
3270 -- Generate code to create the storage for the Dispatch_Table object.
3271 -- If the number of primitives of Typ is 0 we reserve a dummy single
3272 -- entry for its DT because at run-time the pointer to this dummy
3273 -- entry will be used as the tag.
3275 if Num_Iface_Prims = 0 then
3279 Nb_Prim := Num_Iface_Prims;
3284 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
3285 -- (predef-prim-op-thunk-1'address,
3286 -- predef-prim-op-thunk-2'address,
3288 -- predef-prim-op-thunk-n'address);
3289 -- for Predef_Prims'Alignment use Address'Alignment
3291 -- Stage 1: Calculate the number of predefined primitives
3293 if not Building_Static_DT (Typ) then
3294 Nb_Predef_Prims := Max_Predef_Prims;
3296 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3297 while Present (Prim_Elmt) loop
3298 Prim := Node (Prim_Elmt);
3300 if Is_Predefined_Dispatching_Operation (Prim)
3301 and then not Is_Abstract_Subprogram (Prim)
3303 Pos := UI_To_Int (DT_Position (Prim));
3305 if Pos > Nb_Predef_Prims then
3306 Nb_Predef_Prims := Pos;
3310 Next_Elmt (Prim_Elmt);
3314 -- Stage 2: Create the thunks associated with the predefined
3315 -- primitives and save their entity to fill the aggregate.
3318 Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
3320 Thunk_Id : Entity_Id;
3321 Thunk_Code : Node_Id;
3324 Prim_Ops_Aggr_List := New_List;
3325 Prim_Table := (others => Empty);
3327 if Building_Static_DT (Typ) then
3328 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3329 while Present (Prim_Elmt) loop
3330 Prim := Node (Prim_Elmt);
3332 if Is_Predefined_Dispatching_Operation (Prim)
3333 and then not Is_Abstract_Subprogram (Prim)
3334 and then not Present (Prim_Table
3335 (UI_To_Int (DT_Position (Prim))))
3337 if not Build_Thunks then
3338 Prim_Table (UI_To_Int (DT_Position (Prim))) :=
3342 while Present (Alias (Prim)) loop
3343 Prim := Alias (Prim);
3346 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
3348 if Present (Thunk_Id) then
3349 Append_To (Result, Thunk_Code);
3350 Prim_Table (UI_To_Int (DT_Position (Prim)))
3356 Next_Elmt (Prim_Elmt);
3360 for J in Prim_Table'Range loop
3361 if Present (Prim_Table (J)) then
3363 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
3364 Make_Attribute_Reference (Loc,
3365 Prefix => New_Reference_To (Prim_Table (J), Loc),
3366 Attribute_Name => Name_Unrestricted_Access));
3368 New_Node := Make_Null (Loc);
3371 Append_To (Prim_Ops_Aggr_List, New_Node);
3375 Make_Aggregate (Loc,
3376 Expressions => Prim_Ops_Aggr_List);
3378 -- Remember aggregates initializing dispatch tables
3380 Append_Elmt (New_Node, DT_Aggr);
3383 Make_Subtype_Declaration (Loc,
3384 Defining_Identifier =>
3385 Make_Defining_Identifier (Loc,
3386 New_Internal_Name ('S')),
3387 Subtype_Indication =>
3388 New_Reference_To (RTE (RE_Address_Array), Loc));
3390 Append_To (Result, Decl);
3393 Make_Object_Declaration (Loc,
3394 Defining_Identifier => Predef_Prims,
3395 Constant_Present => Building_Static_DT (Typ),
3396 Aliased_Present => True,
3397 Object_Definition => New_Reference_To
3398 (Defining_Identifier (Decl), Loc),
3399 Expression => New_Node));
3402 Make_Attribute_Definition_Clause (Loc,
3403 Name => New_Reference_To (Predef_Prims, Loc),
3404 Chars => Name_Alignment,
3406 Make_Attribute_Reference (Loc,
3408 New_Reference_To (RTE (RE_Integer_Address), Loc),
3409 Attribute_Name => Name_Alignment)));
3414 -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
3415 -- (OSD_Table => (1 => <value>,
3419 -- Iface_DT : Dispatch_Table (Nb_Prims) :=
3420 -- ([ Signature => <sig-value> ],
3421 -- Tag_Kind => <tag_kind-value>,
3422 -- Predef_Prims => Predef_Prims'Address,
3423 -- Offset_To_Top => 0,
3424 -- OSD => OSD'Address,
3425 -- Prims_Ptr => (prim-op-1'address,
3426 -- prim-op-2'address,
3428 -- prim-op-n'address));
3430 -- Stage 3: Initialize the discriminant and the record components
3432 DT_Constr_List := New_List;
3433 DT_Aggr_List := New_List;
3435 -- Nb_Prim. If the tagged type has no primitives we add a dummy
3436 -- slot whose address will be the tag of this type.
3439 New_Node := Make_Integer_Literal (Loc, 1);
3441 New_Node := Make_Integer_Literal (Loc, Nb_Prim);
3444 Append_To (DT_Constr_List, New_Node);
3445 Append_To (DT_Aggr_List, New_Copy (New_Node));
3449 if RTE_Record_Component_Available (RE_Signature) then
3450 Append_To (DT_Aggr_List,
3451 New_Reference_To (RTE (RE_Secondary_DT), Loc));
3456 if RTE_Record_Component_Available (RE_Tag_Kind) then
3457 Append_To (DT_Aggr_List, Tagged_Kind (Typ));
3462 Append_To (DT_Aggr_List,
3463 Make_Attribute_Reference (Loc,
3464 Prefix => New_Reference_To (Predef_Prims, Loc),
3465 Attribute_Name => Name_Address));
3467 -- Note: The correct value of Offset_To_Top will be set by the init
3470 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
3472 -- Generate the Object Specific Data table required to dispatch calls
3473 -- through synchronized interfaces.
3476 or else Is_Abstract_Type (Typ)
3477 or else Is_Controlled (Typ)
3478 or else Restriction_Active (No_Dispatching_Calls)
3479 or else not Is_Limited_Type (Typ)
3480 or else not Has_Interfaces (Typ)
3481 or else not Build_Thunks
3483 -- No OSD table required
3485 Append_To (DT_Aggr_List,
3486 New_Reference_To (RTE (RE_Null_Address), Loc));
3489 OSD_Aggr_List := New_List;
3492 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
3494 Prim_Alias : Entity_Id;
3495 Prim_Elmt : Elmt_Id;
3501 Prim_Table := (others => Empty);
3502 Prim_Alias := Empty;
3504 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3505 while Present (Prim_Elmt) loop
3506 Prim := Node (Prim_Elmt);
3508 if Present (Interface_Alias (Prim))
3509 and then Find_Dispatching_Type
3510 (Interface_Alias (Prim)) = Iface
3512 Prim_Alias := Interface_Alias (Prim);
3515 while Present (Alias (E)) loop
3519 Pos := UI_To_Int (DT_Position (Prim_Alias));
3521 if Present (Prim_Table (Pos)) then
3522 pragma Assert (Prim_Table (Pos) = E);
3526 Prim_Table (Pos) := E;
3528 Append_To (OSD_Aggr_List,
3529 Make_Component_Association (Loc,
3530 Choices => New_List (
3531 Make_Integer_Literal (Loc,
3532 DT_Position (Prim_Alias))),
3534 Make_Integer_Literal (Loc,
3535 DT_Position (Alias (Prim)))));
3541 Next_Elmt (Prim_Elmt);
3543 pragma Assert (Count = Nb_Prim);
3546 OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
3549 Make_Object_Declaration (Loc,
3550 Defining_Identifier => OSD,
3551 Object_Definition =>
3552 Make_Subtype_Indication (Loc,
3554 New_Reference_To (RTE (RE_Object_Specific_Data), Loc),
3556 Make_Index_Or_Discriminant_Constraint (Loc,
3557 Constraints => New_List (
3558 Make_Integer_Literal (Loc, Nb_Prim)))),
3559 Expression => Make_Aggregate (Loc,
3560 Component_Associations => New_List (
3561 Make_Component_Association (Loc,
3562 Choices => New_List (
3564 (RTE_Record_Component (RE_OSD_Num_Prims), Loc)),
3566 Make_Integer_Literal (Loc, Nb_Prim)),
3568 Make_Component_Association (Loc,
3569 Choices => New_List (
3571 (RTE_Record_Component (RE_OSD_Table), Loc)),
3572 Expression => Make_Aggregate (Loc,
3573 Component_Associations => OSD_Aggr_List))))));
3576 Make_Attribute_Definition_Clause (Loc,
3577 Name => New_Reference_To (OSD, Loc),
3578 Chars => Name_Alignment,
3580 Make_Attribute_Reference (Loc,
3582 New_Reference_To (RTE (RE_Integer_Address), Loc),
3583 Attribute_Name => Name_Alignment)));
3585 -- In secondary dispatch tables the Typeinfo component contains
3586 -- the address of the Object Specific Data (see a-tags.ads)
3588 Append_To (DT_Aggr_List,
3589 Make_Attribute_Reference (Loc,
3590 Prefix => New_Reference_To (OSD, Loc),
3591 Attribute_Name => Name_Address));
3594 -- Initialize the table of primitive operations
3596 Prim_Ops_Aggr_List := New_List;
3599 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
3601 elsif Is_Abstract_Type (Typ)
3602 or else not Building_Static_DT (Typ)
3604 for J in 1 .. Nb_Prim loop
3605 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
3610 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
3612 Thunk_Code : Node_Id;
3613 Thunk_Id : Entity_Id;
3616 Prim_Table := (others => Empty);
3618 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3619 while Present (Prim_Elmt) loop
3620 Prim := Node (Prim_Elmt);
3622 if not Is_Predefined_Dispatching_Operation (Prim)
3623 and then Present (Interface_Alias (Prim))
3624 and then not Is_Abstract_Subprogram (Alias (Prim))
3625 and then not Is_Imported (Alias (Prim))
3626 and then Find_Dispatching_Type
3627 (Interface_Alias (Prim)) = Iface
3629 -- Generate the code of the thunk only if the abstract
3630 -- interface type is not an immediate ancestor of
3631 -- Tagged_Type; otherwise the DT associated with the
3632 -- interface is the primary DT.
3634 and then not Is_Ancestor (Iface, Typ)
3636 if not Build_Thunks then
3638 UI_To_Int (DT_Position (Interface_Alias (Prim)));
3639 Prim_Table (Pos) := Alias (Prim);
3641 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
3643 if Present (Thunk_Id) then
3645 UI_To_Int (DT_Position (Interface_Alias (Prim)));
3647 Prim_Table (Pos) := Thunk_Id;
3648 Append_To (Result, Thunk_Code);
3653 Next_Elmt (Prim_Elmt);
3656 for J in Prim_Table'Range loop
3657 if Present (Prim_Table (J)) then
3659 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
3660 Make_Attribute_Reference (Loc,
3661 Prefix => New_Reference_To (Prim_Table (J), Loc),
3662 Attribute_Name => Name_Unrestricted_Access));
3664 New_Node := Make_Null (Loc);
3667 Append_To (Prim_Ops_Aggr_List, New_Node);
3673 Make_Aggregate (Loc,
3674 Expressions => Prim_Ops_Aggr_List);
3676 Append_To (DT_Aggr_List, New_Node);
3678 -- Remember aggregates initializing dispatch tables
3680 Append_Elmt (New_Node, DT_Aggr);
3683 Make_Object_Declaration (Loc,
3684 Defining_Identifier => Iface_DT,
3685 Aliased_Present => True,
3686 Object_Definition =>
3687 Make_Subtype_Indication (Loc,
3688 Subtype_Mark => New_Reference_To
3689 (RTE (RE_Dispatch_Table_Wrapper), Loc),
3690 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
3691 Constraints => DT_Constr_List)),
3693 Expression => Make_Aggregate (Loc,
3694 Expressions => DT_Aggr_List)));
3697 Make_Attribute_Definition_Clause (Loc,
3698 Name => New_Reference_To (Iface_DT, Loc),
3699 Chars => Name_Alignment,
3701 Make_Attribute_Reference (Loc,
3703 New_Reference_To (RTE (RE_Integer_Address), Loc),
3704 Attribute_Name => Name_Alignment)));
3706 -- Generate code to create the pointer to the dispatch table
3708 -- Iface_DT_Ptr : Tag := Tag!(DT'Address);
3711 Make_Object_Declaration (Loc,
3712 Defining_Identifier => Iface_DT_Ptr,
3713 Constant_Present => True,
3714 Object_Definition =>
3715 New_Reference_To (RTE (RE_Interface_Tag), Loc),
3717 Unchecked_Convert_To (RTE (RE_Interface_Tag),
3718 Make_Attribute_Reference (Loc,
3720 Make_Selected_Component (Loc,
3721 Prefix => New_Reference_To (Iface_DT, Loc),
3724 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
3725 Attribute_Name => Name_Address))));
3728 Make_Object_Declaration (Loc,
3729 Defining_Identifier => Predef_Prims_Ptr,
3730 Constant_Present => True,
3731 Object_Definition =>
3732 New_Reference_To (RTE (RE_Address), Loc),
3734 Make_Attribute_Reference (Loc,
3736 Make_Selected_Component (Loc,
3737 Prefix => New_Reference_To (Iface_DT, Loc),
3740 (RTE_Record_Component (RE_Predef_Prims), Loc)),
3741 Attribute_Name => Name_Address)));
3743 -- Remember entities containing dispatch tables
3745 Append_Elmt (Predef_Prims, DT_Decl);
3746 Append_Elmt (Iface_DT, DT_Decl);
3747 end Make_Secondary_DT;
3751 Elab_Code : constant List_Id := New_List;
3752 Result : constant List_Id := New_List;
3753 Tname : constant Name_Id := Chars (Typ);
3755 AI_Tag_Elmt : Elmt_Id;
3756 AI_Tag_Comp : Elmt_Id;
3757 DT_Aggr_List : List_Id;
3758 DT_Constr_List : List_Id;
3762 Iface_Table_Node : Node_Id;
3763 Name_ITable : Name_Id;
3764 Nb_Predef_Prims : Nat := 0;
3767 Num_Ifaces : Nat := 0;
3768 Parent_Typ : Entity_Id;
3770 Prim_Elmt : Elmt_Id;
3771 Prim_Ops_Aggr_List : List_Id;
3773 Typ_Comps : Elist_Id;
3774 Typ_Ifaces : Elist_Id;
3775 TSD_Aggr_List : List_Id;
3776 TSD_Tags_List : List_Id;
3778 -- The following name entries are used by Make_DT to generate a number
3779 -- of entities related to a tagged type. These entities may be generated
3780 -- in a scope other than that of the tagged type declaration, and if
3781 -- the entities for two tagged types with the same name happen to be
3782 -- generated in the same scope, we have to take care to use different
3783 -- names. This is achieved by means of a unique serial number appended
3784 -- to each generated entity name.
3786 Name_DT : constant Name_Id :=
3787 New_External_Name (Tname, 'T', Suffix_Index => -1);
3788 Name_Exname : constant Name_Id :=
3789 New_External_Name (Tname, 'E', Suffix_Index => -1);
3790 Name_HT_Link : constant Name_Id :=
3791 New_External_Name (Tname, 'H', Suffix_Index => -1);
3792 Name_Predef_Prims : constant Name_Id :=
3793 New_External_Name (Tname, 'R', Suffix_Index => -1);
3794 Name_SSD : constant Name_Id :=
3795 New_External_Name (Tname, 'S', Suffix_Index => -1);
3796 Name_TSD : constant Name_Id :=
3797 New_External_Name (Tname, 'B', Suffix_Index => -1);
3799 -- Entities built with above names
3801 DT : constant Entity_Id :=
3802 Make_Defining_Identifier (Loc, Name_DT);
3803 Exname : constant Entity_Id :=
3804 Make_Defining_Identifier (Loc, Name_Exname);
3805 HT_Link : constant Entity_Id :=
3806 Make_Defining_Identifier (Loc, Name_HT_Link);
3807 Predef_Prims : constant Entity_Id :=
3808 Make_Defining_Identifier (Loc, Name_Predef_Prims);
3809 SSD : constant Entity_Id :=
3810 Make_Defining_Identifier (Loc, Name_SSD);
3811 TSD : constant Entity_Id :=
3812 Make_Defining_Identifier (Loc, Name_TSD);
3814 -- Start of processing for Make_DT
3817 pragma Assert (Is_Frozen (Typ));
3819 -- Handle cases in which there is no need to build the dispatch table
3821 if Has_Dispatch_Table (Typ)
3822 or else No (Access_Disp_Table (Typ))
3823 or else Is_CPP_Class (Typ)
3827 elsif No_Run_Time_Mode then
3828 Error_Msg_CRT ("tagged types", Typ);
3831 elsif not RTE_Available (RE_Tag) then
3833 Make_Object_Declaration (Loc,
3834 Defining_Identifier => Node (First_Elmt
3835 (Access_Disp_Table (Typ))),
3836 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
3837 Constant_Present => True,
3839 Unchecked_Convert_To (RTE (RE_Tag),
3840 New_Reference_To (RTE (RE_Null_Address), Loc))));
3842 Analyze_List (Result, Suppress => All_Checks);
3843 Error_Msg_CRT ("tagged types", Typ);
3847 -- Ensure that the value of Max_Predef_Prims defined in a-tags is
3848 -- correct. Valid values are 10 under configurable runtime or 16
3849 -- with full runtime.
3851 if RTE_Available (RE_Interface_Data) then
3852 if Max_Predef_Prims /= 16 then
3853 Error_Msg_N ("run-time library configuration error", Typ);
3857 if Max_Predef_Prims /= 10 then
3858 Error_Msg_N ("run-time library configuration error", Typ);
3859 Error_Msg_CRT ("tagged types", Typ);
3864 -- Initialize Parent_Typ handling private types
3866 Parent_Typ := Etype (Typ);
3868 if Present (Full_View (Parent_Typ)) then
3869 Parent_Typ := Full_View (Parent_Typ);
3872 -- Ensure that all the primitives are frozen. This is only required when
3873 -- building static dispatch tables --- the primitives must be frozen to
3874 -- be referenced (otherwise we have problems with the backend). It is
3875 -- not a requirement with nonstatic dispatch tables because in this case
3876 -- we generate now an empty dispatch table; the extra code required to
3877 -- register the primitives in the slots will be generated later --- when
3878 -- each primitive is frozen (see Freeze_Subprogram).
3880 if Building_Static_DT (Typ)
3881 and then not Is_CPP_Class (Typ)
3884 Save : constant Boolean := Freezing_Library_Level_Tagged_Type;
3885 Prim_Elmt : Elmt_Id;
3889 Freezing_Library_Level_Tagged_Type := True;
3890 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3891 while Present (Prim_Elmt) loop
3892 Frnodes := Freeze_Entity (Node (Prim_Elmt), Loc);
3895 Subp : constant Entity_Id := Node (Prim_Elmt);
3899 F := First_Formal (Subp);
3900 while Present (F) loop
3901 Check_Premature_Freezing (Subp, Etype (F));
3905 Check_Premature_Freezing (Subp, Etype (Subp));
3908 if Present (Frnodes) then
3909 Append_List_To (Result, Frnodes);
3912 Next_Elmt (Prim_Elmt);
3914 Freezing_Library_Level_Tagged_Type := Save;
3918 -- Ada 2005 (AI-251): Build the secondary dispatch tables
3920 if Has_Interfaces (Typ) then
3921 Collect_Interface_Components (Typ, Typ_Comps);
3925 Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
3927 AI_Tag_Comp := First_Elmt (Typ_Comps);
3928 while Present (AI_Tag_Comp) loop
3930 -- Build the secondary table containing pointers to thunks
3934 Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))),
3935 Num_Iface_Prims => UI_To_Int
3936 (DT_Entry_Count (Node (AI_Tag_Comp))),
3937 Iface_DT_Ptr => Node (AI_Tag_Elmt),
3938 Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
3939 Build_Thunks => True,
3941 Next_Elmt (AI_Tag_Elmt);
3943 -- Skip the secondary dispatch table of predefined primitives
3945 Next_Elmt (AI_Tag_Elmt);
3947 -- Build the secondary table containing pointers to primitives
3948 -- (used to give support to Generic Dispatching Constructors).
3952 Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))),
3953 Num_Iface_Prims => UI_To_Int
3954 (DT_Entry_Count (Node (AI_Tag_Comp))),
3955 Iface_DT_Ptr => Node (AI_Tag_Elmt),
3956 Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
3957 Build_Thunks => False,
3959 Next_Elmt (AI_Tag_Elmt);
3961 -- Skip the secondary dispatch table of predefined primitives
3963 Next_Elmt (AI_Tag_Elmt);
3965 Suffix_Index := Suffix_Index + 1;
3966 Next_Elmt (AI_Tag_Comp);
3970 -- Get the _tag entity and the number of primitives of its dispatch
3973 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
3974 Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
3976 Set_Is_Statically_Allocated (DT, Is_Library_Level_Tagged_Type (Typ));
3977 Set_Is_Statically_Allocated (SSD, Is_Library_Level_Tagged_Type (Typ));
3978 Set_Is_Statically_Allocated (TSD, Is_Library_Level_Tagged_Type (Typ));
3979 Set_Is_Statically_Allocated (Predef_Prims,
3980 Is_Library_Level_Tagged_Type (Typ));
3982 -- In case of locally defined tagged type we declare the object
3983 -- containing the dispatch table by means of a variable. Its
3984 -- initialization is done later by means of an assignment. This is
3985 -- required to generate its External_Tag.
3987 if not Building_Static_DT (Typ) then
3990 -- DT : No_Dispatch_Table_Wrapper;
3991 -- for DT'Alignment use Address'Alignment;
3992 -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
3994 if not Has_DT (Typ) then
3996 Make_Object_Declaration (Loc,
3997 Defining_Identifier => DT,
3998 Aliased_Present => True,
3999 Constant_Present => False,
4000 Object_Definition =>
4002 (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
4005 Make_Attribute_Definition_Clause (Loc,
4006 Name => New_Reference_To (DT, Loc),
4007 Chars => Name_Alignment,
4009 Make_Attribute_Reference (Loc,
4011 New_Reference_To (RTE (RE_Integer_Address), Loc),
4012 Attribute_Name => Name_Alignment)));
4015 Make_Object_Declaration (Loc,
4016 Defining_Identifier => DT_Ptr,
4017 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
4018 Constant_Present => True,
4020 Unchecked_Convert_To (RTE (RE_Tag),
4021 Make_Attribute_Reference (Loc,
4023 Make_Selected_Component (Loc,
4024 Prefix => New_Reference_To (DT, Loc),
4027 (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
4028 Attribute_Name => Name_Address))));
4031 -- DT : Dispatch_Table_Wrapper (Nb_Prim);
4032 -- for DT'Alignment use Address'Alignment;
4033 -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
4036 -- If the tagged type has no primitives we add a dummy slot
4037 -- whose address will be the tag of this type.
4041 New_List (Make_Integer_Literal (Loc, 1));
4044 New_List (Make_Integer_Literal (Loc, Nb_Prim));
4048 Make_Object_Declaration (Loc,
4049 Defining_Identifier => DT,
4050 Aliased_Present => True,
4051 Constant_Present => False,
4052 Object_Definition =>
4053 Make_Subtype_Indication (Loc,
4055 New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc),
4056 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
4057 Constraints => DT_Constr_List))));
4060 Make_Attribute_Definition_Clause (Loc,
4061 Name => New_Reference_To (DT, Loc),
4062 Chars => Name_Alignment,
4064 Make_Attribute_Reference (Loc,
4066 New_Reference_To (RTE (RE_Integer_Address), Loc),
4067 Attribute_Name => Name_Alignment)));
4070 Make_Object_Declaration (Loc,
4071 Defining_Identifier => DT_Ptr,
4072 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
4073 Constant_Present => True,
4075 Unchecked_Convert_To (RTE (RE_Tag),
4076 Make_Attribute_Reference (Loc,
4078 Make_Selected_Component (Loc,
4079 Prefix => New_Reference_To (DT, Loc),
4082 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
4083 Attribute_Name => Name_Address))));
4086 Make_Object_Declaration (Loc,
4087 Defining_Identifier =>
4088 Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))),
4089 Constant_Present => True,
4090 Object_Definition => New_Reference_To
4091 (RTE (RE_Address), Loc),
4093 Make_Attribute_Reference (Loc,
4095 Make_Selected_Component (Loc,
4096 Prefix => New_Reference_To (DT, Loc),
4099 (RTE_Record_Component (RE_Predef_Prims), Loc)),
4100 Attribute_Name => Name_Address)));
4104 -- Generate: Exname : constant String := full_qualified_name (typ);
4105 -- The type itself may be an anonymous parent type, so use the first
4106 -- subtype to have a user-recognizable name.
4109 Make_Object_Declaration (Loc,
4110 Defining_Identifier => Exname,
4111 Constant_Present => True,
4112 Object_Definition => New_Reference_To (Standard_String, Loc),
4114 Make_String_Literal (Loc,
4115 Full_Qualified_Name (First_Subtype (Typ)))));
4117 Set_Is_Statically_Allocated (Exname);
4118 Set_Is_True_Constant (Exname);
4120 -- Declare the object used by Ada.Tags.Register_Tag
4122 if RTE_Available (RE_Register_Tag) then
4124 Make_Object_Declaration (Loc,
4125 Defining_Identifier => HT_Link,
4126 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc)));
4129 -- Generate code to create the storage for the type specific data object
4130 -- with enough space to store the tags of the ancestors plus the tags
4131 -- of all the implemented interfaces (as described in a-tags.adb).
4133 -- TSD : Type_Specific_Data (I_Depth) :=
4134 -- (Idepth => I_Depth,
4135 -- Access_Level => Type_Access_Level (Typ),
4136 -- Expanded_Name => Cstring_Ptr!(Exname'Address))
4137 -- External_Tag => Cstring_Ptr!(Exname'Address))
4138 -- HT_Link => HT_Link'Address,
4139 -- Transportable => <<boolean-value>>,
4140 -- RC_Offset => <<integer-value>>,
4141 -- [ Size_Func => Size_Prim'Access ]
4142 -- [ Interfaces_Table => <<access-value>> ]
4143 -- [ SSD => SSD_Table'Address ]
4144 -- Tags_Table => (0 => null,
4147 -- for TSD'Alignment use Address'Alignment
4149 TSD_Aggr_List := New_List;
4151 -- Idepth: Count ancestors to compute the inheritance depth. For private
4152 -- extensions, always go to the full view in order to compute the real
4153 -- inheritance depth.
4156 Current_Typ : Entity_Id;
4157 Parent_Typ : Entity_Id;
4163 Parent_Typ := Etype (Current_Typ);
4165 if Is_Private_Type (Parent_Typ) then
4166 Parent_Typ := Full_View (Base_Type (Parent_Typ));
4169 exit when Parent_Typ = Current_Typ;
4171 I_Depth := I_Depth + 1;
4172 Current_Typ := Parent_Typ;
4176 Append_To (TSD_Aggr_List,
4177 Make_Integer_Literal (Loc, I_Depth));
4181 Append_To (TSD_Aggr_List,
4182 Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
4186 Append_To (TSD_Aggr_List,
4187 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4188 Make_Attribute_Reference (Loc,
4189 Prefix => New_Reference_To (Exname, Loc),
4190 Attribute_Name => Name_Address)));
4192 -- External_Tag of a local tagged type
4194 -- <typ>A : constant String :=
4195 -- "Internal tag at 16#tag-addr#: <full-name-of-typ>";
4197 -- The reason we generate this strange name is that we do not want to
4198 -- enter local tagged types in the global hash table used to compute
4199 -- the Internal_Tag attribute for two reasons:
4201 -- 1. It is hard to avoid a tasking race condition for entering the
4202 -- entry into the hash table.
4204 -- 2. It would cause a storage leak, unless we rig up considerable
4205 -- mechanism to remove the entry from the hash table on exit.
4207 -- So what we do is to generate the above external tag name, where the
4208 -- hex address is the address of the local dispatch table (i.e. exactly
4209 -- the value we want if Internal_Tag is computed from this string).
4211 -- Of course this value will only be valid if the tagged type is still
4212 -- in scope, but it clearly must be erroneous to compute the internal
4213 -- tag of a tagged type that is out of scope!
4215 -- We don't do this processing if an explicit external tag has been
4216 -- specified. That's an odd case for which we have already issued a
4217 -- warning, where we will not be able to compute the internal tag.
4219 if not Is_Library_Level_Entity (Typ)
4220 and then not Has_External_Tag_Rep_Clause (Typ)
4223 Exname : constant Entity_Id :=
4224 Make_Defining_Identifier (Loc,
4225 New_External_Name (Tname, 'A'));
4227 Full_Name : constant String_Id :=
4228 Full_Qualified_Name (First_Subtype (Typ));
4229 Str1_Id : String_Id;
4230 Str2_Id : String_Id;
4234 -- Str1 = "Internal tag at 16#";
4237 Store_String_Chars ("Internal tag at 16#");
4238 Str1_Id := End_String;
4241 -- Str2 = "#: <type-full-name>";
4244 Store_String_Chars ("#: ");
4245 Store_String_Chars (Full_Name);
4246 Str2_Id := End_String;
4249 -- Exname : constant String :=
4250 -- Str1 & Address_Image (Tag) & Str2;
4252 if RTE_Available (RE_Address_Image) then
4254 Make_Object_Declaration (Loc,
4255 Defining_Identifier => Exname,
4256 Constant_Present => True,
4257 Object_Definition => New_Reference_To
4258 (Standard_String, Loc),
4260 Make_Op_Concat (Loc,
4262 Make_String_Literal (Loc, Str1_Id),
4264 Make_Op_Concat (Loc,
4266 Make_Function_Call (Loc,
4269 (RTE (RE_Address_Image), Loc),
4270 Parameter_Associations => New_List (
4271 Unchecked_Convert_To (RTE (RE_Address),
4272 New_Reference_To (DT_Ptr, Loc)))),
4274 Make_String_Literal (Loc, Str2_Id)))));
4278 Make_Object_Declaration (Loc,
4279 Defining_Identifier => Exname,
4280 Constant_Present => True,
4281 Object_Definition => New_Reference_To
4282 (Standard_String, Loc),
4284 Make_Op_Concat (Loc,
4286 Make_String_Literal (Loc, Str1_Id),
4288 Make_String_Literal (Loc, Str2_Id))));
4292 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4293 Make_Attribute_Reference (Loc,
4294 Prefix => New_Reference_To (Exname, Loc),
4295 Attribute_Name => Name_Address));
4298 -- External tag of a library-level tagged type: Check for a definition
4299 -- of External_Tag. The clause is considered only if it applies to this
4300 -- specific tagged type, as opposed to one of its ancestors.
4301 -- If the type is an unconstrained type extension, we are building the
4302 -- dispatch table of its anonymous base type, so the external tag, if
4303 -- any was specified, must be retrieved from the first subtype.
4307 Def : constant Node_Id := Get_Attribute_Definition_Clause
4308 (First_Subtype (Typ),
4309 Attribute_External_Tag);
4311 Old_Val : String_Id;
4312 New_Val : String_Id;
4316 if not Present (Def)
4317 or else Entity (Name (Def)) /= First_Subtype (Typ)
4320 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4321 Make_Attribute_Reference (Loc,
4322 Prefix => New_Reference_To (Exname, Loc),
4323 Attribute_Name => Name_Address));
4325 Old_Val := Strval (Expr_Value_S (Expression (Def)));
4327 -- For the rep clause "for <typ>'external_tag use y" generate:
4329 -- <typ>A : constant string := y;
4331 -- <typ>A'Address is used to set the External_Tag component
4334 -- Create a new nul terminated string if it is not already
4336 if String_Length (Old_Val) > 0
4338 Get_String_Char (Old_Val, String_Length (Old_Val)) = 0
4342 Start_String (Old_Val);
4343 Store_String_Char (Get_Char_Code (ASCII.NUL));
4344 New_Val := End_String;
4347 E := Make_Defining_Identifier (Loc,
4348 New_External_Name (Chars (Typ), 'A'));
4351 Make_Object_Declaration (Loc,
4352 Defining_Identifier => E,
4353 Constant_Present => True,
4354 Object_Definition =>
4355 New_Reference_To (Standard_String, Loc),
4357 Make_String_Literal (Loc, New_Val)));
4360 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4361 Make_Attribute_Reference (Loc,
4362 Prefix => New_Reference_To (E, Loc),
4363 Attribute_Name => Name_Address));
4368 Append_To (TSD_Aggr_List, New_Node);
4372 if RTE_Available (RE_Register_Tag) then
4373 Append_To (TSD_Aggr_List,
4374 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
4375 Make_Attribute_Reference (Loc,
4376 Prefix => New_Reference_To (HT_Link, Loc),
4377 Attribute_Name => Name_Address)));
4379 Append_To (TSD_Aggr_List,
4380 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
4381 New_Reference_To (RTE (RE_Null_Address), Loc)));
4384 -- Transportable: Set for types that can be used in remote calls
4385 -- with respect to E.4(18) legality rules.
4388 Transportable : Entity_Id;
4394 or else Is_Shared_Passive (Typ)
4396 ((Is_Remote_Types (Typ)
4397 or else Is_Remote_Call_Interface (Typ))
4398 and then Original_View_In_Visible_Part (Typ))
4399 or else not Comes_From_Source (Typ));
4401 Append_To (TSD_Aggr_List,
4402 New_Occurrence_Of (Transportable, Loc));
4405 -- RC_Offset: These are the valid values and their meaning:
4407 -- >0: For simple types with controlled components is
4408 -- type._record_controller'position
4410 -- 0: For types with no controlled components
4412 -- -1: For complex types with controlled components where the position
4413 -- of the record controller is not statically computable but there
4414 -- are controlled components at this level. The _Controller field
4415 -- is available right after the _parent.
4417 -- -2: There are no controlled components at this level. We need to
4418 -- get the position from the parent.
4421 RC_Offset_Node : Node_Id;
4424 if not Has_Controlled_Component (Typ) then
4425 RC_Offset_Node := Make_Integer_Literal (Loc, 0);
4427 elsif Etype (Typ) /= Typ
4428 and then Has_Discriminants (Parent_Typ)
4430 if Has_New_Controlled_Component (Typ) then
4431 RC_Offset_Node := Make_Integer_Literal (Loc, -1);
4433 RC_Offset_Node := Make_Integer_Literal (Loc, -2);
4437 Make_Attribute_Reference (Loc,
4439 Make_Selected_Component (Loc,
4440 Prefix => New_Reference_To (Typ, Loc),
4442 New_Reference_To (Controller_Component (Typ), Loc)),
4443 Attribute_Name => Name_Position);
4445 -- This is not proper Ada code to use the attribute 'Position
4446 -- on something else than an object but this is supported by
4447 -- the back end (see comment on the Bit_Component attribute in
4448 -- sem_attr). So we avoid semantic checking here.
4450 -- Is this documented in sinfo.ads??? it should be!
4452 Set_Analyzed (RC_Offset_Node);
4453 Set_Etype (Prefix (RC_Offset_Node), RTE (RE_Record_Controller));
4454 Set_Etype (Prefix (Prefix (RC_Offset_Node)), Typ);
4455 Set_Etype (Selector_Name (Prefix (RC_Offset_Node)),
4456 RTE (RE_Record_Controller));
4457 Set_Etype (RC_Offset_Node, RTE (RE_Storage_Offset));
4460 Append_To (TSD_Aggr_List, RC_Offset_Node);
4465 if RTE_Record_Component_Available (RE_Size_Func) then
4466 if not Building_Static_DT (Typ)
4467 or else Is_Interface (Typ)
4469 Append_To (TSD_Aggr_List,
4470 Unchecked_Convert_To (RTE (RE_Size_Ptr),
4471 New_Reference_To (RTE (RE_Null_Address), Loc)));
4475 Prim_Elmt : Elmt_Id;
4479 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4480 while Present (Prim_Elmt) loop
4481 Prim := Node (Prim_Elmt);
4483 if Chars (Prim) = Name_uSize then
4484 while Present (Alias (Prim)) loop
4485 Prim := Alias (Prim);
4488 if Is_Abstract_Subprogram (Prim) then
4489 Append_To (TSD_Aggr_List,
4490 Unchecked_Convert_To (RTE (RE_Size_Ptr),
4491 New_Reference_To (RTE (RE_Null_Address), Loc)));
4493 Append_To (TSD_Aggr_List,
4494 Unchecked_Convert_To (RTE (RE_Size_Ptr),
4495 Make_Attribute_Reference (Loc,
4496 Prefix => New_Reference_To (Prim, Loc),
4497 Attribute_Name => Name_Unrestricted_Access)));
4503 Next_Elmt (Prim_Elmt);
4509 -- Interfaces_Table (required for AI-405)
4511 if RTE_Record_Component_Available (RE_Interfaces_Table) then
4513 -- Count the number of interface types implemented by Typ
4515 Collect_Interfaces (Typ, Typ_Ifaces);
4517 AI := First_Elmt (Typ_Ifaces);
4518 while Present (AI) loop
4519 Num_Ifaces := Num_Ifaces + 1;
4523 if Num_Ifaces = 0 then
4524 Iface_Table_Node := Make_Null (Loc);
4526 -- Generate the Interface_Table object
4530 TSD_Ifaces_List : constant List_Id := New_List;
4532 Sec_DT_Tag : Node_Id;
4535 AI := First_Elmt (Typ_Ifaces);
4536 while Present (AI) loop
4537 if Is_Ancestor (Node (AI), Typ) then
4539 New_Reference_To (DT_Ptr, Loc);
4543 (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
4544 pragma Assert (Has_Thunks (Node (Elmt)));
4546 while Ekind (Node (Elmt)) = E_Constant
4548 Is_Ancestor (Node (AI), Related_Type (Node (Elmt)))
4550 pragma Assert (Has_Thunks (Node (Elmt)));
4552 pragma Assert (Has_Thunks (Node (Elmt)));
4554 pragma Assert (not Has_Thunks (Node (Elmt)));
4556 pragma Assert (not Has_Thunks (Node (Elmt)));
4560 pragma Assert (Ekind (Node (Elmt)) = E_Constant
4562 Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt)))));
4564 New_Reference_To (Node (Next_Elmt (Next_Elmt (Elmt))),
4568 Append_To (TSD_Ifaces_List,
4569 Make_Aggregate (Loc,
4570 Expressions => New_List (
4574 Unchecked_Convert_To (RTE (RE_Tag),
4576 (Node (First_Elmt (Access_Disp_Table (Node (AI)))),
4579 -- Static_Offset_To_Top
4581 New_Reference_To (Standard_True, Loc),
4583 -- Offset_To_Top_Value
4585 Make_Integer_Literal (Loc, 0),
4587 -- Offset_To_Top_Func
4593 Unchecked_Convert_To (RTE (RE_Tag), Sec_DT_Tag)
4600 Name_ITable := New_External_Name (Tname, 'I');
4601 ITable := Make_Defining_Identifier (Loc, Name_ITable);
4602 Set_Is_Statically_Allocated (ITable,
4603 Is_Library_Level_Tagged_Type (Typ));
4605 -- The table of interfaces is not constant; its slots are
4606 -- filled at run-time by the IP routine using attribute
4607 -- 'Position to know the location of the tag components
4608 -- (and this attribute cannot be safely used before the
4609 -- object is initialized).
4612 Make_Object_Declaration (Loc,
4613 Defining_Identifier => ITable,
4614 Aliased_Present => True,
4615 Constant_Present => False,
4616 Object_Definition =>
4617 Make_Subtype_Indication (Loc,
4619 New_Reference_To (RTE (RE_Interface_Data), Loc),
4620 Constraint => Make_Index_Or_Discriminant_Constraint
4622 Constraints => New_List (
4623 Make_Integer_Literal (Loc, Num_Ifaces)))),
4625 Expression => Make_Aggregate (Loc,
4626 Expressions => New_List (
4627 Make_Integer_Literal (Loc, Num_Ifaces),
4628 Make_Aggregate (Loc,
4629 Expressions => TSD_Ifaces_List)))));
4632 Make_Attribute_Definition_Clause (Loc,
4633 Name => New_Reference_To (ITable, Loc),
4634 Chars => Name_Alignment,
4636 Make_Attribute_Reference (Loc,
4638 New_Reference_To (RTE (RE_Integer_Address), Loc),
4639 Attribute_Name => Name_Alignment)));
4642 Make_Attribute_Reference (Loc,
4643 Prefix => New_Reference_To (ITable, Loc),
4644 Attribute_Name => Name_Unchecked_Access);
4648 Append_To (TSD_Aggr_List, Iface_Table_Node);
4651 -- Generate the Select Specific Data table for synchronized types that
4652 -- implement synchronized interfaces. The size of the table is
4653 -- constrained by the number of non-predefined primitive operations.
4655 if RTE_Record_Component_Available (RE_SSD) then
4656 if Ada_Version >= Ada_05
4657 and then Has_DT (Typ)
4658 and then Is_Concurrent_Record_Type (Typ)
4659 and then Has_Interfaces (Typ)
4660 and then Nb_Prim > 0
4661 and then not Is_Abstract_Type (Typ)
4662 and then not Is_Controlled (Typ)
4663 and then not Restriction_Active (No_Dispatching_Calls)
4666 Make_Object_Declaration (Loc,
4667 Defining_Identifier => SSD,
4668 Aliased_Present => True,
4669 Object_Definition =>
4670 Make_Subtype_Indication (Loc,
4671 Subtype_Mark => New_Reference_To (
4672 RTE (RE_Select_Specific_Data), Loc),
4674 Make_Index_Or_Discriminant_Constraint (Loc,
4675 Constraints => New_List (
4676 Make_Integer_Literal (Loc, Nb_Prim))))));
4679 Make_Attribute_Definition_Clause (Loc,
4680 Name => New_Reference_To (SSD, Loc),
4681 Chars => Name_Alignment,
4683 Make_Attribute_Reference (Loc,
4685 New_Reference_To (RTE (RE_Integer_Address), Loc),
4686 Attribute_Name => Name_Alignment)));
4688 -- This table is initialized by Make_Select_Specific_Data_Table,
4689 -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
4691 Append_To (TSD_Aggr_List,
4692 Make_Attribute_Reference (Loc,
4693 Prefix => New_Reference_To (SSD, Loc),
4694 Attribute_Name => Name_Unchecked_Access));
4696 Append_To (TSD_Aggr_List, Make_Null (Loc));
4700 -- Initialize the table of ancestor tags. In case of interface types
4701 -- this table is not needed.
4703 TSD_Tags_List := New_List;
4705 -- If we are not statically allocating the dispatch table then we must
4706 -- fill position 0 with null because we still have not generated the
4709 if not Building_Static_DT (Typ)
4710 or else Is_Interface (Typ)
4712 Append_To (TSD_Tags_List,
4713 Unchecked_Convert_To (RTE (RE_Tag),
4714 New_Reference_To (RTE (RE_Null_Address), Loc)));
4716 -- Otherwise we can safely reference the tag
4719 Append_To (TSD_Tags_List,
4720 New_Reference_To (DT_Ptr, Loc));
4723 -- Fill the rest of the table with the tags of the ancestors
4726 Current_Typ : Entity_Id;
4727 Parent_Typ : Entity_Id;
4735 Parent_Typ := Etype (Current_Typ);
4737 if Is_Private_Type (Parent_Typ) then
4738 Parent_Typ := Full_View (Base_Type (Parent_Typ));
4741 exit when Parent_Typ = Current_Typ;
4743 if Is_CPP_Class (Parent_Typ)
4744 or else Is_Interface (Typ)
4746 -- The tags defined in the C++ side will be inherited when
4747 -- the object is constructed (Exp_Ch3.Build_Init_Procedure)
4749 Append_To (TSD_Tags_List,
4750 Unchecked_Convert_To (RTE (RE_Tag),
4751 New_Reference_To (RTE (RE_Null_Address), Loc)));
4753 Append_To (TSD_Tags_List,
4755 (Node (First_Elmt (Access_Disp_Table (Parent_Typ))),
4760 Current_Typ := Parent_Typ;
4763 pragma Assert (Pos = I_Depth + 1);
4766 Append_To (TSD_Aggr_List,
4767 Make_Aggregate (Loc,
4768 Expressions => TSD_Tags_List));
4770 -- Build the TSD object
4773 Make_Object_Declaration (Loc,
4774 Defining_Identifier => TSD,
4775 Aliased_Present => True,
4776 Constant_Present => Building_Static_DT (Typ),
4777 Object_Definition =>
4778 Make_Subtype_Indication (Loc,
4779 Subtype_Mark => New_Reference_To (
4780 RTE (RE_Type_Specific_Data), Loc),
4782 Make_Index_Or_Discriminant_Constraint (Loc,
4783 Constraints => New_List (
4784 Make_Integer_Literal (Loc, I_Depth)))),
4786 Expression => Make_Aggregate (Loc,
4787 Expressions => TSD_Aggr_List)));
4789 Set_Is_True_Constant (TSD, Building_Static_DT (Typ));
4792 Make_Attribute_Definition_Clause (Loc,
4793 Name => New_Reference_To (TSD, Loc),
4794 Chars => Name_Alignment,
4796 Make_Attribute_Reference (Loc,
4797 Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
4798 Attribute_Name => Name_Alignment)));
4800 -- Initialize or declare the dispatch table object
4802 if not Has_DT (Typ) then
4803 DT_Constr_List := New_List;
4804 DT_Aggr_List := New_List;
4809 Make_Attribute_Reference (Loc,
4810 Prefix => New_Reference_To (TSD, Loc),
4811 Attribute_Name => Name_Address);
4813 Append_To (DT_Constr_List, New_Node);
4814 Append_To (DT_Aggr_List, New_Copy (New_Node));
4815 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
4817 -- In case of locally defined tagged types we have already declared
4818 -- and uninitialized object for the dispatch table, which is now
4819 -- initialized by means of the following assignment:
4821 -- DT := (TSD'Address, 0);
4823 if not Building_Static_DT (Typ) then
4825 Make_Assignment_Statement (Loc,
4826 Name => New_Reference_To (DT, Loc),
4827 Expression => Make_Aggregate (Loc,
4828 Expressions => DT_Aggr_List)));
4830 -- In case of library level tagged types we declare and export now
4831 -- the constant object containing the dummy dispatch table. There
4832 -- is no need to declare the tag here because it has been previously
4833 -- declared by Make_Tags
4835 -- DT : aliased constant No_Dispatch_Table :=
4836 -- (NDT_TSD => TSD'Address;
4837 -- NDT_Prims_Ptr => 0);
4838 -- for DT'Alignment use Address'Alignment;
4842 Make_Object_Declaration (Loc,
4843 Defining_Identifier => DT,
4844 Aliased_Present => True,
4845 Constant_Present => True,
4846 Object_Definition =>
4847 New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc),
4848 Expression => Make_Aggregate (Loc,
4849 Expressions => DT_Aggr_List)));
4852 Make_Attribute_Definition_Clause (Loc,
4853 Name => New_Reference_To (DT, Loc),
4854 Chars => Name_Alignment,
4856 Make_Attribute_Reference (Loc,
4858 New_Reference_To (RTE (RE_Integer_Address), Loc),
4859 Attribute_Name => Name_Alignment)));
4861 Export_DT (Typ, DT);
4864 -- Common case: Typ has a dispatch table
4868 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
4869 -- (predef-prim-op-1'address,
4870 -- predef-prim-op-2'address,
4872 -- predef-prim-op-n'address);
4873 -- for Predef_Prims'Alignment use Address'Alignment
4875 -- DT : Dispatch_Table (Nb_Prims) :=
4876 -- (Signature => <sig-value>,
4877 -- Tag_Kind => <tag_kind-value>,
4878 -- Predef_Prims => Predef_Prims'First'Address,
4879 -- Offset_To_Top => 0,
4880 -- TSD => TSD'Address;
4881 -- Prims_Ptr => (prim-op-1'address,
4882 -- prim-op-2'address,
4884 -- prim-op-n'address));
4885 -- for DT'Alignment use Address'Alignment
4892 if not Building_Static_DT (Typ) then
4893 Nb_Predef_Prims := Max_Predef_Prims;
4896 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4897 while Present (Prim_Elmt) loop
4898 Prim := Node (Prim_Elmt);
4900 if Is_Predefined_Dispatching_Operation (Prim)
4901 and then not Is_Abstract_Subprogram (Prim)
4903 Pos := UI_To_Int (DT_Position (Prim));
4905 if Pos > Nb_Predef_Prims then
4906 Nb_Predef_Prims := Pos;
4910 Next_Elmt (Prim_Elmt);
4916 (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
4921 Prim_Ops_Aggr_List := New_List;
4923 Prim_Table := (others => Empty);
4925 if Building_Static_DT (Typ) then
4926 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4927 while Present (Prim_Elmt) loop
4928 Prim := Node (Prim_Elmt);
4930 if Is_Predefined_Dispatching_Operation (Prim)
4931 and then not Is_Abstract_Subprogram (Prim)
4932 and then not Present (Prim_Table
4933 (UI_To_Int (DT_Position (Prim))))
4936 while Present (Alias (E)) loop
4940 pragma Assert (not Is_Abstract_Subprogram (E));
4941 Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
4944 Next_Elmt (Prim_Elmt);
4948 for J in Prim_Table'Range loop
4949 if Present (Prim_Table (J)) then
4951 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
4952 Make_Attribute_Reference (Loc,
4953 Prefix => New_Reference_To (Prim_Table (J), Loc),
4954 Attribute_Name => Name_Unrestricted_Access));
4956 New_Node := Make_Null (Loc);
4959 Append_To (Prim_Ops_Aggr_List, New_Node);
4963 Make_Aggregate (Loc,
4964 Expressions => Prim_Ops_Aggr_List);
4967 Make_Subtype_Declaration (Loc,
4968 Defining_Identifier =>
4969 Make_Defining_Identifier (Loc,
4970 New_Internal_Name ('S')),
4971 Subtype_Indication =>
4972 New_Reference_To (RTE (RE_Address_Array), Loc));
4974 Append_To (Result, Decl);
4977 Make_Object_Declaration (Loc,
4978 Defining_Identifier => Predef_Prims,
4979 Aliased_Present => True,
4980 Constant_Present => Building_Static_DT (Typ),
4981 Object_Definition => New_Reference_To
4982 (Defining_Identifier (Decl), Loc),
4983 Expression => New_Node));
4985 -- Remember aggregates initializing dispatch tables
4987 Append_Elmt (New_Node, DT_Aggr);
4990 Make_Attribute_Definition_Clause (Loc,
4991 Name => New_Reference_To (Predef_Prims, Loc),
4992 Chars => Name_Alignment,
4994 Make_Attribute_Reference (Loc,
4996 New_Reference_To (RTE (RE_Integer_Address), Loc),
4997 Attribute_Name => Name_Alignment)));
5001 -- Stage 1: Initialize the discriminant and the record components
5003 DT_Constr_List := New_List;
5004 DT_Aggr_List := New_List;
5006 -- Num_Prims. If the tagged type has no primitives we add a dummy
5007 -- slot whose address will be the tag of this type.
5010 New_Node := Make_Integer_Literal (Loc, 1);
5012 New_Node := Make_Integer_Literal (Loc, Nb_Prim);
5015 Append_To (DT_Constr_List, New_Node);
5016 Append_To (DT_Aggr_List, New_Copy (New_Node));
5020 if RTE_Record_Component_Available (RE_Signature) then
5021 Append_To (DT_Aggr_List,
5022 New_Reference_To (RTE (RE_Primary_DT), Loc));
5027 if RTE_Record_Component_Available (RE_Tag_Kind) then
5028 Append_To (DT_Aggr_List, Tagged_Kind (Typ));
5033 Append_To (DT_Aggr_List,
5034 Make_Attribute_Reference (Loc,
5035 Prefix => New_Reference_To (Predef_Prims, Loc),
5036 Attribute_Name => Name_Address));
5040 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
5044 Append_To (DT_Aggr_List,
5045 Make_Attribute_Reference (Loc,
5046 Prefix => New_Reference_To (TSD, Loc),
5047 Attribute_Name => Name_Address));
5049 -- Stage 2: Initialize the table of primitive operations
5051 Prim_Ops_Aggr_List := New_List;
5054 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
5056 elsif not Building_Static_DT (Typ) then
5057 for J in 1 .. Nb_Prim loop
5058 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
5063 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
5066 Prim_Elmt : Elmt_Id;
5069 Prim_Table := (others => Empty);
5071 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5072 while Present (Prim_Elmt) loop
5073 Prim := Node (Prim_Elmt);
5075 if Is_Imported (Prim)
5076 or else Present (Interface_Alias (Prim))
5077 or else Is_Predefined_Dispatching_Operation (Prim)
5082 -- Traverse the list of aliased entities to handle
5083 -- renamings of predefined primitives.
5086 while Present (Alias (E)) loop
5090 if not Is_Predefined_Dispatching_Operation (E)
5091 and then not Is_Abstract_Subprogram (E)
5092 and then not Present (Interface_Alias (E))
5095 (UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
5097 Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
5101 Next_Elmt (Prim_Elmt);
5104 for J in Prim_Table'Range loop
5105 if Present (Prim_Table (J)) then
5107 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
5108 Make_Attribute_Reference (Loc,
5109 Prefix => New_Reference_To (Prim_Table (J), Loc),
5110 Attribute_Name => Name_Unrestricted_Access));
5112 New_Node := Make_Null (Loc);
5115 Append_To (Prim_Ops_Aggr_List, New_Node);
5121 Make_Aggregate (Loc,
5122 Expressions => Prim_Ops_Aggr_List);
5124 Append_To (DT_Aggr_List, New_Node);
5126 -- Remember aggregates initializing dispatch tables
5128 Append_Elmt (New_Node, DT_Aggr);
5130 -- In case of locally defined tagged types we have already declared
5131 -- and uninitialized object for the dispatch table, which is now
5132 -- initialized by means of an assignment.
5134 if not Building_Static_DT (Typ) then
5136 Make_Assignment_Statement (Loc,
5137 Name => New_Reference_To (DT, Loc),
5138 Expression => Make_Aggregate (Loc,
5139 Expressions => DT_Aggr_List)));
5141 -- In case of library level tagged types we declare now and export
5142 -- the constant object containing the dispatch table.
5146 Make_Object_Declaration (Loc,
5147 Defining_Identifier => DT,
5148 Aliased_Present => True,
5149 Constant_Present => True,
5150 Object_Definition =>
5151 Make_Subtype_Indication (Loc,
5152 Subtype_Mark => New_Reference_To
5153 (RTE (RE_Dispatch_Table_Wrapper), Loc),
5154 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
5155 Constraints => DT_Constr_List)),
5156 Expression => Make_Aggregate (Loc,
5157 Expressions => DT_Aggr_List)));
5160 Make_Attribute_Definition_Clause (Loc,
5161 Name => New_Reference_To (DT, Loc),
5162 Chars => Name_Alignment,
5164 Make_Attribute_Reference (Loc,
5166 New_Reference_To (RTE (RE_Integer_Address), Loc),
5167 Attribute_Name => Name_Alignment)));
5169 Export_DT (Typ, DT);
5173 -- Initialize the table of ancestor tags
5175 if not Building_Static_DT (Typ)
5176 and then not Is_Interface (Typ)
5177 and then not Is_CPP_Class (Typ)
5180 Make_Assignment_Statement (Loc,
5182 Make_Indexed_Component (Loc,
5184 Make_Selected_Component (Loc,
5186 New_Reference_To (TSD, Loc),
5189 (RTE_Record_Component (RE_Tags_Table), Loc)),
5191 New_List (Make_Integer_Literal (Loc, 0))),
5195 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
5198 -- Inherit the dispatch tables of the parent
5200 -- There is no need to inherit anything from the parent when building
5201 -- static dispatch tables because the whole dispatch table (including
5202 -- inherited primitives) has been already built.
5204 if Building_Static_DT (Typ) then
5207 -- If the ancestor is a CPP_Class type we inherit the dispatch tables
5208 -- in the init proc, and we don't need to fill them in here.
5210 elsif Is_CPP_Class (Parent_Typ) then
5213 -- Otherwise we fill in the dispatch tables here
5216 if Typ /= Parent_Typ
5217 and then not Is_Interface (Typ)
5218 and then not Restriction_Active (No_Dispatching_Calls)
5220 -- Inherit the dispatch table
5222 if not Is_Interface (Typ)
5223 and then not Is_Interface (Parent_Typ)
5224 and then not Is_CPP_Class (Parent_Typ)
5227 Nb_Prims : constant Int :=
5228 UI_To_Int (DT_Entry_Count
5229 (First_Tag_Component (Parent_Typ)));
5232 Append_To (Elab_Code,
5233 Build_Inherit_Predefined_Prims (Loc,
5239 (Access_Disp_Table (Parent_Typ)))), Loc),
5245 (Access_Disp_Table (Typ)))), Loc)));
5247 if Nb_Prims /= 0 then
5248 Append_To (Elab_Code,
5249 Build_Inherit_Prims (Loc,
5255 (Access_Disp_Table (Parent_Typ))), Loc),
5256 New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
5257 Num_Prims => Nb_Prims));
5262 -- Inherit the secondary dispatch tables of the ancestor
5264 if not Is_CPP_Class (Parent_Typ) then
5266 Sec_DT_Ancestor : Elmt_Id :=
5270 (Access_Disp_Table (Parent_Typ))));
5271 Sec_DT_Typ : Elmt_Id :=
5275 (Access_Disp_Table (Typ))));
5277 procedure Copy_Secondary_DTs (Typ : Entity_Id);
5278 -- Local procedure required to climb through the ancestors
5279 -- and copy the contents of all their secondary dispatch
5282 ------------------------
5283 -- Copy_Secondary_DTs --
5284 ------------------------
5286 procedure Copy_Secondary_DTs (Typ : Entity_Id) is
5291 -- Climb to the ancestor (if any) handling private types
5293 if Present (Full_View (Etype (Typ))) then
5294 if Full_View (Etype (Typ)) /= Typ then
5295 Copy_Secondary_DTs (Full_View (Etype (Typ)));
5298 elsif Etype (Typ) /= Typ then
5299 Copy_Secondary_DTs (Etype (Typ));
5302 if Present (Interfaces (Typ))
5303 and then not Is_Empty_Elmt_List (Interfaces (Typ))
5305 Iface := First_Elmt (Interfaces (Typ));
5306 E := First_Entity (Typ);
5308 and then Present (Node (Sec_DT_Ancestor))
5309 and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
5311 if Is_Tag (E) and then Chars (E) /= Name_uTag then
5313 Num_Prims : constant Int :=
5314 UI_To_Int (DT_Entry_Count (E));
5317 if not Is_Interface (Etype (Typ)) then
5319 -- Inherit first secondary dispatch table
5321 Append_To (Elab_Code,
5322 Build_Inherit_Predefined_Prims (Loc,
5324 Unchecked_Convert_To (RTE (RE_Tag),
5327 (Next_Elmt (Sec_DT_Ancestor)),
5330 Unchecked_Convert_To (RTE (RE_Tag),
5332 (Node (Next_Elmt (Sec_DT_Typ)),
5335 if Num_Prims /= 0 then
5336 Append_To (Elab_Code,
5337 Build_Inherit_Prims (Loc,
5338 Typ => Node (Iface),
5340 Unchecked_Convert_To
5343 (Node (Sec_DT_Ancestor),
5346 Unchecked_Convert_To
5349 (Node (Sec_DT_Typ), Loc)),
5350 Num_Prims => Num_Prims));
5354 Next_Elmt (Sec_DT_Ancestor);
5355 Next_Elmt (Sec_DT_Typ);
5357 -- Skip the secondary dispatch table of
5358 -- predefined primitives
5360 Next_Elmt (Sec_DT_Ancestor);
5361 Next_Elmt (Sec_DT_Typ);
5363 if not Is_Interface (Etype (Typ)) then
5365 -- Inherit second secondary dispatch table
5367 Append_To (Elab_Code,
5368 Build_Inherit_Predefined_Prims (Loc,
5370 Unchecked_Convert_To (RTE (RE_Tag),
5373 (Next_Elmt (Sec_DT_Ancestor)),
5376 Unchecked_Convert_To (RTE (RE_Tag),
5378 (Node (Next_Elmt (Sec_DT_Typ)),
5381 if Num_Prims /= 0 then
5382 Append_To (Elab_Code,
5383 Build_Inherit_Prims (Loc,
5384 Typ => Node (Iface),
5386 Unchecked_Convert_To
5389 (Node (Sec_DT_Ancestor),
5392 Unchecked_Convert_To
5395 (Node (Sec_DT_Typ), Loc)),
5396 Num_Prims => Num_Prims));
5401 Next_Elmt (Sec_DT_Ancestor);
5402 Next_Elmt (Sec_DT_Typ);
5404 -- Skip the secondary dispatch table of
5405 -- predefined primitives
5407 Next_Elmt (Sec_DT_Ancestor);
5408 Next_Elmt (Sec_DT_Typ);
5416 end Copy_Secondary_DTs;
5419 if Present (Node (Sec_DT_Ancestor))
5420 and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
5422 -- Handle private types
5424 if Present (Full_View (Typ)) then
5425 Copy_Secondary_DTs (Full_View (Typ));
5427 Copy_Secondary_DTs (Typ);
5435 -- Generate code to register the Tag in the External_Tag hash table for
5436 -- the pure Ada type only.
5438 -- Register_Tag (Dt_Ptr);
5440 -- Skip this action in the following cases:
5441 -- 1) if Register_Tag is not available.
5442 -- 2) in No_Run_Time mode.
5443 -- 3) if Typ is not defined at the library level (this is required
5444 -- to avoid adding concurrency control to the hash table used
5445 -- by the run-time to register the tags).
5447 if not No_Run_Time_Mode
5448 and then Is_Library_Level_Entity (Typ)
5449 and then RTE_Available (RE_Register_Tag)
5451 Append_To (Elab_Code,
5452 Make_Procedure_Call_Statement (Loc,
5453 Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
5454 Parameter_Associations =>
5455 New_List (New_Reference_To (DT_Ptr, Loc))));
5458 if not Is_Empty_List (Elab_Code) then
5459 Append_List_To (Result, Elab_Code);
5462 -- Populate the two auxiliary tables used for dispatching
5463 -- asynchronous, conditional and timed selects for synchronized
5464 -- types that implement a limited interface.
5466 if Ada_Version >= Ada_05
5467 and then Is_Concurrent_Record_Type (Typ)
5468 and then Has_Interfaces (Typ)
5470 Append_List_To (Result,
5471 Make_Select_Specific_Data_Table (Typ));
5474 -- Remember entities containing dispatch tables
5476 Append_Elmt (Predef_Prims, DT_Decl);
5477 Append_Elmt (DT, DT_Decl);
5479 Analyze_List (Result, Suppress => All_Checks);
5480 Set_Has_Dispatch_Table (Typ);
5482 -- Mark entities containing dispatch tables. Required by the
5483 -- backend to handle them properly.
5485 if not Is_Interface (Typ) then
5490 -- Ensure that entities Prim_Ptr and Predef_Prims_Table_Ptr have
5491 -- the decoration required by the backend
5493 Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr));
5494 Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr));
5496 -- Object declarations
5498 Elmt := First_Elmt (DT_Decl);
5499 while Present (Elmt) loop
5500 Set_Is_Dispatch_Table_Entity (Node (Elmt));
5501 pragma Assert (Ekind (Etype (Node (Elmt))) = E_Array_Subtype
5502 or else Ekind (Etype (Node (Elmt))) = E_Record_Subtype);
5503 Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
5507 -- Aggregates initializing dispatch tables
5509 Elmt := First_Elmt (DT_Aggr);
5510 while Present (Elmt) loop
5511 Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
5520 -------------------------------------
5521 -- Make_Select_Specific_Data_Table --
5522 -------------------------------------
5524 function Make_Select_Specific_Data_Table
5525 (Typ : Entity_Id) return List_Id
5527 Assignments : constant List_Id := New_List;
5528 Loc : constant Source_Ptr := Sloc (Typ);
5530 Conc_Typ : Entity_Id;
5534 Prim_Als : Entity_Id;
5535 Prim_Elmt : Elmt_Id;
5539 type Examined_Array is array (Int range <>) of Boolean;
5541 function Find_Entry_Index (E : Entity_Id) return Uint;
5542 -- Given an entry, find its index in the visible declarations of the
5543 -- corresponding concurrent type of Typ.
5545 ----------------------
5546 -- Find_Entry_Index --
5547 ----------------------
5549 function Find_Entry_Index (E : Entity_Id) return Uint is
5550 Index : Uint := Uint_1;
5551 Subp_Decl : Entity_Id;
5555 and then not Is_Empty_List (Decls)
5557 Subp_Decl := First (Decls);
5558 while Present (Subp_Decl) loop
5559 if Nkind (Subp_Decl) = N_Entry_Declaration then
5560 if Defining_Identifier (Subp_Decl) = E then
5572 end Find_Entry_Index;
5574 -- Start of processing for Make_Select_Specific_Data_Table
5577 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
5579 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
5581 if Present (Corresponding_Concurrent_Type (Typ)) then
5582 Conc_Typ := Corresponding_Concurrent_Type (Typ);
5584 if Present (Full_View (Conc_Typ)) then
5585 Conc_Typ := Full_View (Conc_Typ);
5588 if Ekind (Conc_Typ) = E_Protected_Type then
5589 Decls := Visible_Declarations (Protected_Definition (
5590 Parent (Conc_Typ)));
5592 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
5593 Decls := Visible_Declarations (Task_Definition (
5594 Parent (Conc_Typ)));
5598 -- Count the non-predefined primitive operations
5600 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5601 while Present (Prim_Elmt) loop
5602 Prim := Node (Prim_Elmt);
5604 if not (Is_Predefined_Dispatching_Operation (Prim)
5605 or else Is_Predefined_Dispatching_Alias (Prim))
5607 Nb_Prim := Nb_Prim + 1;
5610 Next_Elmt (Prim_Elmt);
5614 Examined : Examined_Array (1 .. Nb_Prim) := (others => False);
5617 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5618 while Present (Prim_Elmt) loop
5619 Prim := Node (Prim_Elmt);
5621 -- Look for primitive overriding an abstract interface subprogram
5623 if Present (Interface_Alias (Prim))
5624 and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
5626 Prim_Pos := DT_Position (Alias (Prim));
5627 pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
5628 Examined (UI_To_Int (Prim_Pos)) := True;
5630 -- Set the primitive operation kind regardless of subprogram
5632 -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
5634 Append_To (Assignments,
5635 Make_Procedure_Call_Statement (Loc,
5636 Name => New_Reference_To (RTE (RE_Set_Prim_Op_Kind), Loc),
5637 Parameter_Associations => New_List (
5638 New_Reference_To (DT_Ptr, Loc),
5639 Make_Integer_Literal (Loc, Prim_Pos),
5640 Prim_Op_Kind (Alias (Prim), Typ))));
5642 -- Retrieve the root of the alias chain
5645 while Present (Alias (Prim_Als)) loop
5646 Prim_Als := Alias (Prim_Als);
5649 -- In the case of an entry wrapper, set the entry index
5651 if Ekind (Prim) = E_Procedure
5652 and then Is_Primitive_Wrapper (Prim_Als)
5653 and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry
5656 -- Ada.Tags.Set_Entry_Index
5657 -- (DT_Ptr, <position>, <index>);
5659 Append_To (Assignments,
5660 Make_Procedure_Call_Statement (Loc,
5662 New_Reference_To (RTE (RE_Set_Entry_Index), Loc),
5663 Parameter_Associations => New_List (
5664 New_Reference_To (DT_Ptr, Loc),
5665 Make_Integer_Literal (Loc, Prim_Pos),
5666 Make_Integer_Literal (Loc,
5667 Find_Entry_Index (Wrapped_Entity (Prim_Als))))));
5671 Next_Elmt (Prim_Elmt);
5676 end Make_Select_Specific_Data_Table;
5682 function Make_Tags (Typ : Entity_Id) return List_Id is
5683 Loc : constant Source_Ptr := Sloc (Typ);
5684 Tname : constant Name_Id := Chars (Typ);
5685 Result : constant List_Id := New_List;
5686 AI_Tag_Comp : Elmt_Id;
5688 DT_Constr_List : List_Id;
5690 Predef_Prims_Ptr : Node_Id;
5691 Iface_DT_Ptr : Node_Id;
5695 Typ_Comps : Elist_Id;
5698 -- 1) Generate the primary and secondary tag entities
5700 -- Collect the components associated with secondary dispatch tables
5702 if Has_Interfaces (Typ) then
5703 Collect_Interface_Components (Typ, Typ_Comps);
5706 -- 1) Generate the primary tag entities
5708 -- Primary dispatch table containing user-defined primitives
5710 DT_Ptr := Make_Defining_Identifier (Loc,
5711 New_External_Name (Tname, 'P'));
5712 Set_Etype (DT_Ptr, RTE (RE_Tag));
5714 -- Primary dispatch table containing predefined primitives
5717 Make_Defining_Identifier (Loc,
5718 Chars => New_External_Name (Tname, 'Y'));
5719 Set_Etype (Predef_Prims_Ptr, RTE (RE_Address));
5721 -- Import the forward declaration of the Dispatch Table wrapper record
5722 -- (Make_DT will take care of its exportation)
5724 if Building_Static_DT (Typ) then
5726 Make_Defining_Identifier (Loc,
5727 Chars => New_External_Name (Tname, 'T'));
5730 -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
5731 -- $pragma import (ada, DT);
5733 Set_Is_Imported (DT);
5735 -- The scope must be set now to call Get_External_Name
5737 Set_Scope (DT, Current_Scope);
5739 Get_External_Name (DT, True);
5740 Set_Interface_Name (DT,
5741 Make_String_Literal (Loc,
5742 Strval => String_From_Name_Buffer));
5744 -- Ensure proper Sprint output of this implicit importation
5746 Set_Is_Internal (DT);
5748 -- Save this entity to allow Make_DT to generate its exportation
5750 Set_Dispatch_Table_Wrapper (Typ, DT);
5752 if Has_DT (Typ) then
5754 -- Calculate the number of primitives of the dispatch table and
5755 -- the size of the Type_Specific_Data record.
5757 Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
5759 -- If the tagged type has no primitives we add a dummy slot
5760 -- whose address will be the tag of this type.
5764 New_List (Make_Integer_Literal (Loc, 1));
5767 New_List (Make_Integer_Literal (Loc, Nb_Prim));
5771 Make_Object_Declaration (Loc,
5772 Defining_Identifier => DT,
5773 Aliased_Present => True,
5774 Constant_Present => True,
5775 Object_Definition =>
5776 Make_Subtype_Indication (Loc,
5778 New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc),
5779 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
5780 Constraints => DT_Constr_List))));
5783 Make_Object_Declaration (Loc,
5784 Defining_Identifier => DT_Ptr,
5785 Constant_Present => True,
5786 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
5788 Unchecked_Convert_To (RTE (RE_Tag),
5789 Make_Attribute_Reference (Loc,
5791 Make_Selected_Component (Loc,
5792 Prefix => New_Reference_To (DT, Loc),
5795 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
5796 Attribute_Name => Name_Address))));
5799 Make_Object_Declaration (Loc,
5800 Defining_Identifier => Predef_Prims_Ptr,
5801 Constant_Present => True,
5802 Object_Definition => New_Reference_To
5803 (RTE (RE_Address), Loc),
5805 Make_Attribute_Reference (Loc,
5807 Make_Selected_Component (Loc,
5808 Prefix => New_Reference_To (DT, Loc),
5811 (RTE_Record_Component (RE_Predef_Prims), Loc)),
5812 Attribute_Name => Name_Address)));
5814 -- No dispatch table required
5818 Make_Object_Declaration (Loc,
5819 Defining_Identifier => DT,
5820 Aliased_Present => True,
5821 Constant_Present => True,
5822 Object_Definition =>
5823 New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
5826 Make_Object_Declaration (Loc,
5827 Defining_Identifier => DT_Ptr,
5828 Constant_Present => True,
5829 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
5831 Unchecked_Convert_To (RTE (RE_Tag),
5832 Make_Attribute_Reference (Loc,
5834 Make_Selected_Component (Loc,
5835 Prefix => New_Reference_To (DT, Loc),
5838 (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
5839 Attribute_Name => Name_Address))));
5842 Set_Is_True_Constant (DT_Ptr);
5843 Set_Is_Statically_Allocated (DT_Ptr);
5846 pragma Assert (No (Access_Disp_Table (Typ)));
5847 Set_Access_Disp_Table (Typ, New_Elmt_List);
5848 Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
5849 Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
5851 -- 2) Generate the secondary tag entities
5853 if Has_Interfaces (Typ) then
5856 -- For each interface type we build an unique external name
5857 -- associated with its corresponding secondary dispatch table.
5858 -- This external name will be used to declare an object that
5859 -- references this secondary dispatch table, value that will be
5860 -- used for the elaboration of Typ's objects and also for the
5861 -- elaboration of objects of derivations of Typ that do not
5862 -- override the primitive operation of this interface type.
5864 AI_Tag_Comp := First_Elmt (Typ_Comps);
5865 while Present (AI_Tag_Comp) loop
5866 Get_Secondary_DT_External_Name
5867 (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
5869 Typ_Name := Name_Find;
5871 -- Secondary dispatch table referencing thunks to user-defined
5872 -- primitives covered by this interface.
5875 Make_Defining_Identifier (Loc,
5876 Chars => New_External_Name (Typ_Name, 'P'));
5877 Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
5878 Set_Ekind (Iface_DT_Ptr, E_Constant);
5879 Set_Is_Tag (Iface_DT_Ptr);
5880 Set_Has_Thunks (Iface_DT_Ptr);
5881 Set_Is_Statically_Allocated (Iface_DT_Ptr,
5882 Is_Library_Level_Tagged_Type (Typ));
5883 Set_Is_True_Constant (Iface_DT_Ptr);
5885 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
5886 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
5888 -- Secondary dispatch table referencing thunks to predefined
5892 Make_Defining_Identifier (Loc,
5893 Chars => New_External_Name (Typ_Name, 'Y'));
5894 Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
5895 Set_Ekind (Iface_DT_Ptr, E_Constant);
5896 Set_Is_Tag (Iface_DT_Ptr);
5897 Set_Has_Thunks (Iface_DT_Ptr);
5898 Set_Is_Statically_Allocated (Iface_DT_Ptr,
5899 Is_Library_Level_Tagged_Type (Typ));
5900 Set_Is_True_Constant (Iface_DT_Ptr);
5902 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
5903 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
5905 -- Secondary dispatch table referencing user-defined primitives
5906 -- covered by this interface.
5909 Make_Defining_Identifier (Loc,
5910 Chars => New_External_Name (Typ_Name, 'D'));
5911 Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
5912 Set_Ekind (Iface_DT_Ptr, E_Constant);
5913 Set_Is_Tag (Iface_DT_Ptr);
5914 Set_Is_Statically_Allocated (Iface_DT_Ptr,
5915 Is_Library_Level_Tagged_Type (Typ));
5916 Set_Is_True_Constant (Iface_DT_Ptr);
5918 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
5919 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
5921 -- Secondary dispatch table referencing predefined primitives
5924 Make_Defining_Identifier (Loc,
5925 Chars => New_External_Name (Typ_Name, 'Z'));
5926 Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
5927 Set_Ekind (Iface_DT_Ptr, E_Constant);
5928 Set_Is_Tag (Iface_DT_Ptr);
5929 Set_Is_Statically_Allocated (Iface_DT_Ptr,
5930 Is_Library_Level_Tagged_Type (Typ));
5931 Set_Is_True_Constant (Iface_DT_Ptr);
5933 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
5934 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
5936 Next_Elmt (AI_Tag_Comp);
5940 -- 3) At the end of Access_Disp_Table we add the entity of an access
5941 -- type declaration. It is used by Build_Get_Prim_Op_Address to
5942 -- expand dispatching calls through the primary dispatch table.
5945 -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
5946 -- type Typ_DT_Acc is access Typ_DT;
5949 Name_DT_Prims : constant Name_Id :=
5950 New_External_Name (Tname, 'G');
5951 Name_DT_Prims_Acc : constant Name_Id :=
5952 New_External_Name (Tname, 'H');
5953 DT_Prims : constant Entity_Id :=
5954 Make_Defining_Identifier (Loc, Name_DT_Prims);
5955 DT_Prims_Acc : constant Entity_Id :=
5956 Make_Defining_Identifier (Loc,
5960 Make_Full_Type_Declaration (Loc,
5961 Defining_Identifier => DT_Prims,
5963 Make_Constrained_Array_Definition (Loc,
5964 Discrete_Subtype_Definitions => New_List (
5966 Low_Bound => Make_Integer_Literal (Loc, 1),
5967 High_Bound => Make_Integer_Literal (Loc,
5969 (First_Tag_Component (Typ))))),
5970 Component_Definition =>
5971 Make_Component_Definition (Loc,
5972 Subtype_Indication =>
5973 New_Reference_To (RTE (RE_Prim_Ptr), Loc)))));
5976 Make_Full_Type_Declaration (Loc,
5977 Defining_Identifier => DT_Prims_Acc,
5979 Make_Access_To_Object_Definition (Loc,
5980 Subtype_Indication =>
5981 New_Occurrence_Of (DT_Prims, Loc))));
5983 Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
5985 -- Analyze the resulting list and suppress the generation of the
5986 -- Init_Proc associated with the above array declaration because
5987 -- we never use such type in object declarations; this type is only
5988 -- used to simplify the expansion associated with dispatching calls.
5990 Analyze_List (Result);
5991 Set_Suppress_Init_Proc (Base_Type (DT_Prims));
5993 -- Mark entity of dispatch table. Required by the backend to handle
5996 Set_Is_Dispatch_Table_Entity (DT_Prims);
5999 Set_Ekind (DT_Ptr, E_Constant);
6000 Set_Is_Tag (DT_Ptr);
6001 Set_Related_Type (DT_Ptr, Typ);
6006 -----------------------------------
6007 -- Original_View_In_Visible_Part --
6008 -----------------------------------
6010 function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
6011 Scop : constant Entity_Id := Scope (Typ);
6014 -- The scope must be a package
6016 if not Is_Package_Or_Generic_Package (Scop) then
6020 -- A type with a private declaration has a private view declared in
6021 -- the visible part.
6023 if Has_Private_Declaration (Typ) then
6027 return List_Containing (Parent (Typ)) =
6028 Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
6029 end Original_View_In_Visible_Part;
6035 function Prim_Op_Kind
6037 Typ : Entity_Id) return Node_Id
6039 Full_Typ : Entity_Id := Typ;
6040 Loc : constant Source_Ptr := Sloc (Prim);
6041 Prim_Op : Entity_Id;
6044 -- Retrieve the original primitive operation
6047 while Present (Alias (Prim_Op)) loop
6048 Prim_Op := Alias (Prim_Op);
6051 if Ekind (Typ) = E_Record_Type
6052 and then Present (Corresponding_Concurrent_Type (Typ))
6054 Full_Typ := Corresponding_Concurrent_Type (Typ);
6057 -- When a private tagged type is completed by a concurrent type,
6058 -- retrieve the full view.
6060 if Is_Private_Type (Full_Typ) then
6061 Full_Typ := Full_View (Full_Typ);
6064 if Ekind (Prim_Op) = E_Function then
6066 -- Protected function
6068 if Ekind (Full_Typ) = E_Protected_Type then
6069 return New_Reference_To (RTE (RE_POK_Protected_Function), Loc);
6073 elsif Ekind (Full_Typ) = E_Task_Type then
6074 return New_Reference_To (RTE (RE_POK_Task_Function), Loc);
6079 return New_Reference_To (RTE (RE_POK_Function), Loc);
6083 pragma Assert (Ekind (Prim_Op) = E_Procedure);
6085 if Ekind (Full_Typ) = E_Protected_Type then
6089 if Is_Primitive_Wrapper (Prim_Op)
6090 and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
6092 return New_Reference_To (RTE (RE_POK_Protected_Entry), Loc);
6094 -- Protected procedure
6097 return New_Reference_To (RTE (RE_POK_Protected_Procedure), Loc);
6100 elsif Ekind (Full_Typ) = E_Task_Type then
6104 if Is_Primitive_Wrapper (Prim_Op)
6105 and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
6107 return New_Reference_To (RTE (RE_POK_Task_Entry), Loc);
6109 -- Task "procedure". These are the internally Expander-generated
6110 -- procedures (task body for instance).
6113 return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc);
6116 -- Regular procedure
6119 return New_Reference_To (RTE (RE_POK_Procedure), Loc);
6124 ------------------------
6125 -- Register_Primitive --
6126 ------------------------
6128 procedure Register_Primitive
6134 Iface_Prim : Entity_Id;
6135 Iface_Typ : Entity_Id;
6136 Iface_DT_Ptr : Entity_Id;
6137 Iface_DT_Elmt : Elmt_Id;
6141 Tag_Typ : Entity_Id;
6142 Thunk_Id : Entity_Id;
6143 Thunk_Code : Node_Id;
6146 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
6148 if not RTE_Available (RE_Tag) then
6152 if not Present (Interface_Alias (Prim)) then
6153 Tag_Typ := Scope (DTC_Entity (Prim));
6154 Pos := DT_Position (Prim);
6155 Tag := First_Tag_Component (Tag_Typ);
6157 if Is_Predefined_Dispatching_Operation (Prim)
6158 or else Is_Predefined_Dispatching_Alias (Prim)
6161 Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ))));
6163 Insert_After (Ins_Nod,
6164 Build_Set_Predefined_Prim_Op_Address (Loc,
6165 Tag_Node => New_Reference_To (DT_Ptr, Loc),
6168 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6169 Make_Attribute_Reference (Loc,
6170 Prefix => New_Reference_To (Prim, Loc),
6171 Attribute_Name => Name_Unrestricted_Access))));
6173 -- Register copy of the pointer to the 'size primitive in the TSD.
6175 if Chars (Prim) = Name_uSize
6176 and then RTE_Record_Component_Available (RE_Size_Func)
6178 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
6179 Insert_After (Ins_Nod,
6180 Build_Set_Size_Function (Loc,
6181 Tag_Node => New_Reference_To (DT_Ptr, Loc),
6182 Size_Func => Prim));
6186 pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
6188 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
6189 Insert_After (Ins_Nod,
6190 Build_Set_Prim_Op_Address (Loc,
6192 Tag_Node => New_Reference_To (DT_Ptr, Loc),
6195 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6196 Make_Attribute_Reference (Loc,
6197 Prefix => New_Reference_To (Prim, Loc),
6198 Attribute_Name => Name_Unrestricted_Access))));
6201 -- Ada 2005 (AI-251): Primitive associated with an interface type
6202 -- Generate the code of the thunk only if the interface type is not an
6203 -- immediate ancestor of Typ; otherwise the dispatch table associated
6204 -- with the interface is the primary dispatch table and we have nothing
6208 Tag_Typ := Find_Dispatching_Type (Alias (Prim));
6209 Iface_Typ := Find_Dispatching_Type (Interface_Alias (Prim));
6211 pragma Assert (Is_Interface (Iface_Typ));
6213 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
6215 if not Is_Ancestor (Iface_Typ, Tag_Typ)
6216 and then Present (Thunk_Code)
6218 -- Comment needed on why checks are suppressed. This is not just
6219 -- efficiency, but fundamental functionality (see 1.295 RH, which
6220 -- still does not answer this question) ???
6222 Insert_Action (Ins_Nod, Thunk_Code, Suppress => All_Checks);
6224 -- Generate the code necessary to fill the appropriate entry of
6225 -- the secondary dispatch table of Prim's controlling type with
6226 -- Thunk_Id's address.
6228 Iface_DT_Elmt := Find_Interface_ADT (Tag_Typ, Iface_Typ);
6229 Iface_DT_Ptr := Node (Iface_DT_Elmt);
6230 pragma Assert (Has_Thunks (Iface_DT_Ptr));
6232 Iface_Prim := Interface_Alias (Prim);
6233 Pos := DT_Position (Iface_Prim);
6234 Tag := First_Tag_Component (Iface_Typ);
6237 if Is_Predefined_Dispatching_Operation (Prim)
6238 or else Is_Predefined_Dispatching_Alias (Prim)
6241 Build_Set_Predefined_Prim_Op_Address (Loc,
6243 New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
6246 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6247 Make_Attribute_Reference (Loc,
6248 Prefix => New_Reference_To (Thunk_Id, Loc),
6249 Attribute_Name => Name_Unrestricted_Access))));
6251 Next_Elmt (Iface_DT_Elmt);
6252 Next_Elmt (Iface_DT_Elmt);
6253 Iface_DT_Ptr := Node (Iface_DT_Elmt);
6254 pragma Assert (not Has_Thunks (Iface_DT_Ptr));
6257 Build_Set_Predefined_Prim_Op_Address (Loc,
6259 New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
6262 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6263 Make_Attribute_Reference (Loc,
6264 Prefix => New_Reference_To (Alias (Prim), Loc),
6265 Attribute_Name => Name_Unrestricted_Access))));
6267 Insert_Actions_After (Ins_Nod, L);
6270 pragma Assert (Pos /= Uint_0
6271 and then Pos <= DT_Entry_Count (Tag));
6274 Build_Set_Prim_Op_Address (Loc,
6276 Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
6279 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6280 Make_Attribute_Reference (Loc,
6281 Prefix => New_Reference_To (Thunk_Id, Loc),
6282 Attribute_Name => Name_Unrestricted_Access))));
6284 Next_Elmt (Iface_DT_Elmt);
6285 Next_Elmt (Iface_DT_Elmt);
6286 Iface_DT_Ptr := Node (Iface_DT_Elmt);
6287 pragma Assert (not Has_Thunks (Iface_DT_Ptr));
6290 Build_Set_Prim_Op_Address (Loc,
6292 Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
6295 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6296 Make_Attribute_Reference (Loc,
6297 Prefix => New_Reference_To (Alias (Prim), Loc),
6298 Attribute_Name => Name_Unrestricted_Access))));
6300 Insert_Actions_After (Ins_Nod, L);
6304 end Register_Primitive;
6306 -------------------------
6307 -- Set_All_DT_Position --
6308 -------------------------
6310 procedure Set_All_DT_Position (Typ : Entity_Id) is
6312 procedure Validate_Position (Prim : Entity_Id);
6313 -- Check that the position assigned to Prim is completely safe
6314 -- (it has not been assigned to a previously defined primitive
6315 -- operation of Typ)
6317 -----------------------
6318 -- Validate_Position --
6319 -----------------------
6321 procedure Validate_Position (Prim : Entity_Id) is
6326 -- Aliased primitives are safe
6328 if Present (Alias (Prim)) then
6332 Op_Elmt := First_Elmt (Primitive_Operations (Typ));
6333 while Present (Op_Elmt) loop
6334 Op := Node (Op_Elmt);
6336 -- No need to check against itself
6341 -- Primitive operations covering abstract interfaces are
6344 elsif Present (Interface_Alias (Op)) then
6347 -- Predefined dispatching operations are completely safe. They
6348 -- are allocated at fixed positions in a separate table.
6350 elsif Is_Predefined_Dispatching_Operation (Op)
6351 or else Is_Predefined_Dispatching_Alias (Op)
6355 -- Aliased subprograms are safe
6357 elsif Present (Alias (Op)) then
6360 elsif DT_Position (Op) = DT_Position (Prim)
6361 and then not Is_Predefined_Dispatching_Operation (Op)
6362 and then not Is_Predefined_Dispatching_Operation (Prim)
6363 and then not Is_Predefined_Dispatching_Alias (Op)
6364 and then not Is_Predefined_Dispatching_Alias (Prim)
6367 -- Handle aliased subprograms
6376 if Present (Overridden_Operation (Op_1)) then
6377 Op_1 := Overridden_Operation (Op_1);
6378 elsif Present (Alias (Op_1)) then
6379 Op_1 := Alias (Op_1);
6387 if Present (Overridden_Operation (Op_2)) then
6388 Op_2 := Overridden_Operation (Op_2);
6389 elsif Present (Alias (Op_2)) then
6390 Op_2 := Alias (Op_2);
6396 if Op_1 /= Op_2 then
6397 raise Program_Error;
6402 Next_Elmt (Op_Elmt);
6404 end Validate_Position;
6408 Parent_Typ : constant Entity_Id := Etype (Typ);
6409 First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
6410 The_Tag : constant Entity_Id := First_Tag_Component (Typ);
6412 Adjusted : Boolean := False;
6413 Finalized : Boolean := False;
6419 Prim_Elmt : Elmt_Id;
6421 -- Start of processing for Set_All_DT_Position
6424 pragma Assert (Present (First_Tag_Component (Typ)));
6426 -- Set the DT_Position for each primitive operation. Perform some
6427 -- sanity checks to avoid to build completely inconsistent dispatch
6430 -- First stage: Set the DTC entity of all the primitive operations
6431 -- This is required to properly read the DT_Position attribute in
6432 -- the latter stages.
6434 Prim_Elmt := First_Prim;
6436 while Present (Prim_Elmt) loop
6437 Prim := Node (Prim_Elmt);
6439 -- Predefined primitives have a separate dispatch table
6441 if not (Is_Predefined_Dispatching_Operation (Prim)
6442 or else Is_Predefined_Dispatching_Alias (Prim))
6444 Count_Prim := Count_Prim + 1;
6447 Set_DTC_Entity_Value (Typ, Prim);
6449 -- Clear any previous value of the DT_Position attribute. In this
6450 -- way we ensure that the final position of all the primitives is
6451 -- established by the following stages of this algorithm.
6453 Set_DT_Position (Prim, No_Uint);
6455 Next_Elmt (Prim_Elmt);
6459 Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean :=
6464 procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id);
6465 -- Called if Typ is declared in a nested package or a public child
6466 -- package to handle inherited primitives that were inherited by Typ
6467 -- in the visible part, but whose declaration was deferred because
6468 -- the parent operation was private and not visible at that point.
6470 procedure Set_Fixed_Prim (Pos : Nat);
6471 -- Sets to true an element of the Fixed_Prim table to indicate
6472 -- that this entry of the dispatch table of Typ is occupied.
6474 ------------------------------------------
6475 -- Handle_Inherited_Private_Subprograms --
6476 ------------------------------------------
6478 procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id) is
6481 Op_Elmt_2 : Elmt_Id;
6482 Prim_Op : Entity_Id;
6483 Parent_Subp : Entity_Id;
6486 Op_List := Primitive_Operations (Typ);
6488 Op_Elmt := First_Elmt (Op_List);
6489 while Present (Op_Elmt) loop
6490 Prim_Op := Node (Op_Elmt);
6492 -- Search primitives that are implicit operations with an
6493 -- internal name whose parent operation has a normal name.
6495 if Present (Alias (Prim_Op))
6496 and then Find_Dispatching_Type (Alias (Prim_Op)) /= Typ
6497 and then not Comes_From_Source (Prim_Op)
6498 and then Is_Internal_Name (Chars (Prim_Op))
6499 and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
6501 Parent_Subp := Alias (Prim_Op);
6503 -- Check if the type has an explicit overriding for this
6506 Op_Elmt_2 := Next_Elmt (Op_Elmt);
6507 while Present (Op_Elmt_2) loop
6508 if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
6509 and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
6511 Set_DT_Position (Prim_Op, DT_Position (Parent_Subp));
6512 Set_DT_Position (Node (Op_Elmt_2),
6513 DT_Position (Parent_Subp));
6514 Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op)));
6516 goto Next_Primitive;
6519 Next_Elmt (Op_Elmt_2);
6524 Next_Elmt (Op_Elmt);
6526 end Handle_Inherited_Private_Subprograms;
6528 --------------------
6529 -- Set_Fixed_Prim --
6530 --------------------
6532 procedure Set_Fixed_Prim (Pos : Nat) is
6534 pragma Assert (Pos >= 0 and then Pos <= Count_Prim);
6535 Fixed_Prim (Pos) := True;
6537 when Constraint_Error =>
6538 raise Program_Error;
6542 -- In case of nested packages and public child package it may be
6543 -- necessary a special management on inherited subprograms so that
6544 -- the dispatch table is properly filled.
6546 if Ekind (Scope (Scope (Typ))) = E_Package
6547 and then Scope (Scope (Typ)) /= Standard_Standard
6548 and then ((Is_Derived_Type (Typ) and then not Is_Private_Type (Typ))
6550 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration
6551 and then Is_Generic_Type (Typ)))
6552 and then In_Open_Scopes (Scope (Etype (Typ)))
6553 and then Typ = Base_Type (Typ)
6555 Handle_Inherited_Private_Subprograms (Typ);
6558 -- Second stage: Register fixed entries
6561 Prim_Elmt := First_Prim;
6562 while Present (Prim_Elmt) loop
6563 Prim := Node (Prim_Elmt);
6565 -- Predefined primitives have a separate table and all its
6566 -- entries are at predefined fixed positions.
6568 if Is_Predefined_Dispatching_Operation (Prim) then
6569 Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
6571 elsif Is_Predefined_Dispatching_Alias (Prim) then
6573 while Present (Alias (E)) loop
6577 Set_DT_Position (Prim, Default_Prim_Op_Position (E));
6579 -- Overriding primitives of ancestor abstract interfaces
6581 elsif Present (Interface_Alias (Prim))
6582 and then Is_Ancestor
6583 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
6585 pragma Assert (DT_Position (Prim) = No_Uint
6586 and then Present (DTC_Entity (Interface_Alias (Prim))));
6588 E := Interface_Alias (Prim);
6589 Set_DT_Position (Prim, DT_Position (E));
6592 (DT_Position (Alias (Prim)) = No_Uint
6593 or else DT_Position (Alias (Prim)) = DT_Position (E));
6594 Set_DT_Position (Alias (Prim), DT_Position (E));
6595 Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
6597 -- Overriding primitives must use the same entry as the
6598 -- overridden primitive.
6600 elsif not Present (Interface_Alias (Prim))
6601 and then Present (Alias (Prim))
6602 and then Chars (Prim) = Chars (Alias (Prim))
6603 and then Find_Dispatching_Type (Alias (Prim)) /= Typ
6604 and then Is_Ancestor
6605 (Find_Dispatching_Type (Alias (Prim)), Typ)
6606 and then Present (DTC_Entity (Alias (Prim)))
6609 Set_DT_Position (Prim, DT_Position (E));
6611 if not Is_Predefined_Dispatching_Alias (E) then
6612 Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
6616 Next_Elmt (Prim_Elmt);
6619 -- Third stage: Fix the position of all the new primitives
6620 -- Entries associated with primitives covering interfaces
6621 -- are handled in a latter round.
6623 Prim_Elmt := First_Prim;
6624 while Present (Prim_Elmt) loop
6625 Prim := Node (Prim_Elmt);
6627 -- Skip primitives previously set entries
6629 if DT_Position (Prim) /= No_Uint then
6632 -- Primitives covering interface primitives are handled later
6634 elsif Present (Interface_Alias (Prim)) then
6638 -- Take the next available position in the DT
6641 Nb_Prim := Nb_Prim + 1;
6642 pragma Assert (Nb_Prim <= Count_Prim);
6643 exit when not Fixed_Prim (Nb_Prim);
6646 Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
6647 Set_Fixed_Prim (Nb_Prim);
6650 Next_Elmt (Prim_Elmt);
6654 -- Fourth stage: Complete the decoration of primitives covering
6655 -- interfaces (that is, propagate the DT_Position attribute
6656 -- from the aliased primitive)
6658 Prim_Elmt := First_Prim;
6659 while Present (Prim_Elmt) loop
6660 Prim := Node (Prim_Elmt);
6662 if DT_Position (Prim) = No_Uint
6663 and then Present (Interface_Alias (Prim))
6665 pragma Assert (Present (Alias (Prim))
6666 and then Find_Dispatching_Type (Alias (Prim)) = Typ);
6668 -- Check if this entry will be placed in the primary DT
6671 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
6673 pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
6674 Set_DT_Position (Prim, DT_Position (Alias (Prim)));
6676 -- Otherwise it will be placed in the secondary DT
6680 (DT_Position (Interface_Alias (Prim)) /= No_Uint);
6681 Set_DT_Position (Prim,
6682 DT_Position (Interface_Alias (Prim)));
6686 Next_Elmt (Prim_Elmt);
6689 -- Generate listing showing the contents of the dispatch tables.
6690 -- This action is done before some further static checks because
6691 -- in case of critical errors caused by a wrong dispatch table
6692 -- we need to see the contents of such table.
6694 if Debug_Flag_ZZ then
6698 -- Final stage: Ensure that the table is correct plus some further
6699 -- verifications concerning the primitives.
6701 Prim_Elmt := First_Prim;
6703 while Present (Prim_Elmt) loop
6704 Prim := Node (Prim_Elmt);
6706 -- At this point all the primitives MUST have a position
6707 -- in the dispatch table.
6709 if DT_Position (Prim) = No_Uint then
6710 raise Program_Error;
6713 -- Calculate real size of the dispatch table
6715 if not (Is_Predefined_Dispatching_Operation (Prim)
6716 or else Is_Predefined_Dispatching_Alias (Prim))
6717 and then UI_To_Int (DT_Position (Prim)) > DT_Length
6719 DT_Length := UI_To_Int (DT_Position (Prim));
6722 -- Ensure that the assigned position to non-predefined
6723 -- dispatching operations in the dispatch table is correct.
6725 if not (Is_Predefined_Dispatching_Operation (Prim)
6726 or else Is_Predefined_Dispatching_Alias (Prim))
6728 Validate_Position (Prim);
6731 if Chars (Prim) = Name_Finalize then
6735 if Chars (Prim) = Name_Adjust then
6739 -- An abstract operation cannot be declared in the private part
6740 -- for a visible abstract type, because it could never be over-
6741 -- ridden. For explicit declarations this is checked at the
6742 -- point of declaration, but for inherited operations it must
6743 -- be done when building the dispatch table.
6745 -- Ada 2005 (AI-251): Primitives associated with interfaces are
6746 -- excluded from this check because interfaces must be visible in
6747 -- the public and private part (RM 7.3 (7.3/2))
6749 if Is_Abstract_Type (Typ)
6750 and then Is_Abstract_Subprogram (Prim)
6751 and then Present (Alias (Prim))
6752 and then not Is_Interface
6753 (Find_Dispatching_Type (Ultimate_Alias (Prim)))
6754 and then not Present (Interface_Alias (Prim))
6755 and then Is_Derived_Type (Typ)
6756 and then In_Private_Part (Current_Scope)
6758 List_Containing (Parent (Prim)) =
6759 Private_Declarations
6760 (Specification (Unit_Declaration_Node (Current_Scope)))
6761 and then Original_View_In_Visible_Part (Typ)
6763 -- We exclude Input and Output stream operations because
6764 -- Limited_Controlled inherits useless Input and Output
6765 -- stream operations from Root_Controlled, which can
6766 -- never be overridden.
6768 if not Is_TSS (Prim, TSS_Stream_Input)
6770 not Is_TSS (Prim, TSS_Stream_Output)
6773 ("abstract inherited private operation&" &
6774 " must be overridden (RM 3.9.3(10))",
6775 Parent (Typ), Prim);
6779 Next_Elmt (Prim_Elmt);
6784 if Is_Controlled (Typ) then
6785 if not Finalized then
6787 ("controlled type has no explicit Finalize method?", Typ);
6789 elsif not Adjusted then
6791 ("controlled type has no explicit Adjust method?", Typ);
6795 -- Set the final size of the Dispatch Table
6797 Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
6799 -- The derived type must have at least as many components as its parent
6800 -- (for root types Etype points to itself and the test cannot fail).
6802 if DT_Entry_Count (The_Tag) <
6803 DT_Entry_Count (First_Tag_Component (Parent_Typ))
6805 raise Program_Error;
6807 end Set_All_DT_Position;
6809 -----------------------------
6810 -- Set_Default_Constructor --
6811 -----------------------------
6813 procedure Set_Default_Constructor (Typ : Entity_Id) is
6820 -- Look for the default constructor entity. For now only the
6821 -- default constructor has the flag Is_Constructor.
6823 E := Next_Entity (Typ);
6825 and then (Ekind (E) /= E_Function or else not Is_Constructor (E))
6830 -- Create the init procedure
6834 Init := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
6835 Param := Make_Defining_Identifier (Loc, Name_X);
6838 Make_Subprogram_Declaration (Loc,
6839 Make_Procedure_Specification (Loc,
6840 Defining_Unit_Name => Init,
6841 Parameter_Specifications => New_List (
6842 Make_Parameter_Specification (Loc,
6843 Defining_Identifier => Param,
6844 Parameter_Type => New_Reference_To (Typ, Loc))))));
6846 Set_Init_Proc (Typ, Init);
6847 Set_Is_Imported (Init);
6848 Set_Interface_Name (Init, Interface_Name (E));
6849 Set_Convention (Init, Convention_C);
6850 Set_Is_Public (Init);
6851 Set_Has_Completion (Init);
6853 -- If there are no constructors, mark the type as abstract since we
6854 -- won't be able to declare objects of that type.
6857 Set_Is_Abstract_Type (Typ);
6859 end Set_Default_Constructor;
6861 --------------------------
6862 -- Set_DTC_Entity_Value --
6863 --------------------------
6865 procedure Set_DTC_Entity_Value
6866 (Tagged_Type : Entity_Id;
6870 if Present (Interface_Alias (Prim))
6871 and then Is_Interface
6872 (Find_Dispatching_Type (Interface_Alias (Prim)))
6874 Set_DTC_Entity (Prim,
6877 Iface => Find_Dispatching_Type (Interface_Alias (Prim))));
6879 Set_DTC_Entity (Prim,
6880 First_Tag_Component (Tagged_Type));
6882 end Set_DTC_Entity_Value;
6888 function Tagged_Kind (T : Entity_Id) return Node_Id is
6889 Conc_Typ : Entity_Id;
6890 Loc : constant Source_Ptr := Sloc (T);
6894 (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind));
6898 if Is_Abstract_Type (T) then
6899 if Is_Limited_Record (T) then
6900 return New_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc);
6902 return New_Reference_To (RTE (RE_TK_Abstract_Tagged), Loc);
6907 elsif Is_Concurrent_Record_Type (T) then
6908 Conc_Typ := Corresponding_Concurrent_Type (T);
6910 if Present (Full_View (Conc_Typ)) then
6911 Conc_Typ := Full_View (Conc_Typ);
6914 if Ekind (Conc_Typ) = E_Protected_Type then
6915 return New_Reference_To (RTE (RE_TK_Protected), Loc);
6917 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
6918 return New_Reference_To (RTE (RE_TK_Task), Loc);
6921 -- Regular tagged kinds
6924 if Is_Limited_Record (T) then
6925 return New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc);
6927 return New_Reference_To (RTE (RE_TK_Tagged), Loc);
6936 procedure Write_DT (Typ : Entity_Id) is
6941 -- Protect this procedure against wrong usage. Required because it will
6942 -- be used directly from GDB
6944 if not (Typ <= Last_Node_Id)
6945 or else not Is_Tagged_Type (Typ)
6947 Write_Str ("wrong usage: Write_DT must be used with tagged types");
6952 Write_Int (Int (Typ));
6954 Write_Name (Chars (Typ));
6956 if Is_Interface (Typ) then
6957 Write_Str (" is interface");
6962 Elmt := First_Elmt (Primitive_Operations (Typ));
6963 while Present (Elmt) loop
6964 Prim := Node (Elmt);
6967 -- Indicate if this primitive will be allocated in the primary
6968 -- dispatch table or in a secondary dispatch table associated
6969 -- with an abstract interface type
6971 if Present (DTC_Entity (Prim)) then
6972 if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
6979 -- Output the node of this primitive operation and its name
6981 Write_Int (Int (Prim));
6984 if Is_Predefined_Dispatching_Operation (Prim) then
6985 Write_Str ("(predefined) ");
6988 Write_Name (Chars (Prim));
6990 -- Indicate if this primitive has an aliased primitive
6992 if Present (Alias (Prim)) then
6993 Write_Str (" (alias = ");
6994 Write_Int (Int (Alias (Prim)));
6996 -- If the DTC_Entity attribute is already set we can also output
6997 -- the name of the interface covered by this primitive (if any)
6999 if Present (DTC_Entity (Alias (Prim)))
7000 and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
7002 Write_Str (" from interface ");
7003 Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
7006 if Present (Interface_Alias (Prim)) then
7007 Write_Str (", AI_Alias of ");
7009 (Chars (Find_Dispatching_Type (Interface_Alias (Prim))));
7011 Write_Int (Int (Interface_Alias (Prim)));
7017 -- Display the final position of this primitive in its associated
7018 -- (primary or secondary) dispatch table
7020 if Present (DTC_Entity (Prim))
7021 and then DT_Position (Prim) /= No_Uint
7023 Write_Str (" at #");
7024 Write_Int (UI_To_Int (DT_Position (Prim)));
7027 if Is_Abstract_Subprogram (Prim) then
7028 Write_Str (" is abstract;");
7030 -- Check if this is a null primitive
7032 elsif Comes_From_Source (Prim)
7033 and then Ekind (Prim) = E_Procedure
7034 and then Null_Present (Parent (Prim))
7036 Write_Str (" is null;");