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 pragma Assert (not Is_Static
770 or else (not Is_Class_Wide_Type (Iface_Typ)
771 and then Is_Interface (Iface_Typ)));
773 if VM_Target /= No_VM then
775 -- For VM, just do a conversion ???
777 Rewrite (N, Unchecked_Convert_To (Etype (N), N));
782 if not Is_Static then
784 -- Give error if configurable run time and Displace not available
786 if not RTE_Available (RE_Displace) then
787 Error_Msg_CRT ("dynamic interface conversion", N);
791 -- Handle conversion of access-to-class-wide interface types. Target
792 -- can be an access to an object or an access to another class-wide
793 -- interface (see -1- and -2- in the following example):
795 -- type Iface1_Ref is access all Iface1'Class;
796 -- type Iface2_Ref is access all Iface1'Class;
798 -- Acc1 : Iface1_Ref := new ...
799 -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1
800 -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
802 if Is_Access_Type (Operand_Typ) then
804 (Is_Interface (Directly_Designated_Type (Operand_Typ)));
807 Unchecked_Convert_To (Etype (N),
808 Make_Function_Call (Loc,
809 Name => New_Reference_To (RTE (RE_Displace), Loc),
810 Parameter_Associations => New_List (
812 Unchecked_Convert_To (RTE (RE_Address),
813 Relocate_Node (Expression (N))),
816 (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
824 Make_Function_Call (Loc,
825 Name => New_Reference_To (RTE (RE_Displace), Loc),
826 Parameter_Associations => New_List (
827 Make_Attribute_Reference (Loc,
828 Prefix => Relocate_Node (Expression (N)),
829 Attribute_Name => Name_Address),
832 (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
837 -- If the target is a class-wide interface we change the type of the
838 -- data returned by IW_Convert to indicate that this is a dispatching
842 New_Itype : Entity_Id;
845 New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
846 Set_Etype (New_Itype, New_Itype);
847 Set_Directly_Designated_Type (New_Itype, Etyp);
850 Make_Explicit_Dereference (Loc,
852 Unchecked_Convert_To (New_Itype, Relocate_Node (N))));
854 Freeze_Itype (New_Itype, N);
860 Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
861 pragma Assert (Iface_Tag /= Empty);
863 -- Keep separate access types to interfaces because one internal
864 -- function is used to handle the null value (see following comment)
866 if not Is_Access_Type (Etype (N)) then
868 Unchecked_Convert_To (Etype (N),
869 Make_Selected_Component (Loc,
870 Prefix => Relocate_Node (Expression (N)),
872 New_Occurrence_Of (Iface_Tag, Loc))));
875 -- Build internal function to handle the case in which the
876 -- actual is null. If the actual is null returns null because
877 -- no displacement is required; otherwise performs a type
878 -- conversion that will be expanded in the code that returns
879 -- the value of the displaced actual. That is:
881 -- function Func (O : Address) return Iface_Typ is
882 -- type Op_Typ is access all Operand_Typ;
883 -- Aux : Op_Typ := To_Op_Typ (O);
885 -- if O = Null_Address then
888 -- return Iface_Typ!(Aux.Iface_Tag'Address);
893 Desig_Typ : Entity_Id;
895 New_Typ_Decl : Node_Id;
899 Desig_Typ := Etype (Expression (N));
901 if Is_Access_Type (Desig_Typ) then
902 Desig_Typ := Directly_Designated_Type (Desig_Typ);
905 if Is_Concurrent_Type (Desig_Typ) then
906 Desig_Typ := Base_Type (Corresponding_Record_Type (Desig_Typ));
910 Make_Full_Type_Declaration (Loc,
911 Defining_Identifier =>
912 Make_Defining_Identifier (Loc, New_Internal_Name ('T')),
914 Make_Access_To_Object_Definition (Loc,
916 Null_Exclusion_Present => False,
917 Constant_Present => False,
918 Subtype_Indication =>
919 New_Reference_To (Desig_Typ, Loc)));
922 Make_Simple_Return_Statement (Loc,
923 Unchecked_Convert_To (Etype (N),
924 Make_Attribute_Reference (Loc,
926 Make_Selected_Component (Loc,
929 (Defining_Identifier (New_Typ_Decl),
930 Make_Identifier (Loc, Name_uO)),
932 New_Occurrence_Of (Iface_Tag, Loc)),
933 Attribute_Name => Name_Address))));
935 -- If the type is null-excluding, no need for the null branch.
936 -- Otherwise we need to check for it and return null.
938 if not Can_Never_Be_Null (Etype (N)) then
940 Make_If_Statement (Loc,
943 Left_Opnd => Make_Identifier (Loc, Name_uO),
944 Right_Opnd => New_Reference_To
945 (RTE (RE_Null_Address), Loc)),
947 Then_Statements => New_List (
948 Make_Simple_Return_Statement (Loc,
950 Else_Statements => Stats));
954 Make_Defining_Identifier (Loc,
955 New_Internal_Name ('F'));
958 Make_Subprogram_Body (Loc,
960 Make_Function_Specification (Loc,
961 Defining_Unit_Name => Fent,
963 Parameter_Specifications => New_List (
964 Make_Parameter_Specification (Loc,
965 Defining_Identifier =>
966 Make_Defining_Identifier (Loc, Name_uO),
968 New_Reference_To (RTE (RE_Address), Loc))),
971 New_Reference_To (Etype (N), Loc)),
973 Declarations => New_List (New_Typ_Decl),
975 Handled_Statement_Sequence =>
976 Make_Handled_Sequence_Of_Statements (Loc, Stats));
978 -- Place function body before the expression containing the
979 -- conversion. We suppress all checks because the body of the
980 -- internally generated function already takes care of the case
981 -- in which the actual is null; therefore there is no need to
982 -- double check that the pointer is not null when the program
983 -- executes the alternative that performs the type conversion).
985 Insert_Action (N, Func, Suppress => All_Checks);
987 if Is_Access_Type (Etype (Expression (N))) then
989 -- Generate: Func (Address!(Expression))
992 Make_Function_Call (Loc,
993 Name => New_Reference_To (Fent, Loc),
994 Parameter_Associations => New_List (
995 Unchecked_Convert_To (RTE (RE_Address),
996 Relocate_Node (Expression (N))))));
999 -- Generate: Func (Operand_Typ!(Expression)'Address)
1002 Make_Function_Call (Loc,
1003 Name => New_Reference_To (Fent, Loc),
1004 Parameter_Associations => New_List (
1005 Make_Attribute_Reference (Loc,
1006 Prefix => Unchecked_Convert_To (Operand_Typ,
1007 Relocate_Node (Expression (N))),
1008 Attribute_Name => Name_Address))));
1014 end Expand_Interface_Conversion;
1016 ------------------------------
1017 -- Expand_Interface_Actuals --
1018 ------------------------------
1020 procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
1022 Actual_Dup : Node_Id;
1023 Actual_Typ : Entity_Id;
1025 Conversion : Node_Id;
1027 Formal_Typ : Entity_Id;
1029 Formal_DDT : Entity_Id;
1030 Actual_DDT : Entity_Id;
1033 -- This subprogram is called directly from the semantics, so we need a
1034 -- check to see whether expansion is active before proceeding.
1036 if not Expander_Active then
1040 -- Call using access to subprogram with explicit dereference
1042 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
1043 Subp := Etype (Name (Call_Node));
1048 Subp := Entity (Name (Call_Node));
1051 -- Ada 2005 (AI-251): Look for interface type formals to force "this"
1054 Formal := First_Formal (Subp);
1055 Actual := First_Actual (Call_Node);
1056 while Present (Formal) loop
1057 Formal_Typ := Etype (Formal);
1059 if Ekind (Formal_Typ) = E_Record_Type_With_Private then
1060 Formal_Typ := Full_View (Formal_Typ);
1063 if Is_Access_Type (Formal_Typ) then
1064 Formal_DDT := Directly_Designated_Type (Formal_Typ);
1067 Actual_Typ := Etype (Actual);
1069 if Is_Access_Type (Actual_Typ) then
1070 Actual_DDT := Directly_Designated_Type (Actual_Typ);
1073 if Is_Interface (Formal_Typ)
1074 and then Is_Class_Wide_Type (Formal_Typ)
1076 -- No need to displace the pointer if the type of the actual
1077 -- coindices with the type of the formal.
1079 if Actual_Typ = Formal_Typ then
1082 -- No need to displace the pointer if the interface type is
1083 -- a parent of the type of the actual because in this case the
1084 -- interface primitives are located in the primary dispatch table.
1086 elsif Is_Ancestor (Formal_Typ, Actual_Typ) then
1089 -- Implicit conversion to the class-wide formal type to force
1090 -- the displacement of the pointer.
1093 Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
1094 Rewrite (Actual, Conversion);
1095 Analyze_And_Resolve (Actual, Formal_Typ);
1098 -- Access to class-wide interface type
1100 elsif Is_Access_Type (Formal_Typ)
1101 and then Is_Interface (Formal_DDT)
1102 and then Is_Class_Wide_Type (Formal_DDT)
1103 and then Interface_Present_In_Ancestor
1105 Iface => Etype (Formal_DDT))
1107 -- Handle attributes 'Access and 'Unchecked_Access
1109 if Nkind (Actual) = N_Attribute_Reference
1111 (Attribute_Name (Actual) = Name_Access
1112 or else Attribute_Name (Actual) = Name_Unchecked_Access)
1114 -- This case must have been handled by the analysis and
1115 -- expansion of 'Access. The only exception is when types
1116 -- match and no further expansion is required.
1118 pragma Assert (Base_Type (Etype (Prefix (Actual)))
1119 = Base_Type (Formal_DDT));
1122 -- No need to displace the pointer if the type of the actual
1123 -- coincides with the type of the formal.
1125 elsif Actual_DDT = Formal_DDT then
1128 -- No need to displace the pointer if the interface type is
1129 -- a parent of the type of the actual because in this case the
1130 -- interface primitives are located in the primary dispatch table.
1132 elsif Is_Ancestor (Formal_DDT, Actual_DDT) then
1136 Actual_Dup := Relocate_Node (Actual);
1138 if From_With_Type (Actual_Typ) then
1140 -- If the type of the actual parameter comes from a limited
1141 -- with-clause and the non-limited view is already available
1142 -- we replace the anonymous access type by a duplicate
1143 -- declaration whose designated type is the non-limited view
1145 if Ekind (Actual_DDT) = E_Incomplete_Type
1146 and then Present (Non_Limited_View (Actual_DDT))
1148 Anon := New_Copy (Actual_Typ);
1150 if Is_Itype (Anon) then
1151 Set_Scope (Anon, Current_Scope);
1154 Set_Directly_Designated_Type (Anon,
1155 Non_Limited_View (Actual_DDT));
1156 Set_Etype (Actual_Dup, Anon);
1158 elsif Is_Class_Wide_Type (Actual_DDT)
1159 and then Ekind (Etype (Actual_DDT)) = E_Incomplete_Type
1160 and then Present (Non_Limited_View (Etype (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 New_Copy (Actual_DDT));
1170 Set_Class_Wide_Type (Directly_Designated_Type (Anon),
1171 New_Copy (Class_Wide_Type (Actual_DDT)));
1172 Set_Etype (Directly_Designated_Type (Anon),
1173 Non_Limited_View (Etype (Actual_DDT)));
1175 Class_Wide_Type (Directly_Designated_Type (Anon)),
1176 Non_Limited_View (Etype (Actual_DDT)));
1177 Set_Etype (Actual_Dup, Anon);
1181 Conversion := Convert_To (Formal_Typ, Actual_Dup);
1182 Rewrite (Actual, Conversion);
1183 Analyze_And_Resolve (Actual, Formal_Typ);
1187 Next_Actual (Actual);
1188 Next_Formal (Formal);
1190 end Expand_Interface_Actuals;
1192 ----------------------------
1193 -- Expand_Interface_Thunk --
1194 ----------------------------
1196 procedure Expand_Interface_Thunk
1198 Thunk_Id : out Entity_Id;
1199 Thunk_Code : out Node_Id)
1201 Loc : constant Source_Ptr := Sloc (Prim);
1202 Actuals : constant List_Id := New_List;
1203 Decl : constant List_Id := New_List;
1204 Formals : constant List_Id := New_List;
1206 Controlling_Typ : Entity_Id;
1211 Offset_To_Top : Node_Id;
1213 Target_Formal : Entity_Id;
1217 Thunk_Code := Empty;
1219 -- Traverse the list of alias to find the final target
1222 while Present (Alias (Target)) loop
1223 Target := Alias (Target);
1226 -- In case of primitives that are functions without formals and
1227 -- a controlling result there is no need to build the thunk.
1229 if not Present (First_Formal (Target)) then
1230 pragma Assert (Ekind (Target) = E_Function
1231 and then Has_Controlling_Result (Target));
1235 -- Duplicate the formals
1237 Formal := First_Formal (Target);
1238 while Present (Formal) loop
1240 Make_Parameter_Specification (Loc,
1241 Defining_Identifier =>
1242 Make_Defining_Identifier (Sloc (Formal),
1243 Chars => Chars (Formal)),
1244 In_Present => In_Present (Parent (Formal)),
1245 Out_Present => Out_Present (Parent (Formal)),
1247 New_Reference_To (Etype (Formal), Loc),
1248 Expression => New_Copy_Tree (Expression (Parent (Formal)))));
1250 Next_Formal (Formal);
1253 Controlling_Typ := Find_Dispatching_Type (Target);
1255 Target_Formal := First_Formal (Target);
1256 Formal := First (Formals);
1257 while Present (Formal) loop
1258 if Ekind (Target_Formal) = E_In_Parameter
1259 and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
1260 and then Directly_Designated_Type (Etype (Target_Formal))
1265 -- type T is access all <<type of the target formal>>
1266 -- S : Storage_Offset := Storage_Offset!(Formal)
1267 -- - Offset_To_Top (address!(Formal))
1270 Make_Full_Type_Declaration (Loc,
1271 Defining_Identifier =>
1272 Make_Defining_Identifier (Loc,
1273 New_Internal_Name ('T')),
1275 Make_Access_To_Object_Definition (Loc,
1276 All_Present => True,
1277 Null_Exclusion_Present => False,
1278 Constant_Present => False,
1279 Subtype_Indication =>
1281 (Directly_Designated_Type
1282 (Etype (Target_Formal)), Loc)));
1285 Unchecked_Convert_To (RTE (RE_Address),
1286 New_Reference_To (Defining_Identifier (Formal), Loc));
1288 if not RTE_Available (RE_Offset_To_Top) then
1290 Build_Offset_To_Top (Loc, New_Arg);
1293 Make_Function_Call (Loc,
1294 Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
1295 Parameter_Associations => New_List (New_Arg));
1299 Make_Object_Declaration (Loc,
1300 Defining_Identifier =>
1301 Make_Defining_Identifier (Loc,
1302 New_Internal_Name ('S')),
1303 Constant_Present => True,
1304 Object_Definition =>
1305 New_Reference_To (RTE (RE_Storage_Offset), Loc),
1307 Make_Op_Subtract (Loc,
1309 Unchecked_Convert_To
1310 (RTE (RE_Storage_Offset),
1311 New_Reference_To (Defining_Identifier (Formal), Loc)),
1315 Append_To (Decl, Decl_2);
1316 Append_To (Decl, Decl_1);
1318 -- Reference the new actual. Generate:
1322 Unchecked_Convert_To
1323 (Defining_Identifier (Decl_2),
1324 New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1326 elsif Etype (Target_Formal) = Controlling_Typ then
1329 -- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
1330 -- - Offset_To_Top (Formal'Address)
1331 -- S2 : Addr_Ptr := Addr_Ptr!(S1)
1334 Make_Attribute_Reference (Loc,
1336 New_Reference_To (Defining_Identifier (Formal), Loc),
1340 if not RTE_Available (RE_Offset_To_Top) then
1342 Build_Offset_To_Top (Loc, New_Arg);
1345 Make_Function_Call (Loc,
1346 Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
1347 Parameter_Associations => New_List (New_Arg));
1351 Make_Object_Declaration (Loc,
1352 Defining_Identifier =>
1353 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
1354 Constant_Present => True,
1355 Object_Definition =>
1356 New_Reference_To (RTE (RE_Storage_Offset), Loc),
1358 Make_Op_Subtract (Loc,
1360 Unchecked_Convert_To
1361 (RTE (RE_Storage_Offset),
1362 Make_Attribute_Reference (Loc,
1365 (Defining_Identifier (Formal), Loc),
1366 Attribute_Name => Name_Address)),
1371 Make_Object_Declaration (Loc,
1372 Defining_Identifier =>
1373 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
1374 Constant_Present => True,
1375 Object_Definition => New_Reference_To (RTE (RE_Addr_Ptr), Loc),
1377 Unchecked_Convert_To
1379 New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1381 Append_To (Decl, Decl_1);
1382 Append_To (Decl, Decl_2);
1384 -- Reference the new actual. Generate:
1385 -- Target_Formal (S2.all)
1388 Unchecked_Convert_To
1389 (Etype (Target_Formal),
1390 Make_Explicit_Dereference (Loc,
1391 New_Reference_To (Defining_Identifier (Decl_2), Loc))));
1393 -- No special management required for this actual
1397 New_Reference_To (Defining_Identifier (Formal), Loc));
1400 Next_Formal (Target_Formal);
1405 Make_Defining_Identifier (Loc,
1406 Chars => New_Internal_Name ('T'));
1408 Set_Is_Thunk (Thunk_Id);
1410 if Ekind (Target) = E_Procedure then
1412 Make_Subprogram_Body (Loc,
1414 Make_Procedure_Specification (Loc,
1415 Defining_Unit_Name => Thunk_Id,
1416 Parameter_Specifications => Formals),
1417 Declarations => Decl,
1418 Handled_Statement_Sequence =>
1419 Make_Handled_Sequence_Of_Statements (Loc,
1420 Statements => New_List (
1421 Make_Procedure_Call_Statement (Loc,
1422 Name => New_Occurrence_Of (Target, Loc),
1423 Parameter_Associations => Actuals))));
1425 else pragma Assert (Ekind (Target) = E_Function);
1428 Make_Subprogram_Body (Loc,
1430 Make_Function_Specification (Loc,
1431 Defining_Unit_Name => Thunk_Id,
1432 Parameter_Specifications => Formals,
1433 Result_Definition =>
1434 New_Copy (Result_Definition (Parent (Target)))),
1435 Declarations => Decl,
1436 Handled_Statement_Sequence =>
1437 Make_Handled_Sequence_Of_Statements (Loc,
1438 Statements => New_List (
1439 Make_Simple_Return_Statement (Loc,
1440 Make_Function_Call (Loc,
1441 Name => New_Occurrence_Of (Target, Loc),
1442 Parameter_Associations => Actuals)))));
1444 end Expand_Interface_Thunk;
1450 function Has_DT (Typ : Entity_Id) return Boolean is
1452 return not Is_Interface (Typ)
1453 and then not Restriction_Active (No_Dispatching_Calls);
1456 -----------------------------------------
1457 -- Is_Predefined_Dispatching_Operation --
1458 -----------------------------------------
1460 function Is_Predefined_Dispatching_Operation
1461 (E : Entity_Id) return Boolean
1463 TSS_Name : TSS_Name_Type;
1466 if not Is_Dispatching_Operation (E) then
1470 Get_Name_String (Chars (E));
1472 -- Most predefined primitives have internally generated names. Equality
1473 -- must be treated differently; the predefined operation is recognized
1474 -- as a homogeneous binary operator that returns Boolean.
1476 if Name_Len > TSS_Name_Type'Last then
1477 TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
1479 if Chars (E) = Name_uSize
1480 or else Chars (E) = Name_uAlignment
1481 or else TSS_Name = TSS_Stream_Read
1482 or else TSS_Name = TSS_Stream_Write
1483 or else TSS_Name = TSS_Stream_Input
1484 or else TSS_Name = TSS_Stream_Output
1486 (Chars (E) = Name_Op_Eq
1487 and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
1488 or else Chars (E) = Name_uAssign
1489 or else TSS_Name = TSS_Deep_Adjust
1490 or else TSS_Name = TSS_Deep_Finalize
1491 or else Is_Predefined_Interface_Primitive (E)
1498 end Is_Predefined_Dispatching_Operation;
1500 -------------------------------------
1501 -- Is_Predefined_Dispatching_Alias --
1502 -------------------------------------
1504 function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean
1509 if not Is_Predefined_Dispatching_Operation (Prim)
1510 and then Present (Alias (Prim))
1513 while Present (Alias (E)) loop
1517 if Is_Predefined_Dispatching_Operation (E) then
1523 end Is_Predefined_Dispatching_Alias;
1525 ---------------------------------------
1526 -- Is_Predefined_Interface_Primitive --
1527 ---------------------------------------
1529 function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is
1531 return Ada_Version >= Ada_05
1532 and then (Chars (E) = Name_uDisp_Asynchronous_Select or else
1533 Chars (E) = Name_uDisp_Conditional_Select or else
1534 Chars (E) = Name_uDisp_Get_Prim_Op_Kind or else
1535 Chars (E) = Name_uDisp_Get_Task_Id or else
1536 Chars (E) = Name_uDisp_Requeue or else
1537 Chars (E) = Name_uDisp_Timed_Select);
1538 end Is_Predefined_Interface_Primitive;
1540 ----------------------------------------
1541 -- Make_Disp_Asynchronous_Select_Body --
1542 ----------------------------------------
1544 -- For interface types, generate:
1546 -- procedure _Disp_Asynchronous_Select
1547 -- (T : in out <Typ>;
1549 -- P : System.Address;
1550 -- B : out System.Storage_Elements.Dummy_Communication_Block;
1555 -- end _Disp_Asynchronous_Select;
1557 -- For protected types, generate:
1559 -- procedure _Disp_Asynchronous_Select
1560 -- (T : in out <Typ>;
1562 -- P : System.Address;
1563 -- B : out System.Storage_Elements.Dummy_Communication_Block;
1567 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
1568 -- Bnn : System.Tasking.Protected_Objects.Operations.
1569 -- Communication_Block;
1571 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
1572 -- (T._object'Access,
1573 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
1575 -- System.Tasking.Asynchronous_Call,
1577 -- B := System.Storage_Elements.Dummy_Communication_Block (Bnn);
1578 -- end _Disp_Asynchronous_Select;
1580 -- For task types, generate:
1582 -- procedure _Disp_Asynchronous_Select
1583 -- (T : in out <Typ>;
1585 -- P : System.Address;
1586 -- B : out System.Storage_Elements.Dummy_Communication_Block;
1590 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
1592 -- System.Tasking.Rendezvous.Task_Entry_Call
1594 -- System.Tasking.Task_Entry_Index (I),
1596 -- System.Tasking.Asynchronous_Call,
1598 -- end _Disp_Asynchronous_Select;
1600 function Make_Disp_Asynchronous_Select_Body
1601 (Typ : Entity_Id) return Node_Id
1603 Com_Block : Entity_Id;
1604 Conc_Typ : Entity_Id := Empty;
1605 Decls : constant List_Id := New_List;
1607 Loc : constant Source_Ptr := Sloc (Typ);
1609 Stmts : constant List_Id := New_List;
1612 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1614 -- Null body is generated for interface types
1616 if Is_Interface (Typ) then
1618 Make_Subprogram_Body (Loc,
1620 Make_Disp_Asynchronous_Select_Spec (Typ),
1623 Handled_Statement_Sequence =>
1624 Make_Handled_Sequence_Of_Statements (Loc,
1625 New_List (Make_Null_Statement (Loc))));
1628 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
1630 if Is_Concurrent_Record_Type (Typ) then
1631 Conc_Typ := Corresponding_Concurrent_Type (Typ);
1635 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
1637 -- where I will be used to capture the entry index of the primitive
1638 -- wrapper at position S.
1641 Make_Object_Declaration (Loc,
1642 Defining_Identifier =>
1643 Make_Defining_Identifier (Loc, Name_uI),
1644 Object_Definition =>
1645 New_Reference_To (Standard_Integer, Loc),
1647 Make_Function_Call (Loc,
1649 New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
1650 Parameter_Associations =>
1652 Unchecked_Convert_To (RTE (RE_Tag),
1653 New_Reference_To (DT_Ptr, Loc)),
1654 Make_Identifier (Loc, Name_uS)))));
1656 if Ekind (Conc_Typ) = E_Protected_Type then
1659 -- Bnn : Communication_Block;
1662 Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
1665 Make_Object_Declaration (Loc,
1666 Defining_Identifier =>
1668 Object_Definition =>
1669 New_Reference_To (RTE (RE_Communication_Block), Loc)));
1671 -- Build T._object'Access for calls below
1674 Make_Attribute_Reference (Loc,
1675 Attribute_Name => Name_Unchecked_Access,
1677 Make_Selected_Component (Loc,
1678 Prefix => Make_Identifier (Loc, Name_uT),
1679 Selector_Name => Make_Identifier (Loc, Name_uObject)));
1681 case Corresponding_Runtime_Package (Conc_Typ) is
1682 when System_Tasking_Protected_Objects_Entries =>
1685 -- Protected_Entry_Call
1686 -- (T._object'Access, -- Object
1687 -- Protected_Entry_Index! (I), -- E
1688 -- P, -- Uninterpreted_Data
1689 -- Asynchronous_Call, -- Mode
1690 -- Bnn); -- Communication_Block
1692 -- where T is the protected object, I is the entry index, P
1693 -- is the wrapped parameters and B is the name of the
1694 -- communication block.
1697 Make_Procedure_Call_Statement (Loc,
1699 New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
1700 Parameter_Associations =>
1704 Make_Unchecked_Type_Conversion (Loc, -- entry index
1707 (RTE (RE_Protected_Entry_Index), Loc),
1708 Expression => Make_Identifier (Loc, Name_uI)),
1710 Make_Identifier (Loc, Name_uP), -- parameter block
1711 New_Reference_To ( -- Asynchronous_Call
1712 RTE (RE_Asynchronous_Call), Loc),
1714 New_Reference_To (Com_Block, Loc)))); -- comm block
1716 when System_Tasking_Protected_Objects_Single_Entry =>
1719 -- procedure Protected_Single_Entry_Call
1720 -- (Object : Protection_Entry_Access;
1721 -- Uninterpreted_Data : System.Address;
1722 -- Mode : Call_Modes);
1725 Make_Procedure_Call_Statement (Loc,
1728 (RTE (RE_Protected_Single_Entry_Call), Loc),
1729 Parameter_Associations =>
1733 Make_Attribute_Reference (Loc,
1734 Prefix => Make_Identifier (Loc, Name_uP),
1735 Attribute_Name => Name_Address),
1738 (RTE (RE_Asynchronous_Call), Loc))));
1741 raise Program_Error;
1745 -- B := Dummy_Communication_Block (Bnn);
1748 Make_Assignment_Statement (Loc,
1750 Make_Identifier (Loc, Name_uB),
1752 Make_Unchecked_Type_Conversion (Loc,
1755 RTE (RE_Dummy_Communication_Block), Loc),
1757 New_Reference_To (Com_Block, Loc))));
1760 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
1764 -- (T._task_id, -- Acceptor
1765 -- Task_Entry_Index! (I), -- E
1766 -- P, -- Uninterpreted_Data
1767 -- Asynchronous_Call, -- Mode
1768 -- F); -- Rendezvous_Successful
1770 -- where T is the task object, I is the entry index, P is the
1771 -- wrapped parameters and F is the status flag.
1774 Make_Procedure_Call_Statement (Loc,
1776 New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
1777 Parameter_Associations =>
1779 Make_Selected_Component (Loc, -- T._task_id
1781 Make_Identifier (Loc, Name_uT),
1783 Make_Identifier (Loc, Name_uTask_Id)),
1785 Make_Unchecked_Type_Conversion (Loc, -- entry index
1787 New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
1789 Make_Identifier (Loc, Name_uI)),
1791 Make_Identifier (Loc, Name_uP), -- parameter block
1792 New_Reference_To ( -- Asynchronous_Call
1793 RTE (RE_Asynchronous_Call), Loc),
1794 Make_Identifier (Loc, Name_uF)))); -- status flag
1799 Make_Subprogram_Body (Loc,
1801 Make_Disp_Asynchronous_Select_Spec (Typ),
1804 Handled_Statement_Sequence =>
1805 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
1806 end Make_Disp_Asynchronous_Select_Body;
1808 ----------------------------------------
1809 -- Make_Disp_Asynchronous_Select_Spec --
1810 ----------------------------------------
1812 function Make_Disp_Asynchronous_Select_Spec
1813 (Typ : Entity_Id) return Node_Id
1815 Loc : constant Source_Ptr := Sloc (Typ);
1816 Def_Id : constant Node_Id :=
1817 Make_Defining_Identifier (Loc,
1818 Name_uDisp_Asynchronous_Select);
1819 Params : constant List_Id := New_List;
1822 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1824 -- T : in out Typ; -- Object parameter
1825 -- S : Integer; -- Primitive operation slot
1826 -- P : Address; -- Wrapped parameters
1827 -- B : out Dummy_Communication_Block; -- Communication block dummy
1828 -- F : out Boolean; -- Status flag
1830 Append_List_To (Params, New_List (
1832 Make_Parameter_Specification (Loc,
1833 Defining_Identifier =>
1834 Make_Defining_Identifier (Loc, Name_uT),
1836 New_Reference_To (Typ, Loc),
1838 Out_Present => True),
1840 Make_Parameter_Specification (Loc,
1841 Defining_Identifier =>
1842 Make_Defining_Identifier (Loc, Name_uS),
1844 New_Reference_To (Standard_Integer, Loc)),
1846 Make_Parameter_Specification (Loc,
1847 Defining_Identifier =>
1848 Make_Defining_Identifier (Loc, Name_uP),
1850 New_Reference_To (RTE (RE_Address), Loc)),
1852 Make_Parameter_Specification (Loc,
1853 Defining_Identifier =>
1854 Make_Defining_Identifier (Loc, Name_uB),
1856 New_Reference_To (RTE (RE_Dummy_Communication_Block), Loc),
1857 Out_Present => True),
1859 Make_Parameter_Specification (Loc,
1860 Defining_Identifier =>
1861 Make_Defining_Identifier (Loc, Name_uF),
1863 New_Reference_To (Standard_Boolean, Loc),
1864 Out_Present => True)));
1867 Make_Procedure_Specification (Loc,
1868 Defining_Unit_Name => Def_Id,
1869 Parameter_Specifications => Params);
1870 end Make_Disp_Asynchronous_Select_Spec;
1872 ---------------------------------------
1873 -- Make_Disp_Conditional_Select_Body --
1874 ---------------------------------------
1876 -- For interface types, generate:
1878 -- procedure _Disp_Conditional_Select
1879 -- (T : in out <Typ>;
1881 -- P : System.Address;
1882 -- C : out Ada.Tags.Prim_Op_Kind;
1887 -- end _Disp_Conditional_Select;
1889 -- For protected types, generate:
1891 -- procedure _Disp_Conditional_Select
1892 -- (T : in out <Typ>;
1894 -- P : System.Address;
1895 -- C : out Ada.Tags.Prim_Op_Kind;
1899 -- Bnn : System.Tasking.Protected_Objects.Operations.
1900 -- Communication_Block;
1903 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S));
1905 -- if C = Ada.Tags.POK_Procedure
1906 -- or else C = Ada.Tags.POK_Protected_Procedure
1907 -- or else C = Ada.Tags.POK_Task_Procedure
1913 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
1914 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
1915 -- (T.object'Access,
1916 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
1918 -- System.Tasking.Conditional_Call,
1920 -- F := not Cancelled (Bnn);
1921 -- end _Disp_Conditional_Select;
1923 -- For task types, generate:
1925 -- procedure _Disp_Conditional_Select
1926 -- (T : in out <Typ>;
1928 -- P : System.Address;
1929 -- C : out Ada.Tags.Prim_Op_Kind;
1935 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
1936 -- System.Tasking.Rendezvous.Task_Entry_Call
1938 -- System.Tasking.Task_Entry_Index (I),
1940 -- System.Tasking.Conditional_Call,
1942 -- end _Disp_Conditional_Select;
1944 function Make_Disp_Conditional_Select_Body
1945 (Typ : Entity_Id) return Node_Id
1947 Loc : constant Source_Ptr := Sloc (Typ);
1948 Blk_Nam : Entity_Id;
1949 Conc_Typ : Entity_Id := Empty;
1950 Decls : constant List_Id := New_List;
1953 Stmts : constant List_Id := New_List;
1956 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1958 -- Null body is generated for interface types
1960 if Is_Interface (Typ) then
1962 Make_Subprogram_Body (Loc,
1964 Make_Disp_Conditional_Select_Spec (Typ),
1967 Handled_Statement_Sequence =>
1968 Make_Handled_Sequence_Of_Statements (Loc,
1969 New_List (Make_Null_Statement (Loc))));
1972 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
1974 if Is_Concurrent_Record_Type (Typ) then
1975 Conc_Typ := Corresponding_Concurrent_Type (Typ);
1980 -- where I will be used to capture the entry index of the primitive
1981 -- wrapper at position S.
1984 Make_Object_Declaration (Loc,
1985 Defining_Identifier =>
1986 Make_Defining_Identifier (Loc, Name_uI),
1987 Object_Definition =>
1988 New_Reference_To (Standard_Integer, Loc)));
1991 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S);
1993 -- if C = POK_Procedure
1994 -- or else C = POK_Protected_Procedure
1995 -- or else C = POK_Task_Procedure;
2001 Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts);
2004 -- Bnn : Communication_Block;
2006 -- where Bnn is the name of the communication block used in the
2007 -- call to Protected_Entry_Call.
2009 Blk_Nam := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
2012 Make_Object_Declaration (Loc,
2013 Defining_Identifier =>
2015 Object_Definition =>
2016 New_Reference_To (RTE (RE_Communication_Block), Loc)));
2019 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2021 -- I is the entry index and S is the dispatch table slot
2024 Make_Assignment_Statement (Loc,
2026 Make_Identifier (Loc, Name_uI),
2028 Make_Function_Call (Loc,
2030 New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
2031 Parameter_Associations =>
2033 Unchecked_Convert_To (RTE (RE_Tag),
2034 New_Reference_To (DT_Ptr, Loc)),
2035 Make_Identifier (Loc, Name_uS)))));
2037 if Ekind (Conc_Typ) = E_Protected_Type then
2039 Obj_Ref := -- T._object'Access
2040 Make_Attribute_Reference (Loc,
2041 Attribute_Name => Name_Unchecked_Access,
2043 Make_Selected_Component (Loc,
2044 Prefix => Make_Identifier (Loc, Name_uT),
2045 Selector_Name => Make_Identifier (Loc, Name_uObject)));
2047 case Corresponding_Runtime_Package (Conc_Typ) is
2048 when System_Tasking_Protected_Objects_Entries =>
2051 -- Protected_Entry_Call
2052 -- (T._object'Access, -- Object
2053 -- Protected_Entry_Index! (I), -- E
2054 -- P, -- Uninterpreted_Data
2055 -- Conditional_Call, -- Mode
2058 -- where T is the protected object, I is the entry index, P
2059 -- are the wrapped parameters and Bnn is the name of the
2060 -- communication block.
2063 Make_Procedure_Call_Statement (Loc,
2065 New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
2066 Parameter_Associations =>
2070 Make_Unchecked_Type_Conversion (Loc, -- entry index
2073 (RTE (RE_Protected_Entry_Index), Loc),
2074 Expression => Make_Identifier (Loc, Name_uI)),
2076 Make_Identifier (Loc, Name_uP), -- parameter block
2078 New_Reference_To ( -- Conditional_Call
2079 RTE (RE_Conditional_Call), Loc),
2080 New_Reference_To ( -- Bnn
2083 when System_Tasking_Protected_Objects_Single_Entry =>
2085 -- If we are compiling for a restricted run-time, the call
2086 -- uses the simpler form.
2089 Make_Procedure_Call_Statement (Loc,
2092 (RTE (RE_Protected_Single_Entry_Call), Loc),
2093 Parameter_Associations =>
2097 Make_Attribute_Reference (Loc,
2098 Prefix => Make_Identifier (Loc, Name_uP),
2099 Attribute_Name => Name_Address),
2102 (RTE (RE_Conditional_Call), Loc))));
2104 raise Program_Error;
2108 -- F := not Cancelled (Bnn);
2110 -- where F is the success flag. The status of Cancelled is negated
2111 -- in order to match the behaviour of the version for task types.
2114 Make_Assignment_Statement (Loc,
2116 Make_Identifier (Loc, Name_uF),
2120 Make_Function_Call (Loc,
2122 New_Reference_To (RTE (RE_Cancelled), Loc),
2123 Parameter_Associations =>
2125 New_Reference_To (Blk_Nam, Loc))))));
2127 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2131 -- (T._task_id, -- Acceptor
2132 -- Task_Entry_Index! (I), -- E
2133 -- P, -- Uninterpreted_Data
2134 -- Conditional_Call, -- Mode
2135 -- F); -- Rendezvous_Successful
2137 -- where T is the task object, I is the entry index, P are the
2138 -- wrapped parameters and F is the status flag.
2141 Make_Procedure_Call_Statement (Loc,
2143 New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
2144 Parameter_Associations =>
2147 Make_Selected_Component (Loc, -- T._task_id
2149 Make_Identifier (Loc, Name_uT),
2151 Make_Identifier (Loc, Name_uTask_Id)),
2153 Make_Unchecked_Type_Conversion (Loc, -- entry index
2155 New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
2157 Make_Identifier (Loc, Name_uI)),
2159 Make_Identifier (Loc, Name_uP), -- parameter block
2160 New_Reference_To ( -- Conditional_Call
2161 RTE (RE_Conditional_Call), Loc),
2162 Make_Identifier (Loc, Name_uF)))); -- status flag
2167 Make_Subprogram_Body (Loc,
2169 Make_Disp_Conditional_Select_Spec (Typ),
2172 Handled_Statement_Sequence =>
2173 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2174 end Make_Disp_Conditional_Select_Body;
2176 ---------------------------------------
2177 -- Make_Disp_Conditional_Select_Spec --
2178 ---------------------------------------
2180 function Make_Disp_Conditional_Select_Spec
2181 (Typ : Entity_Id) return Node_Id
2183 Loc : constant Source_Ptr := Sloc (Typ);
2184 Def_Id : constant Node_Id :=
2185 Make_Defining_Identifier (Loc,
2186 Name_uDisp_Conditional_Select);
2187 Params : constant List_Id := New_List;
2190 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2192 -- T : in out Typ; -- Object parameter
2193 -- S : Integer; -- Primitive operation slot
2194 -- P : Address; -- Wrapped parameters
2195 -- C : out Prim_Op_Kind; -- Call kind
2196 -- F : out Boolean; -- Status flag
2198 Append_List_To (Params, New_List (
2200 Make_Parameter_Specification (Loc,
2201 Defining_Identifier =>
2202 Make_Defining_Identifier (Loc, Name_uT),
2204 New_Reference_To (Typ, Loc),
2206 Out_Present => True),
2208 Make_Parameter_Specification (Loc,
2209 Defining_Identifier =>
2210 Make_Defining_Identifier (Loc, Name_uS),
2212 New_Reference_To (Standard_Integer, Loc)),
2214 Make_Parameter_Specification (Loc,
2215 Defining_Identifier =>
2216 Make_Defining_Identifier (Loc, Name_uP),
2218 New_Reference_To (RTE (RE_Address), Loc)),
2220 Make_Parameter_Specification (Loc,
2221 Defining_Identifier =>
2222 Make_Defining_Identifier (Loc, Name_uC),
2224 New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
2225 Out_Present => True),
2227 Make_Parameter_Specification (Loc,
2228 Defining_Identifier =>
2229 Make_Defining_Identifier (Loc, Name_uF),
2231 New_Reference_To (Standard_Boolean, Loc),
2232 Out_Present => True)));
2235 Make_Procedure_Specification (Loc,
2236 Defining_Unit_Name => Def_Id,
2237 Parameter_Specifications => Params);
2238 end Make_Disp_Conditional_Select_Spec;
2240 -------------------------------------
2241 -- Make_Disp_Get_Prim_Op_Kind_Body --
2242 -------------------------------------
2244 function Make_Disp_Get_Prim_Op_Kind_Body
2245 (Typ : Entity_Id) return Node_Id
2247 Loc : constant Source_Ptr := Sloc (Typ);
2251 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2253 if Is_Interface (Typ) then
2255 Make_Subprogram_Body (Loc,
2257 Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2260 Handled_Statement_Sequence =>
2261 Make_Handled_Sequence_Of_Statements (Loc,
2262 New_List (Make_Null_Statement (Loc))));
2265 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
2268 -- C := get_prim_op_kind (tag! (<type>VP), S);
2270 -- where C is the out parameter capturing the call kind and S is the
2271 -- dispatch table slot number.
2274 Make_Subprogram_Body (Loc,
2276 Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2279 Handled_Statement_Sequence =>
2280 Make_Handled_Sequence_Of_Statements (Loc,
2282 Make_Assignment_Statement (Loc,
2284 Make_Identifier (Loc, Name_uC),
2286 Make_Function_Call (Loc,
2288 New_Reference_To (RTE (RE_Get_Prim_Op_Kind), Loc),
2289 Parameter_Associations => New_List (
2290 Unchecked_Convert_To (RTE (RE_Tag),
2291 New_Reference_To (DT_Ptr, Loc)),
2292 Make_Identifier (Loc, Name_uS)))))));
2293 end Make_Disp_Get_Prim_Op_Kind_Body;
2295 -------------------------------------
2296 -- Make_Disp_Get_Prim_Op_Kind_Spec --
2297 -------------------------------------
2299 function Make_Disp_Get_Prim_Op_Kind_Spec
2300 (Typ : Entity_Id) return Node_Id
2302 Loc : constant Source_Ptr := Sloc (Typ);
2303 Def_Id : constant Node_Id :=
2304 Make_Defining_Identifier (Loc,
2305 Name_uDisp_Get_Prim_Op_Kind);
2306 Params : constant List_Id := New_List;
2309 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2311 -- T : in out Typ; -- Object parameter
2312 -- S : Integer; -- Primitive operation slot
2313 -- C : out Prim_Op_Kind; -- Call kind
2315 Append_List_To (Params, New_List (
2317 Make_Parameter_Specification (Loc,
2318 Defining_Identifier =>
2319 Make_Defining_Identifier (Loc, Name_uT),
2321 New_Reference_To (Typ, Loc),
2323 Out_Present => True),
2325 Make_Parameter_Specification (Loc,
2326 Defining_Identifier =>
2327 Make_Defining_Identifier (Loc, Name_uS),
2329 New_Reference_To (Standard_Integer, Loc)),
2331 Make_Parameter_Specification (Loc,
2332 Defining_Identifier =>
2333 Make_Defining_Identifier (Loc, Name_uC),
2335 New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
2336 Out_Present => True)));
2339 Make_Procedure_Specification (Loc,
2340 Defining_Unit_Name => Def_Id,
2341 Parameter_Specifications => Params);
2342 end Make_Disp_Get_Prim_Op_Kind_Spec;
2344 --------------------------------
2345 -- Make_Disp_Get_Task_Id_Body --
2346 --------------------------------
2348 function Make_Disp_Get_Task_Id_Body
2349 (Typ : Entity_Id) return Node_Id
2351 Loc : constant Source_Ptr := Sloc (Typ);
2355 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2357 if Is_Concurrent_Record_Type (Typ)
2358 and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type
2361 -- return To_Address (_T._task_id);
2364 Make_Simple_Return_Statement (Loc,
2366 Make_Unchecked_Type_Conversion (Loc,
2368 New_Reference_To (RTE (RE_Address), Loc),
2370 Make_Selected_Component (Loc,
2372 Make_Identifier (Loc, Name_uT),
2374 Make_Identifier (Loc, Name_uTask_Id))));
2376 -- A null body is constructed for non-task types
2380 -- return Null_Address;
2383 Make_Simple_Return_Statement (Loc,
2385 New_Reference_To (RTE (RE_Null_Address), Loc));
2389 Make_Subprogram_Body (Loc,
2391 Make_Disp_Get_Task_Id_Spec (Typ),
2394 Handled_Statement_Sequence =>
2395 Make_Handled_Sequence_Of_Statements (Loc,
2397 end Make_Disp_Get_Task_Id_Body;
2399 --------------------------------
2400 -- Make_Disp_Get_Task_Id_Spec --
2401 --------------------------------
2403 function Make_Disp_Get_Task_Id_Spec
2404 (Typ : Entity_Id) return Node_Id
2406 Loc : constant Source_Ptr := Sloc (Typ);
2409 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2412 Make_Function_Specification (Loc,
2413 Defining_Unit_Name =>
2414 Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id),
2415 Parameter_Specifications => New_List (
2416 Make_Parameter_Specification (Loc,
2417 Defining_Identifier =>
2418 Make_Defining_Identifier (Loc, Name_uT),
2420 New_Reference_To (Typ, Loc))),
2421 Result_Definition =>
2422 New_Reference_To (RTE (RE_Address), Loc));
2423 end Make_Disp_Get_Task_Id_Spec;
2425 ----------------------------
2426 -- Make_Disp_Requeue_Body --
2427 ----------------------------
2429 function Make_Disp_Requeue_Body
2430 (Typ : Entity_Id) return Node_Id
2432 Loc : constant Source_Ptr := Sloc (Typ);
2433 Conc_Typ : Entity_Id := Empty;
2434 Stmts : constant List_Id := New_List;
2437 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2439 -- Null body is generated for interface types and non-concurrent
2442 if Is_Interface (Typ)
2443 or else not Is_Concurrent_Record_Type (Typ)
2446 Make_Subprogram_Body (Loc,
2448 Make_Disp_Requeue_Spec (Typ),
2451 Handled_Statement_Sequence =>
2452 Make_Handled_Sequence_Of_Statements (Loc,
2453 New_List (Make_Null_Statement (Loc))));
2456 Conc_Typ := Corresponding_Concurrent_Type (Typ);
2458 if Ekind (Conc_Typ) = E_Protected_Type then
2460 -- Generate statements:
2462 -- System.Tasking.Protected_Objects.Operations.
2463 -- Requeue_Protected_Entry
2464 -- (Protection_Entries_Access (P),
2465 -- O._object'Unchecked_Access,
2466 -- Protected_Entry_Index (I),
2469 -- System.Tasking.Protected_Objects.Operations.
2470 -- Requeue_Task_To_Protected_Entry
2471 -- (O._object'Unchecked_Access,
2472 -- Protected_Entry_Index (I),
2476 if Restriction_Active (No_Entry_Queue) then
2477 Append_To (Stmts, Make_Null_Statement (Loc));
2480 Make_If_Statement (Loc,
2482 Make_Identifier (Loc, Name_uF),
2487 -- Call to Requeue_Protected_Entry
2489 Make_Procedure_Call_Statement (Loc,
2492 RTE (RE_Requeue_Protected_Entry), Loc),
2493 Parameter_Associations =>
2496 Make_Unchecked_Type_Conversion (Loc, -- PEA (P)
2499 RTE (RE_Protection_Entries_Access), Loc),
2501 Make_Identifier (Loc, Name_uP)),
2503 Make_Attribute_Reference (Loc, -- O._object'Acc
2505 Name_Unchecked_Access,
2507 Make_Selected_Component (Loc,
2509 Make_Identifier (Loc, Name_uO),
2511 Make_Identifier (Loc, Name_uObject))),
2513 Make_Unchecked_Type_Conversion (Loc, -- entry index
2516 RTE (RE_Protected_Entry_Index), Loc),
2518 Make_Identifier (Loc, Name_uI)),
2520 Make_Identifier (Loc, Name_uA)))), -- abort status
2525 -- Call to Requeue_Task_To_Protected_Entry
2527 Make_Procedure_Call_Statement (Loc,
2530 RTE (RE_Requeue_Task_To_Protected_Entry), Loc),
2531 Parameter_Associations =>
2534 Make_Attribute_Reference (Loc, -- O._object'Acc
2536 Name_Unchecked_Access,
2538 Make_Selected_Component (Loc,
2540 Make_Identifier (Loc, Name_uO),
2542 Make_Identifier (Loc, Name_uObject))),
2544 Make_Unchecked_Type_Conversion (Loc, -- entry index
2547 RTE (RE_Protected_Entry_Index), Loc),
2549 Make_Identifier (Loc, Name_uI)),
2551 Make_Identifier (Loc, Name_uA)))))); -- abort status
2554 pragma Assert (Is_Task_Type (Conc_Typ));
2558 -- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry
2559 -- (Protection_Entries_Access (P),
2561 -- Task_Entry_Index (I),
2564 -- System.Tasking.Rendezvous.Requeue_Task_Entry
2566 -- Task_Entry_Index (I),
2571 Make_If_Statement (Loc,
2573 Make_Identifier (Loc, Name_uF),
2578 -- Call to Requeue_Protected_To_Task_Entry
2580 Make_Procedure_Call_Statement (Loc,
2583 RTE (RE_Requeue_Protected_To_Task_Entry), Loc),
2585 Parameter_Associations =>
2588 Make_Unchecked_Type_Conversion (Loc, -- PEA (P)
2591 RTE (RE_Protection_Entries_Access), Loc),
2593 Make_Identifier (Loc, Name_uP)),
2595 Make_Selected_Component (Loc, -- O._task_id
2597 Make_Identifier (Loc, Name_uO),
2599 Make_Identifier (Loc, Name_uTask_Id)),
2601 Make_Unchecked_Type_Conversion (Loc, -- entry index
2604 RTE (RE_Task_Entry_Index), Loc),
2606 Make_Identifier (Loc, Name_uI)),
2608 Make_Identifier (Loc, Name_uA)))), -- abort status
2613 -- Call to Requeue_Task_Entry
2615 Make_Procedure_Call_Statement (Loc,
2617 New_Reference_To (RTE (RE_Requeue_Task_Entry), Loc),
2619 Parameter_Associations =>
2622 Make_Selected_Component (Loc, -- O._task_id
2624 Make_Identifier (Loc, Name_uO),
2626 Make_Identifier (Loc, Name_uTask_Id)),
2628 Make_Unchecked_Type_Conversion (Loc, -- entry index
2631 RTE (RE_Task_Entry_Index), Loc),
2633 Make_Identifier (Loc, Name_uI)),
2635 Make_Identifier (Loc, Name_uA)))))); -- abort status
2638 -- Even though no declarations are needed in both cases, we allocate
2639 -- a list for entities added by Freeze.
2642 Make_Subprogram_Body (Loc,
2644 Make_Disp_Requeue_Spec (Typ),
2647 Handled_Statement_Sequence =>
2648 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2649 end Make_Disp_Requeue_Body;
2651 ----------------------------
2652 -- Make_Disp_Requeue_Spec --
2653 ----------------------------
2655 function Make_Disp_Requeue_Spec
2656 (Typ : Entity_Id) return Node_Id
2658 Loc : constant Source_Ptr := Sloc (Typ);
2661 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2663 -- O : in out Typ; - Object parameter
2664 -- F : Boolean; - Protected (True) / task (False) flag
2665 -- P : Address; - Protection_Entries_Access value
2666 -- I : Entry_Index - Index of entry call
2667 -- A : Boolean - Abort flag
2669 -- Note that the Protection_Entries_Access value is represented as a
2670 -- System.Address in order to avoid dragging in the tasking runtime
2671 -- when compiling sources without tasking constructs.
2674 Make_Procedure_Specification (Loc,
2675 Defining_Unit_Name =>
2676 Make_Defining_Identifier (Loc, Name_uDisp_Requeue),
2678 Parameter_Specifications =>
2681 Make_Parameter_Specification (Loc, -- O
2682 Defining_Identifier =>
2683 Make_Defining_Identifier (Loc, Name_uO),
2685 New_Reference_To (Typ, Loc),
2687 Out_Present => True),
2689 Make_Parameter_Specification (Loc, -- F
2690 Defining_Identifier =>
2691 Make_Defining_Identifier (Loc, Name_uF),
2693 New_Reference_To (Standard_Boolean, Loc)),
2695 Make_Parameter_Specification (Loc, -- P
2696 Defining_Identifier =>
2697 Make_Defining_Identifier (Loc, Name_uP),
2699 New_Reference_To (RTE (RE_Address), Loc)),
2701 Make_Parameter_Specification (Loc, -- I
2702 Defining_Identifier =>
2703 Make_Defining_Identifier (Loc, Name_uI),
2705 New_Reference_To (Standard_Integer, Loc)),
2707 Make_Parameter_Specification (Loc, -- A
2708 Defining_Identifier =>
2709 Make_Defining_Identifier (Loc, Name_uA),
2711 New_Reference_To (Standard_Boolean, Loc))));
2712 end Make_Disp_Requeue_Spec;
2714 ---------------------------------
2715 -- Make_Disp_Timed_Select_Body --
2716 ---------------------------------
2718 -- For interface types, generate:
2720 -- procedure _Disp_Timed_Select
2721 -- (T : in out <Typ>;
2723 -- P : System.Address;
2726 -- C : out Ada.Tags.Prim_Op_Kind;
2731 -- end _Disp_Timed_Select;
2733 -- For protected types, generate:
2735 -- procedure _Disp_Timed_Select
2736 -- (T : in out <Typ>;
2738 -- P : System.Address;
2741 -- C : out Ada.Tags.Prim_Op_Kind;
2747 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S);
2749 -- if C = Ada.Tags.POK_Procedure
2750 -- or else C = Ada.Tags.POK_Protected_Procedure
2751 -- or else C = Ada.Tags.POK_Task_Procedure
2757 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
2758 -- System.Tasking.Protected_Objects.Operations.
2759 -- Timed_Protected_Entry_Call
2760 -- (T._object'Access,
2761 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2766 -- end _Disp_Timed_Select;
2768 -- For task types, generate:
2770 -- procedure _Disp_Timed_Select
2771 -- (T : in out <Typ>;
2773 -- P : System.Address;
2776 -- C : out Ada.Tags.Prim_Op_Kind;
2782 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
2783 -- System.Tasking.Rendezvous.Timed_Task_Entry_Call
2785 -- System.Tasking.Task_Entry_Index (I),
2790 -- end _Disp_Time_Select;
2792 function Make_Disp_Timed_Select_Body
2793 (Typ : Entity_Id) return Node_Id
2795 Loc : constant Source_Ptr := Sloc (Typ);
2796 Conc_Typ : Entity_Id := Empty;
2797 Decls : constant List_Id := New_List;
2800 Stmts : constant List_Id := New_List;
2803 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2805 -- Null body is generated for interface types
2807 if Is_Interface (Typ) then
2809 Make_Subprogram_Body (Loc,
2811 Make_Disp_Timed_Select_Spec (Typ),
2814 Handled_Statement_Sequence =>
2815 Make_Handled_Sequence_Of_Statements (Loc,
2816 New_List (Make_Null_Statement (Loc))));
2819 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
2821 if Is_Concurrent_Record_Type (Typ) then
2822 Conc_Typ := Corresponding_Concurrent_Type (Typ);
2827 -- where I will be used to capture the entry index of the primitive
2828 -- wrapper at position S.
2831 Make_Object_Declaration (Loc,
2832 Defining_Identifier =>
2833 Make_Defining_Identifier (Loc, Name_uI),
2834 Object_Definition =>
2835 New_Reference_To (Standard_Integer, Loc)));
2838 -- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
2840 -- if C = POK_Procedure
2841 -- or else C = POK_Protected_Procedure
2842 -- or else C = POK_Task_Procedure;
2848 Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts);
2851 -- I := Get_Entry_Index (tag! (<type>VP), S);
2853 -- I is the entry index and S is the dispatch table slot
2856 Make_Assignment_Statement (Loc,
2858 Make_Identifier (Loc, Name_uI),
2860 Make_Function_Call (Loc,
2862 New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
2863 Parameter_Associations =>
2865 Unchecked_Convert_To (RTE (RE_Tag),
2866 New_Reference_To (DT_Ptr, Loc)),
2867 Make_Identifier (Loc, Name_uS)))));
2871 if Ekind (Conc_Typ) = E_Protected_Type then
2873 -- Build T._object'Access
2876 Make_Attribute_Reference (Loc,
2877 Attribute_Name => Name_Unchecked_Access,
2879 Make_Selected_Component (Loc,
2880 Prefix => Make_Identifier (Loc, Name_uT),
2881 Selector_Name => Make_Identifier (Loc, Name_uObject)));
2883 -- Normal case, No_Entry_Queue restriction not active. In this
2884 -- case we generate:
2886 -- Timed_Protected_Entry_Call
2887 -- (T._object'access,
2888 -- Protected_Entry_Index! (I),
2891 -- where T is the protected object, I is the entry index, P are
2892 -- the wrapped parameters, D is the delay amount, M is the delay
2893 -- mode and F is the status flag.
2895 case Corresponding_Runtime_Package (Conc_Typ) is
2896 when System_Tasking_Protected_Objects_Entries =>
2898 Make_Procedure_Call_Statement (Loc,
2901 (RTE (RE_Timed_Protected_Entry_Call), Loc),
2902 Parameter_Associations =>
2906 Make_Unchecked_Type_Conversion (Loc, -- entry index
2909 (RTE (RE_Protected_Entry_Index), Loc),
2911 Make_Identifier (Loc, Name_uI)),
2913 Make_Identifier (Loc, Name_uP), -- parameter block
2914 Make_Identifier (Loc, Name_uD), -- delay
2915 Make_Identifier (Loc, Name_uM), -- delay mode
2916 Make_Identifier (Loc, Name_uF)))); -- status flag
2918 when System_Tasking_Protected_Objects_Single_Entry =>
2921 -- Timed_Protected_Single_Entry_Call
2922 -- (T._object'access, P, D, M, F);
2924 -- where T is the protected object, P is the wrapped
2925 -- parameters, D is the delay amount, M is the delay mode, F
2926 -- is the status flag.
2929 Make_Procedure_Call_Statement (Loc,
2932 (RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
2933 Parameter_Associations =>
2936 Make_Identifier (Loc, Name_uP), -- parameter block
2937 Make_Identifier (Loc, Name_uD), -- delay
2938 Make_Identifier (Loc, Name_uM), -- delay mode
2939 Make_Identifier (Loc, Name_uF)))); -- status flag
2942 raise Program_Error;
2948 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2951 -- Timed_Task_Entry_Call (
2953 -- Task_Entry_Index! (I),
2959 -- where T is the task object, I is the entry index, P are the
2960 -- wrapped parameters, D is the delay amount, M is the delay
2961 -- mode and F is the status flag.
2964 Make_Procedure_Call_Statement (Loc,
2966 New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
2967 Parameter_Associations =>
2970 Make_Selected_Component (Loc, -- T._task_id
2972 Make_Identifier (Loc, Name_uT),
2974 Make_Identifier (Loc, Name_uTask_Id)),
2976 Make_Unchecked_Type_Conversion (Loc, -- entry index
2978 New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
2980 Make_Identifier (Loc, Name_uI)),
2982 Make_Identifier (Loc, Name_uP), -- parameter block
2983 Make_Identifier (Loc, Name_uD), -- delay
2984 Make_Identifier (Loc, Name_uM), -- delay mode
2985 Make_Identifier (Loc, Name_uF)))); -- status flag
2990 Make_Subprogram_Body (Loc,
2992 Make_Disp_Timed_Select_Spec (Typ),
2995 Handled_Statement_Sequence =>
2996 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2997 end Make_Disp_Timed_Select_Body;
2999 ---------------------------------
3000 -- Make_Disp_Timed_Select_Spec --
3001 ---------------------------------
3003 function Make_Disp_Timed_Select_Spec
3004 (Typ : Entity_Id) return Node_Id
3006 Loc : constant Source_Ptr := Sloc (Typ);
3007 Def_Id : constant Node_Id :=
3008 Make_Defining_Identifier (Loc,
3009 Name_uDisp_Timed_Select);
3010 Params : constant List_Id := New_List;
3013 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3015 -- T : in out Typ; -- Object parameter
3016 -- S : Integer; -- Primitive operation slot
3017 -- P : Address; -- Wrapped parameters
3018 -- D : Duration; -- Delay
3019 -- M : Integer; -- Delay Mode
3020 -- C : out Prim_Op_Kind; -- Call kind
3021 -- F : out Boolean; -- Status flag
3023 Append_List_To (Params, New_List (
3025 Make_Parameter_Specification (Loc,
3026 Defining_Identifier =>
3027 Make_Defining_Identifier (Loc, Name_uT),
3029 New_Reference_To (Typ, Loc),
3031 Out_Present => True),
3033 Make_Parameter_Specification (Loc,
3034 Defining_Identifier =>
3035 Make_Defining_Identifier (Loc, Name_uS),
3037 New_Reference_To (Standard_Integer, Loc)),
3039 Make_Parameter_Specification (Loc,
3040 Defining_Identifier =>
3041 Make_Defining_Identifier (Loc, Name_uP),
3043 New_Reference_To (RTE (RE_Address), Loc)),
3045 Make_Parameter_Specification (Loc,
3046 Defining_Identifier =>
3047 Make_Defining_Identifier (Loc, Name_uD),
3049 New_Reference_To (Standard_Duration, Loc)),
3051 Make_Parameter_Specification (Loc,
3052 Defining_Identifier =>
3053 Make_Defining_Identifier (Loc, Name_uM),
3055 New_Reference_To (Standard_Integer, Loc)),
3057 Make_Parameter_Specification (Loc,
3058 Defining_Identifier =>
3059 Make_Defining_Identifier (Loc, Name_uC),
3061 New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
3062 Out_Present => True)));
3065 Make_Parameter_Specification (Loc,
3066 Defining_Identifier =>
3067 Make_Defining_Identifier (Loc, Name_uF),
3069 New_Reference_To (Standard_Boolean, Loc),
3070 Out_Present => True));
3073 Make_Procedure_Specification (Loc,
3074 Defining_Unit_Name => Def_Id,
3075 Parameter_Specifications => Params);
3076 end Make_Disp_Timed_Select_Spec;
3082 -- The frontend supports two models for expanding dispatch tables
3083 -- associated with library-level defined tagged types: statically
3084 -- and non-statically allocated dispatch tables. In the former case
3085 -- the object containing the dispatch table is constant and it is
3086 -- initialized by means of a positional aggregate. In the latter case,
3087 -- the object containing the dispatch table is a variable which is
3088 -- initialized by means of assignments.
3090 -- In case of locally defined tagged types, the object containing the
3091 -- object containing the dispatch table is always a variable (instead
3092 -- of a constant). This is currently required to give support to late
3093 -- overriding of primitives. For example:
3095 -- procedure Example is
3097 -- type T1 is tagged null record;
3098 -- procedure Prim (O : T1);
3101 -- type T2 is new Pkg.T1 with null record;
3102 -- procedure Prim (X : T2) is -- late overriding
3108 function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is
3109 Loc : constant Source_Ptr := Sloc (Typ);
3111 Max_Predef_Prims : constant Int :=
3115 (Parent (RTE (RE_Max_Predef_Prims)))));
3117 DT_Decl : constant Elist_Id := New_Elmt_List;
3118 DT_Aggr : constant Elist_Id := New_Elmt_List;
3119 -- Entities marked with attribute Is_Dispatch_Table_Entity
3121 procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id);
3122 -- Verify that all non-tagged types in the profile of a subprogram
3123 -- are frozen at the point the subprogram is frozen. This enforces
3124 -- the rule on RM 13.14 (14) as modified by AI05-019. At the point a
3125 -- subprogram is frozen, enough must be known about it to build the
3126 -- activation record for it, which requires at least that the size of
3127 -- all parameters be known. Controlling arguments are by-reference,
3128 -- and therefore the rule only applies to non-tagged types.
3129 -- Typical violation of the rule involves an object declaration that
3130 -- freezes a tagged type, when one of its primitive operations has a
3131 -- type in its profile whose full view has not been analyzed yet.
3133 procedure Export_DT (Typ : Entity_Id; DT : Entity_Id);
3134 -- Export the dispatch table entity DT of tagged type Typ. Required to
3135 -- generate forward references and statically allocate the table.
3137 procedure Make_Secondary_DT
3140 Num_Iface_Prims : Nat;
3141 Iface_DT_Ptr : Entity_Id;
3142 Predef_Prims_Ptr : Entity_Id;
3143 Build_Thunks : Boolean;
3145 -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch
3146 -- Table of Typ associated with Iface. Each abstract interface of Typ
3147 -- has two secondary dispatch tables: one containing pointers to thunks
3148 -- and another containing pointers to the primitives covering the
3149 -- interface primitives. The former secondary table is generated when
3150 -- Build_Thunks is True, and provides common support for dispatching
3151 -- calls through interface types; the latter secondary table is
3152 -- generated when Build_Thunks is False, and provides support for
3153 -- Generic Dispatching Constructors that dispatch calls through
3156 ------------------------------
3157 -- Check_Premature_Freezing --
3158 ------------------------------
3160 procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id) is
3163 and then Is_Private_Type (Typ)
3164 and then No (Full_View (Typ))
3165 and then not Is_Generic_Type (Typ)
3166 and then not Is_Tagged_Type (Typ)
3167 and then not Is_Frozen (Typ)
3169 Error_Msg_Sloc := Sloc (Subp);
3171 ("declaration must appear after completion of type &", N, Typ);
3173 ("\which is an untagged type in the profile of"
3174 & " primitive operation & declared#",
3177 end Check_Premature_Freezing;
3183 procedure Export_DT (Typ : Entity_Id; DT : Entity_Id) is
3185 Set_Is_Statically_Allocated (DT);
3186 Set_Is_True_Constant (DT);
3187 Set_Is_Exported (DT);
3189 pragma Assert (Present (Dispatch_Table_Wrapper (Typ)));
3190 Get_External_Name (Dispatch_Table_Wrapper (Typ), True);
3191 Set_Interface_Name (DT,
3192 Make_String_Literal (Loc,
3193 Strval => String_From_Name_Buffer));
3195 -- Ensure proper Sprint output of this implicit importation
3197 Set_Is_Internal (DT);
3201 -----------------------
3202 -- Make_Secondary_DT --
3203 -----------------------
3205 procedure Make_Secondary_DT
3208 Num_Iface_Prims : Nat;
3209 Iface_DT_Ptr : Entity_Id;
3210 Predef_Prims_Ptr : Entity_Id;
3211 Build_Thunks : Boolean;
3214 Loc : constant Source_Ptr := Sloc (Typ);
3215 Name_DT : constant Name_Id := New_Internal_Name ('T');
3216 Iface_DT : constant Entity_Id :=
3217 Make_Defining_Identifier (Loc, Name_DT);
3218 Name_Predef_Prims : constant Name_Id := New_Internal_Name ('R');
3219 Predef_Prims : constant Entity_Id :=
3220 Make_Defining_Identifier (Loc,
3222 DT_Constr_List : List_Id;
3223 DT_Aggr_List : List_Id;
3224 Empty_DT : Boolean := False;
3225 Nb_Predef_Prims : Nat := 0;
3229 OSD_Aggr_List : List_Id;
3232 Prim_Elmt : Elmt_Id;
3233 Prim_Ops_Aggr_List : List_Id;
3236 -- Handle cases in which we do not generate statically allocated
3239 if not Building_Static_DT (Typ) then
3240 Set_Ekind (Predef_Prims, E_Variable);
3241 Set_Ekind (Iface_DT, E_Variable);
3243 -- Statically allocated dispatch tables and related entities are
3247 Set_Ekind (Predef_Prims, E_Constant);
3248 Set_Is_Statically_Allocated (Predef_Prims);
3249 Set_Is_True_Constant (Predef_Prims);
3251 Set_Ekind (Iface_DT, E_Constant);
3252 Set_Is_Statically_Allocated (Iface_DT);
3253 Set_Is_True_Constant (Iface_DT);
3256 -- Generate code to create the storage for the Dispatch_Table object.
3257 -- If the number of primitives of Typ is 0 we reserve a dummy single
3258 -- entry for its DT because at run-time the pointer to this dummy
3259 -- entry will be used as the tag.
3261 if Num_Iface_Prims = 0 then
3265 Nb_Prim := Num_Iface_Prims;
3270 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
3271 -- (predef-prim-op-thunk-1'address,
3272 -- predef-prim-op-thunk-2'address,
3274 -- predef-prim-op-thunk-n'address);
3275 -- for Predef_Prims'Alignment use Address'Alignment
3277 -- Stage 1: Calculate the number of predefined primitives
3279 if not Building_Static_DT (Typ) then
3280 Nb_Predef_Prims := Max_Predef_Prims;
3282 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3283 while Present (Prim_Elmt) loop
3284 Prim := Node (Prim_Elmt);
3286 if Is_Predefined_Dispatching_Operation (Prim)
3287 and then not Is_Abstract_Subprogram (Prim)
3289 Pos := UI_To_Int (DT_Position (Prim));
3291 if Pos > Nb_Predef_Prims then
3292 Nb_Predef_Prims := Pos;
3296 Next_Elmt (Prim_Elmt);
3300 -- Stage 2: Create the thunks associated with the predefined
3301 -- primitives and save their entity to fill the aggregate.
3304 Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
3306 Thunk_Id : Entity_Id;
3307 Thunk_Code : Node_Id;
3310 Prim_Ops_Aggr_List := New_List;
3311 Prim_Table := (others => Empty);
3313 if Building_Static_DT (Typ) then
3314 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3315 while Present (Prim_Elmt) loop
3316 Prim := Node (Prim_Elmt);
3318 if Is_Predefined_Dispatching_Operation (Prim)
3319 and then not Is_Abstract_Subprogram (Prim)
3320 and then not Present (Prim_Table
3321 (UI_To_Int (DT_Position (Prim))))
3323 if not Build_Thunks then
3324 Prim_Table (UI_To_Int (DT_Position (Prim))) :=
3328 while Present (Alias (Prim)) loop
3329 Prim := Alias (Prim);
3332 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
3334 if Present (Thunk_Id) then
3335 Append_To (Result, Thunk_Code);
3336 Prim_Table (UI_To_Int (DT_Position (Prim)))
3342 Next_Elmt (Prim_Elmt);
3346 for J in Prim_Table'Range loop
3347 if Present (Prim_Table (J)) then
3349 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
3350 Make_Attribute_Reference (Loc,
3351 Prefix => New_Reference_To (Prim_Table (J), Loc),
3352 Attribute_Name => Name_Unrestricted_Access));
3354 New_Node := Make_Null (Loc);
3357 Append_To (Prim_Ops_Aggr_List, New_Node);
3361 Make_Aggregate (Loc,
3362 Expressions => Prim_Ops_Aggr_List);
3364 -- Remember aggregates initializing dispatch tables
3366 Append_Elmt (New_Node, DT_Aggr);
3369 Make_Subtype_Declaration (Loc,
3370 Defining_Identifier =>
3371 Make_Defining_Identifier (Loc,
3372 New_Internal_Name ('S')),
3373 Subtype_Indication =>
3374 New_Reference_To (RTE (RE_Address_Array), Loc));
3376 Append_To (Result, Decl);
3379 Make_Object_Declaration (Loc,
3380 Defining_Identifier => Predef_Prims,
3381 Constant_Present => Building_Static_DT (Typ),
3382 Aliased_Present => True,
3383 Object_Definition => New_Reference_To
3384 (Defining_Identifier (Decl), Loc),
3385 Expression => New_Node));
3388 Make_Attribute_Definition_Clause (Loc,
3389 Name => New_Reference_To (Predef_Prims, Loc),
3390 Chars => Name_Alignment,
3392 Make_Attribute_Reference (Loc,
3394 New_Reference_To (RTE (RE_Integer_Address), Loc),
3395 Attribute_Name => Name_Alignment)));
3400 -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
3401 -- (OSD_Table => (1 => <value>,
3405 -- Iface_DT : Dispatch_Table (Nb_Prims) :=
3406 -- ([ Signature => <sig-value> ],
3407 -- Tag_Kind => <tag_kind-value>,
3408 -- Predef_Prims => Predef_Prims'Address,
3409 -- Offset_To_Top => 0,
3410 -- OSD => OSD'Address,
3411 -- Prims_Ptr => (prim-op-1'address,
3412 -- prim-op-2'address,
3414 -- prim-op-n'address));
3416 -- Stage 3: Initialize the discriminant and the record components
3418 DT_Constr_List := New_List;
3419 DT_Aggr_List := New_List;
3421 -- Nb_Prim. If the tagged type has no primitives we add a dummy
3422 -- slot whose address will be the tag of this type.
3425 New_Node := Make_Integer_Literal (Loc, 1);
3427 New_Node := Make_Integer_Literal (Loc, Nb_Prim);
3430 Append_To (DT_Constr_List, New_Node);
3431 Append_To (DT_Aggr_List, New_Copy (New_Node));
3435 if RTE_Record_Component_Available (RE_Signature) then
3436 Append_To (DT_Aggr_List,
3437 New_Reference_To (RTE (RE_Secondary_DT), Loc));
3442 if RTE_Record_Component_Available (RE_Tag_Kind) then
3443 Append_To (DT_Aggr_List, Tagged_Kind (Typ));
3448 Append_To (DT_Aggr_List,
3449 Make_Attribute_Reference (Loc,
3450 Prefix => New_Reference_To (Predef_Prims, Loc),
3451 Attribute_Name => Name_Address));
3453 -- Note: The correct value of Offset_To_Top will be set by the init
3456 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
3458 -- Generate the Object Specific Data table required to dispatch calls
3459 -- through synchronized interfaces.
3462 or else Is_Abstract_Type (Typ)
3463 or else Is_Controlled (Typ)
3464 or else Restriction_Active (No_Dispatching_Calls)
3465 or else not Is_Limited_Type (Typ)
3466 or else not Has_Interfaces (Typ)
3467 or else not Build_Thunks
3469 -- No OSD table required
3471 Append_To (DT_Aggr_List,
3472 New_Reference_To (RTE (RE_Null_Address), Loc));
3475 OSD_Aggr_List := New_List;
3478 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
3480 Prim_Alias : Entity_Id;
3481 Prim_Elmt : Elmt_Id;
3487 Prim_Table := (others => Empty);
3488 Prim_Alias := Empty;
3490 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3491 while Present (Prim_Elmt) loop
3492 Prim := Node (Prim_Elmt);
3494 if Present (Interface_Alias (Prim))
3495 and then Find_Dispatching_Type
3496 (Interface_Alias (Prim)) = Iface
3498 Prim_Alias := Interface_Alias (Prim);
3501 while Present (Alias (E)) loop
3505 Pos := UI_To_Int (DT_Position (Prim_Alias));
3507 if Present (Prim_Table (Pos)) then
3508 pragma Assert (Prim_Table (Pos) = E);
3512 Prim_Table (Pos) := E;
3514 Append_To (OSD_Aggr_List,
3515 Make_Component_Association (Loc,
3516 Choices => New_List (
3517 Make_Integer_Literal (Loc,
3518 DT_Position (Prim_Alias))),
3520 Make_Integer_Literal (Loc,
3521 DT_Position (Alias (Prim)))));
3527 Next_Elmt (Prim_Elmt);
3529 pragma Assert (Count = Nb_Prim);
3532 OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
3535 Make_Object_Declaration (Loc,
3536 Defining_Identifier => OSD,
3537 Object_Definition =>
3538 Make_Subtype_Indication (Loc,
3540 New_Reference_To (RTE (RE_Object_Specific_Data), Loc),
3542 Make_Index_Or_Discriminant_Constraint (Loc,
3543 Constraints => New_List (
3544 Make_Integer_Literal (Loc, Nb_Prim)))),
3545 Expression => Make_Aggregate (Loc,
3546 Component_Associations => New_List (
3547 Make_Component_Association (Loc,
3548 Choices => New_List (
3550 (RTE_Record_Component (RE_OSD_Num_Prims), Loc)),
3552 Make_Integer_Literal (Loc, Nb_Prim)),
3554 Make_Component_Association (Loc,
3555 Choices => New_List (
3557 (RTE_Record_Component (RE_OSD_Table), Loc)),
3558 Expression => Make_Aggregate (Loc,
3559 Component_Associations => OSD_Aggr_List))))));
3562 Make_Attribute_Definition_Clause (Loc,
3563 Name => New_Reference_To (OSD, Loc),
3564 Chars => Name_Alignment,
3566 Make_Attribute_Reference (Loc,
3568 New_Reference_To (RTE (RE_Integer_Address), Loc),
3569 Attribute_Name => Name_Alignment)));
3571 -- In secondary dispatch tables the Typeinfo component contains
3572 -- the address of the Object Specific Data (see a-tags.ads)
3574 Append_To (DT_Aggr_List,
3575 Make_Attribute_Reference (Loc,
3576 Prefix => New_Reference_To (OSD, Loc),
3577 Attribute_Name => Name_Address));
3580 -- Initialize the table of primitive operations
3582 Prim_Ops_Aggr_List := New_List;
3585 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
3587 elsif Is_Abstract_Type (Typ)
3588 or else not Building_Static_DT (Typ)
3590 for J in 1 .. Nb_Prim loop
3591 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
3596 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
3598 Thunk_Code : Node_Id;
3599 Thunk_Id : Entity_Id;
3602 Prim_Table := (others => Empty);
3604 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3605 while Present (Prim_Elmt) loop
3606 Prim := Node (Prim_Elmt);
3608 if not Is_Predefined_Dispatching_Operation (Prim)
3609 and then Present (Interface_Alias (Prim))
3610 and then not Is_Abstract_Subprogram (Alias (Prim))
3611 and then not Is_Imported (Alias (Prim))
3612 and then Find_Dispatching_Type
3613 (Interface_Alias (Prim)) = Iface
3615 -- Generate the code of the thunk only if the abstract
3616 -- interface type is not an immediate ancestor of
3617 -- Tagged_Type; otherwise the DT associated with the
3618 -- interface is the primary DT.
3620 and then not Is_Ancestor (Iface, Typ)
3622 if not Build_Thunks then
3624 UI_To_Int (DT_Position (Interface_Alias (Prim)));
3625 Prim_Table (Pos) := Alias (Prim);
3627 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
3629 if Present (Thunk_Id) then
3631 UI_To_Int (DT_Position (Interface_Alias (Prim)));
3633 Prim_Table (Pos) := Thunk_Id;
3634 Append_To (Result, Thunk_Code);
3639 Next_Elmt (Prim_Elmt);
3642 for J in Prim_Table'Range loop
3643 if Present (Prim_Table (J)) then
3645 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
3646 Make_Attribute_Reference (Loc,
3647 Prefix => New_Reference_To (Prim_Table (J), Loc),
3648 Attribute_Name => Name_Unrestricted_Access));
3650 New_Node := Make_Null (Loc);
3653 Append_To (Prim_Ops_Aggr_List, New_Node);
3659 Make_Aggregate (Loc,
3660 Expressions => Prim_Ops_Aggr_List);
3662 Append_To (DT_Aggr_List, New_Node);
3664 -- Remember aggregates initializing dispatch tables
3666 Append_Elmt (New_Node, DT_Aggr);
3669 Make_Object_Declaration (Loc,
3670 Defining_Identifier => Iface_DT,
3671 Aliased_Present => True,
3672 Object_Definition =>
3673 Make_Subtype_Indication (Loc,
3674 Subtype_Mark => New_Reference_To
3675 (RTE (RE_Dispatch_Table_Wrapper), Loc),
3676 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
3677 Constraints => DT_Constr_List)),
3679 Expression => Make_Aggregate (Loc,
3680 Expressions => DT_Aggr_List)));
3683 Make_Attribute_Definition_Clause (Loc,
3684 Name => New_Reference_To (Iface_DT, Loc),
3685 Chars => Name_Alignment,
3687 Make_Attribute_Reference (Loc,
3689 New_Reference_To (RTE (RE_Integer_Address), Loc),
3690 Attribute_Name => Name_Alignment)));
3692 -- Generate code to create the pointer to the dispatch table
3694 -- Iface_DT_Ptr : Tag := Tag!(DT'Address);
3697 Make_Object_Declaration (Loc,
3698 Defining_Identifier => Iface_DT_Ptr,
3699 Constant_Present => True,
3700 Object_Definition =>
3701 New_Reference_To (RTE (RE_Interface_Tag), Loc),
3703 Unchecked_Convert_To (RTE (RE_Interface_Tag),
3704 Make_Attribute_Reference (Loc,
3706 Make_Selected_Component (Loc,
3707 Prefix => New_Reference_To (Iface_DT, Loc),
3710 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
3711 Attribute_Name => Name_Address))));
3714 Make_Object_Declaration (Loc,
3715 Defining_Identifier => Predef_Prims_Ptr,
3716 Constant_Present => True,
3717 Object_Definition =>
3718 New_Reference_To (RTE (RE_Address), Loc),
3720 Make_Attribute_Reference (Loc,
3722 Make_Selected_Component (Loc,
3723 Prefix => New_Reference_To (Iface_DT, Loc),
3726 (RTE_Record_Component (RE_Predef_Prims), Loc)),
3727 Attribute_Name => Name_Address)));
3729 -- Remember entities containing dispatch tables
3731 Append_Elmt (Predef_Prims, DT_Decl);
3732 Append_Elmt (Iface_DT, DT_Decl);
3733 end Make_Secondary_DT;
3737 Elab_Code : constant List_Id := New_List;
3738 Result : constant List_Id := New_List;
3739 Tname : constant Name_Id := Chars (Typ);
3741 AI_Tag_Elmt : Elmt_Id;
3742 AI_Tag_Comp : Elmt_Id;
3743 DT_Aggr_List : List_Id;
3744 DT_Constr_List : List_Id;
3748 Iface_Table_Node : Node_Id;
3749 Name_ITable : Name_Id;
3750 Nb_Predef_Prims : Nat := 0;
3753 Num_Ifaces : Nat := 0;
3754 Parent_Typ : Entity_Id;
3756 Prim_Elmt : Elmt_Id;
3757 Prim_Ops_Aggr_List : List_Id;
3759 Typ_Comps : Elist_Id;
3760 Typ_Ifaces : Elist_Id;
3761 TSD_Aggr_List : List_Id;
3762 TSD_Tags_List : List_Id;
3764 -- The following name entries are used by Make_DT to generate a number
3765 -- of entities related to a tagged type. These entities may be generated
3766 -- in a scope other than that of the tagged type declaration, and if
3767 -- the entities for two tagged types with the same name happen to be
3768 -- generated in the same scope, we have to take care to use different
3769 -- names. This is achieved by means of a unique serial number appended
3770 -- to each generated entity name.
3772 Name_DT : constant Name_Id :=
3773 New_External_Name (Tname, 'T', Suffix_Index => -1);
3774 Name_Exname : constant Name_Id :=
3775 New_External_Name (Tname, 'E', Suffix_Index => -1);
3776 Name_HT_Link : constant Name_Id :=
3777 New_External_Name (Tname, 'H', Suffix_Index => -1);
3778 Name_Predef_Prims : constant Name_Id :=
3779 New_External_Name (Tname, 'R', Suffix_Index => -1);
3780 Name_SSD : constant Name_Id :=
3781 New_External_Name (Tname, 'S', Suffix_Index => -1);
3782 Name_TSD : constant Name_Id :=
3783 New_External_Name (Tname, 'B', Suffix_Index => -1);
3785 -- Entities built with above names
3787 DT : constant Entity_Id :=
3788 Make_Defining_Identifier (Loc, Name_DT);
3789 Exname : constant Entity_Id :=
3790 Make_Defining_Identifier (Loc, Name_Exname);
3791 HT_Link : constant Entity_Id :=
3792 Make_Defining_Identifier (Loc, Name_HT_Link);
3793 Predef_Prims : constant Entity_Id :=
3794 Make_Defining_Identifier (Loc, Name_Predef_Prims);
3795 SSD : constant Entity_Id :=
3796 Make_Defining_Identifier (Loc, Name_SSD);
3797 TSD : constant Entity_Id :=
3798 Make_Defining_Identifier (Loc, Name_TSD);
3800 -- Start of processing for Make_DT
3803 pragma Assert (Is_Frozen (Typ));
3805 -- Handle cases in which there is no need to build the dispatch table
3807 if Has_Dispatch_Table (Typ)
3808 or else No (Access_Disp_Table (Typ))
3809 or else Is_CPP_Class (Typ)
3813 elsif No_Run_Time_Mode then
3814 Error_Msg_CRT ("tagged types", Typ);
3817 elsif not RTE_Available (RE_Tag) then
3819 Make_Object_Declaration (Loc,
3820 Defining_Identifier => Node (First_Elmt
3821 (Access_Disp_Table (Typ))),
3822 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
3823 Constant_Present => True,
3825 Unchecked_Convert_To (RTE (RE_Tag),
3826 New_Reference_To (RTE (RE_Null_Address), Loc))));
3828 Analyze_List (Result, Suppress => All_Checks);
3829 Error_Msg_CRT ("tagged types", Typ);
3833 -- Ensure that the value of Max_Predef_Prims defined in a-tags is
3834 -- correct. Valid values are 10 under configurable runtime or 16
3835 -- with full runtime.
3837 if RTE_Available (RE_Interface_Data) then
3838 if Max_Predef_Prims /= 16 then
3839 Error_Msg_N ("run-time library configuration error", Typ);
3843 if Max_Predef_Prims /= 10 then
3844 Error_Msg_N ("run-time library configuration error", Typ);
3845 Error_Msg_CRT ("tagged types", Typ);
3850 -- Initialize Parent_Typ handling private types
3852 Parent_Typ := Etype (Typ);
3854 if Present (Full_View (Parent_Typ)) then
3855 Parent_Typ := Full_View (Parent_Typ);
3858 -- Ensure that all the primitives are frozen. This is only required when
3859 -- building static dispatch tables --- the primitives must be frozen to
3860 -- be referenced (otherwise we have problems with the backend). It is
3861 -- not a requirement with nonstatic dispatch tables because in this case
3862 -- we generate now an empty dispatch table; the extra code required to
3863 -- register the primitives in the slots will be generated later --- when
3864 -- each primitive is frozen (see Freeze_Subprogram).
3866 if Building_Static_DT (Typ)
3867 and then not Is_CPP_Class (Typ)
3870 Save : constant Boolean := Freezing_Library_Level_Tagged_Type;
3871 Prim_Elmt : Elmt_Id;
3875 Freezing_Library_Level_Tagged_Type := True;
3876 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3877 while Present (Prim_Elmt) loop
3878 Frnodes := Freeze_Entity (Node (Prim_Elmt), Loc);
3881 Subp : constant Entity_Id := Node (Prim_Elmt);
3885 F := First_Formal (Subp);
3886 while Present (F) loop
3887 Check_Premature_Freezing (Subp, Etype (F));
3891 Check_Premature_Freezing (Subp, Etype (Subp));
3894 if Present (Frnodes) then
3895 Append_List_To (Result, Frnodes);
3898 Next_Elmt (Prim_Elmt);
3900 Freezing_Library_Level_Tagged_Type := Save;
3904 -- Ada 2005 (AI-251): Build the secondary dispatch tables
3906 if Has_Interfaces (Typ) then
3907 Collect_Interface_Components (Typ, Typ_Comps);
3911 Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
3913 AI_Tag_Comp := First_Elmt (Typ_Comps);
3914 while Present (AI_Tag_Comp) loop
3916 -- Build the secondary table containing pointers to thunks
3920 Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))),
3921 Num_Iface_Prims => UI_To_Int
3922 (DT_Entry_Count (Node (AI_Tag_Comp))),
3923 Iface_DT_Ptr => Node (AI_Tag_Elmt),
3924 Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
3925 Build_Thunks => True,
3927 Next_Elmt (AI_Tag_Elmt);
3929 -- Skip the secondary dispatch table of predefined primitives
3931 Next_Elmt (AI_Tag_Elmt);
3933 -- Build the secondary table containing pointers to primitives
3934 -- (used to give support to Generic Dispatching Constructors).
3938 Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))),
3939 Num_Iface_Prims => UI_To_Int
3940 (DT_Entry_Count (Node (AI_Tag_Comp))),
3941 Iface_DT_Ptr => Node (AI_Tag_Elmt),
3942 Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
3943 Build_Thunks => False,
3945 Next_Elmt (AI_Tag_Elmt);
3947 -- Skip the secondary dispatch table of predefined primitives
3949 Next_Elmt (AI_Tag_Elmt);
3951 Suffix_Index := Suffix_Index + 1;
3952 Next_Elmt (AI_Tag_Comp);
3956 -- Get the _tag entity and the number of primitives of its dispatch
3959 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
3960 Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
3962 Set_Is_Statically_Allocated (DT, Is_Library_Level_Tagged_Type (Typ));
3963 Set_Is_Statically_Allocated (SSD, Is_Library_Level_Tagged_Type (Typ));
3964 Set_Is_Statically_Allocated (TSD, Is_Library_Level_Tagged_Type (Typ));
3965 Set_Is_Statically_Allocated (Predef_Prims,
3966 Is_Library_Level_Tagged_Type (Typ));
3968 -- In case of locally defined tagged type we declare the object
3969 -- containing the dispatch table by means of a variable. Its
3970 -- initialization is done later by means of an assignment. This is
3971 -- required to generate its External_Tag.
3973 if not Building_Static_DT (Typ) then
3976 -- DT : No_Dispatch_Table_Wrapper;
3977 -- for DT'Alignment use Address'Alignment;
3978 -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
3980 if not Has_DT (Typ) then
3982 Make_Object_Declaration (Loc,
3983 Defining_Identifier => DT,
3984 Aliased_Present => True,
3985 Constant_Present => False,
3986 Object_Definition =>
3988 (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
3991 Make_Attribute_Definition_Clause (Loc,
3992 Name => New_Reference_To (DT, Loc),
3993 Chars => Name_Alignment,
3995 Make_Attribute_Reference (Loc,
3997 New_Reference_To (RTE (RE_Integer_Address), Loc),
3998 Attribute_Name => Name_Alignment)));
4001 Make_Object_Declaration (Loc,
4002 Defining_Identifier => DT_Ptr,
4003 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
4004 Constant_Present => True,
4006 Unchecked_Convert_To (RTE (RE_Tag),
4007 Make_Attribute_Reference (Loc,
4009 Make_Selected_Component (Loc,
4010 Prefix => New_Reference_To (DT, Loc),
4013 (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
4014 Attribute_Name => Name_Address))));
4017 -- DT : Dispatch_Table_Wrapper (Nb_Prim);
4018 -- for DT'Alignment use Address'Alignment;
4019 -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
4022 -- If the tagged type has no primitives we add a dummy slot
4023 -- whose address will be the tag of this type.
4027 New_List (Make_Integer_Literal (Loc, 1));
4030 New_List (Make_Integer_Literal (Loc, Nb_Prim));
4034 Make_Object_Declaration (Loc,
4035 Defining_Identifier => DT,
4036 Aliased_Present => True,
4037 Constant_Present => False,
4038 Object_Definition =>
4039 Make_Subtype_Indication (Loc,
4041 New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc),
4042 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
4043 Constraints => DT_Constr_List))));
4046 Make_Attribute_Definition_Clause (Loc,
4047 Name => New_Reference_To (DT, Loc),
4048 Chars => Name_Alignment,
4050 Make_Attribute_Reference (Loc,
4052 New_Reference_To (RTE (RE_Integer_Address), Loc),
4053 Attribute_Name => Name_Alignment)));
4056 Make_Object_Declaration (Loc,
4057 Defining_Identifier => DT_Ptr,
4058 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
4059 Constant_Present => True,
4061 Unchecked_Convert_To (RTE (RE_Tag),
4062 Make_Attribute_Reference (Loc,
4064 Make_Selected_Component (Loc,
4065 Prefix => New_Reference_To (DT, Loc),
4068 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
4069 Attribute_Name => Name_Address))));
4072 Make_Object_Declaration (Loc,
4073 Defining_Identifier =>
4074 Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))),
4075 Constant_Present => True,
4076 Object_Definition => New_Reference_To
4077 (RTE (RE_Address), Loc),
4079 Make_Attribute_Reference (Loc,
4081 Make_Selected_Component (Loc,
4082 Prefix => New_Reference_To (DT, Loc),
4085 (RTE_Record_Component (RE_Predef_Prims), Loc)),
4086 Attribute_Name => Name_Address)));
4090 -- Generate: Exname : constant String := full_qualified_name (typ);
4091 -- The type itself may be an anonymous parent type, so use the first
4092 -- subtype to have a user-recognizable name.
4095 Make_Object_Declaration (Loc,
4096 Defining_Identifier => Exname,
4097 Constant_Present => True,
4098 Object_Definition => New_Reference_To (Standard_String, Loc),
4100 Make_String_Literal (Loc,
4101 Full_Qualified_Name (First_Subtype (Typ)))));
4103 Set_Is_Statically_Allocated (Exname);
4104 Set_Is_True_Constant (Exname);
4106 -- Declare the object used by Ada.Tags.Register_Tag
4108 if RTE_Available (RE_Register_Tag) then
4110 Make_Object_Declaration (Loc,
4111 Defining_Identifier => HT_Link,
4112 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc)));
4115 -- Generate code to create the storage for the type specific data object
4116 -- with enough space to store the tags of the ancestors plus the tags
4117 -- of all the implemented interfaces (as described in a-tags.adb).
4119 -- TSD : Type_Specific_Data (I_Depth) :=
4120 -- (Idepth => I_Depth,
4121 -- Access_Level => Type_Access_Level (Typ),
4122 -- Expanded_Name => Cstring_Ptr!(Exname'Address))
4123 -- External_Tag => Cstring_Ptr!(Exname'Address))
4124 -- HT_Link => HT_Link'Address,
4125 -- Transportable => <<boolean-value>>,
4126 -- RC_Offset => <<integer-value>>,
4127 -- [ Size_Func => Size_Prim'Access ]
4128 -- [ Interfaces_Table => <<access-value>> ]
4129 -- [ SSD => SSD_Table'Address ]
4130 -- Tags_Table => (0 => null,
4133 -- for TSD'Alignment use Address'Alignment
4135 TSD_Aggr_List := New_List;
4137 -- Idepth: Count ancestors to compute the inheritance depth. For private
4138 -- extensions, always go to the full view in order to compute the real
4139 -- inheritance depth.
4142 Current_Typ : Entity_Id;
4143 Parent_Typ : Entity_Id;
4149 Parent_Typ := Etype (Current_Typ);
4151 if Is_Private_Type (Parent_Typ) then
4152 Parent_Typ := Full_View (Base_Type (Parent_Typ));
4155 exit when Parent_Typ = Current_Typ;
4157 I_Depth := I_Depth + 1;
4158 Current_Typ := Parent_Typ;
4162 Append_To (TSD_Aggr_List,
4163 Make_Integer_Literal (Loc, I_Depth));
4167 Append_To (TSD_Aggr_List,
4168 Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
4172 Append_To (TSD_Aggr_List,
4173 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4174 Make_Attribute_Reference (Loc,
4175 Prefix => New_Reference_To (Exname, Loc),
4176 Attribute_Name => Name_Address)));
4178 -- External_Tag of a local tagged type
4180 -- <typ>A : constant String :=
4181 -- "Internal tag at 16#tag-addr#: <full-name-of-typ>";
4183 -- The reason we generate this strange name is that we do not want to
4184 -- enter local tagged types in the global hash table used to compute
4185 -- the Internal_Tag attribute for two reasons:
4187 -- 1. It is hard to avoid a tasking race condition for entering the
4188 -- entry into the hash table.
4190 -- 2. It would cause a storage leak, unless we rig up considerable
4191 -- mechanism to remove the entry from the hash table on exit.
4193 -- So what we do is to generate the above external tag name, where the
4194 -- hex address is the address of the local dispatch table (i.e. exactly
4195 -- the value we want if Internal_Tag is computed from this string).
4197 -- Of course this value will only be valid if the tagged type is still
4198 -- in scope, but it clearly must be erroneous to compute the internal
4199 -- tag of a tagged type that is out of scope!
4201 -- We don't do this processing if an explicit external tag has been
4202 -- specified. That's an odd case for which we have already issued a
4203 -- warning, where we will not be able to compute the internal tag.
4205 if not Is_Library_Level_Entity (Typ)
4206 and then not Has_External_Tag_Rep_Clause (Typ)
4209 Exname : constant Entity_Id :=
4210 Make_Defining_Identifier (Loc,
4211 New_External_Name (Tname, 'A'));
4213 Full_Name : constant String_Id :=
4214 Full_Qualified_Name (First_Subtype (Typ));
4215 Str1_Id : String_Id;
4216 Str2_Id : String_Id;
4220 -- Str1 = "Internal tag at 16#";
4223 Store_String_Chars ("Internal tag at 16#");
4224 Str1_Id := End_String;
4227 -- Str2 = "#: <type-full-name>";
4230 Store_String_Chars ("#: ");
4231 Store_String_Chars (Full_Name);
4232 Str2_Id := End_String;
4235 -- Exname : constant String :=
4236 -- Str1 & Address_Image (Tag) & Str2;
4238 if RTE_Available (RE_Address_Image) then
4240 Make_Object_Declaration (Loc,
4241 Defining_Identifier => Exname,
4242 Constant_Present => True,
4243 Object_Definition => New_Reference_To
4244 (Standard_String, Loc),
4246 Make_Op_Concat (Loc,
4248 Make_String_Literal (Loc, Str1_Id),
4250 Make_Op_Concat (Loc,
4252 Make_Function_Call (Loc,
4255 (RTE (RE_Address_Image), Loc),
4256 Parameter_Associations => New_List (
4257 Unchecked_Convert_To (RTE (RE_Address),
4258 New_Reference_To (DT_Ptr, Loc)))),
4260 Make_String_Literal (Loc, Str2_Id)))));
4264 Make_Object_Declaration (Loc,
4265 Defining_Identifier => Exname,
4266 Constant_Present => True,
4267 Object_Definition => New_Reference_To
4268 (Standard_String, Loc),
4270 Make_Op_Concat (Loc,
4272 Make_String_Literal (Loc, Str1_Id),
4274 Make_String_Literal (Loc, Str2_Id))));
4278 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4279 Make_Attribute_Reference (Loc,
4280 Prefix => New_Reference_To (Exname, Loc),
4281 Attribute_Name => Name_Address));
4284 -- External tag of a library-level tagged type: Check for a definition
4285 -- of External_Tag. The clause is considered only if it applies to this
4286 -- specific tagged type, as opposed to one of its ancestors.
4287 -- If the type is an unconstrained type extension, we are building the
4288 -- dispatch table of its anonymous base type, so the external tag, if
4289 -- any was specified, must be retrieved from the first subtype.
4293 Def : constant Node_Id := Get_Attribute_Definition_Clause
4294 (First_Subtype (Typ),
4295 Attribute_External_Tag);
4297 Old_Val : String_Id;
4298 New_Val : String_Id;
4302 if not Present (Def)
4303 or else Entity (Name (Def)) /= First_Subtype (Typ)
4306 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4307 Make_Attribute_Reference (Loc,
4308 Prefix => New_Reference_To (Exname, Loc),
4309 Attribute_Name => Name_Address));
4311 Old_Val := Strval (Expr_Value_S (Expression (Def)));
4313 -- For the rep clause "for <typ>'external_tag use y" generate:
4315 -- <typ>A : constant string := y;
4317 -- <typ>A'Address is used to set the External_Tag component
4320 -- Create a new nul terminated string if it is not already
4322 if String_Length (Old_Val) > 0
4324 Get_String_Char (Old_Val, String_Length (Old_Val)) = 0
4328 Start_String (Old_Val);
4329 Store_String_Char (Get_Char_Code (ASCII.NUL));
4330 New_Val := End_String;
4333 E := Make_Defining_Identifier (Loc,
4334 New_External_Name (Chars (Typ), 'A'));
4337 Make_Object_Declaration (Loc,
4338 Defining_Identifier => E,
4339 Constant_Present => True,
4340 Object_Definition =>
4341 New_Reference_To (Standard_String, Loc),
4343 Make_String_Literal (Loc, New_Val)));
4346 Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4347 Make_Attribute_Reference (Loc,
4348 Prefix => New_Reference_To (E, Loc),
4349 Attribute_Name => Name_Address));
4354 Append_To (TSD_Aggr_List, New_Node);
4358 if RTE_Available (RE_Register_Tag) then
4359 Append_To (TSD_Aggr_List,
4360 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
4361 Make_Attribute_Reference (Loc,
4362 Prefix => New_Reference_To (HT_Link, Loc),
4363 Attribute_Name => Name_Address)));
4365 Append_To (TSD_Aggr_List,
4366 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
4367 New_Reference_To (RTE (RE_Null_Address), Loc)));
4370 -- Transportable: Set for types that can be used in remote calls
4371 -- with respect to E.4(18) legality rules.
4374 Transportable : Entity_Id;
4380 or else Is_Shared_Passive (Typ)
4382 ((Is_Remote_Types (Typ)
4383 or else Is_Remote_Call_Interface (Typ))
4384 and then Original_View_In_Visible_Part (Typ))
4385 or else not Comes_From_Source (Typ));
4387 Append_To (TSD_Aggr_List,
4388 New_Occurrence_Of (Transportable, Loc));
4391 -- RC_Offset: These are the valid values and their meaning:
4393 -- >0: For simple types with controlled components is
4394 -- type._record_controller'position
4396 -- 0: For types with no controlled components
4398 -- -1: For complex types with controlled components where the position
4399 -- of the record controller is not statically computable but there
4400 -- are controlled components at this level. The _Controller field
4401 -- is available right after the _parent.
4403 -- -2: There are no controlled components at this level. We need to
4404 -- get the position from the parent.
4407 RC_Offset_Node : Node_Id;
4410 if not Has_Controlled_Component (Typ) then
4411 RC_Offset_Node := Make_Integer_Literal (Loc, 0);
4413 elsif Etype (Typ) /= Typ
4414 and then Has_Discriminants (Parent_Typ)
4416 if Has_New_Controlled_Component (Typ) then
4417 RC_Offset_Node := Make_Integer_Literal (Loc, -1);
4419 RC_Offset_Node := Make_Integer_Literal (Loc, -2);
4423 Make_Attribute_Reference (Loc,
4425 Make_Selected_Component (Loc,
4426 Prefix => New_Reference_To (Typ, Loc),
4428 New_Reference_To (Controller_Component (Typ), Loc)),
4429 Attribute_Name => Name_Position);
4431 -- This is not proper Ada code to use the attribute 'Position
4432 -- on something else than an object but this is supported by
4433 -- the back end (see comment on the Bit_Component attribute in
4434 -- sem_attr). So we avoid semantic checking here.
4436 -- Is this documented in sinfo.ads??? it should be!
4438 Set_Analyzed (RC_Offset_Node);
4439 Set_Etype (Prefix (RC_Offset_Node), RTE (RE_Record_Controller));
4440 Set_Etype (Prefix (Prefix (RC_Offset_Node)), Typ);
4441 Set_Etype (Selector_Name (Prefix (RC_Offset_Node)),
4442 RTE (RE_Record_Controller));
4443 Set_Etype (RC_Offset_Node, RTE (RE_Storage_Offset));
4446 Append_To (TSD_Aggr_List, RC_Offset_Node);
4451 if RTE_Record_Component_Available (RE_Size_Func) then
4452 if not Building_Static_DT (Typ)
4453 or else Is_Interface (Typ)
4455 Append_To (TSD_Aggr_List,
4456 Unchecked_Convert_To (RTE (RE_Size_Ptr),
4457 New_Reference_To (RTE (RE_Null_Address), Loc)));
4461 Prim_Elmt : Elmt_Id;
4465 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4466 while Present (Prim_Elmt) loop
4467 Prim := Node (Prim_Elmt);
4469 if Chars (Prim) = Name_uSize then
4470 while Present (Alias (Prim)) loop
4471 Prim := Alias (Prim);
4474 if Is_Abstract_Subprogram (Prim) then
4475 Append_To (TSD_Aggr_List,
4476 Unchecked_Convert_To (RTE (RE_Size_Ptr),
4477 New_Reference_To (RTE (RE_Null_Address), Loc)));
4479 Append_To (TSD_Aggr_List,
4480 Unchecked_Convert_To (RTE (RE_Size_Ptr),
4481 Make_Attribute_Reference (Loc,
4482 Prefix => New_Reference_To (Prim, Loc),
4483 Attribute_Name => Name_Unrestricted_Access)));
4489 Next_Elmt (Prim_Elmt);
4495 -- Interfaces_Table (required for AI-405)
4497 if RTE_Record_Component_Available (RE_Interfaces_Table) then
4499 -- Count the number of interface types implemented by Typ
4501 Collect_Interfaces (Typ, Typ_Ifaces);
4503 AI := First_Elmt (Typ_Ifaces);
4504 while Present (AI) loop
4505 Num_Ifaces := Num_Ifaces + 1;
4509 if Num_Ifaces = 0 then
4510 Iface_Table_Node := Make_Null (Loc);
4512 -- Generate the Interface_Table object
4516 TSD_Ifaces_List : constant List_Id := New_List;
4518 Sec_DT_Tag : Node_Id;
4521 AI := First_Elmt (Typ_Ifaces);
4522 while Present (AI) loop
4523 if Is_Ancestor (Node (AI), Typ) then
4525 New_Reference_To (DT_Ptr, Loc);
4529 (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
4530 pragma Assert (Has_Thunks (Node (Elmt)));
4532 while Ekind (Node (Elmt)) = E_Constant
4534 Is_Ancestor (Node (AI), Related_Type (Node (Elmt)))
4536 pragma Assert (Has_Thunks (Node (Elmt)));
4538 pragma Assert (Has_Thunks (Node (Elmt)));
4540 pragma Assert (not Has_Thunks (Node (Elmt)));
4542 pragma Assert (not Has_Thunks (Node (Elmt)));
4546 pragma Assert (Ekind (Node (Elmt)) = E_Constant
4548 Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt)))));
4550 New_Reference_To (Node (Next_Elmt (Next_Elmt (Elmt))),
4554 Append_To (TSD_Ifaces_List,
4555 Make_Aggregate (Loc,
4556 Expressions => New_List (
4560 Unchecked_Convert_To (RTE (RE_Tag),
4562 (Node (First_Elmt (Access_Disp_Table (Node (AI)))),
4565 -- Static_Offset_To_Top
4567 New_Reference_To (Standard_True, Loc),
4569 -- Offset_To_Top_Value
4571 Make_Integer_Literal (Loc, 0),
4573 -- Offset_To_Top_Func
4579 Unchecked_Convert_To (RTE (RE_Tag), Sec_DT_Tag)
4586 Name_ITable := New_External_Name (Tname, 'I');
4587 ITable := Make_Defining_Identifier (Loc, Name_ITable);
4588 Set_Is_Statically_Allocated (ITable,
4589 Is_Library_Level_Tagged_Type (Typ));
4591 -- The table of interfaces is not constant; its slots are
4592 -- filled at run-time by the IP routine using attribute
4593 -- 'Position to know the location of the tag components
4594 -- (and this attribute cannot be safely used before the
4595 -- object is initialized).
4598 Make_Object_Declaration (Loc,
4599 Defining_Identifier => ITable,
4600 Aliased_Present => True,
4601 Constant_Present => False,
4602 Object_Definition =>
4603 Make_Subtype_Indication (Loc,
4605 New_Reference_To (RTE (RE_Interface_Data), Loc),
4606 Constraint => Make_Index_Or_Discriminant_Constraint
4608 Constraints => New_List (
4609 Make_Integer_Literal (Loc, Num_Ifaces)))),
4611 Expression => Make_Aggregate (Loc,
4612 Expressions => New_List (
4613 Make_Integer_Literal (Loc, Num_Ifaces),
4614 Make_Aggregate (Loc,
4615 Expressions => TSD_Ifaces_List)))));
4618 Make_Attribute_Definition_Clause (Loc,
4619 Name => New_Reference_To (ITable, Loc),
4620 Chars => Name_Alignment,
4622 Make_Attribute_Reference (Loc,
4624 New_Reference_To (RTE (RE_Integer_Address), Loc),
4625 Attribute_Name => Name_Alignment)));
4628 Make_Attribute_Reference (Loc,
4629 Prefix => New_Reference_To (ITable, Loc),
4630 Attribute_Name => Name_Unchecked_Access);
4634 Append_To (TSD_Aggr_List, Iface_Table_Node);
4637 -- Generate the Select Specific Data table for synchronized types that
4638 -- implement synchronized interfaces. The size of the table is
4639 -- constrained by the number of non-predefined primitive operations.
4641 if RTE_Record_Component_Available (RE_SSD) then
4642 if Ada_Version >= Ada_05
4643 and then Has_DT (Typ)
4644 and then Is_Concurrent_Record_Type (Typ)
4645 and then Has_Interfaces (Typ)
4646 and then Nb_Prim > 0
4647 and then not Is_Abstract_Type (Typ)
4648 and then not Is_Controlled (Typ)
4649 and then not Restriction_Active (No_Dispatching_Calls)
4652 Make_Object_Declaration (Loc,
4653 Defining_Identifier => SSD,
4654 Aliased_Present => True,
4655 Object_Definition =>
4656 Make_Subtype_Indication (Loc,
4657 Subtype_Mark => New_Reference_To (
4658 RTE (RE_Select_Specific_Data), Loc),
4660 Make_Index_Or_Discriminant_Constraint (Loc,
4661 Constraints => New_List (
4662 Make_Integer_Literal (Loc, Nb_Prim))))));
4665 Make_Attribute_Definition_Clause (Loc,
4666 Name => New_Reference_To (SSD, Loc),
4667 Chars => Name_Alignment,
4669 Make_Attribute_Reference (Loc,
4671 New_Reference_To (RTE (RE_Integer_Address), Loc),
4672 Attribute_Name => Name_Alignment)));
4674 -- This table is initialized by Make_Select_Specific_Data_Table,
4675 -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
4677 Append_To (TSD_Aggr_List,
4678 Make_Attribute_Reference (Loc,
4679 Prefix => New_Reference_To (SSD, Loc),
4680 Attribute_Name => Name_Unchecked_Access));
4682 Append_To (TSD_Aggr_List, Make_Null (Loc));
4686 -- Initialize the table of ancestor tags. In case of interface types
4687 -- this table is not needed.
4689 TSD_Tags_List := New_List;
4691 -- If we are not statically allocating the dispatch table then we must
4692 -- fill position 0 with null because we still have not generated the
4695 if not Building_Static_DT (Typ)
4696 or else Is_Interface (Typ)
4698 Append_To (TSD_Tags_List,
4699 Unchecked_Convert_To (RTE (RE_Tag),
4700 New_Reference_To (RTE (RE_Null_Address), Loc)));
4702 -- Otherwise we can safely reference the tag
4705 Append_To (TSD_Tags_List,
4706 New_Reference_To (DT_Ptr, Loc));
4709 -- Fill the rest of the table with the tags of the ancestors
4712 Current_Typ : Entity_Id;
4713 Parent_Typ : Entity_Id;
4721 Parent_Typ := Etype (Current_Typ);
4723 if Is_Private_Type (Parent_Typ) then
4724 Parent_Typ := Full_View (Base_Type (Parent_Typ));
4727 exit when Parent_Typ = Current_Typ;
4729 if Is_CPP_Class (Parent_Typ)
4730 or else Is_Interface (Typ)
4732 -- The tags defined in the C++ side will be inherited when
4733 -- the object is constructed (Exp_Ch3.Build_Init_Procedure)
4735 Append_To (TSD_Tags_List,
4736 Unchecked_Convert_To (RTE (RE_Tag),
4737 New_Reference_To (RTE (RE_Null_Address), Loc)));
4739 Append_To (TSD_Tags_List,
4741 (Node (First_Elmt (Access_Disp_Table (Parent_Typ))),
4746 Current_Typ := Parent_Typ;
4749 pragma Assert (Pos = I_Depth + 1);
4752 Append_To (TSD_Aggr_List,
4753 Make_Aggregate (Loc,
4754 Expressions => TSD_Tags_List));
4756 -- Build the TSD object
4759 Make_Object_Declaration (Loc,
4760 Defining_Identifier => TSD,
4761 Aliased_Present => True,
4762 Constant_Present => Building_Static_DT (Typ),
4763 Object_Definition =>
4764 Make_Subtype_Indication (Loc,
4765 Subtype_Mark => New_Reference_To (
4766 RTE (RE_Type_Specific_Data), Loc),
4768 Make_Index_Or_Discriminant_Constraint (Loc,
4769 Constraints => New_List (
4770 Make_Integer_Literal (Loc, I_Depth)))),
4772 Expression => Make_Aggregate (Loc,
4773 Expressions => TSD_Aggr_List)));
4775 Set_Is_True_Constant (TSD, Building_Static_DT (Typ));
4778 Make_Attribute_Definition_Clause (Loc,
4779 Name => New_Reference_To (TSD, Loc),
4780 Chars => Name_Alignment,
4782 Make_Attribute_Reference (Loc,
4783 Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
4784 Attribute_Name => Name_Alignment)));
4786 -- Initialize or declare the dispatch table object
4788 if not Has_DT (Typ) then
4789 DT_Constr_List := New_List;
4790 DT_Aggr_List := New_List;
4795 Make_Attribute_Reference (Loc,
4796 Prefix => New_Reference_To (TSD, Loc),
4797 Attribute_Name => Name_Address);
4799 Append_To (DT_Constr_List, New_Node);
4800 Append_To (DT_Aggr_List, New_Copy (New_Node));
4801 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
4803 -- In case of locally defined tagged types we have already declared
4804 -- and uninitialized object for the dispatch table, which is now
4805 -- initialized by means of the following assignment:
4807 -- DT := (TSD'Address, 0);
4809 if not Building_Static_DT (Typ) then
4811 Make_Assignment_Statement (Loc,
4812 Name => New_Reference_To (DT, Loc),
4813 Expression => Make_Aggregate (Loc,
4814 Expressions => DT_Aggr_List)));
4816 -- In case of library level tagged types we declare and export now
4817 -- the constant object containing the dummy dispatch table. There
4818 -- is no need to declare the tag here because it has been previously
4819 -- declared by Make_Tags
4821 -- DT : aliased constant No_Dispatch_Table :=
4822 -- (NDT_TSD => TSD'Address;
4823 -- NDT_Prims_Ptr => 0);
4824 -- for DT'Alignment use Address'Alignment;
4828 Make_Object_Declaration (Loc,
4829 Defining_Identifier => DT,
4830 Aliased_Present => True,
4831 Constant_Present => True,
4832 Object_Definition =>
4833 New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc),
4834 Expression => Make_Aggregate (Loc,
4835 Expressions => DT_Aggr_List)));
4838 Make_Attribute_Definition_Clause (Loc,
4839 Name => New_Reference_To (DT, Loc),
4840 Chars => Name_Alignment,
4842 Make_Attribute_Reference (Loc,
4844 New_Reference_To (RTE (RE_Integer_Address), Loc),
4845 Attribute_Name => Name_Alignment)));
4847 Export_DT (Typ, DT);
4850 -- Common case: Typ has a dispatch table
4854 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
4855 -- (predef-prim-op-1'address,
4856 -- predef-prim-op-2'address,
4858 -- predef-prim-op-n'address);
4859 -- for Predef_Prims'Alignment use Address'Alignment
4861 -- DT : Dispatch_Table (Nb_Prims) :=
4862 -- (Signature => <sig-value>,
4863 -- Tag_Kind => <tag_kind-value>,
4864 -- Predef_Prims => Predef_Prims'First'Address,
4865 -- Offset_To_Top => 0,
4866 -- TSD => TSD'Address;
4867 -- Prims_Ptr => (prim-op-1'address,
4868 -- prim-op-2'address,
4870 -- prim-op-n'address));
4871 -- for DT'Alignment use Address'Alignment
4878 if not Building_Static_DT (Typ) then
4879 Nb_Predef_Prims := Max_Predef_Prims;
4882 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4883 while Present (Prim_Elmt) loop
4884 Prim := Node (Prim_Elmt);
4886 if Is_Predefined_Dispatching_Operation (Prim)
4887 and then not Is_Abstract_Subprogram (Prim)
4889 Pos := UI_To_Int (DT_Position (Prim));
4891 if Pos > Nb_Predef_Prims then
4892 Nb_Predef_Prims := Pos;
4896 Next_Elmt (Prim_Elmt);
4902 (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
4907 Prim_Ops_Aggr_List := New_List;
4909 Prim_Table := (others => Empty);
4911 if Building_Static_DT (Typ) then
4912 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4913 while Present (Prim_Elmt) loop
4914 Prim := Node (Prim_Elmt);
4916 if Is_Predefined_Dispatching_Operation (Prim)
4917 and then not Is_Abstract_Subprogram (Prim)
4918 and then not Present (Prim_Table
4919 (UI_To_Int (DT_Position (Prim))))
4922 while Present (Alias (E)) loop
4926 pragma Assert (not Is_Abstract_Subprogram (E));
4927 Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
4930 Next_Elmt (Prim_Elmt);
4934 for J in Prim_Table'Range loop
4935 if Present (Prim_Table (J)) then
4937 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
4938 Make_Attribute_Reference (Loc,
4939 Prefix => New_Reference_To (Prim_Table (J), Loc),
4940 Attribute_Name => Name_Unrestricted_Access));
4942 New_Node := Make_Null (Loc);
4945 Append_To (Prim_Ops_Aggr_List, New_Node);
4949 Make_Aggregate (Loc,
4950 Expressions => Prim_Ops_Aggr_List);
4953 Make_Subtype_Declaration (Loc,
4954 Defining_Identifier =>
4955 Make_Defining_Identifier (Loc,
4956 New_Internal_Name ('S')),
4957 Subtype_Indication =>
4958 New_Reference_To (RTE (RE_Address_Array), Loc));
4960 Append_To (Result, Decl);
4963 Make_Object_Declaration (Loc,
4964 Defining_Identifier => Predef_Prims,
4965 Aliased_Present => True,
4966 Constant_Present => Building_Static_DT (Typ),
4967 Object_Definition => New_Reference_To
4968 (Defining_Identifier (Decl), Loc),
4969 Expression => New_Node));
4971 -- Remember aggregates initializing dispatch tables
4973 Append_Elmt (New_Node, DT_Aggr);
4976 Make_Attribute_Definition_Clause (Loc,
4977 Name => New_Reference_To (Predef_Prims, Loc),
4978 Chars => Name_Alignment,
4980 Make_Attribute_Reference (Loc,
4982 New_Reference_To (RTE (RE_Integer_Address), Loc),
4983 Attribute_Name => Name_Alignment)));
4987 -- Stage 1: Initialize the discriminant and the record components
4989 DT_Constr_List := New_List;
4990 DT_Aggr_List := New_List;
4992 -- Num_Prims. If the tagged type has no primitives we add a dummy
4993 -- slot whose address will be the tag of this type.
4996 New_Node := Make_Integer_Literal (Loc, 1);
4998 New_Node := Make_Integer_Literal (Loc, Nb_Prim);
5001 Append_To (DT_Constr_List, New_Node);
5002 Append_To (DT_Aggr_List, New_Copy (New_Node));
5006 if RTE_Record_Component_Available (RE_Signature) then
5007 Append_To (DT_Aggr_List,
5008 New_Reference_To (RTE (RE_Primary_DT), Loc));
5013 if RTE_Record_Component_Available (RE_Tag_Kind) then
5014 Append_To (DT_Aggr_List, Tagged_Kind (Typ));
5019 Append_To (DT_Aggr_List,
5020 Make_Attribute_Reference (Loc,
5021 Prefix => New_Reference_To (Predef_Prims, Loc),
5022 Attribute_Name => Name_Address));
5026 Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
5030 Append_To (DT_Aggr_List,
5031 Make_Attribute_Reference (Loc,
5032 Prefix => New_Reference_To (TSD, Loc),
5033 Attribute_Name => Name_Address));
5035 -- Stage 2: Initialize the table of primitive operations
5037 Prim_Ops_Aggr_List := New_List;
5040 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
5042 elsif not Building_Static_DT (Typ) then
5043 for J in 1 .. Nb_Prim loop
5044 Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
5049 Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
5052 Prim_Elmt : Elmt_Id;
5055 Prim_Table := (others => Empty);
5057 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5058 while Present (Prim_Elmt) loop
5059 Prim := Node (Prim_Elmt);
5061 if Is_Imported (Prim)
5062 or else Present (Interface_Alias (Prim))
5063 or else Is_Predefined_Dispatching_Operation (Prim)
5068 -- Traverse the list of aliased entities to handle
5069 -- renamings of predefined primitives.
5072 while Present (Alias (E)) loop
5076 if not Is_Predefined_Dispatching_Operation (E)
5077 and then not Is_Abstract_Subprogram (E)
5078 and then not Present (Interface_Alias (E))
5081 (UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
5083 Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
5087 Next_Elmt (Prim_Elmt);
5090 for J in Prim_Table'Range loop
5091 if Present (Prim_Table (J)) then
5093 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
5094 Make_Attribute_Reference (Loc,
5095 Prefix => New_Reference_To (Prim_Table (J), Loc),
5096 Attribute_Name => Name_Unrestricted_Access));
5098 New_Node := Make_Null (Loc);
5101 Append_To (Prim_Ops_Aggr_List, New_Node);
5107 Make_Aggregate (Loc,
5108 Expressions => Prim_Ops_Aggr_List);
5110 Append_To (DT_Aggr_List, New_Node);
5112 -- Remember aggregates initializing dispatch tables
5114 Append_Elmt (New_Node, DT_Aggr);
5116 -- In case of locally defined tagged types we have already declared
5117 -- and uninitialized object for the dispatch table, which is now
5118 -- initialized by means of an assignment.
5120 if not Building_Static_DT (Typ) then
5122 Make_Assignment_Statement (Loc,
5123 Name => New_Reference_To (DT, Loc),
5124 Expression => Make_Aggregate (Loc,
5125 Expressions => DT_Aggr_List)));
5127 -- In case of library level tagged types we declare now and export
5128 -- the constant object containing the dispatch table.
5132 Make_Object_Declaration (Loc,
5133 Defining_Identifier => DT,
5134 Aliased_Present => True,
5135 Constant_Present => True,
5136 Object_Definition =>
5137 Make_Subtype_Indication (Loc,
5138 Subtype_Mark => New_Reference_To
5139 (RTE (RE_Dispatch_Table_Wrapper), Loc),
5140 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
5141 Constraints => DT_Constr_List)),
5142 Expression => Make_Aggregate (Loc,
5143 Expressions => DT_Aggr_List)));
5146 Make_Attribute_Definition_Clause (Loc,
5147 Name => New_Reference_To (DT, Loc),
5148 Chars => Name_Alignment,
5150 Make_Attribute_Reference (Loc,
5152 New_Reference_To (RTE (RE_Integer_Address), Loc),
5153 Attribute_Name => Name_Alignment)));
5155 Export_DT (Typ, DT);
5159 -- Initialize the table of ancestor tags
5161 if not Building_Static_DT (Typ)
5162 and then not Is_Interface (Typ)
5163 and then not Is_CPP_Class (Typ)
5166 Make_Assignment_Statement (Loc,
5168 Make_Indexed_Component (Loc,
5170 Make_Selected_Component (Loc,
5172 New_Reference_To (TSD, Loc),
5175 (RTE_Record_Component (RE_Tags_Table), Loc)),
5177 New_List (Make_Integer_Literal (Loc, 0))),
5181 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
5184 -- Inherit the dispatch tables of the parent
5186 -- There is no need to inherit anything from the parent when building
5187 -- static dispatch tables because the whole dispatch table (including
5188 -- inherited primitives) has been already built.
5190 if Building_Static_DT (Typ) then
5193 -- If the ancestor is a CPP_Class type we inherit the dispatch tables
5194 -- in the init proc, and we don't need to fill them in here.
5196 elsif Is_CPP_Class (Parent_Typ) then
5199 -- Otherwise we fill in the dispatch tables here
5202 if Typ /= Parent_Typ
5203 and then not Is_Interface (Typ)
5204 and then not Restriction_Active (No_Dispatching_Calls)
5206 -- Inherit the dispatch table
5208 if not Is_Interface (Typ)
5209 and then not Is_Interface (Parent_Typ)
5210 and then not Is_CPP_Class (Parent_Typ)
5213 Nb_Prims : constant Int :=
5214 UI_To_Int (DT_Entry_Count
5215 (First_Tag_Component (Parent_Typ)));
5218 Append_To (Elab_Code,
5219 Build_Inherit_Predefined_Prims (Loc,
5225 (Access_Disp_Table (Parent_Typ)))), Loc),
5231 (Access_Disp_Table (Typ)))), Loc)));
5233 if Nb_Prims /= 0 then
5234 Append_To (Elab_Code,
5235 Build_Inherit_Prims (Loc,
5241 (Access_Disp_Table (Parent_Typ))), Loc),
5242 New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
5243 Num_Prims => Nb_Prims));
5248 -- Inherit the secondary dispatch tables of the ancestor
5250 if not Is_CPP_Class (Parent_Typ) then
5252 Sec_DT_Ancestor : Elmt_Id :=
5256 (Access_Disp_Table (Parent_Typ))));
5257 Sec_DT_Typ : Elmt_Id :=
5261 (Access_Disp_Table (Typ))));
5263 procedure Copy_Secondary_DTs (Typ : Entity_Id);
5264 -- Local procedure required to climb through the ancestors
5265 -- and copy the contents of all their secondary dispatch
5268 ------------------------
5269 -- Copy_Secondary_DTs --
5270 ------------------------
5272 procedure Copy_Secondary_DTs (Typ : Entity_Id) is
5277 -- Climb to the ancestor (if any) handling private types
5279 if Present (Full_View (Etype (Typ))) then
5280 if Full_View (Etype (Typ)) /= Typ then
5281 Copy_Secondary_DTs (Full_View (Etype (Typ)));
5284 elsif Etype (Typ) /= Typ then
5285 Copy_Secondary_DTs (Etype (Typ));
5288 if Present (Interfaces (Typ))
5289 and then not Is_Empty_Elmt_List (Interfaces (Typ))
5291 Iface := First_Elmt (Interfaces (Typ));
5292 E := First_Entity (Typ);
5294 and then Present (Node (Sec_DT_Ancestor))
5295 and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
5297 if Is_Tag (E) and then Chars (E) /= Name_uTag then
5299 Num_Prims : constant Int :=
5300 UI_To_Int (DT_Entry_Count (E));
5303 if not Is_Interface (Etype (Typ)) then
5305 -- Inherit first secondary dispatch table
5307 Append_To (Elab_Code,
5308 Build_Inherit_Predefined_Prims (Loc,
5310 Unchecked_Convert_To (RTE (RE_Tag),
5313 (Next_Elmt (Sec_DT_Ancestor)),
5316 Unchecked_Convert_To (RTE (RE_Tag),
5318 (Node (Next_Elmt (Sec_DT_Typ)),
5321 if Num_Prims /= 0 then
5322 Append_To (Elab_Code,
5323 Build_Inherit_Prims (Loc,
5324 Typ => Node (Iface),
5326 Unchecked_Convert_To
5329 (Node (Sec_DT_Ancestor),
5332 Unchecked_Convert_To
5335 (Node (Sec_DT_Typ), Loc)),
5336 Num_Prims => Num_Prims));
5340 Next_Elmt (Sec_DT_Ancestor);
5341 Next_Elmt (Sec_DT_Typ);
5343 -- Skip the secondary dispatch table of
5344 -- predefined primitives
5346 Next_Elmt (Sec_DT_Ancestor);
5347 Next_Elmt (Sec_DT_Typ);
5349 if not Is_Interface (Etype (Typ)) then
5351 -- Inherit second secondary dispatch table
5353 Append_To (Elab_Code,
5354 Build_Inherit_Predefined_Prims (Loc,
5356 Unchecked_Convert_To (RTE (RE_Tag),
5359 (Next_Elmt (Sec_DT_Ancestor)),
5362 Unchecked_Convert_To (RTE (RE_Tag),
5364 (Node (Next_Elmt (Sec_DT_Typ)),
5367 if Num_Prims /= 0 then
5368 Append_To (Elab_Code,
5369 Build_Inherit_Prims (Loc,
5370 Typ => Node (Iface),
5372 Unchecked_Convert_To
5375 (Node (Sec_DT_Ancestor),
5378 Unchecked_Convert_To
5381 (Node (Sec_DT_Typ), Loc)),
5382 Num_Prims => Num_Prims));
5387 Next_Elmt (Sec_DT_Ancestor);
5388 Next_Elmt (Sec_DT_Typ);
5390 -- Skip the secondary dispatch table of
5391 -- predefined primitives
5393 Next_Elmt (Sec_DT_Ancestor);
5394 Next_Elmt (Sec_DT_Typ);
5402 end Copy_Secondary_DTs;
5405 if Present (Node (Sec_DT_Ancestor))
5406 and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
5408 -- Handle private types
5410 if Present (Full_View (Typ)) then
5411 Copy_Secondary_DTs (Full_View (Typ));
5413 Copy_Secondary_DTs (Typ);
5421 -- Generate code to register the Tag in the External_Tag hash table for
5422 -- the pure Ada type only.
5424 -- Register_Tag (Dt_Ptr);
5426 -- Skip this action in the following cases:
5427 -- 1) if Register_Tag is not available.
5428 -- 2) in No_Run_Time mode.
5429 -- 3) if Typ is not defined at the library level (this is required
5430 -- to avoid adding concurrency control to the hash table used
5431 -- by the run-time to register the tags).
5433 if not No_Run_Time_Mode
5434 and then Is_Library_Level_Entity (Typ)
5435 and then RTE_Available (RE_Register_Tag)
5437 Append_To (Elab_Code,
5438 Make_Procedure_Call_Statement (Loc,
5439 Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
5440 Parameter_Associations =>
5441 New_List (New_Reference_To (DT_Ptr, Loc))));
5444 if not Is_Empty_List (Elab_Code) then
5445 Append_List_To (Result, Elab_Code);
5448 -- Populate the two auxiliary tables used for dispatching
5449 -- asynchronous, conditional and timed selects for synchronized
5450 -- types that implement a limited interface.
5452 if Ada_Version >= Ada_05
5453 and then Is_Concurrent_Record_Type (Typ)
5454 and then Has_Interfaces (Typ)
5456 Append_List_To (Result,
5457 Make_Select_Specific_Data_Table (Typ));
5460 -- Remember entities containing dispatch tables
5462 Append_Elmt (Predef_Prims, DT_Decl);
5463 Append_Elmt (DT, DT_Decl);
5465 Analyze_List (Result, Suppress => All_Checks);
5466 Set_Has_Dispatch_Table (Typ);
5468 -- Mark entities containing dispatch tables. Required by the
5469 -- backend to handle them properly.
5471 if not Is_Interface (Typ) then
5476 -- Ensure that entities Prim_Ptr and Predef_Prims_Table_Ptr have
5477 -- the decoration required by the backend
5479 Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr));
5480 Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr));
5482 -- Object declarations
5484 Elmt := First_Elmt (DT_Decl);
5485 while Present (Elmt) loop
5486 Set_Is_Dispatch_Table_Entity (Node (Elmt));
5487 pragma Assert (Ekind (Etype (Node (Elmt))) = E_Array_Subtype
5488 or else Ekind (Etype (Node (Elmt))) = E_Record_Subtype);
5489 Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
5493 -- Aggregates initializing dispatch tables
5495 Elmt := First_Elmt (DT_Aggr);
5496 while Present (Elmt) loop
5497 Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
5506 -------------------------------------
5507 -- Make_Select_Specific_Data_Table --
5508 -------------------------------------
5510 function Make_Select_Specific_Data_Table
5511 (Typ : Entity_Id) return List_Id
5513 Assignments : constant List_Id := New_List;
5514 Loc : constant Source_Ptr := Sloc (Typ);
5516 Conc_Typ : Entity_Id;
5520 Prim_Als : Entity_Id;
5521 Prim_Elmt : Elmt_Id;
5525 type Examined_Array is array (Int range <>) of Boolean;
5527 function Find_Entry_Index (E : Entity_Id) return Uint;
5528 -- Given an entry, find its index in the visible declarations of the
5529 -- corresponding concurrent type of Typ.
5531 ----------------------
5532 -- Find_Entry_Index --
5533 ----------------------
5535 function Find_Entry_Index (E : Entity_Id) return Uint is
5536 Index : Uint := Uint_1;
5537 Subp_Decl : Entity_Id;
5541 and then not Is_Empty_List (Decls)
5543 Subp_Decl := First (Decls);
5544 while Present (Subp_Decl) loop
5545 if Nkind (Subp_Decl) = N_Entry_Declaration then
5546 if Defining_Identifier (Subp_Decl) = E then
5558 end Find_Entry_Index;
5560 -- Start of processing for Make_Select_Specific_Data_Table
5563 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
5565 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
5567 if Present (Corresponding_Concurrent_Type (Typ)) then
5568 Conc_Typ := Corresponding_Concurrent_Type (Typ);
5570 if Present (Full_View (Conc_Typ)) then
5571 Conc_Typ := Full_View (Conc_Typ);
5574 if Ekind (Conc_Typ) = E_Protected_Type then
5575 Decls := Visible_Declarations (Protected_Definition (
5576 Parent (Conc_Typ)));
5578 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
5579 Decls := Visible_Declarations (Task_Definition (
5580 Parent (Conc_Typ)));
5584 -- Count the non-predefined primitive operations
5586 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5587 while Present (Prim_Elmt) loop
5588 Prim := Node (Prim_Elmt);
5590 if not (Is_Predefined_Dispatching_Operation (Prim)
5591 or else Is_Predefined_Dispatching_Alias (Prim))
5593 Nb_Prim := Nb_Prim + 1;
5596 Next_Elmt (Prim_Elmt);
5600 Examined : Examined_Array (1 .. Nb_Prim) := (others => False);
5603 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5604 while Present (Prim_Elmt) loop
5605 Prim := Node (Prim_Elmt);
5607 -- Look for primitive overriding an abstract interface subprogram
5609 if Present (Interface_Alias (Prim))
5610 and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
5612 Prim_Pos := DT_Position (Alias (Prim));
5613 pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
5614 Examined (UI_To_Int (Prim_Pos)) := True;
5616 -- Set the primitive operation kind regardless of subprogram
5618 -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
5620 Append_To (Assignments,
5621 Make_Procedure_Call_Statement (Loc,
5622 Name => New_Reference_To (RTE (RE_Set_Prim_Op_Kind), Loc),
5623 Parameter_Associations => New_List (
5624 New_Reference_To (DT_Ptr, Loc),
5625 Make_Integer_Literal (Loc, Prim_Pos),
5626 Prim_Op_Kind (Alias (Prim), Typ))));
5628 -- Retrieve the root of the alias chain
5631 while Present (Alias (Prim_Als)) loop
5632 Prim_Als := Alias (Prim_Als);
5635 -- In the case of an entry wrapper, set the entry index
5637 if Ekind (Prim) = E_Procedure
5638 and then Is_Primitive_Wrapper (Prim_Als)
5639 and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry
5642 -- Ada.Tags.Set_Entry_Index
5643 -- (DT_Ptr, <position>, <index>);
5645 Append_To (Assignments,
5646 Make_Procedure_Call_Statement (Loc,
5648 New_Reference_To (RTE (RE_Set_Entry_Index), Loc),
5649 Parameter_Associations => New_List (
5650 New_Reference_To (DT_Ptr, Loc),
5651 Make_Integer_Literal (Loc, Prim_Pos),
5652 Make_Integer_Literal (Loc,
5653 Find_Entry_Index (Wrapped_Entity (Prim_Als))))));
5657 Next_Elmt (Prim_Elmt);
5662 end Make_Select_Specific_Data_Table;
5668 function Make_Tags (Typ : Entity_Id) return List_Id is
5669 Loc : constant Source_Ptr := Sloc (Typ);
5670 Tname : constant Name_Id := Chars (Typ);
5671 Result : constant List_Id := New_List;
5672 AI_Tag_Comp : Elmt_Id;
5674 DT_Constr_List : List_Id;
5676 Predef_Prims_Ptr : Node_Id;
5677 Iface_DT_Ptr : Node_Id;
5681 Typ_Comps : Elist_Id;
5684 -- 1) Generate the primary and secondary tag entities
5686 -- Collect the components associated with secondary dispatch tables
5688 if Has_Interfaces (Typ) then
5689 Collect_Interface_Components (Typ, Typ_Comps);
5692 -- 1) Generate the primary tag entities
5694 -- Primary dispatch table containing user-defined primitives
5696 DT_Ptr := Make_Defining_Identifier (Loc,
5697 New_External_Name (Tname, 'P'));
5698 Set_Etype (DT_Ptr, RTE (RE_Tag));
5700 -- Primary dispatch table containing predefined primitives
5703 Make_Defining_Identifier (Loc,
5704 Chars => New_External_Name (Tname, 'Y'));
5705 Set_Etype (Predef_Prims_Ptr, RTE (RE_Address));
5707 -- Import the forward declaration of the Dispatch Table wrapper record
5708 -- (Make_DT will take care of its exportation)
5710 if Building_Static_DT (Typ) then
5712 Make_Defining_Identifier (Loc,
5713 Chars => New_External_Name (Tname, 'T'));
5716 -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
5717 -- $pragma import (ada, DT);
5719 Set_Is_Imported (DT);
5721 -- The scope must be set now to call Get_External_Name
5723 Set_Scope (DT, Current_Scope);
5725 Get_External_Name (DT, True);
5726 Set_Interface_Name (DT,
5727 Make_String_Literal (Loc,
5728 Strval => String_From_Name_Buffer));
5730 -- Ensure proper Sprint output of this implicit importation
5732 Set_Is_Internal (DT);
5734 -- Save this entity to allow Make_DT to generate its exportation
5736 Set_Dispatch_Table_Wrapper (Typ, DT);
5738 if Has_DT (Typ) then
5740 -- Calculate the number of primitives of the dispatch table and
5741 -- the size of the Type_Specific_Data record.
5743 Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
5745 -- If the tagged type has no primitives we add a dummy slot
5746 -- whose address will be the tag of this type.
5750 New_List (Make_Integer_Literal (Loc, 1));
5753 New_List (Make_Integer_Literal (Loc, Nb_Prim));
5757 Make_Object_Declaration (Loc,
5758 Defining_Identifier => DT,
5759 Aliased_Present => True,
5760 Constant_Present => True,
5761 Object_Definition =>
5762 Make_Subtype_Indication (Loc,
5764 New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc),
5765 Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
5766 Constraints => DT_Constr_List))));
5769 Make_Object_Declaration (Loc,
5770 Defining_Identifier => DT_Ptr,
5771 Constant_Present => True,
5772 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
5774 Unchecked_Convert_To (RTE (RE_Tag),
5775 Make_Attribute_Reference (Loc,
5777 Make_Selected_Component (Loc,
5778 Prefix => New_Reference_To (DT, Loc),
5781 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
5782 Attribute_Name => Name_Address))));
5785 Make_Object_Declaration (Loc,
5786 Defining_Identifier => Predef_Prims_Ptr,
5787 Constant_Present => True,
5788 Object_Definition => New_Reference_To
5789 (RTE (RE_Address), Loc),
5791 Make_Attribute_Reference (Loc,
5793 Make_Selected_Component (Loc,
5794 Prefix => New_Reference_To (DT, Loc),
5797 (RTE_Record_Component (RE_Predef_Prims), Loc)),
5798 Attribute_Name => Name_Address)));
5800 -- No dispatch table required
5804 Make_Object_Declaration (Loc,
5805 Defining_Identifier => DT,
5806 Aliased_Present => True,
5807 Constant_Present => True,
5808 Object_Definition =>
5809 New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
5812 Make_Object_Declaration (Loc,
5813 Defining_Identifier => DT_Ptr,
5814 Constant_Present => True,
5815 Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
5817 Unchecked_Convert_To (RTE (RE_Tag),
5818 Make_Attribute_Reference (Loc,
5820 Make_Selected_Component (Loc,
5821 Prefix => New_Reference_To (DT, Loc),
5824 (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
5825 Attribute_Name => Name_Address))));
5828 Set_Is_True_Constant (DT_Ptr);
5829 Set_Is_Statically_Allocated (DT_Ptr);
5832 pragma Assert (No (Access_Disp_Table (Typ)));
5833 Set_Access_Disp_Table (Typ, New_Elmt_List);
5834 Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
5835 Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
5837 -- 2) Generate the secondary tag entities
5839 if Has_Interfaces (Typ) then
5842 -- For each interface type we build an unique external name
5843 -- associated with its corresponding secondary dispatch table.
5844 -- This external name will be used to declare an object that
5845 -- references this secondary dispatch table, value that will be
5846 -- used for the elaboration of Typ's objects and also for the
5847 -- elaboration of objects of derivations of Typ that do not
5848 -- override the primitive operation of this interface type.
5850 AI_Tag_Comp := First_Elmt (Typ_Comps);
5851 while Present (AI_Tag_Comp) loop
5852 Get_Secondary_DT_External_Name
5853 (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
5855 Typ_Name := Name_Find;
5857 -- Secondary dispatch table referencing thunks to user-defined
5858 -- primitives covered by this interface.
5861 Make_Defining_Identifier (Loc,
5862 Chars => New_External_Name (Typ_Name, 'P'));
5863 Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
5864 Set_Ekind (Iface_DT_Ptr, E_Constant);
5865 Set_Is_Tag (Iface_DT_Ptr);
5866 Set_Has_Thunks (Iface_DT_Ptr);
5867 Set_Is_Statically_Allocated (Iface_DT_Ptr,
5868 Is_Library_Level_Tagged_Type (Typ));
5869 Set_Is_True_Constant (Iface_DT_Ptr);
5871 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
5872 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
5874 -- Secondary dispatch table referencing thunks to predefined
5878 Make_Defining_Identifier (Loc,
5879 Chars => New_External_Name (Typ_Name, 'Y'));
5880 Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
5881 Set_Ekind (Iface_DT_Ptr, E_Constant);
5882 Set_Is_Tag (Iface_DT_Ptr);
5883 Set_Has_Thunks (Iface_DT_Ptr);
5884 Set_Is_Statically_Allocated (Iface_DT_Ptr,
5885 Is_Library_Level_Tagged_Type (Typ));
5886 Set_Is_True_Constant (Iface_DT_Ptr);
5888 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
5889 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
5891 -- Secondary dispatch table referencing user-defined primitives
5892 -- covered by this interface.
5895 Make_Defining_Identifier (Loc,
5896 Chars => New_External_Name (Typ_Name, 'D'));
5897 Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
5898 Set_Ekind (Iface_DT_Ptr, E_Constant);
5899 Set_Is_Tag (Iface_DT_Ptr);
5900 Set_Is_Statically_Allocated (Iface_DT_Ptr,
5901 Is_Library_Level_Tagged_Type (Typ));
5902 Set_Is_True_Constant (Iface_DT_Ptr);
5904 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
5905 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
5907 -- Secondary dispatch table referencing predefined primitives
5910 Make_Defining_Identifier (Loc,
5911 Chars => New_External_Name (Typ_Name, 'Z'));
5912 Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
5913 Set_Ekind (Iface_DT_Ptr, E_Constant);
5914 Set_Is_Tag (Iface_DT_Ptr);
5915 Set_Is_Statically_Allocated (Iface_DT_Ptr,
5916 Is_Library_Level_Tagged_Type (Typ));
5917 Set_Is_True_Constant (Iface_DT_Ptr);
5919 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
5920 Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
5922 Next_Elmt (AI_Tag_Comp);
5926 -- 3) At the end of Access_Disp_Table we add the entity of an access
5927 -- type declaration. It is used by Build_Get_Prim_Op_Address to
5928 -- expand dispatching calls through the primary dispatch table.
5931 -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
5932 -- type Typ_DT_Acc is access Typ_DT;
5935 Name_DT_Prims : constant Name_Id :=
5936 New_External_Name (Tname, 'G');
5937 Name_DT_Prims_Acc : constant Name_Id :=
5938 New_External_Name (Tname, 'H');
5939 DT_Prims : constant Entity_Id :=
5940 Make_Defining_Identifier (Loc, Name_DT_Prims);
5941 DT_Prims_Acc : constant Entity_Id :=
5942 Make_Defining_Identifier (Loc,
5946 Make_Full_Type_Declaration (Loc,
5947 Defining_Identifier => DT_Prims,
5949 Make_Constrained_Array_Definition (Loc,
5950 Discrete_Subtype_Definitions => New_List (
5952 Low_Bound => Make_Integer_Literal (Loc, 1),
5953 High_Bound => Make_Integer_Literal (Loc,
5955 (First_Tag_Component (Typ))))),
5956 Component_Definition =>
5957 Make_Component_Definition (Loc,
5958 Subtype_Indication =>
5959 New_Reference_To (RTE (RE_Prim_Ptr), Loc)))));
5962 Make_Full_Type_Declaration (Loc,
5963 Defining_Identifier => DT_Prims_Acc,
5965 Make_Access_To_Object_Definition (Loc,
5966 Subtype_Indication =>
5967 New_Occurrence_Of (DT_Prims, Loc))));
5969 Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
5971 -- Analyze the resulting list and suppress the generation of the
5972 -- Init_Proc associated with the above array declaration because
5973 -- we never use such type in object declarations; this type is only
5974 -- used to simplify the expansion associated with dispatching calls.
5976 Analyze_List (Result);
5977 Set_Suppress_Init_Proc (Base_Type (DT_Prims));
5979 -- Mark entity of dispatch table. Required by the backend to handle
5982 Set_Is_Dispatch_Table_Entity (DT_Prims);
5985 Set_Ekind (DT_Ptr, E_Constant);
5986 Set_Is_Tag (DT_Ptr);
5987 Set_Related_Type (DT_Ptr, Typ);
5992 -----------------------------------
5993 -- Original_View_In_Visible_Part --
5994 -----------------------------------
5996 function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
5997 Scop : constant Entity_Id := Scope (Typ);
6000 -- The scope must be a package
6002 if Ekind (Scop) /= E_Package
6003 and then Ekind (Scop) /= E_Generic_Package
6008 -- A type with a private declaration has a private view declared in
6009 -- the visible part.
6011 if Has_Private_Declaration (Typ) then
6015 return List_Containing (Parent (Typ)) =
6016 Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
6017 end Original_View_In_Visible_Part;
6023 function Prim_Op_Kind
6025 Typ : Entity_Id) return Node_Id
6027 Full_Typ : Entity_Id := Typ;
6028 Loc : constant Source_Ptr := Sloc (Prim);
6029 Prim_Op : Entity_Id;
6032 -- Retrieve the original primitive operation
6035 while Present (Alias (Prim_Op)) loop
6036 Prim_Op := Alias (Prim_Op);
6039 if Ekind (Typ) = E_Record_Type
6040 and then Present (Corresponding_Concurrent_Type (Typ))
6042 Full_Typ := Corresponding_Concurrent_Type (Typ);
6045 if Ekind (Prim_Op) = E_Function then
6047 -- Protected function
6049 if Ekind (Full_Typ) = E_Protected_Type then
6050 return New_Reference_To (RTE (RE_POK_Protected_Function), Loc);
6054 elsif Ekind (Full_Typ) = E_Task_Type then
6055 return New_Reference_To (RTE (RE_POK_Task_Function), Loc);
6060 return New_Reference_To (RTE (RE_POK_Function), Loc);
6064 pragma Assert (Ekind (Prim_Op) = E_Procedure);
6066 if Ekind (Full_Typ) = E_Protected_Type then
6070 if Is_Primitive_Wrapper (Prim_Op)
6071 and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
6073 return New_Reference_To (RTE (RE_POK_Protected_Entry), Loc);
6075 -- Protected procedure
6078 return New_Reference_To (RTE (RE_POK_Protected_Procedure), Loc);
6081 elsif Ekind (Full_Typ) = E_Task_Type then
6085 if Is_Primitive_Wrapper (Prim_Op)
6086 and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
6088 return New_Reference_To (RTE (RE_POK_Task_Entry), Loc);
6090 -- Task "procedure". These are the internally Expander-generated
6091 -- procedures (task body for instance).
6094 return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc);
6097 -- Regular procedure
6100 return New_Reference_To (RTE (RE_POK_Procedure), Loc);
6105 ------------------------
6106 -- Register_Primitive --
6107 ------------------------
6109 procedure Register_Primitive
6115 Iface_Prim : Entity_Id;
6116 Iface_Typ : Entity_Id;
6117 Iface_DT_Ptr : Entity_Id;
6118 Iface_DT_Elmt : Elmt_Id;
6122 Tag_Typ : Entity_Id;
6123 Thunk_Id : Entity_Id;
6124 Thunk_Code : Node_Id;
6127 pragma Assert (not Restriction_Active (No_Dispatching_Calls));
6129 if not RTE_Available (RE_Tag) then
6133 if not Present (Interface_Alias (Prim)) then
6134 Tag_Typ := Scope (DTC_Entity (Prim));
6135 Pos := DT_Position (Prim);
6136 Tag := First_Tag_Component (Tag_Typ);
6138 if Is_Predefined_Dispatching_Operation (Prim)
6139 or else Is_Predefined_Dispatching_Alias (Prim)
6142 Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ))));
6144 Insert_After (Ins_Nod,
6145 Build_Set_Predefined_Prim_Op_Address (Loc,
6146 Tag_Node => New_Reference_To (DT_Ptr, Loc),
6149 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6150 Make_Attribute_Reference (Loc,
6151 Prefix => New_Reference_To (Prim, Loc),
6152 Attribute_Name => Name_Unrestricted_Access))));
6154 -- Register copy of the pointer to the 'size primitive in the TSD.
6156 if Chars (Prim) = Name_uSize
6157 and then RTE_Record_Component_Available (RE_Size_Func)
6159 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
6160 Insert_After (Ins_Nod,
6161 Build_Set_Size_Function (Loc,
6162 Tag_Node => New_Reference_To (DT_Ptr, Loc),
6163 Size_Func => Prim));
6167 pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
6169 DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
6170 Insert_After (Ins_Nod,
6171 Build_Set_Prim_Op_Address (Loc,
6173 Tag_Node => New_Reference_To (DT_Ptr, Loc),
6176 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6177 Make_Attribute_Reference (Loc,
6178 Prefix => New_Reference_To (Prim, Loc),
6179 Attribute_Name => Name_Unrestricted_Access))));
6182 -- Ada 2005 (AI-251): Primitive associated with an interface type
6183 -- Generate the code of the thunk only if the interface type is not an
6184 -- immediate ancestor of Typ; otherwise the dispatch table associated
6185 -- with the interface is the primary dispatch table and we have nothing
6189 Tag_Typ := Find_Dispatching_Type (Alias (Prim));
6190 Iface_Typ := Find_Dispatching_Type (Interface_Alias (Prim));
6192 pragma Assert (Is_Interface (Iface_Typ));
6194 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
6196 if not Is_Ancestor (Iface_Typ, Tag_Typ)
6197 and then Present (Thunk_Code)
6199 -- Comment needed on why checks are suppressed. This is not just
6200 -- efficiency, but fundamental functionality (see 1.295 RH, which
6201 -- still does not answer this question) ???
6203 Insert_Action (Ins_Nod, Thunk_Code, Suppress => All_Checks);
6205 -- Generate the code necessary to fill the appropriate entry of
6206 -- the secondary dispatch table of Prim's controlling type with
6207 -- Thunk_Id's address.
6209 Iface_DT_Elmt := Find_Interface_ADT (Tag_Typ, Iface_Typ);
6210 Iface_DT_Ptr := Node (Iface_DT_Elmt);
6211 pragma Assert (Has_Thunks (Iface_DT_Ptr));
6213 Iface_Prim := Interface_Alias (Prim);
6214 Pos := DT_Position (Iface_Prim);
6215 Tag := First_Tag_Component (Iface_Typ);
6218 if Is_Predefined_Dispatching_Operation (Prim)
6219 or else Is_Predefined_Dispatching_Alias (Prim)
6222 Build_Set_Predefined_Prim_Op_Address (Loc,
6224 New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
6227 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6228 Make_Attribute_Reference (Loc,
6229 Prefix => New_Reference_To (Thunk_Id, Loc),
6230 Attribute_Name => Name_Unrestricted_Access))));
6232 Next_Elmt (Iface_DT_Elmt);
6233 Next_Elmt (Iface_DT_Elmt);
6234 Iface_DT_Ptr := Node (Iface_DT_Elmt);
6235 pragma Assert (not Has_Thunks (Iface_DT_Ptr));
6238 Build_Set_Predefined_Prim_Op_Address (Loc,
6240 New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
6243 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6244 Make_Attribute_Reference (Loc,
6245 Prefix => New_Reference_To (Alias (Prim), Loc),
6246 Attribute_Name => Name_Unrestricted_Access))));
6248 Insert_Actions_After (Ins_Nod, L);
6251 pragma Assert (Pos /= Uint_0
6252 and then Pos <= DT_Entry_Count (Tag));
6255 Build_Set_Prim_Op_Address (Loc,
6257 Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
6260 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6261 Make_Attribute_Reference (Loc,
6262 Prefix => New_Reference_To (Thunk_Id, Loc),
6263 Attribute_Name => Name_Unrestricted_Access))));
6265 Next_Elmt (Iface_DT_Elmt);
6266 Next_Elmt (Iface_DT_Elmt);
6267 Iface_DT_Ptr := Node (Iface_DT_Elmt);
6268 pragma Assert (not Has_Thunks (Iface_DT_Ptr));
6271 Build_Set_Prim_Op_Address (Loc,
6273 Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
6276 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6277 Make_Attribute_Reference (Loc,
6278 Prefix => New_Reference_To (Alias (Prim), Loc),
6279 Attribute_Name => Name_Unrestricted_Access))));
6281 Insert_Actions_After (Ins_Nod, L);
6285 end Register_Primitive;
6287 -------------------------
6288 -- Set_All_DT_Position --
6289 -------------------------
6291 procedure Set_All_DT_Position (Typ : Entity_Id) is
6293 procedure Validate_Position (Prim : Entity_Id);
6294 -- Check that the position assigned to Prim is completely safe
6295 -- (it has not been assigned to a previously defined primitive
6296 -- operation of Typ)
6298 -----------------------
6299 -- Validate_Position --
6300 -----------------------
6302 procedure Validate_Position (Prim : Entity_Id) is
6307 -- Aliased primitives are safe
6309 if Present (Alias (Prim)) then
6313 Op_Elmt := First_Elmt (Primitive_Operations (Typ));
6314 while Present (Op_Elmt) loop
6315 Op := Node (Op_Elmt);
6317 -- No need to check against itself
6322 -- Primitive operations covering abstract interfaces are
6325 elsif Present (Interface_Alias (Op)) then
6328 -- Predefined dispatching operations are completely safe. They
6329 -- are allocated at fixed positions in a separate table.
6331 elsif Is_Predefined_Dispatching_Operation (Op)
6332 or else Is_Predefined_Dispatching_Alias (Op)
6336 -- Aliased subprograms are safe
6338 elsif Present (Alias (Op)) then
6341 elsif DT_Position (Op) = DT_Position (Prim)
6342 and then not Is_Predefined_Dispatching_Operation (Op)
6343 and then not Is_Predefined_Dispatching_Operation (Prim)
6344 and then not Is_Predefined_Dispatching_Alias (Op)
6345 and then not Is_Predefined_Dispatching_Alias (Prim)
6348 -- Handle aliased subprograms
6357 if Present (Overridden_Operation (Op_1)) then
6358 Op_1 := Overridden_Operation (Op_1);
6359 elsif Present (Alias (Op_1)) then
6360 Op_1 := Alias (Op_1);
6368 if Present (Overridden_Operation (Op_2)) then
6369 Op_2 := Overridden_Operation (Op_2);
6370 elsif Present (Alias (Op_2)) then
6371 Op_2 := Alias (Op_2);
6377 if Op_1 /= Op_2 then
6378 raise Program_Error;
6383 Next_Elmt (Op_Elmt);
6385 end Validate_Position;
6389 Parent_Typ : constant Entity_Id := Etype (Typ);
6390 First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
6391 The_Tag : constant Entity_Id := First_Tag_Component (Typ);
6393 Adjusted : Boolean := False;
6394 Finalized : Boolean := False;
6400 Prim_Elmt : Elmt_Id;
6402 -- Start of processing for Set_All_DT_Position
6405 pragma Assert (Present (First_Tag_Component (Typ)));
6407 -- Set the DT_Position for each primitive operation. Perform some
6408 -- sanity checks to avoid to build completely inconsistent dispatch
6411 -- First stage: Set the DTC entity of all the primitive operations
6412 -- This is required to properly read the DT_Position attribute in
6413 -- the latter stages.
6415 Prim_Elmt := First_Prim;
6417 while Present (Prim_Elmt) loop
6418 Prim := Node (Prim_Elmt);
6420 -- Predefined primitives have a separate dispatch table
6422 if not (Is_Predefined_Dispatching_Operation (Prim)
6423 or else Is_Predefined_Dispatching_Alias (Prim))
6425 Count_Prim := Count_Prim + 1;
6428 Set_DTC_Entity_Value (Typ, Prim);
6430 -- Clear any previous value of the DT_Position attribute. In this
6431 -- way we ensure that the final position of all the primitives is
6432 -- established by the following stages of this algorithm.
6434 Set_DT_Position (Prim, No_Uint);
6436 Next_Elmt (Prim_Elmt);
6440 Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean :=
6445 procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id);
6446 -- Called if Typ is declared in a nested package or a public child
6447 -- package to handle inherited primitives that were inherited by Typ
6448 -- in the visible part, but whose declaration was deferred because
6449 -- the parent operation was private and not visible at that point.
6451 procedure Set_Fixed_Prim (Pos : Nat);
6452 -- Sets to true an element of the Fixed_Prim table to indicate
6453 -- that this entry of the dispatch table of Typ is occupied.
6455 ------------------------------------------
6456 -- Handle_Inherited_Private_Subprograms --
6457 ------------------------------------------
6459 procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id) is
6462 Op_Elmt_2 : Elmt_Id;
6463 Prim_Op : Entity_Id;
6464 Parent_Subp : Entity_Id;
6467 Op_List := Primitive_Operations (Typ);
6469 Op_Elmt := First_Elmt (Op_List);
6470 while Present (Op_Elmt) loop
6471 Prim_Op := Node (Op_Elmt);
6473 -- Search primitives that are implicit operations with an
6474 -- internal name whose parent operation has a normal name.
6476 if Present (Alias (Prim_Op))
6477 and then Find_Dispatching_Type (Alias (Prim_Op)) /= Typ
6478 and then not Comes_From_Source (Prim_Op)
6479 and then Is_Internal_Name (Chars (Prim_Op))
6480 and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
6482 Parent_Subp := Alias (Prim_Op);
6484 -- Check if the type has an explicit overriding for this
6487 Op_Elmt_2 := Next_Elmt (Op_Elmt);
6488 while Present (Op_Elmt_2) loop
6489 if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
6490 and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
6492 Set_DT_Position (Prim_Op, DT_Position (Parent_Subp));
6493 Set_DT_Position (Node (Op_Elmt_2),
6494 DT_Position (Parent_Subp));
6495 Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op)));
6497 goto Next_Primitive;
6500 Next_Elmt (Op_Elmt_2);
6505 Next_Elmt (Op_Elmt);
6507 end Handle_Inherited_Private_Subprograms;
6509 --------------------
6510 -- Set_Fixed_Prim --
6511 --------------------
6513 procedure Set_Fixed_Prim (Pos : Nat) is
6515 pragma Assert (Pos >= 0 and then Pos <= Count_Prim);
6516 Fixed_Prim (Pos) := True;
6518 when Constraint_Error =>
6519 raise Program_Error;
6523 -- In case of nested packages and public child package it may be
6524 -- necessary a special management on inherited subprograms so that
6525 -- the dispatch table is properly filled.
6527 if Ekind (Scope (Scope (Typ))) = E_Package
6528 and then Scope (Scope (Typ)) /= Standard_Standard
6529 and then ((Is_Derived_Type (Typ) and then not Is_Private_Type (Typ))
6531 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration
6532 and then Is_Generic_Type (Typ)))
6533 and then In_Open_Scopes (Scope (Etype (Typ)))
6534 and then Typ = Base_Type (Typ)
6536 Handle_Inherited_Private_Subprograms (Typ);
6539 -- Second stage: Register fixed entries
6542 Prim_Elmt := First_Prim;
6543 while Present (Prim_Elmt) loop
6544 Prim := Node (Prim_Elmt);
6546 -- Predefined primitives have a separate table and all its
6547 -- entries are at predefined fixed positions.
6549 if Is_Predefined_Dispatching_Operation (Prim) then
6550 Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
6552 elsif Is_Predefined_Dispatching_Alias (Prim) then
6554 while Present (Alias (E)) loop
6558 Set_DT_Position (Prim, Default_Prim_Op_Position (E));
6560 -- Overriding primitives of ancestor abstract interfaces
6562 elsif Present (Interface_Alias (Prim))
6563 and then Is_Ancestor
6564 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
6566 pragma Assert (DT_Position (Prim) = No_Uint
6567 and then Present (DTC_Entity (Interface_Alias (Prim))));
6569 E := Interface_Alias (Prim);
6570 Set_DT_Position (Prim, DT_Position (E));
6573 (DT_Position (Alias (Prim)) = No_Uint
6574 or else DT_Position (Alias (Prim)) = DT_Position (E));
6575 Set_DT_Position (Alias (Prim), DT_Position (E));
6576 Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
6578 -- Overriding primitives must use the same entry as the
6579 -- overridden primitive.
6581 elsif not Present (Interface_Alias (Prim))
6582 and then Present (Alias (Prim))
6583 and then Chars (Prim) = Chars (Alias (Prim))
6584 and then Find_Dispatching_Type (Alias (Prim)) /= Typ
6585 and then Is_Ancestor
6586 (Find_Dispatching_Type (Alias (Prim)), Typ)
6587 and then Present (DTC_Entity (Alias (Prim)))
6590 Set_DT_Position (Prim, DT_Position (E));
6592 if not Is_Predefined_Dispatching_Alias (E) then
6593 Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
6597 Next_Elmt (Prim_Elmt);
6600 -- Third stage: Fix the position of all the new primitives
6601 -- Entries associated with primitives covering interfaces
6602 -- are handled in a latter round.
6604 Prim_Elmt := First_Prim;
6605 while Present (Prim_Elmt) loop
6606 Prim := Node (Prim_Elmt);
6608 -- Skip primitives previously set entries
6610 if DT_Position (Prim) /= No_Uint then
6613 -- Primitives covering interface primitives are handled later
6615 elsif Present (Interface_Alias (Prim)) then
6619 -- Take the next available position in the DT
6622 Nb_Prim := Nb_Prim + 1;
6623 pragma Assert (Nb_Prim <= Count_Prim);
6624 exit when not Fixed_Prim (Nb_Prim);
6627 Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
6628 Set_Fixed_Prim (Nb_Prim);
6631 Next_Elmt (Prim_Elmt);
6635 -- Fourth stage: Complete the decoration of primitives covering
6636 -- interfaces (that is, propagate the DT_Position attribute
6637 -- from the aliased primitive)
6639 Prim_Elmt := First_Prim;
6640 while Present (Prim_Elmt) loop
6641 Prim := Node (Prim_Elmt);
6643 if DT_Position (Prim) = No_Uint
6644 and then Present (Interface_Alias (Prim))
6646 pragma Assert (Present (Alias (Prim))
6647 and then Find_Dispatching_Type (Alias (Prim)) = Typ);
6649 -- Check if this entry will be placed in the primary DT
6652 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
6654 pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
6655 Set_DT_Position (Prim, DT_Position (Alias (Prim)));
6657 -- Otherwise it will be placed in the secondary DT
6661 (DT_Position (Interface_Alias (Prim)) /= No_Uint);
6662 Set_DT_Position (Prim,
6663 DT_Position (Interface_Alias (Prim)));
6667 Next_Elmt (Prim_Elmt);
6670 -- Generate listing showing the contents of the dispatch tables.
6671 -- This action is done before some further static checks because
6672 -- in case of critical errors caused by a wrong dispatch table
6673 -- we need to see the contents of such table.
6675 if Debug_Flag_ZZ then
6679 -- Final stage: Ensure that the table is correct plus some further
6680 -- verifications concerning the primitives.
6682 Prim_Elmt := First_Prim;
6684 while Present (Prim_Elmt) loop
6685 Prim := Node (Prim_Elmt);
6687 -- At this point all the primitives MUST have a position
6688 -- in the dispatch table.
6690 if DT_Position (Prim) = No_Uint then
6691 raise Program_Error;
6694 -- Calculate real size of the dispatch table
6696 if not (Is_Predefined_Dispatching_Operation (Prim)
6697 or else Is_Predefined_Dispatching_Alias (Prim))
6698 and then UI_To_Int (DT_Position (Prim)) > DT_Length
6700 DT_Length := UI_To_Int (DT_Position (Prim));
6703 -- Ensure that the assigned position to non-predefined
6704 -- dispatching operations in the dispatch table is correct.
6706 if not (Is_Predefined_Dispatching_Operation (Prim)
6707 or else Is_Predefined_Dispatching_Alias (Prim))
6709 Validate_Position (Prim);
6712 if Chars (Prim) = Name_Finalize then
6716 if Chars (Prim) = Name_Adjust then
6720 -- An abstract operation cannot be declared in the private part
6721 -- for a visible abstract type, because it could never be over-
6722 -- ridden. For explicit declarations this is checked at the
6723 -- point of declaration, but for inherited operations it must
6724 -- be done when building the dispatch table.
6726 -- Ada 2005 (AI-251): Primitives associated with interfaces are
6727 -- excluded from this check because interfaces must be visible in
6728 -- the public and private part (RM 7.3 (7.3/2))
6730 if Is_Abstract_Type (Typ)
6731 and then Is_Abstract_Subprogram (Prim)
6732 and then Present (Alias (Prim))
6733 and then not Is_Interface
6734 (Find_Dispatching_Type (Ultimate_Alias (Prim)))
6735 and then not Present (Interface_Alias (Prim))
6736 and then Is_Derived_Type (Typ)
6737 and then In_Private_Part (Current_Scope)
6739 List_Containing (Parent (Prim)) =
6740 Private_Declarations
6741 (Specification (Unit_Declaration_Node (Current_Scope)))
6742 and then Original_View_In_Visible_Part (Typ)
6744 -- We exclude Input and Output stream operations because
6745 -- Limited_Controlled inherits useless Input and Output
6746 -- stream operations from Root_Controlled, which can
6747 -- never be overridden.
6749 if not Is_TSS (Prim, TSS_Stream_Input)
6751 not Is_TSS (Prim, TSS_Stream_Output)
6754 ("abstract inherited private operation&" &
6755 " must be overridden (RM 3.9.3(10))",
6756 Parent (Typ), Prim);
6760 Next_Elmt (Prim_Elmt);
6765 if Is_Controlled (Typ) then
6766 if not Finalized then
6768 ("controlled type has no explicit Finalize method?", Typ);
6770 elsif not Adjusted then
6772 ("controlled type has no explicit Adjust method?", Typ);
6776 -- Set the final size of the Dispatch Table
6778 Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
6780 -- The derived type must have at least as many components as its parent
6781 -- (for root types Etype points to itself and the test cannot fail).
6783 if DT_Entry_Count (The_Tag) <
6784 DT_Entry_Count (First_Tag_Component (Parent_Typ))
6786 raise Program_Error;
6788 end Set_All_DT_Position;
6790 -----------------------------
6791 -- Set_Default_Constructor --
6792 -----------------------------
6794 procedure Set_Default_Constructor (Typ : Entity_Id) is
6801 -- Look for the default constructor entity. For now only the
6802 -- default constructor has the flag Is_Constructor.
6804 E := Next_Entity (Typ);
6806 and then (Ekind (E) /= E_Function or else not Is_Constructor (E))
6811 -- Create the init procedure
6815 Init := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
6816 Param := Make_Defining_Identifier (Loc, Name_X);
6819 Make_Subprogram_Declaration (Loc,
6820 Make_Procedure_Specification (Loc,
6821 Defining_Unit_Name => Init,
6822 Parameter_Specifications => New_List (
6823 Make_Parameter_Specification (Loc,
6824 Defining_Identifier => Param,
6825 Parameter_Type => New_Reference_To (Typ, Loc))))));
6827 Set_Init_Proc (Typ, Init);
6828 Set_Is_Imported (Init);
6829 Set_Interface_Name (Init, Interface_Name (E));
6830 Set_Convention (Init, Convention_C);
6831 Set_Is_Public (Init);
6832 Set_Has_Completion (Init);
6834 -- If there are no constructors, mark the type as abstract since we
6835 -- won't be able to declare objects of that type.
6838 Set_Is_Abstract_Type (Typ);
6840 end Set_Default_Constructor;
6842 --------------------------
6843 -- Set_DTC_Entity_Value --
6844 --------------------------
6846 procedure Set_DTC_Entity_Value
6847 (Tagged_Type : Entity_Id;
6851 if Present (Interface_Alias (Prim))
6852 and then Is_Interface
6853 (Find_Dispatching_Type (Interface_Alias (Prim)))
6855 Set_DTC_Entity (Prim,
6858 Iface => Find_Dispatching_Type (Interface_Alias (Prim))));
6860 Set_DTC_Entity (Prim,
6861 First_Tag_Component (Tagged_Type));
6863 end Set_DTC_Entity_Value;
6869 function Tagged_Kind (T : Entity_Id) return Node_Id is
6870 Conc_Typ : Entity_Id;
6871 Loc : constant Source_Ptr := Sloc (T);
6875 (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind));
6879 if Is_Abstract_Type (T) then
6880 if Is_Limited_Record (T) then
6881 return New_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc);
6883 return New_Reference_To (RTE (RE_TK_Abstract_Tagged), Loc);
6888 elsif Is_Concurrent_Record_Type (T) then
6889 Conc_Typ := Corresponding_Concurrent_Type (T);
6891 if Present (Full_View (Conc_Typ)) then
6892 Conc_Typ := Full_View (Conc_Typ);
6895 if Ekind (Conc_Typ) = E_Protected_Type then
6896 return New_Reference_To (RTE (RE_TK_Protected), Loc);
6898 pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
6899 return New_Reference_To (RTE (RE_TK_Task), Loc);
6902 -- Regular tagged kinds
6905 if Is_Limited_Record (T) then
6906 return New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc);
6908 return New_Reference_To (RTE (RE_TK_Tagged), Loc);
6917 procedure Write_DT (Typ : Entity_Id) is
6922 -- Protect this procedure against wrong usage. Required because it will
6923 -- be used directly from GDB
6925 if not (Typ <= Last_Node_Id)
6926 or else not Is_Tagged_Type (Typ)
6928 Write_Str ("wrong usage: Write_DT must be used with tagged types");
6933 Write_Int (Int (Typ));
6935 Write_Name (Chars (Typ));
6937 if Is_Interface (Typ) then
6938 Write_Str (" is interface");
6943 Elmt := First_Elmt (Primitive_Operations (Typ));
6944 while Present (Elmt) loop
6945 Prim := Node (Elmt);
6948 -- Indicate if this primitive will be allocated in the primary
6949 -- dispatch table or in a secondary dispatch table associated
6950 -- with an abstract interface type
6952 if Present (DTC_Entity (Prim)) then
6953 if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
6960 -- Output the node of this primitive operation and its name
6962 Write_Int (Int (Prim));
6965 if Is_Predefined_Dispatching_Operation (Prim) then
6966 Write_Str ("(predefined) ");
6969 Write_Name (Chars (Prim));
6971 -- Indicate if this primitive has an aliased primitive
6973 if Present (Alias (Prim)) then
6974 Write_Str (" (alias = ");
6975 Write_Int (Int (Alias (Prim)));
6977 -- If the DTC_Entity attribute is already set we can also output
6978 -- the name of the interface covered by this primitive (if any)
6980 if Present (DTC_Entity (Alias (Prim)))
6981 and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
6983 Write_Str (" from interface ");
6984 Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
6987 if Present (Interface_Alias (Prim)) then
6988 Write_Str (", AI_Alias of ");
6990 (Chars (Find_Dispatching_Type (Interface_Alias (Prim))));
6992 Write_Int (Int (Interface_Alias (Prim)));
6998 -- Display the final position of this primitive in its associated
6999 -- (primary or secondary) dispatch table
7001 if Present (DTC_Entity (Prim))
7002 and then DT_Position (Prim) /= No_Uint
7004 Write_Str (" at #");
7005 Write_Int (UI_To_Int (DT_Position (Prim)));
7008 if Is_Abstract_Subprogram (Prim) then
7009 Write_Str (" is abstract;");
7011 -- Check if this is a null primitive
7013 elsif Comes_From_Source (Prim)
7014 and then Ekind (Prim) = E_Procedure
7015 and then Null_Present (Parent (Prim))
7017 Write_Str (" is null;");