1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2024, 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 Accessibility
; use Accessibility
;
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Einfo
.Entities
; use Einfo
.Entities
;
32 with Einfo
.Utils
; use Einfo
.Utils
;
33 with Elists
; use Elists
;
34 with Errout
; use Errout
;
35 with Expander
; use Expander
;
36 with Exp_Atag
; use Exp_Atag
;
37 with Exp_Ch6
; use Exp_Ch6
;
38 with Exp_CG
; use Exp_CG
;
39 with Exp_Dbug
; use Exp_Dbug
;
40 with Exp_Tss
; use Exp_Tss
;
41 with Exp_Util
; use Exp_Util
;
42 with Freeze
; use Freeze
;
43 with Ghost
; use Ghost
;
44 with Itypes
; use Itypes
;
45 with Layout
; use Layout
;
46 with Nlists
; use Nlists
;
47 with Nmake
; use Nmake
;
48 with Namet
; use Namet
;
50 with Output
; use Output
;
51 with Restrict
; use Restrict
;
52 with Rident
; use Rident
;
53 with Rtsfind
; use Rtsfind
;
55 with Sem_Aux
; use Sem_Aux
;
56 with Sem_Ch6
; use Sem_Ch6
;
57 with Sem_Ch7
; use Sem_Ch7
;
58 with Sem_Ch8
; use Sem_Ch8
;
59 with Sem_Disp
; use Sem_Disp
;
60 with Sem_Eval
; use Sem_Eval
;
61 with Sem_Res
; use Sem_Res
;
62 with Sem_Type
; use Sem_Type
;
63 with Sem_Util
; use Sem_Util
;
64 with Sinfo
; use Sinfo
;
65 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
66 with Sinfo
.Utils
; use Sinfo
.Utils
;
67 with Snames
; use Snames
;
68 with Stand
; use Stand
;
69 with Stringt
; use Stringt
;
70 with Strub
; use Strub
;
71 with SCIL_LL
; use SCIL_LL
;
72 with Tbuild
; use Tbuild
;
73 with Ttypes
; use Ttypes
;
75 package body Exp_Disp
is
77 -----------------------
78 -- Local Subprograms --
79 -----------------------
81 function Default_Prim_Op_Position
(E
: Entity_Id
) return Uint
;
82 -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
83 -- of the default primitive operations.
85 procedure Expand_Interface_Thunk
87 Thunk_Id
: out Entity_Id
;
88 Thunk_Code
: out List_Id
;
90 -- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we
91 -- generate additional subprograms (thunks) associated with each primitive
92 -- Prim to have a layout compatible with the C++ ABI. The thunk displaces
93 -- the pointers to the actuals that depend on the controlling type before
94 -- transferring control to the target subprogram. If there is no need to
95 -- generate the thunk, then Thunk_Id is set to Empty. Otherwise Thunk_Id
96 -- is set to the defining identifier of the thunk and Thunk_Code to the
97 -- code generated for the thunk respectively.
99 procedure Expand_Secondary_Stack_Thunk
101 Thunk_Id
: out Entity_Id
;
102 Thunk_Code
: out Node_Id
);
103 -- When a primitive function of a tagged type can dispatch on result and
104 -- the tagged type is not returned on the secondary stack, we generate an
105 -- additional function (thunk) that calls the primitive function with the
106 -- same actuals and move its result onto the secondary stack. This thunk
107 -- is intended to be put into the slot of the primitive function in the
108 -- dispatch table, so as to be invoked in lieu of the primitive function
109 -- in dispatching calls. If there is no need to generate the thunk, then
110 -- Thunk_Id is set to Empty. Otherwise Thunk_Id is set to the defining
111 -- identifier of the thunk and Thunk_Code to the code generated for the
112 -- thunk respectively.
114 function Has_DT
(Typ
: Entity_Id
) return Boolean;
115 pragma Inline
(Has_DT
);
116 -- Returns true if we generate a dispatch table for tagged type Typ
118 function Is_Predefined_Dispatching_Alias
(Prim
: Entity_Id
) return Boolean;
119 -- Returns true if Prim is not a predefined dispatching primitive but it is
120 -- an alias of a predefined dispatching primitive (i.e. through a renaming)
122 function New_Value
(From
: Node_Id
) return Node_Id
;
123 -- From is the original Expression. New_Value is equivalent to a call to
124 -- Duplicate_Subexpr with an explicit dereference when From is an access
127 function Prim_Op_Kind
129 Typ
: Entity_Id
) return Node_Id
;
130 -- Ada 2005 (AI-345): Determine the primitive operation kind of Prim
131 -- according to its type Typ. Return a reference to an RE_Prim_Op_Kind
132 -- enumeration value.
134 function Tagged_Kind
(T
: Entity_Id
) return Node_Id
;
135 -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
136 -- to an RE_Tagged_Kind enumeration value.
138 ----------------------
139 -- Apply_Tag_Checks --
140 ----------------------
142 procedure Apply_Tag_Checks
(Call_Node
: Node_Id
) is
143 Loc
: constant Source_Ptr
:= Sloc
(Call_Node
);
144 Ctrl_Arg
: constant Node_Id
:= Controlling_Argument
(Call_Node
);
145 Ctrl_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Ctrl_Arg
));
146 Param_List
: constant List_Id
:= Parameter_Associations
(Call_Node
);
152 Eq_Prim_Op
: Entity_Id
:= Empty
;
155 if No_Run_Time_Mode
then
156 Error_Msg_CRT
("tagged types", Call_Node
);
160 -- Apply_Tag_Checks is called directly from the semantics, so we
161 -- need a check to see whether expansion is active before proceeding.
162 -- In addition, there is no need to expand the call when compiling
163 -- under restriction No_Dispatching_Calls; the semantic analyzer has
164 -- previously notified the violation of this restriction.
166 if not Expander_Active
167 or else Restriction_Active
(No_Dispatching_Calls
)
172 -- Set subprogram. If this is an inherited operation that was
173 -- overridden, the body that is being called is its alias.
175 Subp
:= Entity
(Name
(Call_Node
));
177 if Present
(Alias
(Subp
))
178 and then Is_Inherited_Operation
(Subp
)
179 and then No
(DTC_Entity
(Subp
))
181 Subp
:= Alias
(Subp
);
184 -- Definition of the class-wide type and the tagged type
186 -- If the controlling argument is itself a tag rather than a tagged
187 -- object, then use the class-wide type associated with the subprogram's
188 -- controlling type. This case can occur when a call to an inherited
189 -- primitive has an actual that originated from a default parameter
190 -- given by a tag-indeterminate call and when there is no other
191 -- controlling argument providing the tag (AI-239 requires dispatching).
192 -- This capability of dispatching directly by tag is also needed by the
193 -- implementation of AI-260 (for the generic dispatching constructors).
195 if Is_RTE
(Ctrl_Typ
, RE_Tag
)
196 or else Is_RTE
(Ctrl_Typ
, RE_Interface_Tag
)
198 CW_Typ
:= Class_Wide_Type
(Find_Dispatching_Type
(Subp
));
200 -- Class_Wide_Type is applied to the expressions used to initialize
201 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
202 -- there are cases where the controlling type is resolved to a specific
203 -- type (such as for designated types of arguments such as CW'Access).
205 elsif Is_Access_Type
(Ctrl_Typ
) then
206 CW_Typ
:= Class_Wide_Type
(Designated_Type
(Ctrl_Typ
));
209 CW_Typ
:= Class_Wide_Type
(Ctrl_Typ
);
212 Typ
:= Find_Specific_Type
(CW_Typ
);
214 if not Is_Limited_Type
(Typ
) then
215 Eq_Prim_Op
:= Find_Prim_Op
(Typ
, Name_Op_Eq
);
218 -- Dispatching call to C++ primitive
220 if Is_CPP_Class
(Typ
) then
223 -- Dispatching call to Ada primitive
225 elsif Present
(Param_List
) then
227 -- Generate the Tag checks when appropriate
229 Param
:= First_Actual
(Call_Node
);
230 while Present
(Param
) loop
232 -- No tag check with itself
234 if Param
= Ctrl_Arg
then
237 -- No tag check for parameter whose type is neither tagged nor
238 -- access to tagged (for access parameters)
240 elsif No
(Find_Controlling_Arg
(Param
)) then
243 -- No tag check for function dispatching on result if the
244 -- Tag given by the context is this one
246 elsif Find_Controlling_Arg
(Param
) = Ctrl_Arg
then
249 -- "=" is the only dispatching operation allowed to get operands
250 -- with incompatible tags (it just returns false). We use
251 -- Duplicate_Subexpr_Move_Checks instead of calling Relocate_Node
252 -- because the value will be duplicated to check the tags.
254 elsif Subp
= Eq_Prim_Op
then
257 -- No check in presence of suppress flags
259 elsif Tag_Checks_Suppressed
(Etype
(Param
))
260 or else (Is_Access_Type
(Etype
(Param
))
261 and then Tag_Checks_Suppressed
262 (Designated_Type
(Etype
(Param
))))
266 -- Optimization: no tag checks if the parameters are identical
268 elsif Is_Entity_Name
(Param
)
269 and then Is_Entity_Name
(Ctrl_Arg
)
270 and then Entity
(Param
) = Entity
(Ctrl_Arg
)
274 -- Now we need to generate the Tag check
277 -- Generate code for tag equality check
279 -- Perhaps should have Checks.Apply_Tag_Equality_Check???
281 Insert_Action
(Ctrl_Arg
,
282 Make_Implicit_If_Statement
(Call_Node
,
286 Make_Selected_Component
(Loc
,
287 Prefix
=> New_Value
(Ctrl_Arg
),
290 (First_Tag_Component
(Typ
), Loc
)),
293 Make_Selected_Component
(Loc
,
295 Unchecked_Convert_To
(Typ
, New_Value
(Param
)),
298 (First_Tag_Component
(Typ
), Loc
))),
301 New_List
(New_Constraint_Error
(Loc
))));
307 end Apply_Tag_Checks
;
309 ------------------------
310 -- Building_Static_DT --
311 ------------------------
313 function Building_Static_DT
(Typ
: Entity_Id
) return Boolean is
314 Root_Typ
: Entity_Id
:= Root_Type
(Typ
);
318 -- Handle private types
320 if Present
(Full_View
(Root_Typ
)) then
321 Root_Typ
:= Full_View
(Root_Typ
);
325 Building_Static_Dispatch_Tables
326 and then Is_Library_Level_Tagged_Type
(Typ
)
328 -- If the type is derived from a CPP class we cannot statically
329 -- build the dispatch tables because we must inherit primitives
330 -- from the CPP side.
332 and then not Is_CPP_Class
(Root_Typ
);
334 if not Static_DT
then
335 Check_Restriction
(Static_Dispatch_Tables
, Typ
);
339 end Building_Static_DT
;
341 ----------------------------------
342 -- Building_Static_Secondary_DT --
343 ----------------------------------
345 function Building_Static_Secondary_DT
(Typ
: Entity_Id
) return Boolean is
346 Full_Typ
: Entity_Id
:= Typ
;
347 Root_Typ
: Entity_Id
:= Root_Type
(Typ
);
351 -- Handle private types
353 if Present
(Full_View
(Typ
)) then
354 Full_Typ
:= Full_View
(Typ
);
357 if Present
(Full_View
(Root_Typ
)) then
358 Root_Typ
:= Full_View
(Root_Typ
);
362 Building_Static_DT
(Full_Typ
)
363 and then not Is_Interface
(Full_Typ
)
364 and then Has_Interfaces
(Full_Typ
)
365 and then (Full_Typ
= Root_Typ
366 or else not Is_Variable_Size_Record
(Etype
(Full_Typ
)));
369 and then not Is_Interface
(Full_Typ
)
370 and then Has_Interfaces
(Full_Typ
)
372 Check_Restriction
(Static_Dispatch_Tables
, Typ
);
376 end Building_Static_Secondary_DT
;
378 ----------------------------------
379 -- Build_Static_Dispatch_Tables --
380 ----------------------------------
382 procedure Build_Static_Dispatch_Tables
(N
: Node_Id
) is
383 Target_List
: List_Id
;
385 procedure Build_Dispatch_Tables
(List
: List_Id
);
386 -- Build the static dispatch table of tagged types found in the list of
387 -- declarations. The generated nodes are added at the end of Target_List
389 procedure Build_Package_Dispatch_Tables
(N
: Node_Id
);
390 -- Build static dispatch tables associated with package declaration N
392 procedure Make_And_Insert_Dispatch_Table
(Typ
: Entity_Id
);
393 -- Build the dispatch table of the tagged type Typ and insert it at the
394 -- end of Target_List after wrapping it in the Actions list of a freeze
395 -- node, so that it is skipped by Sem_Elab (Expand_Freeze_Record_Type
396 -- does the same for nonstatic dispatch tables).
398 ---------------------------
399 -- Build_Dispatch_Tables --
400 ---------------------------
402 procedure Build_Dispatch_Tables
(List
: List_Id
) is
407 while Present
(D
) loop
409 -- Handle nested packages and package bodies recursively. The
410 -- generated code is placed on the Target_List established for
411 -- the enclosing compilation unit.
413 if Nkind
(D
) = N_Package_Declaration
then
414 Build_Package_Dispatch_Tables
(D
);
416 elsif Nkind
(D
) = N_Package_Body
then
417 Build_Dispatch_Tables
(Declarations
(D
));
419 elsif Nkind
(D
) = N_Package_Body_Stub
420 and then Present
(Library_Unit
(D
))
422 Build_Dispatch_Tables
423 (Declarations
(Proper_Body
(Unit
(Library_Unit
(D
)))));
425 -- Handle full type declarations and derivations of library level
429 N_Full_Type_Declaration | N_Derived_Type_Definition
430 and then Is_Library_Level_Tagged_Type
(Defining_Entity
(D
))
431 and then Ekind
(Defining_Entity
(D
)) /= E_Record_Subtype
432 and then not Is_Private_Type
(Defining_Entity
(D
))
434 -- We do not generate dispatch tables for the internal types
435 -- created for a type extension with unknown discriminants
436 -- The needed information is shared with the source type,
437 -- See Expand_N_Record_Extension.
439 if Is_Underlying_Record_View
(Defining_Entity
(D
))
441 (not Comes_From_Source
(Defining_Entity
(D
))
443 Has_Unknown_Discriminants
(Etype
(Defining_Entity
(D
)))
445 not Comes_From_Source
446 (First_Subtype
(Defining_Entity
(D
))))
450 Make_And_Insert_Dispatch_Table
(Defining_Entity
(D
));
453 -- Handle private types of library level tagged types. We must
454 -- exchange the private and full-view to ensure the correct
455 -- expansion. If the full view is a synchronized type ignore
456 -- the type because the table will be built for the corresponding
457 -- record type, that has its own declaration.
459 elsif (Nkind
(D
) = N_Private_Type_Declaration
460 or else Nkind
(D
) = N_Private_Extension_Declaration
)
461 and then Present
(Full_View
(Defining_Entity
(D
)))
464 E1
: constant Entity_Id
:= Defining_Entity
(D
);
465 E2
: constant Entity_Id
:= Full_View
(E1
);
468 if Is_Library_Level_Tagged_Type
(E2
)
469 and then Ekind
(E2
) /= E_Record_Subtype
470 and then not Is_Concurrent_Type
(E2
)
472 Exchange_Declarations
(E1
);
473 Make_And_Insert_Dispatch_Table
(E1
);
474 Exchange_Declarations
(E2
);
481 end Build_Dispatch_Tables
;
483 -----------------------------------
484 -- Build_Package_Dispatch_Tables --
485 -----------------------------------
487 procedure Build_Package_Dispatch_Tables
(N
: Node_Id
) is
488 Spec
: constant Node_Id
:= Specification
(N
);
489 Id
: constant Entity_Id
:= Defining_Entity
(N
);
490 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
491 Priv_Decls
: constant List_Id
:= Private_Declarations
(Spec
);
496 if Present
(Priv_Decls
) then
497 Build_Dispatch_Tables
(Vis_Decls
);
498 Build_Dispatch_Tables
(Priv_Decls
);
500 elsif Present
(Vis_Decls
) then
501 Build_Dispatch_Tables
(Vis_Decls
);
505 end Build_Package_Dispatch_Tables
;
507 ------------------------------------
508 -- Make_And_Insert_Dispatch_Table --
509 ------------------------------------
511 procedure Make_And_Insert_Dispatch_Table
(Typ
: Entity_Id
) is
512 F_Typ
: constant Entity_Id
:= Create_Itype
(E_Class_Wide_Type
, Typ
);
513 -- The code generator discards freeze nodes of CW types after
514 -- evaluating their side effects, so create an artificial one.
516 F_Nod
: constant Node_Id
:= Make_Freeze_Entity
(Sloc
(Typ
));
519 Set_Is_Frozen
(F_Typ
);
520 Set_Entity
(F_Nod
, F_Typ
);
521 Set_Actions
(F_Nod
, Make_DT
(Typ
));
523 Insert_After_And_Analyze
(Last
(Target_List
), F_Nod
);
524 end Make_And_Insert_Dispatch_Table
;
526 -- Start of processing for Build_Static_Dispatch_Tables
529 if Nkind
(N
) = N_Package_Declaration
then
531 Spec
: constant Node_Id
:= Specification
(N
);
532 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
533 Priv_Decls
: constant List_Id
:= Private_Declarations
(Spec
);
536 if Present
(Priv_Decls
)
537 and then Is_Non_Empty_List
(Priv_Decls
)
539 Target_List
:= Priv_Decls
;
541 elsif No
(Vis_Decls
) then
542 Target_List
:= New_List
;
543 Set_Private_Declarations
(Spec
, Target_List
);
545 Target_List
:= Vis_Decls
;
548 Build_Package_Dispatch_Tables
(N
);
551 else pragma Assert
(Nkind
(N
) = N_Package_Body
);
553 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(N
);
556 Push_Scope
(Spec_Id
);
557 Target_List
:= Declarations
(N
);
558 Build_Dispatch_Tables
(Target_List
);
562 end Build_Static_Dispatch_Tables
;
564 ------------------------------
565 -- Convert_Tag_To_Interface --
566 ------------------------------
568 function Convert_Tag_To_Interface
570 Expr
: Node_Id
) return Node_Id
572 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
573 Anon_Type
: Entity_Id
;
577 pragma Assert
(Is_Class_Wide_Type
(Typ
)
578 and then Is_Interface
(Typ
)
580 ((Nkind
(Expr
) = N_Selected_Component
581 and then Is_Tag
(Entity
(Selector_Name
(Expr
))))
583 (Nkind
(Expr
) = N_Function_Call
584 and then Is_RTE
(Entity
(Name
(Expr
)), RE_Displace
))));
586 Anon_Type
:= Create_Itype
(E_Anonymous_Access_Type
, Expr
);
587 Set_Directly_Designated_Type
(Anon_Type
, Typ
);
588 Set_Etype
(Anon_Type
, Anon_Type
);
589 Set_Can_Never_Be_Null
(Anon_Type
);
591 -- Decorate the size and alignment attributes of the anonymous access
592 -- type, as required by the back end.
594 Layout_Type
(Anon_Type
);
596 if Nkind
(Expr
) = N_Selected_Component
597 and then Is_Tag
(Entity
(Selector_Name
(Expr
)))
600 Make_Explicit_Dereference
(Loc
,
601 Unchecked_Convert_To
(Anon_Type
,
602 Make_Attribute_Reference
(Loc
,
604 Attribute_Name
=> Name_Address
)));
607 Make_Explicit_Dereference
(Loc
,
608 Unchecked_Convert_To
(Anon_Type
, Expr
));
612 end Convert_Tag_To_Interface
;
618 function CPP_Num_Prims
(Typ
: Entity_Id
) return Nat
is
620 Tag_Comp
: Entity_Id
;
623 if not Is_Tagged_Type
(Typ
)
624 or else not Is_CPP_Class
(Root_Type
(Typ
))
629 CPP_Typ
:= Enclosing_CPP_Parent
(Typ
);
630 Tag_Comp
:= First_Tag_Component
(CPP_Typ
);
632 -- If number of primitives already set in the tag component, use it
634 if Present
(Tag_Comp
)
635 and then Present
(DT_Entry_Count
(Tag_Comp
))
637 return UI_To_Int
(DT_Entry_Count
(Tag_Comp
));
639 -- Otherwise, count the primitives of the enclosing CPP type
642 return List_Length
(Primitive_Operations
(CPP_Typ
));
647 ------------------------------
648 -- Default_Prim_Op_Position --
649 ------------------------------
651 function Default_Prim_Op_Position
(E
: Entity_Id
) return Uint
is
652 TSS_Name
: TSS_Name_Type
;
655 Get_Name_String
(Chars
(E
));
658 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
660 if Chars
(E
) = Name_uSize
then
663 elsif TSS_Name
= TSS_Stream_Read
then
666 elsif TSS_Name
= TSS_Stream_Write
then
669 elsif TSS_Name
= TSS_Stream_Input
then
672 elsif TSS_Name
= TSS_Stream_Output
then
675 elsif Chars
(E
) = Name_Op_Eq
then
678 elsif Chars
(E
) = Name_uAssign
then
681 elsif TSS_Name
= TSS_Deep_Adjust
then
684 elsif TSS_Name
= TSS_Deep_Finalize
then
687 elsif TSS_Name
= TSS_Put_Image
then
690 -- In VM targets unconditionally allow obtaining the position associated
691 -- with predefined interface primitives since in these platforms any
692 -- tagged type has these primitives.
694 elsif Ada_Version
>= Ada_2005
or else not Tagged_Type_Expansion
then
695 if Chars
(E
) = Name_uDisp_Asynchronous_Select
then
698 elsif Chars
(E
) = Name_uDisp_Conditional_Select
then
701 elsif Chars
(E
) = Name_uDisp_Get_Prim_Op_Kind
then
704 elsif Chars
(E
) = Name_uDisp_Get_Task_Id
then
707 elsif Chars
(E
) = Name_uDisp_Requeue
then
710 elsif Chars
(E
) = Name_uDisp_Timed_Select
then
716 end Default_Prim_Op_Position
;
718 ----------------------
719 -- Elab_Flag_Needed --
720 ----------------------
722 function Elab_Flag_Needed
(Typ
: Entity_Id
) return Boolean is
724 return Ada_Version
>= Ada_2005
725 and then not Is_Interface
(Typ
)
726 and then Has_Interfaces
(Typ
)
727 and then not Building_Static_DT
(Typ
);
728 end Elab_Flag_Needed
;
730 -----------------------------
731 -- Expand_Dispatching_Call --
732 -----------------------------
734 procedure Expand_Dispatching_Call
(Call_Node
: Node_Id
) is
735 Loc
: constant Source_Ptr
:= Sloc
(Call_Node
);
736 Call_Typ
: constant Entity_Id
:= Etype
(Call_Node
);
738 Ctrl_Arg
: constant Node_Id
:= Controlling_Argument
(Call_Node
);
739 Ctrl_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Ctrl_Arg
));
740 Param_List
: constant List_Id
:= Parameter_Associations
(Call_Node
);
745 New_Call_Name
: Node_Id
;
746 New_Params
: List_Id
:= No_List
;
748 Subp_Ptr_Typ
: Entity_Id
;
749 Subp_Typ
: Entity_Id
;
751 Eq_Prim_Op
: Entity_Id
:= Empty
;
752 Controlling_Tag
: Node_Id
;
754 function New_Value
(From
: Node_Id
) return Node_Id
;
755 -- From is the original Expression. New_Value is equivalent to a call
756 -- to Duplicate_Subexpr with an explicit dereference when From is an
763 function New_Value
(From
: Node_Id
) return Node_Id
is
764 Res
: constant Node_Id
:= Duplicate_Subexpr
(From
);
766 if Is_Access_Type
(Etype
(From
)) then
768 Make_Explicit_Dereference
(Sloc
(From
),
778 SCIL_Node
: Node_Id
:= Empty
;
779 SCIL_Related_Node
: Node_Id
:= Call_Node
;
781 -- Start of processing for Expand_Dispatching_Call
784 if No_Run_Time_Mode
then
785 Error_Msg_CRT
("tagged types", Call_Node
);
789 -- Expand_Dispatching_Call is called directly from the semantics, so we
790 -- only proceed if the expander is active.
792 if not Expander_Active
794 -- And there is no need to expand the call if we are compiling under
795 -- restriction No_Dispatching_Calls; the semantic analyzer has
796 -- previously notified the violation of this restriction.
798 or else Restriction_Active
(No_Dispatching_Calls
)
800 -- No action needed if the dispatching call has been already expanded
802 or else Is_Expanded_Dispatching_Call
(Name
(Call_Node
))
807 -- Set subprogram. If this is an inherited operation that was
808 -- overridden, the body that is being called is its alias.
810 Subp
:= Entity
(Name
(Call_Node
));
812 if Present
(Alias
(Subp
))
813 and then Is_Inherited_Operation
(Subp
)
814 and then No
(DTC_Entity
(Subp
))
816 Subp
:= Alias
(Subp
);
819 -- Definition of the class-wide type and the tagged type
821 -- If the controlling argument is itself a tag rather than a tagged
822 -- object, then use the class-wide type associated with the subprogram's
823 -- controlling type. This case can occur when a call to an inherited
824 -- primitive has an actual that originated from a default parameter
825 -- given by a tag-indeterminate call and when there is no other
826 -- controlling argument providing the tag (AI-239 requires dispatching).
827 -- This capability of dispatching directly by tag is also needed by the
828 -- implementation of AI-260 (for the generic dispatching constructors).
830 if Is_RTE
(Ctrl_Typ
, RE_Tag
)
831 or else Is_RTE
(Ctrl_Typ
, RE_Interface_Tag
)
833 CW_Typ
:= Class_Wide_Type
(Find_Dispatching_Type
(Subp
));
835 -- Class_Wide_Type is applied to the expressions used to initialize
836 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
837 -- there are cases where the controlling type is resolved to a specific
838 -- type (such as for designated types of arguments such as CW'Access).
840 elsif Is_Access_Type
(Ctrl_Typ
) then
841 CW_Typ
:= Class_Wide_Type
(Designated_Type
(Ctrl_Typ
));
844 CW_Typ
:= Class_Wide_Type
(Ctrl_Typ
);
847 Typ
:= Find_Specific_Type
(CW_Typ
);
849 -- The tagged type of a dispatching call must be frozen at this stage
851 pragma Assert
(Is_Frozen
(Typ
));
853 if not Is_Limited_Type
(Typ
) then
854 Eq_Prim_Op
:= Find_Prim_Op
(Typ
, Name_Op_Eq
);
857 -- Dispatching call to C++ primitive. Create a new parameter list
858 -- with no tag checks.
860 New_Params
:= New_List
;
862 if Is_CPP_Class
(Typ
) then
863 Param
:= First_Actual
(Call_Node
);
864 while Present
(Param
) loop
865 Append_To
(New_Params
, Relocate_Node
(Param
));
869 -- Dispatching call to Ada primitive
871 elsif Present
(Param_List
) then
872 Apply_Tag_Checks
(Call_Node
);
874 Param
:= First_Actual
(Call_Node
);
875 while Present
(Param
) loop
877 -- Cases in which we may have generated run-time checks. Note that
878 -- we strip any qualification from Param before comparing with the
879 -- already-stripped controlling argument.
881 if Unqualify
(Param
) = Ctrl_Arg
or else Subp
= Eq_Prim_Op
then
882 Append_To
(New_Params
,
883 Duplicate_Subexpr_Move_Checks
(Param
));
885 elsif Nkind
(Parent
(Param
)) /= N_Parameter_Association
886 or else not Is_Accessibility_Actual
(Parent
(Param
))
888 Append_To
(New_Params
, Relocate_Node
(Param
));
895 -- Generate the appropriate subprogram designated type
897 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, Call_Node
);
898 Copy_Strub_Mode
(Subp_Typ
, Subp
);
899 Set_Convention
(Subp_Typ
, Convention
(Subp
));
901 -- If this is a function and it has a controlling tagged result, then
902 -- the call is dispatching on result and returns the class-wide type.
904 if Ekind
(Subp
) = E_Function
905 and then Has_Controlling_Result
(Subp
)
906 and then Is_Tagged_Type
(Etype
(Subp
))
908 Set_Etype
(Subp_Typ
, Class_Wide_Type
(Etype
(Subp
)));
909 Set_Returns_By_Ref
(Subp_Typ
, True);
911 Set_Etype
(Subp_Typ
, Etype
(Subp
));
912 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
915 -- Notify gigi that the designated type is a dispatching primitive
917 Set_Is_Dispatch_Table_Entity
(Subp_Typ
);
919 -- Create a new list of parameters which is a copy of the old formal
920 -- list including the creation of a new set of matching entities.
923 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
924 New_Formal
: Entity_Id
;
925 Last_Formal
: Entity_Id
:= Empty
;
928 if Present
(Old_Formal
) then
929 New_Formal
:= New_Copy
(Old_Formal
);
930 Set_First_Entity
(Subp_Typ
, New_Formal
);
931 Param
:= First_Actual
(Call_Node
);
934 Set_Scope
(New_Formal
, Subp_Typ
);
936 -- Change all the controlling argument types to be class-wide
937 -- to avoid a recursion in dispatching.
939 if Is_Controlling_Formal
(New_Formal
) then
940 Set_Etype
(New_Formal
, Etype
(Param
));
943 -- If the type of the formal is an itype, there was code here
944 -- introduced in 1998 in revision 1.46, to create a new itype
945 -- by copy. This seems useless, and in fact leads to semantic
946 -- errors when the itype is the completion of a type derived
947 -- from a private type.
949 Last_Formal
:= New_Formal
;
950 Next_Formal
(Old_Formal
);
951 exit when No
(Old_Formal
);
953 Link_Entities
(New_Formal
, New_Copy
(Old_Formal
));
954 Next_Entity
(New_Formal
);
958 Unlink_Next_Entity
(New_Formal
);
959 Set_Last_Entity
(Subp_Typ
, Last_Formal
);
962 -- Now that the explicit formals have been duplicated, any extra
963 -- formals needed by the subprogram must be duplicated; we know
964 -- that extra formals are available because they were added when
965 -- the tagged type was frozen (see Expand_Freeze_Record_Type).
967 pragma Assert
(Is_Frozen
(Typ
));
969 -- Warning: The addition of the extra formals cannot be performed
970 -- here invoking Create_Extra_Formals since we must ensure that all
971 -- the extra formals of the pointer type and the target subprogram
972 -- match (and for functions that return a tagged type the profile of
973 -- the built subprogram type always returns a class-wide type, which
974 -- may affect the addition of some extra formals).
976 if Present
(Last_Formal
)
977 and then Present
(Extra_Formal
(Last_Formal
))
979 Old_Formal
:= Extra_Formal
(Last_Formal
);
980 New_Formal
:= New_Copy
(Old_Formal
);
981 Set_Scope
(New_Formal
, Subp_Typ
);
983 Set_Extra_Formal
(Last_Formal
, New_Formal
);
984 Set_Extra_Formals
(Subp_Typ
, New_Formal
);
986 if Ekind
(Subp
) = E_Function
987 and then Present
(Extra_Accessibility_Of_Result
(Subp
))
988 and then Extra_Accessibility_Of_Result
(Subp
) = Old_Formal
990 Set_Extra_Accessibility_Of_Result
(Subp_Typ
, New_Formal
);
993 Old_Formal
:= Extra_Formal
(Old_Formal
);
994 while Present
(Old_Formal
) loop
995 Set_Extra_Formal
(New_Formal
, New_Copy
(Old_Formal
));
996 New_Formal
:= Extra_Formal
(New_Formal
);
997 Set_Scope
(New_Formal
, Subp_Typ
);
999 if Ekind
(Subp
) = E_Function
1000 and then Present
(Extra_Accessibility_Of_Result
(Subp
))
1001 and then Extra_Accessibility_Of_Result
(Subp
) = Old_Formal
1003 Set_Extra_Accessibility_Of_Result
(Subp_Typ
, New_Formal
);
1006 Old_Formal
:= Extra_Formal
(Old_Formal
);
1011 -- Generate the appropriate subprogram pointer type and decorate it
1013 Subp_Ptr_Typ
:= Create_Itype
(E_Access_Subprogram_Type
, Call_Node
);
1014 Set_Etype
(Subp_Ptr_Typ
, Subp_Ptr_Typ
);
1015 Set_Directly_Designated_Type
(Subp_Ptr_Typ
, Subp_Typ
);
1016 Set_Convention
(Subp_Ptr_Typ
, Convention
(Subp_Typ
));
1017 Layout_Type
(Subp_Ptr_Typ
);
1019 -- If the controlling argument is a value of type Ada.Tag or an abstract
1020 -- interface class-wide type then use it directly. Otherwise, the tag
1021 -- must be extracted from the controlling object.
1023 if Is_RTE
(Ctrl_Typ
, RE_Tag
)
1024 or else Is_RTE
(Ctrl_Typ
, RE_Interface_Tag
)
1026 Controlling_Tag
:= Duplicate_Subexpr
(Ctrl_Arg
);
1028 -- Extract the tag from an unchecked type conversion. Done to avoid
1029 -- the expansion of additional code just to obtain the value of such
1030 -- tag because the current management of interface type conversions
1031 -- generates in some cases this unchecked type conversion with the
1032 -- tag of the object (see Expand_Interface_Conversion).
1034 elsif Nkind
(Ctrl_Arg
) = N_Unchecked_Type_Conversion
1036 (Is_RTE
(Etype
(Expression
(Ctrl_Arg
)), RE_Tag
)
1038 Is_RTE
(Etype
(Expression
(Ctrl_Arg
)), RE_Interface_Tag
))
1040 Controlling_Tag
:= Duplicate_Subexpr
(Expression
(Ctrl_Arg
));
1042 -- Ada 2005 (AI-251): Abstract interface class-wide type
1044 elsif Is_Interface
(Ctrl_Typ
) and then Is_Class_Wide_Type
(Ctrl_Typ
) then
1046 Make_Attribute_Reference
(Loc
,
1047 Prefix
=> Duplicate_Subexpr
(Ctrl_Arg
),
1048 Attribute_Name
=> Name_Tag
);
1050 elsif Is_Access_Type
(Ctrl_Typ
) then
1052 Make_Selected_Component
(Loc
,
1054 Make_Explicit_Dereference
(Loc
,
1055 Duplicate_Subexpr_Move_Checks
(Ctrl_Arg
)),
1056 Selector_Name
=> New_Occurrence_Of
(DTC_Entity
(Subp
), Loc
));
1060 Make_Selected_Component
(Loc
,
1061 Prefix
=> Duplicate_Subexpr_Move_Checks
(Ctrl_Arg
),
1062 Selector_Name
=> New_Occurrence_Of
(DTC_Entity
(Subp
), Loc
));
1065 -- Handle dispatching calls to predefined primitives
1067 if Is_Predefined_Dispatching_Operation
(Subp
)
1068 or else Is_Predefined_Dispatching_Alias
(Subp
)
1070 Build_Get_Predefined_Prim_Op_Address
(Loc
,
1071 Tag_Node
=> Controlling_Tag
,
1072 Position
=> DT_Position
(Subp
),
1073 New_Node
=> New_Node
);
1075 -- Handle dispatching calls to user-defined primitives
1078 Build_Get_Prim_Op_Address
(Loc
,
1079 Typ
=> Underlying_Type
(Find_Dispatching_Type
(Subp
)),
1080 Tag_Node
=> Controlling_Tag
,
1081 Position
=> DT_Position
(Subp
),
1082 New_Node
=> New_Node
);
1086 Unchecked_Convert_To
(Subp_Ptr_Typ
, New_Node
);
1088 -- Generate the SCIL node for this dispatching call. Done now because
1089 -- attribute SCIL_Controlling_Tag must be set after the new call name
1090 -- is built to reference the nodes that will see the SCIL backend
1091 -- (because Build_Get_Prim_Op_Address generates an unchecked type
1092 -- conversion which relocates the controlling tag node).
1094 if Generate_SCIL
then
1095 SCIL_Node
:= Make_SCIL_Dispatching_Call
(Sloc
(Call_Node
));
1096 Set_SCIL_Entity
(SCIL_Node
, Typ
);
1097 Set_SCIL_Target_Prim
(SCIL_Node
, Subp
);
1099 -- Common case: the controlling tag is the tag of an object
1100 -- (for example, obj.tag)
1102 if Nkind
(Controlling_Tag
) = N_Selected_Component
then
1103 Set_SCIL_Controlling_Tag
(SCIL_Node
, Controlling_Tag
);
1105 -- Handle renaming of selected component
1107 elsif Nkind
(Controlling_Tag
) = N_Identifier
1108 and then Nkind
(Parent
(Entity
(Controlling_Tag
))) =
1109 N_Object_Renaming_Declaration
1110 and then Nkind
(Name
(Parent
(Entity
(Controlling_Tag
)))) =
1111 N_Selected_Component
1113 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1114 Name
(Parent
(Entity
(Controlling_Tag
))));
1116 -- If the controlling tag is an identifier, the SCIL node references
1117 -- the corresponding object or parameter declaration
1119 elsif Nkind
(Controlling_Tag
) = N_Identifier
1120 and then Nkind
(Parent
(Entity
(Controlling_Tag
))) in
1121 N_Object_Declaration | N_Parameter_Specification
1123 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1124 Parent
(Entity
(Controlling_Tag
)));
1126 -- If the controlling tag is a dereference, the SCIL node references
1127 -- the corresponding object or parameter declaration
1129 elsif Nkind
(Controlling_Tag
) = N_Explicit_Dereference
1130 and then Nkind
(Prefix
(Controlling_Tag
)) = N_Identifier
1131 and then Nkind
(Parent
(Entity
(Prefix
(Controlling_Tag
)))) in
1132 N_Object_Declaration | N_Parameter_Specification
1134 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1135 Parent
(Entity
(Prefix
(Controlling_Tag
))));
1137 -- Depending on whether a dereference is involved, the SCIL node
1138 -- references the corresponding object/parameter declaration or
1139 -- the internal object declaration containing the tag of the type.
1141 elsif Nkind
(Controlling_Tag
) = N_Attribute_Reference
1142 and then Attribute_Name
(Controlling_Tag
) = Name_Tag
1145 Prefix_Node
: constant Node_Id
:= Prefix
(Controlling_Tag
);
1146 Ent
: constant Entity_Id
:= Entity
1147 (if Nkind
(Prefix_Node
) = N_Explicit_Dereference
then
1148 Prefix
(Prefix_Node
)
1153 if Ekind
(Ent
) in E_Record_Type
1155 | E_Record_Type_With_Private
1157 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1161 (Access_Disp_Table
(Ent
)))));
1164 Set_SCIL_Controlling_Tag
(SCIL_Node
, Parent
(Ent
));
1168 -- Interfaces are not supported. For now we leave the SCIL node
1169 -- decorated with the Controlling_Tag. More work needed here???
1171 elsif Is_Interface
(Etype
(Controlling_Tag
)) then
1172 Set_SCIL_Controlling_Tag
(SCIL_Node
, Controlling_Tag
);
1175 pragma Assert
(False);
1180 if Nkind
(Call_Node
) = N_Function_Call
then
1182 Make_Function_Call
(Loc
,
1183 Name
=> New_Call_Name
,
1184 Parameter_Associations
=> New_Params
);
1186 -- If this is a dispatching "=", we must first compare the tags so
1187 -- we generate: x.tag = y.tag and then x = y
1189 if Subp
= Eq_Prim_Op
then
1190 Param
:= First_Actual
(Call_Node
);
1196 Make_Selected_Component
(Loc
,
1197 Prefix
=> New_Value
(Param
),
1199 New_Occurrence_Of
(First_Tag_Component
(Typ
),
1203 Make_Selected_Component
(Loc
,
1205 Unchecked_Convert_To
(Typ
,
1206 New_Value
(Next_Actual
(Param
))),
1209 (First_Tag_Component
(Typ
), Loc
))),
1210 Right_Opnd
=> New_Call
);
1212 SCIL_Related_Node
:= Right_Opnd
(New_Call
);
1217 Make_Procedure_Call_Statement
(Loc
,
1218 Name
=> New_Call_Name
,
1219 Parameter_Associations
=> New_Params
);
1222 -- Register the dispatching call in the call graph nodes table
1224 Register_CG_Node
(Call_Node
);
1226 Rewrite
(Call_Node
, New_Call
);
1228 -- Associate the SCIL node of this dispatching call
1230 if Generate_SCIL
then
1231 Set_SCIL_Node
(SCIL_Related_Node
, SCIL_Node
);
1234 -- Suppress all checks during the analysis of the expanded code to avoid
1235 -- the generation of spurious warnings under ZFP run-time.
1237 Analyze_And_Resolve
(Call_Node
, Call_Typ
, Suppress
=> All_Checks
);
1238 end Expand_Dispatching_Call
;
1240 ---------------------------------
1241 -- Expand_Interface_Conversion --
1242 ---------------------------------
1244 procedure Expand_Interface_Conversion
(N
: Node_Id
) is
1246 function Underlying_Record_Type
(Typ
: Entity_Id
) return Entity_Id
;
1247 -- Return the underlying record type of Typ
1249 ----------------------------
1250 -- Underlying_Record_Type --
1251 ----------------------------
1253 function Underlying_Record_Type
(Typ
: Entity_Id
) return Entity_Id
is
1254 E
: Entity_Id
:= Typ
;
1257 -- Handle access types
1259 if Is_Access_Type
(E
) then
1260 E
:= Directly_Designated_Type
(E
);
1263 -- Handle class-wide types. This conversion can appear explicitly in
1264 -- the source code. Example: I'Class (Obj)
1266 if Is_Class_Wide_Type
(E
) then
1270 -- If the target type is a tagged synchronized type, the dispatch
1271 -- table info is in the corresponding record type.
1273 if Is_Concurrent_Type
(E
) then
1274 E
:= Corresponding_Record_Type
(E
);
1277 -- Handle private types
1279 E
:= Underlying_Type
(E
);
1283 return Base_Type
(E
);
1284 end Underlying_Record_Type
;
1288 Loc
: constant Source_Ptr
:= Sloc
(N
);
1289 Etyp
: constant Entity_Id
:= Etype
(N
);
1290 Operand
: constant Node_Id
:= Expression
(N
);
1291 Operand_Typ
: Entity_Id
:= Etype
(Operand
);
1293 Iface_Typ
: constant Entity_Id
:= Underlying_Record_Type
(Etype
(N
));
1294 Iface_Tag
: Entity_Id
;
1295 Is_Static
: Boolean;
1297 -- Start of processing for Expand_Interface_Conversion
1300 -- Freeze the entity associated with the target interface to have
1301 -- available the attribute Access_Disp_Table.
1303 Freeze_Before
(N
, Iface_Typ
);
1305 -- Ada 2005 (AI-345): Handle synchronized interface type derivations
1307 if Is_Concurrent_Type
(Operand_Typ
) then
1308 Operand_Typ
:= Base_Type
(Corresponding_Record_Type
(Operand_Typ
));
1311 -- No displacement of the pointer to the object needed when the type of
1312 -- the operand is not an interface type and the interface is one of
1313 -- its parent types (since they share the primary dispatch table).
1316 Opnd
: Entity_Id
:= Operand_Typ
;
1319 if Is_Access_Type
(Opnd
) then
1320 Opnd
:= Designated_Type
(Opnd
);
1323 Opnd
:= Underlying_Record_Type
(Opnd
);
1325 if not Is_Interface
(Opnd
)
1326 and then Is_Ancestor
(Iface_Typ
, Opnd
, Use_Full_View
=> True)
1330 -- When the target type is an interface type that is an ancestor of
1331 -- the operand type, it is generally safe to skip generating code to
1332 -- displace the pointer to the object to reference the secondary
1333 -- dispatch table of the target interface type. Two scenarios are
1335 -- 1) The operand type is a regular tagged type
1336 -- 2) The operand type is an interface type
1337 -- In the former case the target interface and the regular tagged
1338 -- type share the primary dispatch table of the object; in the latter
1339 -- case the operand interface has all the primitives of the ancestor
1340 -- interface type (and exactly in the same dispatch table slots).
1342 -- The exception to this general rule is when the underlying object
1343 -- is built by means of a dispatching constructor (since in such case
1344 -- the expansion of the constructor call is a direct call to an
1345 -- object primitive, i.e. without thunks, and the expansion of
1346 -- the constructor call adds this explicit conversion to the target
1347 -- interface type to force the displacement of the pointer to the
1348 -- object to reference the corresponding secondary dispatch table
1349 -- (cf. Make_DT and Expand_Dispatching_Constructor_Call)).
1351 -- Under configurable runtime it is safe to skip generating code to
1352 -- displace the pointer to the object, because generic dispatching
1353 -- constructors are not supported.
1355 elsif Is_Interface
(Iface_Typ
)
1356 and then Is_Ancestor
(Iface_Typ
, Opnd
, Use_Full_View
=> True)
1357 and then not RTE_Available
(RE_Displace
)
1363 -- Evaluate if we can statically displace the pointer to the object
1366 Opnd_Typ
: constant Node_Id
:= Underlying_Record_Type
(Operand_Typ
);
1370 not Is_Interface
(Opnd_Typ
)
1371 and then Interface_Present_In_Ancestor
1374 and then (Etype
(Opnd_Typ
) = Opnd_Typ
1376 Is_Variable_Size_Record
(Etype
(Opnd_Typ
)));
1379 if not Tagged_Type_Expansion
then
1382 -- A static conversion to an interface type that is not class-wide is
1383 -- curious but legal if the interface operation is a null procedure.
1384 -- If the operation is abstract it will be rejected later.
1387 and then Is_Interface
(Etype
(N
))
1388 and then not Is_Class_Wide_Type
(Etype
(N
))
1389 and then Comes_From_Source
(N
)
1391 Rewrite
(N
, Unchecked_Convert_To
(Etype
(N
), N
));
1396 if not Is_Static
then
1398 -- Give error if configurable run-time and Displace not available
1400 if not RTE_Available
(RE_Displace
) then
1401 Error_Msg_CRT
("dynamic interface conversion", N
);
1405 -- Handle conversion of access-to-class-wide interface types. Target
1406 -- can be an access to an object or an access to another class-wide
1407 -- interface (see -1- and -2- in the following example):
1409 -- type Iface1_Ref is access all Iface1'Class;
1410 -- type Iface2_Ref is access all Iface1'Class;
1412 -- Acc1 : Iface1_Ref := new ...
1413 -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1
1414 -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
1416 if Is_Access_Type
(Operand_Typ
) then
1418 Unchecked_Convert_To
(Etype
(N
),
1419 Make_Function_Call
(Loc
,
1420 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
1421 Parameter_Associations
=> New_List
(
1423 Unchecked_Convert_To
(RTE
(RE_Address
),
1424 Relocate_Node
(Expression
(N
))),
1427 (Node
(First_Elmt
(Access_Disp_Table
(Iface_Typ
))),
1435 Make_Function_Call
(Loc
,
1436 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
1437 Parameter_Associations
=> New_List
(
1438 Make_Attribute_Reference
(Loc
,
1439 Prefix
=> Relocate_Node
(Expression
(N
)),
1440 Attribute_Name
=> Name_Address
),
1443 (Node
(First_Elmt
(Access_Disp_Table
(Iface_Typ
))),
1448 -- If target is a class-wide interface, change the type of the data
1449 -- returned by IW_Convert to indicate this is a dispatching call.
1452 New_Itype
: Entity_Id
;
1455 New_Itype
:= Create_Itype
(E_Anonymous_Access_Type
, N
);
1456 Set_Etype
(New_Itype
, New_Itype
);
1457 Set_Directly_Designated_Type
(New_Itype
, Etyp
);
1460 Make_Explicit_Dereference
(Loc
,
1462 Unchecked_Convert_To
(New_Itype
, Relocate_Node
(N
))));
1464 Freeze_Itype
(New_Itype
, N
);
1470 Iface_Tag
:= Find_Interface_Tag
(Operand_Typ
, Iface_Typ
);
1471 pragma Assert
(Present
(Iface_Tag
));
1473 -- Keep separate access types to interfaces because one internal
1474 -- function is used to handle the null value (see following comments)
1476 if not Is_Access_Type
(Etype
(N
)) then
1478 -- Statically displace the pointer to the object to reference the
1479 -- component containing the secondary dispatch table.
1482 Convert_Tag_To_Interface
(Class_Wide_Type
(Iface_Typ
),
1483 Make_Selected_Component
(Loc
,
1484 Prefix
=> Relocate_Node
(Expression
(N
)),
1485 Selector_Name
=> New_Occurrence_Of
(Iface_Tag
, Loc
))));
1488 -- Build internal function to handle the case in which the actual is
1489 -- null. If the actual is null returns null because no displacement
1490 -- is required; otherwise performs a type conversion that will be
1491 -- expanded in the code that returns the value of the displaced
1494 -- function Func (O : Address) return Iface_Typ is
1495 -- type Op_Typ is access all Operand_Typ;
1496 -- Aux : Op_Typ := To_Op_Typ (O);
1498 -- if O = Null_Address then
1501 -- return Iface_Typ!(Aux.Iface_Tag'Address);
1506 Desig_Typ
: Entity_Id
;
1508 New_Typ_Decl
: Node_Id
;
1512 Desig_Typ
:= Etype
(Expression
(N
));
1514 if Is_Access_Type
(Desig_Typ
) then
1516 Available_View
(Directly_Designated_Type
(Desig_Typ
));
1519 if Is_Concurrent_Type
(Desig_Typ
) then
1520 Desig_Typ
:= Base_Type
(Corresponding_Record_Type
(Desig_Typ
));
1524 Make_Full_Type_Declaration
(Loc
,
1525 Defining_Identifier
=> Make_Temporary
(Loc
, 'T'),
1527 Make_Access_To_Object_Definition
(Loc
,
1528 All_Present
=> True,
1529 Null_Exclusion_Present
=> False,
1530 Constant_Present
=> False,
1531 Subtype_Indication
=>
1532 New_Occurrence_Of
(Desig_Typ
, Loc
)));
1535 Make_Simple_Return_Statement
(Loc
,
1536 Unchecked_Convert_To
(Etype
(N
),
1537 Make_Attribute_Reference
(Loc
,
1539 Make_Selected_Component
(Loc
,
1541 Unchecked_Convert_To
1542 (Defining_Identifier
(New_Typ_Decl
),
1543 Make_Identifier
(Loc
, Name_uO
)),
1545 New_Occurrence_Of
(Iface_Tag
, Loc
)),
1546 Attribute_Name
=> Name_Address
))));
1548 -- If the type is null-excluding, no need for the null branch.
1549 -- Otherwise we need to check for it and return null.
1551 if not Can_Never_Be_Null
(Etype
(N
)) then
1553 Make_If_Statement
(Loc
,
1556 Left_Opnd
=> Make_Identifier
(Loc
, Name_uO
),
1557 Right_Opnd
=> New_Occurrence_Of
1558 (RTE
(RE_Null_Address
), Loc
)),
1560 Then_Statements
=> New_List
(
1561 Make_Simple_Return_Statement
(Loc
, Make_Null
(Loc
))),
1562 Else_Statements
=> Stats
));
1565 Fent
:= Make_Temporary
(Loc
, 'F');
1567 Make_Subprogram_Body
(Loc
,
1569 Make_Function_Specification
(Loc
,
1570 Defining_Unit_Name
=> Fent
,
1572 Parameter_Specifications
=> New_List
(
1573 Make_Parameter_Specification
(Loc
,
1574 Defining_Identifier
=>
1575 Make_Defining_Identifier
(Loc
, Name_uO
),
1577 New_Occurrence_Of
(RTE
(RE_Address
), Loc
))),
1579 Result_Definition
=>
1580 New_Occurrence_Of
(Etype
(N
), Loc
)),
1582 Declarations
=> New_List
(New_Typ_Decl
),
1584 Handled_Statement_Sequence
=>
1585 Make_Handled_Sequence_Of_Statements
(Loc
, Stats
));
1587 -- Place function body before the expression containing the
1588 -- conversion. We suppress all checks because the body of the
1589 -- internally generated function already takes care of the case
1590 -- in which the actual is null; therefore there is no need to
1591 -- double check that the pointer is not null when the program
1592 -- executes the alternative that performs the type conversion).
1594 Insert_Action
(N
, Func
, Suppress
=> All_Checks
);
1596 if Is_Access_Type
(Etype
(Expression
(N
))) then
1598 -- Generate: Func (Address!(Expression))
1601 Make_Function_Call
(Loc
,
1602 Name
=> New_Occurrence_Of
(Fent
, Loc
),
1603 Parameter_Associations
=> New_List
(
1604 Unchecked_Convert_To
(RTE
(RE_Address
),
1605 Relocate_Node
(Expression
(N
))))));
1608 -- Generate: Func (Operand_Typ!(Expression)'Address)
1611 Make_Function_Call
(Loc
,
1612 Name
=> New_Occurrence_Of
(Fent
, Loc
),
1613 Parameter_Associations
=> New_List
(
1614 Make_Attribute_Reference
(Loc
,
1615 Prefix
=> Unchecked_Convert_To
(Operand_Typ
,
1616 Relocate_Node
(Expression
(N
))),
1617 Attribute_Name
=> Name_Address
))));
1623 end Expand_Interface_Conversion
;
1625 ------------------------------
1626 -- Expand_Interface_Actuals --
1627 ------------------------------
1629 procedure Expand_Interface_Actuals
(Call_Node
: Node_Id
) is
1631 Actual_Dup
: Node_Id
;
1632 Actual_Typ
: Entity_Id
;
1634 Conversion
: Node_Id
;
1636 Formal_Typ
: Entity_Id
;
1638 Formal_DDT
: Entity_Id
:= Empty
; -- initialize to prevent warning
1639 Actual_DDT
: Entity_Id
:= Empty
; -- initialize to prevent warning
1642 -- This subprogram is called directly from the semantics, so we need a
1643 -- check to see whether expansion is active before proceeding.
1645 if not Expander_Active
then
1649 -- Call using access to subprogram with explicit dereference
1651 if Nkind
(Name
(Call_Node
)) = N_Explicit_Dereference
then
1652 Subp
:= Etype
(Name
(Call_Node
));
1654 -- Call using selected component
1656 elsif Nkind
(Name
(Call_Node
)) = N_Selected_Component
then
1657 Subp
:= Entity
(Selector_Name
(Name
(Call_Node
)));
1659 -- Call using direct name
1662 Subp
:= Entity
(Name
(Call_Node
));
1665 -- Ada 2005 (AI-251): Look for interface type formals to force "this"
1668 Formal
:= First_Formal
(Subp
);
1669 Actual
:= First_Actual
(Call_Node
);
1670 while Present
(Formal
) loop
1671 Formal_Typ
:= Etype
(Formal
);
1673 if Has_Non_Limited_View
(Formal_Typ
) then
1674 Formal_Typ
:= Non_Limited_View
(Formal_Typ
);
1677 if Ekind
(Formal_Typ
) = E_Record_Type_With_Private
then
1678 Formal_Typ
:= Full_View
(Formal_Typ
);
1681 if Is_Access_Type
(Formal_Typ
) then
1682 Formal_DDT
:= Directly_Designated_Type
(Formal_Typ
);
1684 if Has_Non_Limited_View
(Formal_DDT
) then
1685 Formal_DDT
:= Non_Limited_View
(Formal_DDT
);
1689 Actual_Typ
:= Etype
(Actual
);
1691 if Has_Non_Limited_View
(Actual_Typ
) then
1692 Actual_Typ
:= Non_Limited_View
(Actual_Typ
);
1695 if Is_Access_Type
(Actual_Typ
) then
1696 Actual_DDT
:= Directly_Designated_Type
(Actual_Typ
);
1698 if Has_Non_Limited_View
(Actual_DDT
) then
1699 Actual_DDT
:= Non_Limited_View
(Actual_DDT
);
1703 if Is_Interface
(Formal_Typ
)
1704 and then Is_Class_Wide_Type
(Formal_Typ
)
1706 -- No need to displace the pointer if the type of the actual
1707 -- coincides with the type of the formal.
1709 if Actual_Typ
= Formal_Typ
then
1712 -- No need to displace the pointer if the interface type is a
1713 -- parent of the type of the actual because in this case the
1714 -- interface primitives are located in the primary dispatch table.
1716 elsif Is_Ancestor
(Formal_Typ
, Actual_Typ
,
1717 Use_Full_View
=> True)
1721 -- Implicit conversion to the class-wide formal type to force the
1722 -- displacement of the pointer.
1725 -- Normally, expansion of actuals for calls to build-in-place
1726 -- functions happens as part of Expand_Actuals, but in this
1727 -- case the call will be wrapped in a conversion and soon after
1728 -- expanded further to handle the displacement for a class-wide
1729 -- interface conversion, so if this is a BIP call then we need
1730 -- to handle it now.
1732 if Is_Build_In_Place_Function_Call
(Actual
) then
1733 Make_Build_In_Place_Call_In_Anonymous_Context
(Actual
);
1736 Conversion
:= Convert_To
(Formal_Typ
, Relocate_Node
(Actual
));
1737 Rewrite
(Actual
, Conversion
);
1738 Analyze_And_Resolve
(Actual
, Formal_Typ
);
1741 -- Access to class-wide interface type
1743 elsif Is_Access_Type
(Formal_Typ
)
1744 and then Is_Interface
(Formal_DDT
)
1745 and then Is_Class_Wide_Type
(Formal_DDT
)
1746 and then Interface_Present_In_Ancestor
1748 Iface
=> Etype
(Formal_DDT
))
1750 -- Handle attributes 'Access and 'Unchecked_Access
1752 if Nkind
(Actual
) = N_Attribute_Reference
1754 (Attribute_Name
(Actual
) = Name_Access
1755 or else Attribute_Name
(Actual
) = Name_Unchecked_Access
)
1757 -- This case must have been handled by the analysis and
1758 -- expansion of 'Access. The only exception is when types
1759 -- match and no further expansion is required.
1761 pragma Assert
(Base_Type
(Etype
(Prefix
(Actual
)))
1762 = Base_Type
(Formal_DDT
));
1765 -- No need to displace the pointer if the type of the actual
1766 -- coincides with the type of the formal.
1768 elsif Actual_DDT
= Formal_DDT
then
1771 -- No need to displace the pointer if the interface type is
1772 -- a parent of the type of the actual because in this case the
1773 -- interface primitives are located in the primary dispatch table.
1775 elsif Is_Ancestor
(Formal_DDT
, Actual_DDT
,
1776 Use_Full_View
=> True)
1781 Actual_Dup
:= Relocate_Node
(Actual
);
1783 if From_Limited_With
(Actual_Typ
) then
1785 -- If the type of the actual parameter comes from a limited
1786 -- with_clause and the nonlimited view is already available,
1787 -- we replace the anonymous access type by a duplicate
1788 -- declaration whose designated type is the nonlimited view.
1790 if Has_Non_Limited_View
(Actual_DDT
) then
1791 Anon
:= New_Copy
(Actual_Typ
);
1793 if Is_Itype
(Anon
) then
1794 Set_Scope
(Anon
, Current_Scope
);
1797 Set_Directly_Designated_Type
1798 (Anon
, Non_Limited_View
(Actual_DDT
));
1799 Set_Etype
(Actual_Dup
, Anon
);
1803 Conversion
:= Convert_To
(Formal_Typ
, Actual_Dup
);
1804 Rewrite
(Actual
, Conversion
);
1805 Analyze_And_Resolve
(Actual
, Formal_Typ
);
1809 Next_Actual
(Actual
);
1810 Next_Formal
(Formal
);
1812 end Expand_Interface_Actuals
;
1814 ----------------------------
1815 -- Expand_Interface_Thunk --
1816 ----------------------------
1818 procedure Expand_Interface_Thunk
1820 Thunk_Id
: out Entity_Id
;
1821 Thunk_Code
: out List_Id
;
1824 Actuals
: constant List_Id
:= New_List
;
1825 Decl
: constant List_Id
:= New_List
;
1826 Formals
: constant List_Id
:= New_List
;
1827 Loc
: constant Source_Ptr
:= Sloc
(Prim
);
1828 Target
: constant Entity_Id
:= Ultimate_Alias
(Prim
);
1829 Is_Predef_Op
: constant Boolean :=
1830 Is_Predefined_Dispatching_Operation
(Prim
)
1831 or else Is_Predefined_Dispatching_Operation
(Target
);
1838 Iface_Formal
: Entity_Id
;
1840 Offset_To_Top
: Node_Id
;
1841 Target_Formal
: Entity_Id
;
1845 Thunk_Code
:= Empty_List
;
1847 -- No thunk needed if the primitive has been eliminated
1849 if Is_Eliminated
(Target
) then
1852 -- No thunk needed if the primitive has no formals. In this case, this
1853 -- must be a function with a controlling result.
1855 elsif No
(First_Formal
(Target
)) then
1856 pragma Assert
(Ekind
(Target
) = E_Function
1857 and then Has_Controlling_Result
(Target
));
1862 -- Duplicate the formals of the target primitive. In the thunk, the type
1863 -- of the controlling formal is the covered interface type (instead of
1864 -- the target tagged type). Done to avoid problems with discriminated
1865 -- tagged types because, if the controlling type has discriminants with
1866 -- default values, then the type conversions done inside the body of
1867 -- the thunk (after the displacement of the pointer to the base of the
1868 -- actual object) generate code that modify its contents.
1870 -- Note: This special management is not done for predefined primitives
1871 -- because they don't have available the Interface_Alias attribute (see
1872 -- Sem_Ch3.Add_Internal_Interface_Entities).
1874 if Is_Predef_Op
then
1875 Iface_Formal
:= Empty
;
1877 Iface_Formal
:= First_Formal
(Interface_Alias
(Prim
));
1880 Formal
:= First_Formal
(Target
);
1881 while Present
(Formal
) loop
1882 -- Use the interface type as the type of the controlling formal (see
1885 if not Is_Controlling_Formal
(Formal
) then
1886 Ftyp
:= Etype
(Formal
);
1887 Expr
:= New_Copy_Tree
(Expression
(Parent
(Formal
)));
1889 -- For predefined primitives the controlling type of the thunk is
1890 -- the interface type passed by the caller (since they don't have
1891 -- available the Interface_Alias attribute; see comment above).
1893 elsif Is_Predef_Op
then
1898 Ftyp
:= Etype
(Iface_Formal
);
1901 -- Sanity check performed to ensure the proper controlling type
1902 -- when the thunk has exactly one controlling parameter and it
1903 -- comes first. In such a case, the GCC back end reuses the C++
1904 -- thunks machinery which perform a computation equivalent to
1905 -- the code generated by the expander; for other cases the GCC
1906 -- back end translates the expanded code unmodified. However, as
1907 -- a generalization, the check is performed for all controlling
1910 if Is_Access_Type
(Ftyp
) then
1911 pragma Assert
(Base_Type
(Designated_Type
(Ftyp
)) = Iface
);
1914 Ftyp
:= Base_Type
(Ftyp
);
1915 pragma Assert
(Ftyp
= Iface
);
1920 Make_Parameter_Specification
(Loc
,
1921 Defining_Identifier
=>
1922 Make_Defining_Identifier
(Sloc
(Formal
),
1923 Chars
=> Chars
(Formal
)),
1924 Aliased_Present
=> Aliased_Present
(Parent
(Formal
)),
1925 In_Present
=> In_Present
(Parent
(Formal
)),
1926 Out_Present
=> Out_Present
(Parent
(Formal
)),
1927 Parameter_Type
=> New_Occurrence_Of
(Ftyp
, Loc
),
1928 Expression
=> Expr
));
1930 if not Is_Predef_Op
then
1931 Next_Formal
(Iface_Formal
);
1934 Next_Formal
(Formal
);
1937 Target_Formal
:= First_Formal
(Target
);
1938 Formal
:= First
(Formals
);
1939 while Present
(Formal
) loop
1941 -- If the parent is a constrained discriminated type, then the
1942 -- primitive operation will have been defined on a first subtype.
1943 -- For proper matching with controlling type, use base type.
1945 if Ekind
(Target_Formal
) = E_In_Parameter
1946 and then Ekind
(Etype
(Target_Formal
)) = E_Anonymous_Access_Type
1949 Base_Type
(Directly_Designated_Type
(Etype
(Target_Formal
)));
1951 Ftyp
:= Base_Type
(Etype
(Target_Formal
));
1954 -- For concurrent types, the relevant information is found in the
1955 -- Corresponding_Record_Type, rather than the type entity itself.
1957 if Is_Concurrent_Type
(Ftyp
) then
1958 Ftyp
:= Corresponding_Record_Type
(Ftyp
);
1961 if Ekind
(Target_Formal
) = E_In_Parameter
1962 and then Ekind
(Etype
(Target_Formal
)) = E_Anonymous_Access_Type
1963 and then Is_Controlling_Formal
(Target_Formal
)
1966 -- type T is access all <<type of the target formal>>
1967 -- S : constant Address := Address!(Formal)
1968 -- + Offset_To_Top (Address!(Formal))
1971 Make_Full_Type_Declaration
(Loc
,
1972 Defining_Identifier
=> Make_Temporary
(Loc
, 'T'),
1974 Make_Access_To_Object_Definition
(Loc
,
1975 All_Present
=> True,
1976 Null_Exclusion_Present
=> False,
1977 Constant_Present
=> False,
1978 Subtype_Indication
=>
1979 New_Occurrence_Of
(Ftyp
, Loc
)));
1982 Unchecked_Convert_To
(RTE
(RE_Address
),
1983 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
1985 if not RTE_Available
(RE_Offset_To_Top
) then
1987 Build_Offset_To_Top
(Loc
, New_Arg
);
1990 Make_Function_Call
(Loc
,
1991 Name
=> New_Occurrence_Of
(RTE
(RE_Offset_To_Top
), Loc
),
1992 Parameter_Associations
=> New_List
(New_Arg
));
1996 Make_Object_Declaration
(Loc
,
1997 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
1998 Constant_Present
=> True,
1999 Object_Definition
=>
2000 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
2002 Make_Function_Call
(Loc
,
2004 Make_Expanded_Name
(Loc
,
2005 Chars
=> Name_Op_Add
,
2008 (RTU_Entity
(System_Storage_Elements
), Loc
),
2010 Make_Identifier
(Loc
, Name_Op_Add
)),
2011 Parameter_Associations
=> New_List
(
2012 New_Copy_Tree
(New_Arg
),
2015 Append_To
(Decl
, Decl_2
);
2016 Append_To
(Decl
, Decl_1
);
2018 -- Reference the new actual. Generate:
2022 Unchecked_Convert_To
2023 (Defining_Identifier
(Decl_2
),
2024 New_Occurrence_Of
(Defining_Identifier
(Decl_1
), Loc
)));
2026 elsif Is_Controlling_Formal
(Target_Formal
) then
2029 -- S1 : constant Address := Formal'Address
2030 -- + Offset_To_Top (Formal'Address)
2031 -- S2 : constant Addr_Ptr := Addr_Ptr!(S1)
2034 Make_Attribute_Reference
(Loc
,
2036 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
),
2037 Attribute_Name
=> Name_Address
);
2039 if not RTE_Available
(RE_Offset_To_Top
) then
2041 Build_Offset_To_Top
(Loc
, New_Arg
);
2044 Make_Function_Call
(Loc
,
2045 Name
=> New_Occurrence_Of
(RTE
(RE_Offset_To_Top
), Loc
),
2046 Parameter_Associations
=> New_List
(New_Arg
));
2050 Make_Object_Declaration
(Loc
,
2051 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
2052 Constant_Present
=> True,
2053 Object_Definition
=>
2054 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
2056 Make_Function_Call
(Loc
,
2058 Make_Expanded_Name
(Loc
,
2059 Chars
=> Name_Op_Add
,
2062 (RTU_Entity
(System_Storage_Elements
), Loc
),
2064 Make_Identifier
(Loc
, Name_Op_Add
)),
2065 Parameter_Associations
=> New_List
(
2066 New_Copy_Tree
(New_Arg
),
2070 Make_Object_Declaration
(Loc
,
2071 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
2072 Constant_Present
=> True,
2073 Object_Definition
=>
2074 New_Occurrence_Of
(RTE
(RE_Addr_Ptr
), Loc
),
2076 Unchecked_Convert_To
2078 New_Occurrence_Of
(Defining_Identifier
(Decl_1
), Loc
)));
2080 Append_To
(Decl
, Decl_1
);
2081 Append_To
(Decl
, Decl_2
);
2083 -- Reference the new actual, generate:
2084 -- Target_Formal (S2.all)
2087 Unchecked_Convert_To
(Ftyp
,
2088 Make_Explicit_Dereference
(Loc
,
2089 New_Occurrence_Of
(Defining_Identifier
(Decl_2
), Loc
))));
2091 -- Ensure proper matching of access types. Required to avoid
2092 -- reporting spurious errors.
2094 elsif Is_Access_Type
(Etype
(Target_Formal
)) then
2096 Unchecked_Convert_To
(Base_Type
(Etype
(Target_Formal
)),
2097 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
)));
2099 -- No special management required for this actual
2103 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
2106 Next_Formal
(Target_Formal
);
2110 Thunk_Id
:= Make_Temporary
(Loc
, 'T');
2112 -- Note: any change to this symbol name needs to be coordinated
2113 -- with GNATcoverage, as that tool relies on it to identify
2114 -- thunks and exclude them from source coverage analysis.
2116 Mutate_Ekind
(Thunk_Id
, Ekind
(Prim
));
2117 Set_Is_Thunk
(Thunk_Id
);
2118 Set_Has_Controlling_Result
(Thunk_Id
, False);
2119 Set_Convention
(Thunk_Id
, Convention
(Prim
));
2120 Set_Needs_Debug_Info
(Thunk_Id
, Needs_Debug_Info
(Target
));
2121 Set_Thunk_Entity
(Thunk_Id
, Target
);
2123 Thunk_Code
:= New_List
;
2127 if Ekind
(Target
) = E_Procedure
then
2128 Append_To
(Thunk_Code
,
2129 Make_Subprogram_Body
(Loc
,
2131 Make_Procedure_Specification
(Loc
,
2132 Defining_Unit_Name
=> Thunk_Id
,
2133 Parameter_Specifications
=> Formals
),
2134 Declarations
=> Decl
,
2135 Handled_Statement_Sequence
=>
2136 Make_Handled_Sequence_Of_Statements
(Loc
,
2137 Statements
=> New_List
(
2138 Make_Procedure_Call_Statement
(Loc
,
2139 Name
=> New_Occurrence_Of
(Target
, Loc
),
2140 Parameter_Associations
=> Actuals
)))));
2144 else pragma Assert
(Ekind
(Target
) = E_Function
);
2146 Call_Node
: Node_Id
;
2147 Result_Def
: Node_Id
;
2148 SS_Thunk_Id
: Entity_Id
;
2149 SS_Thunk_Code
: Node_Id
;
2153 Make_Function_Call
(Loc
,
2154 Name
=> New_Occurrence_Of
(Target
, Loc
),
2155 Parameter_Associations
=> Actuals
);
2157 if not Is_Interface
(Etype
(Prim
)) then
2158 Result_Def
:= New_Copy
(Result_Definition
(Parent
(Target
)));
2160 -- Thunk of function returning a class-wide interface object. No
2161 -- extra displacement needed since the displacement is generated
2162 -- in the return statement of Prim. Example:
2164 -- type Iface is interface ...
2165 -- function F (O : Iface) return Iface'Class;
2167 -- type T is new ... and Iface with ...
2168 -- function F (O : T) return Iface'Class;
2170 elsif Is_Class_Wide_Type
(Etype
(Prim
)) then
2171 Result_Def
:= New_Occurrence_Of
(Etype
(Prim
), Loc
);
2173 -- Thunk of function returning an interface object. Displacement
2176 -- type Iface is interface ...
2177 -- function F (O : Iface) return Iface;
2179 -- type T is new ... and Iface with ...
2180 -- function F (O : T) return T;
2183 Expand_Secondary_Stack_Thunk
2184 (Target
, SS_Thunk_Id
, SS_Thunk_Code
);
2186 if Present
(SS_Thunk_Id
) then
2187 Set_Thunk_Entity
(Thunk_Id
, SS_Thunk_Id
);
2189 Make_Function_Call
(Loc
,
2191 New_Occurrence_Of
(SS_Thunk_Id
, Loc
),
2192 Parameter_Associations
=> Actuals
);
2193 Append_To
(Thunk_Code
, SS_Thunk_Code
);
2197 New_Occurrence_Of
(Class_Wide_Type
(Etype
(Prim
)), Loc
);
2199 -- Adding implicit conversion to force the displacement of
2200 -- the pointer to the object to reference the corresponding
2201 -- secondary dispatch table.
2204 Make_Type_Conversion
(Loc
,
2206 New_Occurrence_Of
(Class_Wide_Type
(Etype
(Prim
)), Loc
),
2207 Expression
=> Relocate_Node
(Call_Node
));
2210 Append_To
(Thunk_Code
,
2211 Make_Subprogram_Body
(Loc
,
2213 Make_Function_Specification
(Loc
,
2214 Defining_Unit_Name
=> Thunk_Id
,
2215 Parameter_Specifications
=> Formals
,
2216 Result_Definition
=> Result_Def
),
2217 Declarations
=> Decl
,
2218 Handled_Statement_Sequence
=>
2219 Make_Handled_Sequence_Of_Statements
(Loc
,
2220 Statements
=> New_List
(
2221 Make_Simple_Return_Statement
(Loc
, Call_Node
)))));
2224 end Expand_Interface_Thunk
;
2226 ------------------------------------
2227 -- Expand_Secondary_Stack_Thunk --
2228 ------------------------------------
2230 procedure Expand_Secondary_Stack_Thunk
2232 Thunk_Id
: out Entity_Id
;
2233 Thunk_Code
: out Node_Id
)
2235 Actuals
: constant List_Id
:= New_List
;
2236 Formals
: constant List_Id
:= New_List
;
2237 Loc
: constant Source_Ptr
:= Sloc
(Prim
);
2238 Typ
: constant Entity_Id
:= Etype
(Prim
);
2240 Call_Node
: Node_Id
;
2243 Prim_Formal
: Entity_Id
;
2244 Result_Def
: Node_Id
;
2248 Thunk_Code
:= Empty
;
2250 -- No thunk needed if the primitive has been eliminated
2252 if Is_Eliminated
(Prim
) then
2255 -- No thunk needed for procedures or functions not dispatching on result
2257 elsif Ekind
(Prim
) = E_Procedure
2258 or else not Has_Controlling_Result
(Prim
)
2262 -- No thunk needed if the result type is an access type
2264 elsif Is_Access_Type
(Typ
) then
2267 -- No thunk needed if the tagged type is returned in place
2269 elsif Is_Build_In_Place_Result_Type
(Typ
) then
2272 -- No thunk needed if the tagged type is returned on the secondary stack
2274 elsif Needs_Secondary_Stack
(Typ
) then
2278 pragma Assert
(Is_Tagged_Type
(Typ
));
2280 -- Duplicate the formals of the target primitive and build the actuals
2282 Prim_Formal
:= First_Formal
(Prim
);
2283 while Present
(Prim_Formal
) loop
2284 Expr
:= New_Copy_Tree
(Expression
(Parent
(Prim_Formal
)));
2287 Make_Defining_Identifier
(Sloc
(Prim_Formal
),
2288 Chars
=> Chars
(Prim_Formal
));
2291 Make_Parameter_Specification
(Loc
,
2292 Defining_Identifier
=> Formal
,
2293 Aliased_Present
=> Aliased_Present
(Parent
(Prim_Formal
)),
2294 In_Present
=> In_Present
(Parent
(Prim_Formal
)),
2295 Out_Present
=> Out_Present
(Parent
(Prim_Formal
)),
2296 Parameter_Type
=> New_Occurrence_Of
(Etype
(Prim_Formal
), Loc
),
2297 Expression
=> Expr
));
2299 -- Ensure proper matching of access types. Required to avoid
2300 -- reporting spurious errors.
2302 if Is_Access_Type
(Etype
(Prim_Formal
)) then
2304 Unchecked_Convert_To
(Base_Type
(Etype
(Prim_Formal
)),
2305 New_Occurrence_Of
(Formal
, Loc
)));
2307 -- No special management required for this actual
2310 Append_To
(Actuals
, New_Occurrence_Of
(Formal
, Loc
));
2313 Next_Formal
(Prim_Formal
);
2316 Thunk_Id
:= Make_Temporary
(Loc
, 'T');
2318 -- Note: any change to this symbol name needs to be coordinated
2319 -- with GNATcoverage, as that tool relies on it to identify
2320 -- thunks and exclude them from source coverage analysis.
2322 Mutate_Ekind
(Thunk_Id
, E_Function
);
2323 Set_Is_Thunk
(Thunk_Id
);
2324 Set_Has_Controlling_Result
(Thunk_Id
, True);
2325 Set_Convention
(Thunk_Id
, Convention
(Prim
));
2326 Set_Needs_Debug_Info
(Thunk_Id
, Needs_Debug_Info
(Prim
));
2327 Set_Thunk_Entity
(Thunk_Id
, Prim
);
2329 Result_Def
:= New_Copy
(Result_Definition
(Parent
(Prim
)));
2332 Make_Function_Call
(Loc
,
2333 Name
=> New_Occurrence_Of
(Prim
, Loc
),
2334 Parameter_Associations
=> Actuals
);
2337 Make_Subprogram_Body
(Loc
,
2339 Make_Function_Specification
(Loc
,
2340 Defining_Unit_Name
=> Thunk_Id
,
2341 Parameter_Specifications
=> Formals
,
2342 Result_Definition
=> Result_Def
),
2343 Declarations
=> Empty_List
,
2344 Handled_Statement_Sequence
=>
2345 Make_Handled_Sequence_Of_Statements
(Loc
,
2346 Statements
=> New_List
(
2347 Make_Simple_Return_Statement
(Loc
, Call_Node
))));
2348 end Expand_Secondary_Stack_Thunk
;
2350 --------------------------
2351 -- Has_CPP_Constructors --
2352 --------------------------
2354 function Has_CPP_Constructors
(Typ
: Entity_Id
) return Boolean is
2358 -- Look for the constructor entities
2360 E
:= Next_Entity
(Typ
);
2361 while Present
(E
) loop
2362 if Ekind
(E
) = E_Function
and then Is_Constructor
(E
) then
2370 end Has_CPP_Constructors
;
2376 function Has_DT
(Typ
: Entity_Id
) return Boolean is
2378 return not Is_Interface
(Typ
)
2379 and then not Restriction_Active
(No_Dispatching_Calls
);
2382 ----------------------------------
2383 -- Is_Expanded_Dispatching_Call --
2384 ----------------------------------
2386 function Is_Expanded_Dispatching_Call
(N
: Node_Id
) return Boolean is
2388 return Nkind
(N
) in N_Subprogram_Call
2389 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
2390 and then Is_Dispatch_Table_Entity
(Etype
(Name
(N
)));
2391 end Is_Expanded_Dispatching_Call
;
2393 -------------------------------------
2394 -- Is_Predefined_Dispatching_Alias --
2395 -------------------------------------
2397 function Is_Predefined_Dispatching_Alias
(Prim
: Entity_Id
) return Boolean
2400 return not Is_Predefined_Dispatching_Operation
(Prim
)
2401 and then Present
(Alias
(Prim
))
2402 and then Is_Predefined_Dispatching_Operation
(Ultimate_Alias
(Prim
));
2403 end Is_Predefined_Dispatching_Alias
;
2405 ----------------------------------------
2406 -- Make_Disp_Asynchronous_Select_Body --
2407 ----------------------------------------
2409 -- For interface types, generate:
2411 -- procedure _Disp_Asynchronous_Select
2412 -- (T : in out <Typ>;
2414 -- P : System.Address;
2415 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2420 -- C := Ada.Tags.POK_Function;
2421 -- end _Disp_Asynchronous_Select;
2423 -- For protected types, generate:
2425 -- procedure _Disp_Asynchronous_Select
2426 -- (T : in out <Typ>;
2428 -- P : System.Address;
2429 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2433 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2434 -- Bnn : System.Tasking.Protected_Objects.Operations.
2435 -- Communication_Block;
2437 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2438 -- (T._object'Access,
2439 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2441 -- System.Tasking.Asynchronous_Call,
2443 -- B := System.Storage_Elements.Dummy_Communication_Block (Bnn);
2444 -- end _Disp_Asynchronous_Select;
2446 -- For task types, generate:
2448 -- procedure _Disp_Asynchronous_Select
2449 -- (T : in out <Typ>;
2451 -- P : System.Address;
2452 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2456 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2458 -- System.Tasking.Rendezvous.Task_Entry_Call
2460 -- System.Tasking.Task_Entry_Index (I),
2462 -- System.Tasking.Asynchronous_Call,
2464 -- end _Disp_Asynchronous_Select;
2466 function Make_Disp_Asynchronous_Select_Body
2467 (Typ
: Entity_Id
) return Node_Id
2469 Com_Block
: Entity_Id
;
2470 Conc_Typ
: Entity_Id
:= Empty
;
2471 Decls
: constant List_Id
:= New_List
;
2472 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2474 Stmts
: constant List_Id
:= New_List
;
2478 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2480 -- Null body is generated for interface types
2482 if Is_Interface
(Typ
) then
2484 Make_Subprogram_Body
(Loc
,
2486 Make_Disp_Asynchronous_Select_Spec
(Typ
),
2487 Declarations
=> New_List
,
2488 Handled_Statement_Sequence
=>
2489 Make_Handled_Sequence_Of_Statements
(Loc
,
2491 Make_Assignment_Statement
(Loc
,
2492 Name
=> Make_Identifier
(Loc
, Name_uF
),
2493 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
2496 if Is_Concurrent_Record_Type
(Typ
) then
2497 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
2501 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2503 -- where I will be used to capture the entry index of the primitive
2504 -- wrapper at position S.
2506 if Tagged_Type_Expansion
then
2508 Unchecked_Convert_To
(RTE
(RE_Tag
),
2510 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
2513 Make_Attribute_Reference
(Loc
,
2514 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
2515 Attribute_Name
=> Name_Tag
);
2519 Make_Object_Declaration
(Loc
,
2520 Defining_Identifier
=>
2521 Make_Defining_Identifier
(Loc
, Name_uI
),
2522 Object_Definition
=>
2523 New_Occurrence_Of
(Standard_Integer
, Loc
),
2525 Make_Function_Call
(Loc
,
2527 New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
2528 Parameter_Associations
=>
2529 New_List
(Tag_Node
, Make_Identifier
(Loc
, Name_uS
)))));
2531 if Ekind
(Conc_Typ
) = E_Protected_Type
then
2534 -- Bnn : Communication_Block;
2536 Com_Block
:= Make_Temporary
(Loc
, 'B');
2538 Make_Object_Declaration
(Loc
,
2539 Defining_Identifier
=> Com_Block
,
2540 Object_Definition
=>
2541 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
2543 -- Build T._object'Access for calls below
2546 Make_Attribute_Reference
(Loc
,
2547 Attribute_Name
=> Name_Unchecked_Access
,
2549 Make_Selected_Component
(Loc
,
2550 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2551 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
2553 case Corresponding_Runtime_Package
(Conc_Typ
) is
2554 when System_Tasking_Protected_Objects_Entries
=>
2557 -- Protected_Entry_Call
2558 -- (T._object'Access, -- Object
2559 -- Protected_Entry_Index! (I), -- E
2560 -- P, -- Uninterpreted_Data
2561 -- Asynchronous_Call, -- Mode
2562 -- Bnn); -- Communication_Block
2564 -- where T is the protected object, I is the entry index, P
2565 -- is the wrapped parameters and B is the name of the
2566 -- communication block.
2569 Make_Procedure_Call_Statement
(Loc
,
2571 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
2572 Parameter_Associations
=>
2576 Unchecked_Convert_To
( -- entry index
2577 RTE
(RE_Protected_Entry_Index
),
2578 Make_Identifier
(Loc
, Name_uI
)),
2580 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2581 New_Occurrence_Of
-- Asynchronous_Call
2582 (RTE
(RE_Asynchronous_Call
), Loc
),
2583 New_Occurrence_Of
-- comm block
2584 (Com_Block
, Loc
))));
2587 raise Program_Error
;
2591 -- B := Dummy_Communication_Block (Bnn);
2594 Make_Assignment_Statement
(Loc
,
2595 Name
=> Make_Identifier
(Loc
, Name_uB
),
2597 Unchecked_Convert_To
2598 (RTE
(RE_Dummy_Communication_Block
),
2599 New_Occurrence_Of
(Com_Block
, Loc
))));
2605 Make_Assignment_Statement
(Loc
,
2606 Name
=> Make_Identifier
(Loc
, Name_uF
),
2607 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
2610 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
2614 -- (T._task_id, -- Acceptor
2615 -- Task_Entry_Index! (I), -- E
2616 -- P, -- Uninterpreted_Data
2617 -- Asynchronous_Call, -- Mode
2618 -- F); -- Rendezvous_Successful
2620 -- where T is the task object, I is the entry index, P is the
2621 -- wrapped parameters and F is the status flag.
2624 Make_Procedure_Call_Statement
(Loc
,
2626 New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
2627 Parameter_Associations
=>
2629 Make_Selected_Component
(Loc
, -- T._task_id
2630 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2631 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
2633 Unchecked_Convert_To
( -- entry index
2634 RTE
(RE_Task_Entry_Index
),
2635 Make_Identifier
(Loc
, Name_uI
)),
2637 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2638 New_Occurrence_Of
-- Asynchronous_Call
2639 (RTE
(RE_Asynchronous_Call
), Loc
),
2640 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
2644 -- Ensure that the statements list is non-empty
2647 Make_Assignment_Statement
(Loc
,
2648 Name
=> Make_Identifier
(Loc
, Name_uF
),
2649 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
2653 Make_Subprogram_Body
(Loc
,
2655 Make_Disp_Asynchronous_Select_Spec
(Typ
),
2656 Declarations
=> Decls
,
2657 Handled_Statement_Sequence
=>
2658 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
2659 end Make_Disp_Asynchronous_Select_Body
;
2661 ----------------------------------------
2662 -- Make_Disp_Asynchronous_Select_Spec --
2663 ----------------------------------------
2665 function Make_Disp_Asynchronous_Select_Spec
2666 (Typ
: Entity_Id
) return Node_Id
2668 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2669 B_Id
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
2670 Def_Id
: constant Entity_Id
:=
2671 Make_Defining_Identifier
(Loc
,
2672 Name_uDisp_Asynchronous_Select
);
2676 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2678 -- T : in out Typ; -- Object parameter
2679 -- S : Integer; -- Primitive operation slot
2680 -- P : Address; -- Wrapped parameters
2681 -- B : out Dummy_Communication_Block; -- Communication block dummy
2682 -- F : out Boolean; -- Status flag
2684 -- The B parameter may be left uninitialized
2686 Set_Warnings_Off
(B_Id
);
2688 Params
:= New_List
(
2690 Make_Parameter_Specification
(Loc
,
2691 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
2692 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
2694 Out_Present
=> True),
2696 Make_Parameter_Specification
(Loc
,
2697 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
2698 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
2700 Make_Parameter_Specification
(Loc
,
2701 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
2702 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2704 Make_Parameter_Specification
(Loc
,
2705 Defining_Identifier
=> B_Id
,
2707 New_Occurrence_Of
(RTE
(RE_Dummy_Communication_Block
), Loc
),
2708 Out_Present
=> True),
2710 Make_Parameter_Specification
(Loc
,
2711 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
2712 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
2713 Out_Present
=> True));
2716 Make_Procedure_Specification
(Loc
,
2717 Defining_Unit_Name
=> Def_Id
,
2718 Parameter_Specifications
=> Params
);
2719 end Make_Disp_Asynchronous_Select_Spec
;
2721 ---------------------------------------
2722 -- Make_Disp_Conditional_Select_Body --
2723 ---------------------------------------
2725 -- For interface types, generate:
2727 -- procedure _Disp_Conditional_Select
2728 -- (T : in out <Typ>;
2730 -- P : System.Address;
2731 -- C : out Ada.Tags.Prim_Op_Kind;
2736 -- C := Ada.Tags.POK_Function;
2737 -- end _Disp_Conditional_Select;
2739 -- For protected types, generate:
2741 -- procedure _Disp_Conditional_Select
2742 -- (T : in out <Typ>;
2744 -- P : System.Address;
2745 -- C : out Ada.Tags.Prim_Op_Kind;
2749 -- Bnn : System.Tasking.Protected_Objects.Operations.
2750 -- Communication_Block;
2753 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S));
2755 -- if C = Ada.Tags.POK_Procedure
2756 -- or else C = Ada.Tags.POK_Protected_Procedure
2757 -- or else C = Ada.Tags.POK_Task_Procedure
2763 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2764 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2765 -- (T.object'Access,
2766 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2768 -- System.Tasking.Conditional_Call,
2770 -- F := not Cancelled (Bnn);
2771 -- end _Disp_Conditional_Select;
2773 -- For task types, generate:
2775 -- procedure _Disp_Conditional_Select
2776 -- (T : in out <Typ>;
2778 -- P : System.Address;
2779 -- C : out Ada.Tags.Prim_Op_Kind;
2785 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2786 -- System.Tasking.Rendezvous.Task_Entry_Call
2788 -- System.Tasking.Task_Entry_Index (I),
2790 -- System.Tasking.Conditional_Call,
2792 -- end _Disp_Conditional_Select;
2794 function Make_Disp_Conditional_Select_Body
2795 (Typ
: Entity_Id
) return Node_Id
2797 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2798 Blk_Nam
: Entity_Id
;
2799 Conc_Typ
: Entity_Id
:= Empty
;
2800 Decls
: constant List_Id
:= New_List
;
2802 Stmts
: constant List_Id
:= New_List
;
2806 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2808 -- Null body is generated for interface types
2810 if Is_Interface
(Typ
) then
2812 Make_Subprogram_Body
(Loc
,
2814 Make_Disp_Conditional_Select_Spec
(Typ
),
2815 Declarations
=> No_List
,
2816 Handled_Statement_Sequence
=>
2817 Make_Handled_Sequence_Of_Statements
(Loc
,
2818 New_List
(Make_Assignment_Statement
(Loc
,
2819 Name
=> Make_Identifier
(Loc
, Name_uF
),
2820 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
2823 if Is_Concurrent_Record_Type
(Typ
) then
2824 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
2829 -- where I will be used to capture the entry index of the primitive
2830 -- wrapper at position S.
2833 Make_Object_Declaration
(Loc
,
2834 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uI
),
2835 Object_Definition
=>
2836 New_Occurrence_Of
(Standard_Integer
, Loc
)));
2839 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S);
2841 -- if C = POK_Procedure
2842 -- or else C = POK_Protected_Procedure
2843 -- or else C = POK_Task_Procedure;
2849 Build_Common_Dispatching_Select_Statements
(Typ
, Stmts
);
2852 -- Bnn : Communication_Block;
2854 -- where Bnn is the name of the communication block used in the
2855 -- call to Protected_Entry_Call.
2857 Blk_Nam
:= Make_Temporary
(Loc
, 'B');
2859 Make_Object_Declaration
(Loc
,
2860 Defining_Identifier
=> Blk_Nam
,
2861 Object_Definition
=>
2862 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
2865 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2867 -- I is the entry index and S is the dispatch table slot
2869 if Tagged_Type_Expansion
then
2871 Unchecked_Convert_To
(RTE
(RE_Tag
),
2873 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
2877 Make_Attribute_Reference
(Loc
,
2878 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
2879 Attribute_Name
=> Name_Tag
);
2883 Make_Assignment_Statement
(Loc
,
2884 Name
=> Make_Identifier
(Loc
, Name_uI
),
2886 Make_Function_Call
(Loc
,
2888 New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
2889 Parameter_Associations
=> New_List
(
2891 Make_Identifier
(Loc
, Name_uS
)))));
2893 if Ekind
(Conc_Typ
) = E_Protected_Type
then
2895 Obj_Ref
:= -- T._object'Access
2896 Make_Attribute_Reference
(Loc
,
2897 Attribute_Name
=> Name_Unchecked_Access
,
2899 Make_Selected_Component
(Loc
,
2900 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2901 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
2903 case Corresponding_Runtime_Package
(Conc_Typ
) is
2904 when System_Tasking_Protected_Objects_Entries
=>
2907 -- Protected_Entry_Call
2908 -- (T._object'Access, -- Object
2909 -- Protected_Entry_Index! (I), -- E
2910 -- P, -- Uninterpreted_Data
2911 -- Conditional_Call, -- Mode
2914 -- where T is the protected object, I is the entry index, P
2915 -- are the wrapped parameters and Bnn is the name of the
2916 -- communication block.
2919 Make_Procedure_Call_Statement
(Loc
,
2921 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
2922 Parameter_Associations
=> New_List
(
2925 Unchecked_Convert_To
( -- entry index
2926 RTE
(RE_Protected_Entry_Index
),
2927 Make_Identifier
(Loc
, Name_uI
)),
2929 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2931 New_Occurrence_Of
-- Conditional_Call
2932 (RTE
(RE_Conditional_Call
), Loc
),
2933 New_Occurrence_Of
-- Bnn
2936 when System_Tasking_Protected_Objects_Single_Entry
=>
2938 -- If we are compiling for a restricted run-time, the call
2939 -- uses the simpler form.
2942 Make_Procedure_Call_Statement
(Loc
,
2945 (RTE
(RE_Protected_Single_Entry_Call
), Loc
),
2946 Parameter_Associations
=> New_List
(
2949 Make_Attribute_Reference
(Loc
,
2950 Prefix
=> Make_Identifier
(Loc
, Name_uP
),
2951 Attribute_Name
=> Name_Address
),
2954 (RTE
(RE_Conditional_Call
), Loc
))));
2956 raise Program_Error
;
2960 -- F := not Cancelled (Bnn);
2962 -- where F is the success flag. The status of Cancelled is negated
2963 -- in order to match the behavior of the version for task types.
2966 Make_Assignment_Statement
(Loc
,
2967 Name
=> Make_Identifier
(Loc
, Name_uF
),
2971 Make_Function_Call
(Loc
,
2973 New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
2974 Parameter_Associations
=> New_List
(
2975 New_Occurrence_Of
(Blk_Nam
, Loc
))))));
2977 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
2981 -- (T._task_id, -- Acceptor
2982 -- Task_Entry_Index! (I), -- E
2983 -- P, -- Uninterpreted_Data
2984 -- Conditional_Call, -- Mode
2985 -- F); -- Rendezvous_Successful
2987 -- where T is the task object, I is the entry index, P are the
2988 -- wrapped parameters and F is the status flag.
2991 Make_Procedure_Call_Statement
(Loc
,
2993 New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
2994 Parameter_Associations
=> New_List
(
2996 Make_Selected_Component
(Loc
, -- T._task_id
2997 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2998 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3000 Unchecked_Convert_To
( -- entry index
3001 RTE
(RE_Task_Entry_Index
),
3002 Make_Identifier
(Loc
, Name_uI
)),
3004 Make_Identifier
(Loc
, Name_uP
), -- parameter block
3005 New_Occurrence_Of
-- Conditional_Call
3006 (RTE
(RE_Conditional_Call
), Loc
),
3007 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
3011 -- Initialize out parameters
3014 Make_Assignment_Statement
(Loc
,
3015 Name
=> Make_Identifier
(Loc
, Name_uF
),
3016 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3018 Make_Assignment_Statement
(Loc
,
3019 Name
=> Make_Identifier
(Loc
, Name_uC
),
3020 Expression
=> New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
)));
3024 Make_Subprogram_Body
(Loc
,
3026 Make_Disp_Conditional_Select_Spec
(Typ
),
3027 Declarations
=> Decls
,
3028 Handled_Statement_Sequence
=>
3029 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
3030 end Make_Disp_Conditional_Select_Body
;
3032 ---------------------------------------
3033 -- Make_Disp_Conditional_Select_Spec --
3034 ---------------------------------------
3036 function Make_Disp_Conditional_Select_Spec
3037 (Typ
: Entity_Id
) return Node_Id
3039 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3040 Def_Id
: constant Node_Id
:=
3041 Make_Defining_Identifier
(Loc
,
3042 Name_uDisp_Conditional_Select
);
3043 Params
: constant List_Id
:= New_List
;
3046 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3048 -- T : in out Typ; -- Object parameter
3049 -- S : Integer; -- Primitive operation slot
3050 -- P : Address; -- Wrapped parameters
3051 -- C : out Prim_Op_Kind; -- Call kind
3052 -- F : out Boolean; -- Status flag
3054 Append_List_To
(Params
, New_List
(
3056 Make_Parameter_Specification
(Loc
,
3057 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
3058 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
3060 Out_Present
=> True),
3062 Make_Parameter_Specification
(Loc
,
3063 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
3064 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3066 Make_Parameter_Specification
(Loc
,
3067 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
3068 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3070 Make_Parameter_Specification
(Loc
,
3071 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
3073 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
3074 Out_Present
=> True),
3076 Make_Parameter_Specification
(Loc
,
3077 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
3078 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3079 Out_Present
=> True)));
3082 Make_Procedure_Specification
(Loc
,
3083 Defining_Unit_Name
=> Def_Id
,
3084 Parameter_Specifications
=> Params
);
3085 end Make_Disp_Conditional_Select_Spec
;
3087 -------------------------------------
3088 -- Make_Disp_Get_Prim_Op_Kind_Body --
3089 -------------------------------------
3091 function Make_Disp_Get_Prim_Op_Kind_Body
(Typ
: Entity_Id
) return Node_Id
is
3092 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3096 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3098 if Is_Interface
(Typ
) then
3100 Make_Subprogram_Body
(Loc
,
3102 Make_Disp_Get_Prim_Op_Kind_Spec
(Typ
),
3103 Declarations
=> New_List
,
3104 Handled_Statement_Sequence
=>
3105 Make_Handled_Sequence_Of_Statements
(Loc
,
3106 New_List
(Make_Null_Statement
(Loc
))));
3110 -- C := get_prim_op_kind (tag! (<type>VP), S);
3112 -- where C is the out parameter capturing the call kind and S is the
3113 -- dispatch table slot number.
3115 if Tagged_Type_Expansion
then
3117 Unchecked_Convert_To
(RTE
(RE_Tag
),
3119 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
3123 Make_Attribute_Reference
(Loc
,
3124 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
3125 Attribute_Name
=> Name_Tag
);
3129 Make_Subprogram_Body
(Loc
,
3131 Make_Disp_Get_Prim_Op_Kind_Spec
(Typ
),
3132 Declarations
=> New_List
,
3133 Handled_Statement_Sequence
=>
3134 Make_Handled_Sequence_Of_Statements
(Loc
,
3136 Make_Assignment_Statement
(Loc
,
3137 Name
=> Make_Identifier
(Loc
, Name_uC
),
3139 Make_Function_Call
(Loc
,
3141 New_Occurrence_Of
(RTE
(RE_Get_Prim_Op_Kind
), Loc
),
3142 Parameter_Associations
=> New_List
(
3144 Make_Identifier
(Loc
, Name_uS
)))))));
3145 end Make_Disp_Get_Prim_Op_Kind_Body
;
3147 -------------------------------------
3148 -- Make_Disp_Get_Prim_Op_Kind_Spec --
3149 -------------------------------------
3151 function Make_Disp_Get_Prim_Op_Kind_Spec
3152 (Typ
: Entity_Id
) return Node_Id
3154 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3155 Def_Id
: constant Node_Id
:=
3156 Make_Defining_Identifier
(Loc
, Name_uDisp_Get_Prim_Op_Kind
);
3157 Params
: constant List_Id
:= New_List
;
3160 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3162 -- T : in out Typ; -- Object parameter
3163 -- S : Integer; -- Primitive operation slot
3164 -- C : out Prim_Op_Kind; -- Call kind
3166 Append_List_To
(Params
, New_List
(
3168 Make_Parameter_Specification
(Loc
,
3169 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
3170 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
3172 Out_Present
=> True),
3174 Make_Parameter_Specification
(Loc
,
3175 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
3176 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3178 Make_Parameter_Specification
(Loc
,
3179 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
3181 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
3182 Out_Present
=> True)));
3185 Make_Procedure_Specification
(Loc
,
3186 Defining_Unit_Name
=> Def_Id
,
3187 Parameter_Specifications
=> Params
);
3188 end Make_Disp_Get_Prim_Op_Kind_Spec
;
3190 --------------------------------
3191 -- Make_Disp_Get_Task_Id_Body --
3192 --------------------------------
3194 function Make_Disp_Get_Task_Id_Body
3195 (Typ
: Entity_Id
) return Node_Id
3197 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3201 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3203 if Is_Concurrent_Record_Type
(Typ
)
3204 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) = E_Task_Type
3207 -- return To_Address (_T._task_id);
3210 Make_Simple_Return_Statement
(Loc
,
3212 Unchecked_Convert_To
3214 Make_Selected_Component
(Loc
,
3215 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
3216 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
))));
3218 -- A null body is constructed for non-task types
3222 -- return Null_Address;
3225 Make_Simple_Return_Statement
(Loc
,
3226 Expression
=> New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
3230 Make_Subprogram_Body
(Loc
,
3231 Specification
=> Make_Disp_Get_Task_Id_Spec
(Typ
),
3232 Declarations
=> New_List
,
3233 Handled_Statement_Sequence
=>
3234 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Ret
)));
3235 end Make_Disp_Get_Task_Id_Body
;
3237 --------------------------------
3238 -- Make_Disp_Get_Task_Id_Spec --
3239 --------------------------------
3241 function Make_Disp_Get_Task_Id_Spec
3242 (Typ
: Entity_Id
) return Node_Id
3244 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3247 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3250 Make_Function_Specification
(Loc
,
3251 Defining_Unit_Name
=>
3252 Make_Defining_Identifier
(Loc
, Name_uDisp_Get_Task_Id
),
3253 Parameter_Specifications
=> New_List
(
3254 Make_Parameter_Specification
(Loc
,
3255 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
3256 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
3257 Result_Definition
=>
3258 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
3259 end Make_Disp_Get_Task_Id_Spec
;
3261 ----------------------------
3262 -- Make_Disp_Requeue_Body --
3263 ----------------------------
3265 function Make_Disp_Requeue_Body
3266 (Typ
: Entity_Id
) return Node_Id
3268 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3269 Conc_Typ
: Entity_Id
:= Empty
;
3270 Stmts
: constant List_Id
:= New_List
;
3273 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3275 -- Null body is generated for interface types and nonconcurrent
3278 if Is_Interface
(Typ
)
3279 or else not Is_Concurrent_Record_Type
(Typ
)
3282 Make_Subprogram_Body
(Loc
,
3283 Specification
=> Make_Disp_Requeue_Spec
(Typ
),
3284 Declarations
=> No_List
,
3285 Handled_Statement_Sequence
=>
3286 Make_Handled_Sequence_Of_Statements
(Loc
,
3287 New_List
(Make_Null_Statement
(Loc
))));
3290 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
3292 if Ekind
(Conc_Typ
) = E_Protected_Type
then
3294 -- Generate statements:
3296 -- System.Tasking.Protected_Objects.Operations.
3297 -- Requeue_Protected_Entry
3298 -- (Protection_Entries_Access (P),
3299 -- O._object'Unchecked_Access,
3300 -- Protected_Entry_Index (I),
3303 -- System.Tasking.Protected_Objects.Operations.
3304 -- Requeue_Task_To_Protected_Entry
3305 -- (O._object'Unchecked_Access,
3306 -- Protected_Entry_Index (I),
3310 if Restriction_Active
(No_Entry_Queue
) then
3311 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
3314 Make_If_Statement
(Loc
,
3315 Condition
=> Make_Identifier
(Loc
, Name_uF
),
3320 -- Call to Requeue_Protected_Entry
3322 Make_Procedure_Call_Statement
(Loc
,
3325 (RTE
(RE_Requeue_Protected_Entry
), Loc
),
3326 Parameter_Associations
=>
3329 Unchecked_Convert_To
( -- PEA (P)
3330 RTE
(RE_Protection_Entries_Access
),
3331 Make_Identifier
(Loc
, Name_uP
)),
3333 Make_Attribute_Reference
(Loc
, -- O._object'Acc
3335 Name_Unchecked_Access
,
3337 Make_Selected_Component
(Loc
,
3339 Make_Identifier
(Loc
, Name_uO
),
3341 Make_Identifier
(Loc
, Name_uObject
))),
3343 Unchecked_Convert_To
( -- entry index
3344 RTE
(RE_Protected_Entry_Index
),
3345 Make_Identifier
(Loc
, Name_uI
)),
3347 Make_Identifier
(Loc
, Name_uA
)))), -- abort status
3352 -- Call to Requeue_Task_To_Protected_Entry
3354 Make_Procedure_Call_Statement
(Loc
,
3357 (RTE
(RE_Requeue_Task_To_Protected_Entry
), Loc
),
3358 Parameter_Associations
=>
3361 Make_Attribute_Reference
(Loc
, -- O._object'Acc
3362 Attribute_Name
=> Name_Unchecked_Access
,
3364 Make_Selected_Component
(Loc
,
3366 Make_Identifier
(Loc
, Name_uO
),
3368 Make_Identifier
(Loc
, Name_uObject
))),
3370 Unchecked_Convert_To
( -- entry index
3371 RTE
(RE_Protected_Entry_Index
),
3372 Make_Identifier
(Loc
, Name_uI
)),
3374 Make_Identifier
(Loc
, Name_uA
)))))); -- abort status
3378 pragma Assert
(Is_Task_Type
(Conc_Typ
));
3382 -- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry
3383 -- (Protection_Entries_Access (P),
3385 -- Task_Entry_Index (I),
3388 -- System.Tasking.Rendezvous.Requeue_Task_Entry
3390 -- Task_Entry_Index (I),
3395 Make_If_Statement
(Loc
,
3396 Condition
=> Make_Identifier
(Loc
, Name_uF
),
3398 Then_Statements
=> New_List
(
3400 -- Call to Requeue_Protected_To_Task_Entry
3402 Make_Procedure_Call_Statement
(Loc
,
3405 (RTE
(RE_Requeue_Protected_To_Task_Entry
), Loc
),
3407 Parameter_Associations
=> New_List
(
3409 Unchecked_Convert_To
( -- PEA (P)
3410 RTE
(RE_Protection_Entries_Access
),
3411 Make_Identifier
(Loc
, Name_uP
)),
3413 Make_Selected_Component
(Loc
, -- O._task_id
3414 Prefix
=> Make_Identifier
(Loc
, Name_uO
),
3415 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3417 Unchecked_Convert_To
( -- entry index
3418 RTE
(RE_Task_Entry_Index
),
3419 Make_Identifier
(Loc
, Name_uI
)),
3421 Make_Identifier
(Loc
, Name_uA
)))), -- abort status
3423 Else_Statements
=> New_List
(
3425 -- Call to Requeue_Task_Entry
3427 Make_Procedure_Call_Statement
(Loc
,
3429 New_Occurrence_Of
(RTE
(RE_Requeue_Task_Entry
), Loc
),
3431 Parameter_Associations
=> New_List
(
3433 Make_Selected_Component
(Loc
, -- O._task_id
3434 Prefix
=> Make_Identifier
(Loc
, Name_uO
),
3435 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3437 Unchecked_Convert_To
( -- entry index
3438 RTE
(RE_Task_Entry_Index
),
3439 Make_Identifier
(Loc
, Name_uI
)),
3441 Make_Identifier
(Loc
, Name_uA
)))))); -- abort status
3444 -- Even though no declarations are needed in both cases, we allocate
3445 -- a list for entities added by Freeze.
3448 Make_Subprogram_Body
(Loc
,
3449 Specification
=> Make_Disp_Requeue_Spec
(Typ
),
3450 Declarations
=> New_List
,
3451 Handled_Statement_Sequence
=>
3452 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
3453 end Make_Disp_Requeue_Body
;
3455 ----------------------------
3456 -- Make_Disp_Requeue_Spec --
3457 ----------------------------
3459 function Make_Disp_Requeue_Spec
3460 (Typ
: Entity_Id
) return Node_Id
3462 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3465 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3467 -- O : in out Typ; - Object parameter
3468 -- F : Boolean; - Protected (True) / task (False) flag
3469 -- P : Address; - Protection_Entries_Access value
3470 -- I : Entry_Index - Index of entry call
3471 -- A : Boolean - Abort flag
3473 -- Note that the Protection_Entries_Access value is represented as a
3474 -- System.Address in order to avoid dragging in the tasking runtime
3475 -- when compiling sources without tasking constructs.
3478 Make_Procedure_Specification
(Loc
,
3479 Defining_Unit_Name
=>
3480 Make_Defining_Identifier
(Loc
, Name_uDisp_Requeue
),
3482 Parameter_Specifications
=> New_List
(
3484 Make_Parameter_Specification
(Loc
, -- O
3485 Defining_Identifier
=>
3486 Make_Defining_Identifier
(Loc
, Name_uO
),
3488 New_Occurrence_Of
(Typ
, Loc
),
3490 Out_Present
=> True),
3492 Make_Parameter_Specification
(Loc
, -- F
3493 Defining_Identifier
=>
3494 Make_Defining_Identifier
(Loc
, Name_uF
),
3496 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
3498 Make_Parameter_Specification
(Loc
, -- P
3499 Defining_Identifier
=>
3500 Make_Defining_Identifier
(Loc
, Name_uP
),
3502 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3504 Make_Parameter_Specification
(Loc
, -- I
3505 Defining_Identifier
=>
3506 Make_Defining_Identifier
(Loc
, Name_uI
),
3508 New_Occurrence_Of
(Standard_Integer
, Loc
)),
3510 Make_Parameter_Specification
(Loc
, -- A
3511 Defining_Identifier
=>
3512 Make_Defining_Identifier
(Loc
, Name_uA
),
3514 New_Occurrence_Of
(Standard_Boolean
, Loc
))));
3515 end Make_Disp_Requeue_Spec
;
3517 ---------------------------------
3518 -- Make_Disp_Timed_Select_Body --
3519 ---------------------------------
3521 -- For interface types, generate:
3523 -- procedure _Disp_Timed_Select
3524 -- (T : in out <Typ>;
3526 -- P : System.Address;
3529 -- C : out Ada.Tags.Prim_Op_Kind;
3534 -- C := Ada.Tags.POK_Function;
3535 -- end _Disp_Timed_Select;
3537 -- For protected types, generate:
3539 -- procedure _Disp_Timed_Select
3540 -- (T : in out <Typ>;
3542 -- P : System.Address;
3545 -- C : out Ada.Tags.Prim_Op_Kind;
3551 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S);
3553 -- if C = Ada.Tags.POK_Procedure
3554 -- or else C = Ada.Tags.POK_Protected_Procedure
3555 -- or else C = Ada.Tags.POK_Task_Procedure
3561 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3562 -- System.Tasking.Protected_Objects.Operations.
3563 -- Timed_Protected_Entry_Call
3564 -- (T._object'Access,
3565 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
3570 -- end _Disp_Timed_Select;
3572 -- For task types, generate:
3574 -- procedure _Disp_Timed_Select
3575 -- (T : in out <Typ>;
3577 -- P : System.Address;
3580 -- C : out Ada.Tags.Prim_Op_Kind;
3586 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3587 -- System.Tasking.Rendezvous.Timed_Task_Entry_Call
3589 -- System.Tasking.Task_Entry_Index (I),
3594 -- end _Disp_Time_Select;
3596 function Make_Disp_Timed_Select_Body
3597 (Typ
: Entity_Id
) return Node_Id
3599 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3600 Conc_Typ
: Entity_Id
:= Empty
;
3601 Decls
: constant List_Id
:= New_List
;
3603 Stmts
: constant List_Id
:= New_List
;
3607 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3609 -- Null body is generated for interface types
3611 if Is_Interface
(Typ
) then
3613 Make_Subprogram_Body
(Loc
,
3614 Specification
=> Make_Disp_Timed_Select_Spec
(Typ
),
3615 Declarations
=> New_List
,
3616 Handled_Statement_Sequence
=>
3617 Make_Handled_Sequence_Of_Statements
(Loc
,
3619 Make_Assignment_Statement
(Loc
,
3620 Name
=> Make_Identifier
(Loc
, Name_uF
),
3621 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
3624 if Is_Concurrent_Record_Type
(Typ
) then
3625 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
3630 -- where I will be used to capture the entry index of the primitive
3631 -- wrapper at position S.
3634 Make_Object_Declaration
(Loc
,
3635 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uI
),
3636 Object_Definition
=>
3637 New_Occurrence_Of
(Standard_Integer
, Loc
)));
3640 -- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
3642 -- if C = POK_Procedure
3643 -- or else C = POK_Protected_Procedure
3644 -- or else C = POK_Task_Procedure;
3650 Build_Common_Dispatching_Select_Statements
(Typ
, Stmts
);
3653 -- I := Get_Entry_Index (tag! (<type>VP), S);
3655 -- I is the entry index and S is the dispatch table slot
3657 if Tagged_Type_Expansion
then
3659 Unchecked_Convert_To
(RTE
(RE_Tag
),
3661 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
3665 Make_Attribute_Reference
(Loc
,
3666 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
3667 Attribute_Name
=> Name_Tag
);
3671 Make_Assignment_Statement
(Loc
,
3672 Name
=> Make_Identifier
(Loc
, Name_uI
),
3674 Make_Function_Call
(Loc
,
3675 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
3676 Parameter_Associations
=> New_List
(
3678 Make_Identifier
(Loc
, Name_uS
)))));
3682 if Ekind
(Conc_Typ
) = E_Protected_Type
then
3684 -- Build T._object'Access
3687 Make_Attribute_Reference
(Loc
,
3688 Attribute_Name
=> Name_Unchecked_Access
,
3690 Make_Selected_Component
(Loc
,
3691 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
3692 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
3694 -- Normal case, No_Entry_Queue restriction not active. In this
3695 -- case we generate:
3697 -- Timed_Protected_Entry_Call
3698 -- (T._object'access,
3699 -- Protected_Entry_Index! (I),
3702 -- where T is the protected object, I is the entry index, P are
3703 -- the wrapped parameters, D is the delay amount, M is the delay
3704 -- mode and F is the status flag.
3706 -- Historically, there was also an implementation for single
3707 -- entry protected types (in s-tposen). However, it was removed
3708 -- by also testing for no No_Select_Statements restriction in
3709 -- Exp_Utils.Corresponding_Runtime_Package. This simplified the
3710 -- implementation of s-tposen.adb and provided consistency between
3711 -- all versions of System.Tasking.Protected_Objects.Single_Entry
3714 case Corresponding_Runtime_Package
(Conc_Typ
) is
3715 when System_Tasking_Protected_Objects_Entries
=>
3717 Make_Procedure_Call_Statement
(Loc
,
3720 (RTE
(RE_Timed_Protected_Entry_Call
), Loc
),
3721 Parameter_Associations
=> New_List
(
3724 Unchecked_Convert_To
( -- entry index
3725 RTE
(RE_Protected_Entry_Index
),
3726 Make_Identifier
(Loc
, Name_uI
)),
3728 Make_Identifier
(Loc
, Name_uP
), -- parameter block
3729 Make_Identifier
(Loc
, Name_uD
), -- delay
3730 Make_Identifier
(Loc
, Name_uM
), -- delay mode
3731 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
3734 raise Program_Error
;
3740 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
3743 -- Timed_Task_Entry_Call (
3745 -- Task_Entry_Index! (I),
3751 -- where T is the task object, I is the entry index, P are the
3752 -- wrapped parameters, D is the delay amount, M is the delay
3753 -- mode and F is the status flag.
3756 Make_Procedure_Call_Statement
(Loc
,
3758 New_Occurrence_Of
(RTE
(RE_Timed_Task_Entry_Call
), Loc
),
3760 Parameter_Associations
=> New_List
(
3761 Make_Selected_Component
(Loc
, -- T._task_id
3762 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
3763 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3765 Unchecked_Convert_To
( -- entry index
3766 RTE
(RE_Task_Entry_Index
),
3767 Make_Identifier
(Loc
, Name_uI
)),
3769 Make_Identifier
(Loc
, Name_uP
), -- parameter block
3770 Make_Identifier
(Loc
, Name_uD
), -- delay
3771 Make_Identifier
(Loc
, Name_uM
), -- delay mode
3772 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
3776 -- Initialize out parameters
3779 Make_Assignment_Statement
(Loc
,
3780 Name
=> Make_Identifier
(Loc
, Name_uF
),
3781 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3783 Make_Assignment_Statement
(Loc
,
3784 Name
=> Make_Identifier
(Loc
, Name_uC
),
3785 Expression
=> New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
)));
3789 Make_Subprogram_Body
(Loc
,
3790 Specification
=> Make_Disp_Timed_Select_Spec
(Typ
),
3791 Declarations
=> Decls
,
3792 Handled_Statement_Sequence
=>
3793 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
3794 end Make_Disp_Timed_Select_Body
;
3796 ---------------------------------
3797 -- Make_Disp_Timed_Select_Spec --
3798 ---------------------------------
3800 function Make_Disp_Timed_Select_Spec
3801 (Typ
: Entity_Id
) return Node_Id
3803 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3804 Def_Id
: constant Node_Id
:=
3805 Make_Defining_Identifier
(Loc
,
3806 Name_uDisp_Timed_Select
);
3807 Params
: constant List_Id
:= New_List
;
3810 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3812 -- T : in out Typ; -- Object parameter
3813 -- S : Integer; -- Primitive operation slot
3814 -- P : Address; -- Wrapped parameters
3815 -- D : Duration; -- Delay
3816 -- M : Integer; -- Delay Mode
3817 -- C : out Prim_Op_Kind; -- Call kind
3818 -- F : out Boolean; -- Status flag
3820 Append_List_To
(Params
, New_List
(
3822 Make_Parameter_Specification
(Loc
,
3823 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
3824 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
3826 Out_Present
=> True),
3828 Make_Parameter_Specification
(Loc
,
3829 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
3830 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3832 Make_Parameter_Specification
(Loc
,
3833 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
3834 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3836 Make_Parameter_Specification
(Loc
,
3837 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uD
),
3838 Parameter_Type
=> New_Occurrence_Of
(Standard_Duration
, Loc
)),
3840 Make_Parameter_Specification
(Loc
,
3841 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uM
),
3842 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3844 Make_Parameter_Specification
(Loc
,
3845 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
3847 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
3848 Out_Present
=> True)));
3851 Make_Parameter_Specification
(Loc
,
3852 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
3853 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3854 Out_Present
=> True));
3857 Make_Procedure_Specification
(Loc
,
3858 Defining_Unit_Name
=> Def_Id
,
3859 Parameter_Specifications
=> Params
);
3860 end Make_Disp_Timed_Select_Spec
;
3866 -- The frontend supports two models for expanding dispatch tables
3867 -- associated with library-level defined tagged types: statically and
3868 -- non-statically allocated dispatch tables. In the former case the object
3869 -- containing the dispatch table is constant and it is initialized by means
3870 -- of a positional aggregate. In the latter case, the object containing
3871 -- the dispatch table is a variable which is initialized by means of
3874 -- In case of locally defined tagged types, the object containing the
3875 -- object containing the dispatch table is always a variable (instead of a
3876 -- constant). This is currently required to give support to late overriding
3877 -- of primitives. For example:
3879 -- procedure Example is
3881 -- type T1 is tagged null record;
3882 -- procedure Prim (O : T1);
3885 -- type T2 is new Pkg.T1 with null record;
3886 -- procedure Prim (X : T2) is -- late overriding
3892 -- WARNING: This routine manages Ghost regions. Return statements must be
3893 -- replaced by gotos which jump to the end of the routine and restore the
3896 function Make_DT
(Typ
: Entity_Id
) return List_Id
is
3897 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3899 Max_Predef_Prims
: constant Int
:=
3903 (Parent
(RTE
(RE_Max_Predef_Prims
)))));
3905 DT_Decl
: constant Elist_Id
:= New_Elmt_List
;
3906 DT_Aggr
: constant Elist_Id
:= New_Elmt_List
;
3907 -- Entities marked with attribute Is_Dispatch_Table_Entity
3909 Dummy_Object
: Entity_Id
:= Empty
;
3910 -- Extra nonexistent object of type Typ internally used to compute the
3911 -- offset to the components that reference secondary dispatch tables.
3912 -- Used to compute the offset of components located at fixed position.
3914 procedure Export_DT
(Typ
: Entity_Id
; DT
: Entity_Id
; Index
: Nat
:= 0);
3915 -- Export the dispatch table DT of tagged type Typ. Required to generate
3916 -- forward references and statically allocate the table. For primary
3917 -- dispatch tables Index is 0; for secondary dispatch tables the value
3918 -- of index must match the Suffix_Index value assigned to the table by
3919 -- Make_Tags when generating its unique external name, and it is used to
3920 -- retrieve from the Dispatch_Table_Wrappers list associated with Typ
3921 -- the external name generated by Import_DT.
3923 procedure Make_Secondary_DT
3926 Iface_Comp
: Node_Id
;
3928 Num_Iface_Prims
: Nat
;
3929 Iface_DT_Ptr
: Entity_Id
;
3930 Predef_Prims_Ptr
: Entity_Id
;
3931 Build_Thunks
: Boolean;
3933 -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch
3934 -- Table of Typ associated with Iface. Each abstract interface of Typ
3935 -- has two secondary dispatch tables: one containing pointers to thunks
3936 -- and another containing pointers to the primitives covering the
3937 -- interface primitives. The former secondary table is generated when
3938 -- Build_Thunks is True, and provides common support for dispatching
3939 -- calls through interface types; the latter secondary table is
3940 -- generated when Build_Thunks is False, and provides support for
3941 -- Generic Dispatching Constructors that dispatch calls through
3942 -- interface types. When constructing this latter table the value of
3943 -- Suffix_Index is -1 to indicate that there is no need to export such
3944 -- table when building statically allocated dispatch tables; a positive
3945 -- value of Suffix_Index must match the Suffix_Index value assigned to
3946 -- this secondary dispatch table by Make_Tags when its unique external
3947 -- name was generated.
3949 function Number_Of_Predefined_Prims
(Typ
: Entity_Id
) return Nat
;
3950 -- Returns the number of predefined primitives of Typ
3956 procedure Export_DT
(Typ
: Entity_Id
; DT
: Entity_Id
; Index
: Nat
:= 0)
3962 Set_Is_Statically_Allocated
(DT
);
3963 Set_Is_True_Constant
(DT
);
3964 Set_Is_Exported
(DT
);
3967 Elmt
:= First_Elmt
(Dispatch_Table_Wrappers
(Typ
));
3968 while Count
/= Index
loop
3973 -- Related_Type (Node (Elmt)) should be equal to Typ here, but we
3974 -- can't assert that, because it is sometimes false in illegal
3975 -- programs. We can't check Serious_Errors_Detected, because the
3976 -- errors have not yet been detected.
3978 Get_External_Name
(Node
(Elmt
));
3979 Set_Interface_Name
(DT
,
3980 Make_String_Literal
(Loc
,
3981 Strval
=> String_From_Name_Buffer
));
3983 -- Ensure proper Sprint output of this implicit importation
3985 Set_Is_Internal
(DT
);
3989 -----------------------
3990 -- Make_Secondary_DT --
3991 -----------------------
3993 procedure Make_Secondary_DT
3996 Iface_Comp
: Node_Id
;
3998 Num_Iface_Prims
: Nat
;
3999 Iface_DT_Ptr
: Entity_Id
;
4000 Predef_Prims_Ptr
: Entity_Id
;
4001 Build_Thunks
: Boolean;
4004 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
4005 Exporting_Table
: constant Boolean :=
4006 Building_Static_DT
(Typ
)
4007 and then Suffix_Index
> 0;
4008 Iface_DT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
4009 Predef_Prims
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
4010 DT_Constr_List
: List_Id
;
4011 DT_Aggr_List
: List_Id
;
4012 Empty_DT
: Boolean := False;
4016 OSD_Aggr_List
: List_Id
;
4018 Prim_Elmt
: Elmt_Id
;
4019 Prim_Ops_Aggr_List
: List_Id
;
4022 -- Handle cases in which we do not generate statically allocated
4025 if not Building_Static_DT
(Typ
) then
4026 Mutate_Ekind
(Predef_Prims
, E_Variable
);
4027 Mutate_Ekind
(Iface_DT
, E_Variable
);
4029 -- Statically allocated dispatch tables and related entities are
4033 Mutate_Ekind
(Predef_Prims
, E_Constant
);
4034 Set_Is_Statically_Allocated
(Predef_Prims
);
4035 Set_Is_True_Constant
(Predef_Prims
);
4037 Mutate_Ekind
(Iface_DT
, E_Constant
);
4038 Set_Is_Statically_Allocated
(Iface_DT
);
4039 Set_Is_True_Constant
(Iface_DT
);
4042 -- Calculate the number of slots of the dispatch table. If the number
4043 -- of primitives of Typ is 0 we reserve a dummy single entry for its
4044 -- DT because at run time the pointer to this dummy entry will be
4047 if Num_Iface_Prims
= 0 then
4051 Nb_Prim
:= Num_Iface_Prims
;
4056 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
4057 -- (predef-prim-op-thunk-1'address,
4058 -- predef-prim-op-thunk-2'address,
4060 -- predef-prim-op-thunk-n'address);
4062 -- Create the thunks associated with the predefined primitives and
4063 -- save their entity to fill the aggregate.
4066 Nb_P_Prims
: constant Nat
:= Number_Of_Predefined_Prims
(Typ
);
4067 Prim_Table
: array (Nat
range 1 .. Nb_P_Prims
) of Entity_Id
;
4070 SS_Thunk_Id
: Entity_Id
;
4071 SS_Thunk_Code
: Node_Id
;
4072 Thunk_Id
: Entity_Id
;
4073 Thunk_Code
: List_Id
;
4076 Prim_Ops_Aggr_List
:= New_List
;
4077 Prim_Table
:= (others => Empty
);
4079 if Building_Static_DT
(Typ
) then
4080 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4081 while Present
(Prim_Elmt
) loop
4082 Prim
:= Node
(Prim_Elmt
);
4084 if Is_Predefined_Dispatching_Operation
(Prim
)
4085 and then not Is_Abstract_Subprogram
(Prim
)
4086 and then not Is_Eliminated
(Prim
)
4087 and then not Generate_SCIL
4088 and then No
(Prim_Table
(UI_To_Int
(DT_Position
(Prim
))))
4090 if not Build_Thunks
then
4091 E
:= Ultimate_Alias
(Prim
);
4092 Expand_Secondary_Stack_Thunk
4093 (E
, SS_Thunk_Id
, SS_Thunk_Code
);
4095 if Present
(SS_Thunk_Id
) then
4097 Append_To
(Result
, SS_Thunk_Code
);
4100 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) := E
;
4103 Expand_Interface_Thunk
4104 (Prim
, Thunk_Id
, Thunk_Code
, Iface
);
4106 if Present
(Thunk_Id
) then
4107 Append_List_To
(Result
, Thunk_Code
);
4108 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) :=
4114 Next_Elmt
(Prim_Elmt
);
4118 for J
in Prim_Table
'Range loop
4119 if Present
(Prim_Table
(J
)) then
4121 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
4122 Make_Attribute_Reference
(Loc
,
4123 Prefix
=> New_Occurrence_Of
(Prim_Table
(J
), Loc
),
4124 Attribute_Name
=> Name_Unrestricted_Access
));
4126 New_Node
:= Make_Null
(Loc
);
4129 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
4133 Make_Aggregate
(Loc
, Expressions
=> Prim_Ops_Aggr_List
);
4135 -- Remember aggregates initializing dispatch tables
4137 Append_Elmt
(New_Node
, DT_Aggr
);
4140 Make_Subtype_Declaration
(Loc
,
4141 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
4142 Subtype_Indication
=>
4143 New_Occurrence_Of
(RTE
(RE_Address_Array
), Loc
));
4145 Append_To
(Result
, Decl
);
4148 Make_Object_Declaration
(Loc
,
4149 Defining_Identifier
=> Predef_Prims
,
4150 Constant_Present
=> Building_Static_DT
(Typ
),
4151 Aliased_Present
=> True,
4152 Object_Definition
=> New_Occurrence_Of
4153 (Defining_Identifier
(Decl
), Loc
),
4154 Expression
=> New_Node
));
4159 -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
4160 -- (OSD_Table => (1 => <value>,
4163 -- for OSD'Alignment use Address'Alignment;
4165 -- Iface_DT : Dispatch_Table (Nb_Prims) :=
4166 -- ([ Signature => <sig-value> ],
4167 -- Tag_Kind => <tag_kind-value>,
4168 -- Predef_Prims => Predef_Prims'Address,
4169 -- Offset_To_Top => 0,
4170 -- OSD => OSD'Address,
4171 -- Prims_Ptr => (prim-op-1'address,
4172 -- prim-op-2'address,
4174 -- prim-op-n'address));
4176 -- Stage 3: Initialize the discriminant and the record components
4178 DT_Constr_List
:= New_List
;
4179 DT_Aggr_List
:= New_List
;
4183 Append_To
(DT_Constr_List
, Make_Integer_Literal
(Loc
, Nb_Prim
));
4184 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, Nb_Prim
));
4188 if RTE_Record_Component_Available
(RE_Signature
) then
4189 Append_To
(DT_Aggr_List
,
4190 New_Occurrence_Of
(RTE
(RE_Secondary_DT
), Loc
));
4195 if RTE_Record_Component_Available
(RE_Tag_Kind
) then
4196 Append_To
(DT_Aggr_List
, Tagged_Kind
(Typ
));
4201 Append_To
(DT_Aggr_List
,
4202 Make_Attribute_Reference
(Loc
,
4203 Prefix
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
4204 Attribute_Name
=> Name_Address
));
4206 -- Interface component located at variable offset; the value of
4207 -- Offset_To_Top will be set by the init subprogram.
4209 if No
(Dummy_Object
)
4210 or else Is_Variable_Size_Record
(Etype
(Scope
(Iface_Comp
)))
4212 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
4214 -- Interface component located at fixed offset
4217 Append_To
(DT_Aggr_List
,
4219 Make_Attribute_Reference
(Loc
,
4221 Make_Selected_Component
(Loc
,
4223 New_Occurrence_Of
(Dummy_Object
, Loc
),
4225 New_Occurrence_Of
(Iface_Comp
, Loc
)),
4226 Attribute_Name
=> Name_Position
)));
4229 -- Generate the Object Specific Data table required to dispatch calls
4230 -- through synchronized interfaces.
4233 or else Is_Abstract_Type
(Typ
)
4234 or else Is_Controlled
(Typ
)
4235 or else Restriction_Active
(No_Dispatching_Calls
)
4236 or else not Is_Limited_Type
(Typ
)
4237 or else not Has_Interfaces
(Typ
)
4238 or else not Build_Thunks
4239 or else not RTE_Record_Component_Available
(RE_OSD_Table
)
4241 -- No OSD table required
4243 Append_To
(DT_Aggr_List
,
4244 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
4247 OSD_Aggr_List
:= New_List
;
4250 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
4252 Prim_Alias
: Entity_Id
;
4253 Prim_Elmt
: Elmt_Id
;
4257 SS_Thunk_Id
: Entity_Id
;
4258 SS_Thunk_Code
: Node_Id
;
4261 Prim_Table
:= (others => Empty
);
4262 Prim_Alias
:= Empty
;
4265 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4266 while Present
(Prim_Elmt
) loop
4267 Prim
:= Node
(Prim_Elmt
);
4269 if Present
(Interface_Alias
(Prim
))
4270 and then Find_Dispatching_Type
4271 (Interface_Alias
(Prim
)) = Iface
4273 Prim_Alias
:= Interface_Alias
(Prim
);
4274 E
:= Ultimate_Alias
(Prim
);
4275 Pos
:= UI_To_Int
(DT_Position
(Prim_Alias
));
4277 if No
(Prim_Table
(Pos
)) then
4278 Expand_Secondary_Stack_Thunk
4279 (E
, SS_Thunk_Id
, SS_Thunk_Code
);
4281 if Present
(SS_Thunk_Id
) then
4283 Append_To
(Result
, SS_Thunk_Code
);
4286 Prim_Table
(Pos
) := E
;
4288 Append_To
(OSD_Aggr_List
,
4289 Make_Component_Association
(Loc
,
4290 Choices
=> New_List
(
4291 Make_Integer_Literal
(Loc
,
4292 DT_Position
(Prim_Alias
))),
4294 Make_Integer_Literal
(Loc
,
4295 DT_Position
(Alias
(Prim
)))));
4301 Next_Elmt
(Prim_Elmt
);
4303 pragma Assert
(Count
= Nb_Prim
);
4306 OSD
:= Make_Temporary
(Loc
, 'I');
4309 Make_Object_Declaration
(Loc
,
4310 Defining_Identifier
=> OSD
,
4311 Constant_Present
=> True,
4312 Object_Definition
=>
4313 Make_Subtype_Indication
(Loc
,
4315 New_Occurrence_Of
(RTE
(RE_Object_Specific_Data
), Loc
),
4317 Make_Index_Or_Discriminant_Constraint
(Loc
,
4318 Constraints
=> New_List
(
4319 Make_Integer_Literal
(Loc
, Nb_Prim
)))),
4322 Make_Aggregate
(Loc
,
4323 Component_Associations
=> New_List
(
4324 Make_Component_Association
(Loc
,
4325 Choices
=> New_List
(
4327 (RTE_Record_Component
(RE_OSD_Num_Prims
), Loc
)),
4329 Make_Integer_Literal
(Loc
, Nb_Prim
)),
4331 Make_Component_Association
(Loc
,
4332 Choices
=> New_List
(
4334 (RTE_Record_Component
(RE_OSD_Table
), Loc
)),
4335 Expression
=> Make_Aggregate
(Loc
,
4336 Component_Associations
=> OSD_Aggr_List
))))));
4339 Make_Attribute_Definition_Clause
(Loc
,
4340 Name
=> New_Occurrence_Of
(OSD
, Loc
),
4341 Chars
=> Name_Alignment
,
4343 Make_Attribute_Reference
(Loc
,
4345 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4346 Attribute_Name
=> Name_Alignment
)));
4348 -- In secondary dispatch tables the Typeinfo component contains
4349 -- the address of the Object Specific Data (see a-tags.ads).
4351 Append_To
(DT_Aggr_List
,
4352 Make_Attribute_Reference
(Loc
,
4353 Prefix
=> New_Occurrence_Of
(OSD
, Loc
),
4354 Attribute_Name
=> Name_Address
));
4357 -- Initialize the table of primitive operations
4359 Prim_Ops_Aggr_List
:= New_List
;
4362 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
4364 elsif Is_Abstract_Type
(Typ
)
4365 or else not Building_Static_DT
(Typ
)
4367 for J
in 1 .. Nb_Prim
loop
4368 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
4373 CPP_Nb_Prims
: constant Nat
:= CPP_Num_Prims
(Typ
);
4376 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
4377 SS_Thunk_Id
: Entity_Id
;
4378 SS_Thunk_Code
: Node_Id
;
4379 Thunk_Id
: Entity_Id
;
4380 Thunk_Code
: List_Id
;
4383 Prim_Table
:= (others => Empty
);
4385 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4386 while Present
(Prim_Elmt
) loop
4387 Prim
:= Node
(Prim_Elmt
);
4388 E
:= Ultimate_Alias
(Prim
);
4389 Prim_Pos
:= UI_To_Int
(DT_Position
(E
));
4391 -- Do not reference predefined primitives because they are
4392 -- located in a separate dispatch table; skip abstract and
4393 -- eliminated primitives; skip primitives located in the C++
4394 -- part of the dispatch table because their slot is set by
4397 if not Is_Predefined_Dispatching_Operation
(Prim
)
4398 and then Present
(Interface_Alias
(Prim
))
4399 and then not Is_Abstract_Subprogram
(Alias
(Prim
))
4400 and then not Is_Eliminated
(Alias
(Prim
))
4401 and then (not Is_CPP_Class
(Root_Type
(Typ
))
4402 or else Prim_Pos
> CPP_Nb_Prims
)
4403 and then Find_Dispatching_Type
4404 (Interface_Alias
(Prim
)) = Iface
4406 -- Generate the code of the thunk only if the abstract
4407 -- interface type is not an immediate ancestor of
4408 -- Tagged_Type. Otherwise the DT associated with the
4409 -- interface is the primary DT.
4411 and then not Is_Ancestor
(Iface
, Typ
,
4412 Use_Full_View
=> True)
4414 if not Build_Thunks
then
4416 Expand_Secondary_Stack_Thunk
4417 (E
, SS_Thunk_Id
, SS_Thunk_Code
);
4419 if Present
(SS_Thunk_Id
) then
4421 Append_To
(Result
, SS_Thunk_Code
);
4425 UI_To_Int
(DT_Position
(Interface_Alias
(Prim
)));
4426 Prim_Table
(Prim_Pos
) := E
;
4429 Expand_Interface_Thunk
4430 (Prim
, Thunk_Id
, Thunk_Code
, Iface
);
4432 if Present
(Thunk_Id
) then
4434 UI_To_Int
(DT_Position
(Interface_Alias
(Prim
)));
4436 Prim_Table
(Prim_Pos
) := Thunk_Id
;
4437 Append_List_To
(Result
, Thunk_Code
);
4442 Next_Elmt
(Prim_Elmt
);
4445 for J
in Prim_Table
'Range loop
4446 if Present
(Prim_Table
(J
)) then
4448 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
4449 Make_Attribute_Reference
(Loc
,
4450 Prefix
=> New_Occurrence_Of
(Prim_Table
(J
), Loc
),
4451 Attribute_Name
=> Name_Unrestricted_Access
));
4454 New_Node
:= Make_Null
(Loc
);
4457 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
4463 Make_Aggregate
(Loc
,
4464 Expressions
=> Prim_Ops_Aggr_List
);
4466 Append_To
(DT_Aggr_List
, New_Node
);
4468 -- Remember aggregates initializing dispatch tables
4470 Append_Elmt
(New_Node
, DT_Aggr
);
4472 -- Note: Secondary dispatch tables are declared constant only if
4473 -- we can compute their offset field by means of the extra dummy
4474 -- object; otherwise they cannot be declared constant and the
4475 -- Offset_To_Top component is initialized by the IP routine.
4478 Make_Object_Declaration
(Loc
,
4479 Defining_Identifier
=> Iface_DT
,
4480 Aliased_Present
=> True,
4481 Constant_Present
=> Building_Static_Secondary_DT
(Typ
),
4483 Object_Definition
=>
4484 Make_Subtype_Indication
(Loc
,
4485 Subtype_Mark
=> New_Occurrence_Of
4486 (RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
4487 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
4488 Constraints
=> DT_Constr_List
)),
4491 Make_Aggregate
(Loc
,
4492 Expressions
=> DT_Aggr_List
)));
4494 if Exporting_Table
then
4495 Export_DT
(Typ
, Iface_DT
, Suffix_Index
);
4497 -- Generate code to create the pointer to the dispatch table
4499 -- Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address);
4501 -- Note: This declaration is not added here if the table is exported
4502 -- because in such case Make_Tags has already added this declaration.
4506 Make_Object_Declaration
(Loc
,
4507 Defining_Identifier
=> Iface_DT_Ptr
,
4508 Constant_Present
=> True,
4510 Object_Definition
=>
4511 New_Occurrence_Of
(RTE
(RE_Interface_Tag
), Loc
),
4514 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
4515 Make_Attribute_Reference
(Loc
,
4517 Make_Selected_Component
(Loc
,
4518 Prefix
=> New_Occurrence_Of
(Iface_DT
, Loc
),
4521 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
4522 Attribute_Name
=> Name_Address
))));
4526 Make_Object_Declaration
(Loc
,
4527 Defining_Identifier
=> Predef_Prims_Ptr
,
4528 Constant_Present
=> True,
4530 Object_Definition
=>
4531 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
4534 Make_Attribute_Reference
(Loc
,
4536 Make_Selected_Component
(Loc
,
4537 Prefix
=> New_Occurrence_Of
(Iface_DT
, Loc
),
4540 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
4541 Attribute_Name
=> Name_Address
)));
4543 -- Remember entities containing dispatch tables
4545 Append_Elmt
(Predef_Prims
, DT_Decl
);
4546 Append_Elmt
(Iface_DT
, DT_Decl
);
4547 end Make_Secondary_DT
;
4549 --------------------------------
4550 -- Number_Of_Predefined_Prims --
4551 --------------------------------
4553 function Number_Of_Predefined_Prims
(Typ
: Entity_Id
) return Nat
is
4554 Nb_Predef_Prims
: Nat
:= 0;
4557 if not Generate_SCIL
then
4560 Prim_Elmt
: Elmt_Id
;
4564 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4565 while Present
(Prim_Elmt
) loop
4566 Prim
:= Node
(Prim_Elmt
);
4568 if Is_Predefined_Dispatching_Operation
(Prim
)
4569 and then not Is_Abstract_Subprogram
(Prim
)
4571 Pos
:= UI_To_Int
(DT_Position
(Prim
));
4573 if Pos
> Nb_Predef_Prims
then
4574 Nb_Predef_Prims
:= Pos
;
4578 Next_Elmt
(Prim_Elmt
);
4583 pragma Assert
(Nb_Predef_Prims
<= Max_Predef_Prims
);
4584 return Nb_Predef_Prims
;
4585 end Number_Of_Predefined_Prims
;
4589 Elab_Code
: constant List_Id
:= New_List
;
4590 Result
: constant List_Id
:= New_List
;
4591 Tname
: constant Name_Id
:= Chars
(Typ
);
4593 -- When pragmas Discard_Names and No_Tagged_Streams simultaneously apply
4594 -- we initialize the Expanded_Name and the External_Tag of this tagged
4595 -- type with an empty string. This is useful to avoid exposing entity
4596 -- names at binary level. It can be done when both pragmas apply because
4597 -- (1) Discard_Names allows initializing Expanded_Name with an
4598 -- implementation defined value (Ada RM Section C.5 (7/2)).
4599 -- (2) External_Tag (combined with Internal_Tag) is used for object
4600 -- streaming and No_Tagged_Streams inhibits the generation of
4602 -- Instead of No_Tagged_Streams, which applies either to a single
4603 -- type or to a declarative region, it is possible to use restriction
4604 -- No_Streams, which prevents stream objects from being created in the
4605 -- entire partition.
4607 Discard_Names
: constant Boolean :=
4608 (Present
(No_Tagged_Streams_Pragma
(Typ
))
4609 or else Restriction_Active
(No_Streams
))
4611 (Global_Discard_Names
or else Einfo
.Entities
.Discard_Names
(Typ
));
4613 -- The following name entries are used by Make_DT to generate a number
4614 -- of entities related to a tagged type. These entities may be generated
4615 -- in a scope other than that of the tagged type declaration, and if
4616 -- the entities for two tagged types with the same name happen to be
4617 -- generated in the same scope, we have to take care to use different
4618 -- names. This is achieved by means of a unique serial number appended
4619 -- to each generated entity name.
4621 Name_DT
: constant Name_Id
:=
4622 New_External_Name
(Tname
, 'T', Suffix_Index
=> -1);
4623 Name_Exname
: constant Name_Id
:=
4624 New_External_Name
(Tname
, 'E', Suffix_Index
=> -1);
4625 Name_HT_Link
: constant Name_Id
:=
4626 New_External_Name
(Tname
, 'H', Suffix_Index
=> -1);
4627 Name_Predef_Prims
: constant Name_Id
:=
4628 New_External_Name
(Tname
, 'R', Suffix_Index
=> -1);
4629 Name_SSD
: constant Name_Id
:=
4630 New_External_Name
(Tname
, 'S', Suffix_Index
=> -1);
4631 Name_TSD
: constant Name_Id
:=
4632 New_External_Name
(Tname
, 'B', Suffix_Index
=> -1);
4634 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
4635 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
4636 -- Save the Ghost-related attributes to restore on exit
4639 AI_Tag_Elmt
: Elmt_Id
;
4640 AI_Tag_Comp
: Elmt_Id
;
4642 DT_Aggr_List
: List_Id
;
4643 DT_Constr_List
: List_Id
;
4646 HT_Link
: Entity_Id
;
4649 Iface_Table_Node
: Node_Id
;
4650 Name_ITable
: Name_Id
;
4653 Num_Ifaces
: Nat
:= 0;
4654 Parent_Typ
: Entity_Id
;
4655 Predef_Prims
: Entity_Id
;
4657 Prim_Elmt
: Elmt_Id
;
4658 Prim_Ops_Aggr_List
: List_Id
;
4661 Typ_Comps
: Elist_Id
;
4662 Typ_Ifaces
: Elist_Id
;
4664 TSD_Aggr_List
: List_Id
;
4665 TSD_Tags_List
: List_Id
;
4667 -- Start of processing for Make_DT
4670 pragma Assert
(Is_Frozen
(Typ
));
4672 -- The tagged type being processed may be subject to pragma Ghost. Set
4673 -- the mode now to ensure that any nodes generated during dispatch table
4674 -- creation are properly marked as Ghost.
4676 Set_Ghost_Mode
(Typ
);
4678 -- Handle cases in which there is no need to build the dispatch table
4680 if Has_Dispatch_Table
(Typ
)
4681 or else No
(Access_Disp_Table
(Typ
))
4682 or else Is_CPP_Class
(Typ
)
4686 elsif No_Run_Time_Mode
then
4687 Error_Msg_CRT
("tagged types", Typ
);
4690 elsif not RTE_Available
(RE_Tag
) then
4692 Make_Object_Declaration
(Loc
,
4693 Defining_Identifier
=>
4694 Node
(First_Elmt
(Access_Disp_Table
(Typ
))),
4695 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
4696 Constant_Present
=> True,
4698 Unchecked_Convert_To
(RTE
(RE_Tag
),
4699 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
4701 Analyze_List
(Result
, Suppress
=> All_Checks
);
4702 Error_Msg_CRT
("tagged types", Typ
);
4706 -- Ensure that the value of Max_Predef_Prims defined in a-tags is
4707 -- correct. Valid values are 10 under configurable runtime or 16
4708 -- with full runtime.
4710 if RTE_Available
(RE_Interface_Data
) then
4711 if Max_Predef_Prims
/= 16 then
4712 Error_Msg_N
("run-time library configuration error", Typ
);
4716 if Max_Predef_Prims
/= 10 then
4717 Error_Msg_N
("run-time library configuration error", Typ
);
4718 Error_Msg_CRT
("tagged types", Typ
);
4723 DT
:= Make_Defining_Identifier
(Loc
, Name_DT
);
4724 Exname
:= Make_Defining_Identifier
(Loc
, Name_Exname
);
4725 HT_Link
:= Make_Defining_Identifier
(Loc
, Name_HT_Link
);
4726 Predef_Prims
:= Make_Defining_Identifier
(Loc
, Name_Predef_Prims
);
4727 SSD
:= Make_Defining_Identifier
(Loc
, Name_SSD
);
4728 TSD
:= Make_Defining_Identifier
(Loc
, Name_TSD
);
4730 -- Initialize Parent_Typ handling private types
4732 Parent_Typ
:= Etype
(Typ
);
4734 if Present
(Full_View
(Parent_Typ
)) then
4735 Parent_Typ
:= Full_View
(Parent_Typ
);
4738 if not Is_Interface
(Typ
) and then Has_Interfaces
(Typ
) then
4740 Cannot_Have_Null_Disc
: Boolean := False;
4741 Dummy_Object_Typ
: constant Entity_Id
:= Typ
;
4742 Name_Dummy_Object
: constant Name_Id
:=
4743 New_External_Name
(Tname
,
4744 'P', Suffix_Index
=> -1);
4746 Dummy_Object
:= Make_Defining_Identifier
(Loc
, Name_Dummy_Object
);
4748 -- Define the extra object imported and constant to avoid linker
4749 -- errors (since this object is never declared). Required because
4750 -- we implement RM 13.3(19) for exported and imported (variable)
4751 -- objects by making them volatile.
4753 Set_Is_Imported
(Dummy_Object
);
4754 Mutate_Ekind
(Dummy_Object
, E_Constant
);
4755 Set_Is_True_Constant
(Dummy_Object
);
4756 Set_Related_Type
(Dummy_Object
, Typ
);
4758 -- The scope must be set now to call Get_External_Name
4760 Set_Scope
(Dummy_Object
, Current_Scope
);
4762 Get_External_Name
(Dummy_Object
);
4763 Set_Interface_Name
(Dummy_Object
,
4764 Make_String_Literal
(Loc
, Strval
=> String_From_Name_Buffer
));
4766 -- Ensure proper Sprint output of this implicit importation
4768 Set_Is_Internal
(Dummy_Object
);
4770 if not Has_Discriminants
(Dummy_Object_Typ
) then
4772 Make_Object_Declaration
(Loc
,
4773 Defining_Identifier
=> Dummy_Object
,
4774 Constant_Present
=> True,
4775 Object_Definition
=> New_Occurrence_Of
4776 (Dummy_Object_Typ
, Loc
)));
4779 Constr_List
: constant List_Id
:= New_List
;
4783 Discrim
:= First_Discriminant
(Dummy_Object_Typ
);
4784 while Present
(Discrim
) loop
4785 if Is_Discrete_Type
(Etype
(Discrim
)) then
4786 Append_To
(Constr_List
,
4787 Make_Attribute_Reference
(Loc
,
4789 New_Occurrence_Of
(Etype
(Discrim
), Loc
),
4790 Attribute_Name
=> Name_First
));
4793 pragma Assert
(Is_Access_Type
(Etype
(Discrim
)));
4794 Cannot_Have_Null_Disc
:=
4795 Cannot_Have_Null_Disc
4796 or else Can_Never_Be_Null
(Etype
(Discrim
));
4797 Append_To
(Constr_List
, Make_Null
(Loc
));
4800 Next_Discriminant
(Discrim
);
4804 Make_Object_Declaration
(Loc
,
4805 Defining_Identifier
=> Dummy_Object
,
4806 Constant_Present
=> True,
4807 Object_Definition
=>
4808 Make_Subtype_Indication
(Loc
,
4810 New_Occurrence_Of
(Dummy_Object_Typ
, Loc
),
4812 Make_Index_Or_Discriminant_Constraint
(Loc
,
4813 Constraints
=> Constr_List
))));
4817 -- Given that the dummy object will not be declared at run time,
4818 -- analyze its declaration with expansion disabled and warnings
4819 -- and error messages ignored.
4821 Expander_Mode_Save_And_Set
(False);
4822 Ignore_Errors_Enable
:= Ignore_Errors_Enable
+ 1;
4823 Analyze
(Last
(Result
), Suppress
=> All_Checks
);
4824 Ignore_Errors_Enable
:= Ignore_Errors_Enable
- 1;
4825 Expander_Mode_Restore
;
4829 -- Ada 2005 (AI-251): Build the secondary dispatch tables
4831 if Has_Interfaces
(Typ
) then
4832 Collect_Interface_Components
(Typ
, Typ_Comps
);
4834 -- Each secondary dispatch table is assigned an unique positive
4835 -- suffix index; such value also corresponds with the location of
4836 -- its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
4838 -- Note: This value must be kept sync with the Suffix_Index values
4839 -- generated by Make_Tags
4843 Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
4845 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
4846 while Present
(AI_Tag_Comp
) loop
4847 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'P'));
4849 -- Build the secondary table containing pointers to thunks
4854 Base_Type
(Related_Type
(Node
(AI_Tag_Comp
))),
4855 Iface_Comp
=> Node
(AI_Tag_Comp
),
4856 Suffix_Index
=> Suffix_Index
,
4858 UI_To_Int
(DT_Entry_Count
(Node
(AI_Tag_Comp
))),
4859 Iface_DT_Ptr
=> Node
(AI_Tag_Elmt
),
4860 Predef_Prims_Ptr
=> Node
(Next_Elmt
(AI_Tag_Elmt
)),
4861 Build_Thunks
=> True,
4864 -- Skip secondary dispatch table referencing thunks to predefined
4867 Next_Elmt
(AI_Tag_Elmt
);
4868 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'Y'));
4870 -- Secondary dispatch table referencing user-defined primitives
4871 -- covered by this interface.
4873 Next_Elmt
(AI_Tag_Elmt
);
4874 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'D'));
4876 -- Build the secondary table containing pointers to primitives
4877 -- (used to give support to Generic Dispatching Constructors).
4882 (Related_Type
(Node
(AI_Tag_Comp
))),
4883 Iface_Comp
=> Node
(AI_Tag_Comp
),
4885 Num_Iface_Prims
=> UI_To_Int
4886 (DT_Entry_Count
(Node
(AI_Tag_Comp
))),
4887 Iface_DT_Ptr
=> Node
(AI_Tag_Elmt
),
4888 Predef_Prims_Ptr
=> Node
(Next_Elmt
(AI_Tag_Elmt
)),
4889 Build_Thunks
=> False,
4892 -- Skip secondary dispatch table referencing predefined primitives
4894 Next_Elmt
(AI_Tag_Elmt
);
4895 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'Z'));
4897 Suffix_Index
:= Suffix_Index
+ 1;
4898 Next_Elmt
(AI_Tag_Elmt
);
4899 Next_Elmt
(AI_Tag_Comp
);
4903 -- Get the _tag entity and number of primitives of its dispatch table
4905 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
4906 Nb_Prim
:= UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Typ
)));
4908 if Generate_SCIL
then
4912 Set_Is_Statically_Allocated
(DT
, Is_Library_Level_Tagged_Type
(Typ
));
4913 Set_Is_Statically_Allocated
(SSD
, Is_Library_Level_Tagged_Type
(Typ
));
4914 Set_Is_Statically_Allocated
(TSD
, Is_Library_Level_Tagged_Type
(Typ
));
4915 Set_Is_Statically_Allocated
(Predef_Prims
,
4916 Is_Library_Level_Tagged_Type
(Typ
));
4918 -- In case of locally defined tagged type we declare the object
4919 -- containing the dispatch table by means of a variable. Its
4920 -- initialization is done later by means of an assignment. This is
4921 -- required to generate its External_Tag.
4923 if not Building_Static_DT
(Typ
) then
4926 -- DT : No_Dispatch_Table_Wrapper;
4927 -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
4929 if not Has_DT
(Typ
) then
4931 Make_Object_Declaration
(Loc
,
4932 Defining_Identifier
=> DT
,
4933 Aliased_Present
=> True,
4934 Constant_Present
=> False,
4935 Object_Definition
=>
4937 (RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
)));
4940 Make_Object_Declaration
(Loc
,
4941 Defining_Identifier
=> DT_Ptr
,
4942 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
4943 Constant_Present
=> True,
4945 Unchecked_Convert_To
(RTE
(RE_Tag
),
4946 Make_Attribute_Reference
(Loc
,
4948 Make_Selected_Component
(Loc
,
4949 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
4952 (RTE_Record_Component
(RE_NDT_Prims_Ptr
), Loc
)),
4953 Attribute_Name
=> Name_Address
))));
4955 Set_Is_Statically_Allocated
(DT_Ptr
,
4956 Is_Library_Level_Tagged_Type
(Typ
));
4958 -- Generate the SCIL node for the previous object declaration
4959 -- because it has a tag initialization.
4961 if Generate_SCIL
then
4963 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
4964 Set_SCIL_Entity
(New_Node
, Typ
);
4965 Set_SCIL_Node
(Last
(Result
), New_Node
);
4969 -- Gnat2scil has its own implementation of dispatch tables,
4970 -- different than what is being implemented here. Generating
4971 -- further dispatch table initialization code would just
4972 -- cause gnat2scil to generate useless Scil which CodePeer
4973 -- would waste time and space analyzing, so we skip it.
4977 -- DT : Dispatch_Table_Wrapper (Nb_Prim);
4978 -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
4981 -- If the tagged type has no primitives we add a dummy slot
4982 -- whose address will be the tag of this type.
4986 New_List
(Make_Integer_Literal
(Loc
, 1));
4989 New_List
(Make_Integer_Literal
(Loc
, Nb_Prim
));
4993 Make_Object_Declaration
(Loc
,
4994 Defining_Identifier
=> DT
,
4995 Aliased_Present
=> True,
4996 Constant_Present
=> False,
4997 Object_Definition
=>
4998 Make_Subtype_Indication
(Loc
,
5000 New_Occurrence_Of
(RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
5002 Make_Index_Or_Discriminant_Constraint
(Loc
,
5003 Constraints
=> DT_Constr_List
))));
5006 Make_Object_Declaration
(Loc
,
5007 Defining_Identifier
=> DT_Ptr
,
5008 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
5009 Constant_Present
=> True,
5011 Unchecked_Convert_To
(RTE
(RE_Tag
),
5012 Make_Attribute_Reference
(Loc
,
5014 Make_Selected_Component
(Loc
,
5015 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
5018 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
5019 Attribute_Name
=> Name_Address
))));
5021 Set_Is_Statically_Allocated
(DT_Ptr
,
5022 Is_Library_Level_Tagged_Type
(Typ
));
5024 -- Generate the SCIL node for the previous object declaration
5025 -- because it has a tag initialization.
5027 if Generate_SCIL
then
5029 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
5030 Set_SCIL_Entity
(New_Node
, Typ
);
5031 Set_SCIL_Node
(Last
(Result
), New_Node
);
5035 -- Gnat2scil has its own implementation of dispatch tables,
5036 -- different than what is being implemented here. Generating
5037 -- further dispatch table initialization code would just
5038 -- cause gnat2scil to generate useless Scil which CodePeer
5039 -- would waste time and space analyzing, so we skip it.
5043 Make_Object_Declaration
(Loc
,
5044 Defining_Identifier
=>
5045 Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
)))),
5046 Constant_Present
=> True,
5047 Object_Definition
=>
5048 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
5050 Make_Attribute_Reference
(Loc
,
5052 Make_Selected_Component
(Loc
,
5053 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
5056 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
5057 Attribute_Name
=> Name_Address
)));
5061 -- Generate: Expanded_Name : constant String := "";
5063 if Discard_Names
then
5065 Make_Object_Declaration
(Loc
,
5066 Defining_Identifier
=> Exname
,
5067 Constant_Present
=> True,
5068 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
5070 Make_String_Literal
(Loc
, "")));
5072 -- Generate: Exname : constant String := full_qualified_name (typ);
5073 -- The type itself may be an anonymous parent type, so use the first
5074 -- subtype to have a user-recognizable name.
5078 Make_Object_Declaration
(Loc
,
5079 Defining_Identifier
=> Exname
,
5080 Constant_Present
=> True,
5081 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
5083 Make_String_Literal
(Loc
,
5084 Fully_Qualified_Name_String
(First_Subtype
(Typ
)))));
5087 Set_Is_Statically_Allocated
(Exname
);
5088 Set_Is_True_Constant
(Exname
);
5090 -- Declare the object used by Ada.Tags.Register_Tag, unless
5091 -- No_Tagged_Type_Registration is active.
5093 if not Restriction_Active
(No_Tagged_Type_Registration
)
5094 and then RTE_Available
(RE_Register_Tag
)
5097 Make_Object_Declaration
(Loc
,
5098 Defining_Identifier
=> HT_Link
,
5099 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
5100 Expression
=> New_Occurrence_Of
(RTE
(RE_No_Tag
), Loc
)));
5103 -- Generate code to create the storage for the type specific data object
5104 -- with enough space to store the tags of the ancestors plus the tags
5105 -- of all the implemented interfaces (as described in a-tags.adb).
5107 -- TSD : Type_Specific_Data (I_Depth) :=
5108 -- (Idepth => I_Depth,
5109 -- Access_Level => Type_Access_Level (Typ),
5110 -- Alignment => Typ'Alignment,
5111 -- Expanded_Name => Cstring_Ptr!(Exname'Address))
5112 -- External_Tag => Cstring_Ptr!(Exname'Address))
5113 -- HT_Link => HT_Link'Address,
5114 -- Transportable => <<boolean-value>>,
5115 -- Is_Abstract => <<boolean-value>>,
5116 -- Needs_Finalization => <<boolean-value>>,
5117 -- [ Size_Func => Size_Prim'Access, ]
5118 -- [ Interfaces_Table => <<access-value>>, ]
5119 -- [ SSD => SSD_Table'Address ]
5120 -- Tags_Table => (0 => null,
5124 TSD_Aggr_List
:= New_List
;
5126 -- Idepth: Count ancestors to compute the inheritance depth. For private
5127 -- extensions, always go to the full view in order to compute the real
5128 -- inheritance depth.
5131 Current_Typ
: Entity_Id
;
5132 Parent_Typ
: Entity_Id
;
5138 Parent_Typ
:= Etype
(Current_Typ
);
5140 if Is_Private_Type
(Parent_Typ
) then
5141 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
5144 exit when Parent_Typ
= Current_Typ
;
5146 I_Depth
:= I_Depth
+ 1;
5147 Current_Typ
:= Parent_Typ
;
5151 Append_To
(TSD_Aggr_List
,
5152 Make_Integer_Literal
(Loc
, I_Depth
));
5156 Append_To
(TSD_Aggr_List
,
5157 Make_Integer_Literal
(Loc
, Type_Access_Level
(Typ
)));
5161 -- For CPP types we cannot rely on the value of 'Alignment provided
5162 -- by the backend to initialize this TSD field.
5164 if Convention
(Typ
) = Convention_CPP
5165 or else Is_CPP_Class
(Root_Type
(Typ
))
5167 Append_To
(TSD_Aggr_List
,
5168 Make_Integer_Literal
(Loc
, 0));
5170 Append_To
(TSD_Aggr_List
,
5171 Make_Attribute_Reference
(Loc
,
5172 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
5173 Attribute_Name
=> Name_Alignment
));
5178 Append_To
(TSD_Aggr_List
,
5179 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5180 Make_Attribute_Reference
(Loc
,
5181 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5182 Attribute_Name
=> Name_Address
)));
5184 -- External_Tag of a local tagged type
5186 -- <typ>A : constant String :=
5187 -- "Internal tag at 16#tag-addr#: <full-name-of-typ>";
5189 -- The reason we generate this strange name is that we do not want to
5190 -- enter local tagged types in the global hash table used to compute
5191 -- the Internal_Tag attribute for two reasons:
5193 -- 1. It is hard to avoid a tasking race condition for entering the
5194 -- entry into the hash table.
5196 -- 2. It would cause a storage leak, unless we rig up considerable
5197 -- mechanism to remove the entry from the hash table on exit.
5199 -- So what we do is to generate the above external tag name, where the
5200 -- hex address is the address of the local dispatch table (i.e. exactly
5201 -- the value we want if Internal_Tag is computed from this string).
5203 -- Of course this value will only be valid if the tagged type is still
5204 -- in scope, but it clearly must be erroneous to compute the internal
5205 -- tag of a tagged type that is out of scope.
5207 -- We don't do this processing if an explicit external tag has been
5208 -- specified. That's an odd case for which we have already issued a
5209 -- warning, where we will not be able to compute the internal tag.
5211 if not Discard_Names
5212 and then not Is_Library_Level_Entity
(Typ
)
5213 and then not Has_External_Tag_Rep_Clause
(Typ
)
5216 Exname
: constant Entity_Id
:=
5217 Make_Defining_Identifier
(Loc
,
5218 Chars
=> New_External_Name
(Tname
, 'A'));
5219 Full_Name
: constant String_Id
:=
5220 Fully_Qualified_Name_String
(First_Subtype
(Typ
));
5222 Address_Image
: RE_Id
;
5223 Str1_Id
: String_Id
;
5224 Str2_Id
: String_Id
;
5228 -- Str1 = "Internal tag at 16#";
5231 Store_String_Chars
("Internal tag at 16#");
5232 Str1_Id
:= End_String
;
5235 -- Str2 = "#: <type-full-name>";
5238 Store_String_Chars
("#: ");
5239 Store_String_Chars
(Full_Name
);
5240 Str2_Id
:= End_String
;
5243 -- Exname : constant String :=
5244 -- Str1 & Address_Image (Tag) & Str2;
5246 -- We use Address_Image64 for Morello because Integer_Address
5247 -- is 64-bit large even though Address is 128-bit large.
5249 case System_Address_Size
is
5250 when 32 => Address_Image
:= RE_Address_Image32
;
5251 when 64 => Address_Image
:= RE_Address_Image64
;
5252 when 128 => Address_Image
:= RE_Address_Image64
;
5253 when others => raise Program_Error
;
5256 if RTE_Available
(Address_Image
) then
5258 Make_Object_Declaration
(Loc
,
5259 Defining_Identifier
=> Exname
,
5260 Constant_Present
=> True,
5261 Object_Definition
=> New_Occurrence_Of
5262 (Standard_String
, Loc
),
5264 Make_Op_Concat
(Loc
,
5265 Left_Opnd
=> Make_String_Literal
(Loc
, Str1_Id
),
5267 Make_Op_Concat
(Loc
,
5269 Make_Function_Call
(Loc
,
5272 (RTE
(Address_Image
), Loc
),
5273 Parameter_Associations
=> New_List
(
5274 Unchecked_Convert_To
(RTE
(RE_Address
),
5275 New_Occurrence_Of
(DT_Ptr
, Loc
)))),
5277 Make_String_Literal
(Loc
, Str2_Id
)))));
5280 -- Exname : constant String := Str1 & Str2;
5284 Make_Object_Declaration
(Loc
,
5285 Defining_Identifier
=> Exname
,
5286 Constant_Present
=> True,
5287 Object_Definition
=>
5288 New_Occurrence_Of
(Standard_String
, Loc
),
5290 Make_Op_Concat
(Loc
,
5291 Left_Opnd
=> Make_String_Literal
(Loc
, Str1_Id
),
5292 Right_Opnd
=> Make_String_Literal
(Loc
, Str2_Id
))));
5296 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5297 Make_Attribute_Reference
(Loc
,
5298 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5299 Attribute_Name
=> Name_Address
));
5302 -- External tag of a library-level tagged type: Check for a definition
5303 -- of External_Tag. The clause is considered only if it applies to this
5304 -- specific tagged type, as opposed to one of its ancestors.
5305 -- If the type is an unconstrained type extension, we are building the
5306 -- dispatch table of its anonymous base type, so the external tag, if
5307 -- any was specified, must be retrieved from the first subtype. Go to
5308 -- the full view in case the clause is in the private part.
5312 Def
: constant Node_Id
:= Get_Attribute_Definition_Clause
5313 (Underlying_Type
(First_Subtype
(Typ
)),
5314 Attribute_External_Tag
);
5316 Old_Val
: String_Id
;
5317 New_Val
: String_Id
;
5322 or else Entity
(Name
(Def
)) /= First_Subtype
(Typ
)
5325 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5326 Make_Attribute_Reference
(Loc
,
5327 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5328 Attribute_Name
=> Name_Address
));
5330 Old_Val
:= Strval
(Expr_Value_S
(Expression
(Def
)));
5332 -- For the rep clause "for <typ>'external_tag use y" generate:
5334 -- <typ>A : constant string := y;
5336 -- <typ>A'Address is used to set the External_Tag component
5339 -- Create a new nul terminated string if it is not already
5341 if String_Length
(Old_Val
) > 0
5343 Get_String_Char
(Old_Val
, String_Length
(Old_Val
)) = 0
5347 Start_String
(Old_Val
);
5348 Store_String_Char
(Get_Char_Code
(ASCII
.NUL
));
5349 New_Val
:= End_String
;
5352 E
:= Make_Defining_Identifier
(Loc
,
5353 New_External_Name
(Chars
(Typ
), 'A'));
5356 Make_Object_Declaration
(Loc
,
5357 Defining_Identifier
=> E
,
5358 Constant_Present
=> True,
5359 Object_Definition
=>
5360 New_Occurrence_Of
(Standard_String
, Loc
),
5362 Make_String_Literal
(Loc
, New_Val
)));
5365 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5366 Make_Attribute_Reference
(Loc
,
5367 Prefix
=> New_Occurrence_Of
(E
, Loc
),
5368 Attribute_Name
=> Name_Address
));
5373 Append_To
(TSD_Aggr_List
, New_Node
);
5377 if not Restriction_Active
(No_Tagged_Type_Registration
)
5378 and then RTE_Available
(RE_Register_Tag
)
5380 Append_To
(TSD_Aggr_List
,
5381 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
5382 Make_Attribute_Reference
(Loc
,
5383 Prefix
=> New_Occurrence_Of
(HT_Link
, Loc
),
5384 Attribute_Name
=> Name_Address
)));
5386 elsif RTE_Record_Component_Available
(RE_HT_Link
) then
5387 Append_To
(TSD_Aggr_List
,
5388 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
5389 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5392 -- Transportable: Set for types that can be used in remote calls
5393 -- with respect to E.4(18) legality rules.
5396 Transportable
: Entity_Id
;
5402 or else Is_Shared_Passive
(Typ
)
5404 ((Is_Remote_Types
(Typ
)
5405 or else Is_Remote_Call_Interface
(Typ
))
5406 and then Original_View_In_Visible_Part
(Typ
))
5407 or else not Comes_From_Source
(Typ
));
5409 Append_To
(TSD_Aggr_List
,
5410 New_Occurrence_Of
(Transportable
, Loc
));
5413 -- Is_Abstract (Ada 2012: AI05-0173). This functionality is not
5414 -- available in the HIE runtime.
5416 if RTE_Record_Component_Available
(RE_Is_Abstract
) then
5418 Is_Abstract
: Entity_Id
;
5420 Is_Abstract
:= Boolean_Literals
(Is_Abstract_Type
(Typ
));
5421 Append_To
(TSD_Aggr_List
,
5422 New_Occurrence_Of
(Is_Abstract
, Loc
));
5426 -- Needs_Finalization: Set if the type is controlled or has controlled
5430 Needs_Fin
: Entity_Id
;
5432 Needs_Fin
:= Boolean_Literals
(Needs_Finalization
(Typ
));
5433 Append_To
(TSD_Aggr_List
, New_Occurrence_Of
(Needs_Fin
, Loc
));
5438 if RTE_Record_Component_Available
(RE_Size_Func
) then
5440 -- Initialize this field to Null_Address if we are not building
5441 -- static dispatch tables static or if the size function is not
5442 -- available. In the former case we cannot initialize this field
5443 -- until the function is frozen and registered in the dispatch
5444 -- table (see Register_Primitive).
5446 if not Building_Static_DT
(Typ
) or else not Has_DT
(Typ
) then
5447 Append_To
(TSD_Aggr_List
,
5448 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5449 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5453 Prim_Elmt
: Elmt_Id
;
5455 Size_Comp
: Node_Id
:= Empty
;
5458 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5459 while Present
(Prim_Elmt
) loop
5460 Prim
:= Node
(Prim_Elmt
);
5462 if Chars
(Prim
) = Name_uSize
then
5463 Prim
:= Ultimate_Alias
(Prim
);
5465 if Is_Abstract_Subprogram
(Prim
) then
5467 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5468 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
5471 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5472 Make_Attribute_Reference
(Loc
,
5473 Prefix
=> New_Occurrence_Of
(Prim
, Loc
),
5474 Attribute_Name
=> Name_Unrestricted_Access
));
5480 Next_Elmt
(Prim_Elmt
);
5483 pragma Assert
(Present
(Size_Comp
));
5484 Append_To
(TSD_Aggr_List
, Size_Comp
);
5489 -- Interfaces_Table (required for AI-405)
5491 if RTE_Record_Component_Available
(RE_Interfaces_Table
) then
5493 -- Count the number of interface types implemented by Typ
5495 Collect_Interfaces
(Typ
, Typ_Ifaces
);
5497 AI
:= First_Elmt
(Typ_Ifaces
);
5498 while Present
(AI
) loop
5499 Num_Ifaces
:= Num_Ifaces
+ 1;
5503 if Num_Ifaces
= 0 then
5504 Iface_Table_Node
:= Make_Null
(Loc
);
5506 -- Generate the Interface_Table object
5510 TSD_Ifaces_List
: constant List_Id
:= New_List
;
5512 Offset_To_Top
: Node_Id
;
5513 Sec_DT_Tag
: Node_Id
;
5515 Dummy_Object_Ifaces_List
: Elist_Id
:= No_Elist
;
5516 Dummy_Object_Ifaces_Comp_List
: Elist_Id
:= No_Elist
;
5517 Dummy_Object_Ifaces_Tag_List
: Elist_Id
:= No_Elist
;
5518 -- Interfaces information of the dummy object
5521 -- Collect interfaces information if we need to compute the
5522 -- offset to the top using the dummy object.
5524 if Present
(Dummy_Object
) then
5525 Collect_Interfaces_Info
(Typ
,
5526 Ifaces_List
=> Dummy_Object_Ifaces_List
,
5527 Components_List
=> Dummy_Object_Ifaces_Comp_List
,
5528 Tags_List
=> Dummy_Object_Ifaces_Tag_List
);
5531 AI
:= First_Elmt
(Typ_Ifaces
);
5532 while Present
(AI
) loop
5533 if Is_Ancestor
(Node
(AI
), Typ
, Use_Full_View
=> True) then
5534 Sec_DT_Tag
:= New_Occurrence_Of
(DT_Ptr
, Loc
);
5539 (Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
5540 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5542 while Is_Tag
(Node
(Elmt
))
5544 Is_Ancestor
(Node
(AI
), Related_Type
(Node
(Elmt
)),
5545 Use_Full_View
=> True)
5547 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5549 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5551 pragma Assert
(not Has_Thunks
(Node
(Elmt
)));
5553 pragma Assert
(not Has_Thunks
(Node
(Elmt
)));
5557 pragma Assert
(Ekind
(Node
(Elmt
)) = E_Constant
5559 Has_Thunks
(Node
(Next_Elmt
(Next_Elmt
(Elmt
)))));
5563 (Node
(Next_Elmt
(Next_Elmt
(Elmt
))), Loc
);
5566 -- Use the dummy object to compute Offset_To_Top of
5567 -- components located at fixed position.
5569 if Present
(Dummy_Object
) then
5571 Iface
: constant Node_Id
:= Node
(AI
);
5572 Iface_Comp
: Node_Id
:= Empty
;
5573 Iface_Comp_Elmt
: Elmt_Id
;
5574 Iface_Elmt
: Elmt_Id
;
5578 First_Elmt
(Dummy_Object_Ifaces_List
);
5580 First_Elmt
(Dummy_Object_Ifaces_Comp_List
);
5582 while Present
(Iface_Elmt
) loop
5583 if Node
(Iface_Elmt
) = Iface
then
5584 Iface_Comp
:= Node
(Iface_Comp_Elmt
);
5588 Next_Elmt
(Iface_Elmt
);
5589 Next_Elmt
(Iface_Comp_Elmt
);
5592 pragma Assert
(Present
(Iface_Comp
));
5595 Is_Variable_Size_Record
(Etype
(Scope
(Iface_Comp
)))
5599 Make_Attribute_Reference
(Loc
,
5601 Make_Selected_Component
(Loc
,
5603 New_Occurrence_Of
(Dummy_Object
, Loc
),
5605 New_Occurrence_Of
(Iface_Comp
, Loc
)),
5606 Attribute_Name
=> Name_Position
));
5608 Offset_To_Top
:= Make_Integer_Literal
(Loc
, 0);
5612 Offset_To_Top
:= Make_Integer_Literal
(Loc
, 0);
5615 Append_To
(TSD_Ifaces_List
,
5616 Make_Aggregate
(Loc
,
5617 Expressions
=> New_List
(
5621 Unchecked_Convert_To
(RTE
(RE_Tag
),
5623 (Node
(First_Elmt
(Access_Disp_Table
(Node
(AI
)))),
5626 -- Static_Offset_To_Top
5628 New_Occurrence_Of
(Standard_True
, Loc
),
5630 -- Offset_To_Top_Value
5634 -- Offset_To_Top_Func
5640 Unchecked_Convert_To
(RTE
(RE_Tag
), Sec_DT_Tag
))));
5645 Name_ITable
:= New_External_Name
(Tname
, 'I');
5646 ITable
:= Make_Defining_Identifier
(Loc
, Name_ITable
);
5647 Set_Is_Statically_Allocated
(ITable
,
5648 Is_Library_Level_Tagged_Type
(Typ
));
5650 -- The table of interfaces is constant if we are building a
5651 -- static dispatch table; otherwise is not constant because
5652 -- its slots are filled at run time by the IP routine.
5655 Make_Object_Declaration
(Loc
,
5656 Defining_Identifier
=> ITable
,
5657 Aliased_Present
=> True,
5658 Constant_Present
=> Building_Static_Secondary_DT
(Typ
),
5659 Object_Definition
=>
5660 Make_Subtype_Indication
(Loc
,
5662 New_Occurrence_Of
(RTE
(RE_Interface_Data
), Loc
),
5664 Make_Index_Or_Discriminant_Constraint
(Loc
,
5665 Constraints
=> New_List
(
5666 Make_Integer_Literal
(Loc
, Num_Ifaces
)))),
5669 Make_Aggregate
(Loc
,
5670 Expressions
=> New_List
(
5671 Make_Integer_Literal
(Loc
, Num_Ifaces
),
5672 Make_Aggregate
(Loc
, TSD_Ifaces_List
)))));
5675 Make_Attribute_Reference
(Loc
,
5676 Prefix
=> New_Occurrence_Of
(ITable
, Loc
),
5677 Attribute_Name
=> Name_Unchecked_Access
);
5681 Append_To
(TSD_Aggr_List
, Iface_Table_Node
);
5684 -- Generate the Select Specific Data table for synchronized types that
5685 -- implement synchronized interfaces. The size of the table is
5686 -- constrained by the number of non-predefined primitive operations.
5688 if RTE_Record_Component_Available
(RE_SSD
) then
5689 if Ada_Version
>= Ada_2005
5690 and then Has_DT
(Typ
)
5691 and then Is_Concurrent_Record_Type
(Typ
)
5692 and then Has_Interfaces
(Typ
)
5693 and then Nb_Prim
> 0
5694 and then not Is_Abstract_Type
(Typ
)
5695 and then not Is_Controlled
(Typ
)
5696 and then not Restriction_Active
(No_Dispatching_Calls
)
5697 and then not Restriction_Active
(No_Select_Statements
)
5700 Make_Object_Declaration
(Loc
,
5701 Defining_Identifier
=> SSD
,
5702 Aliased_Present
=> True,
5703 Object_Definition
=>
5704 Make_Subtype_Indication
(Loc
,
5705 Subtype_Mark
=> New_Occurrence_Of
(
5706 RTE
(RE_Select_Specific_Data
), Loc
),
5708 Make_Index_Or_Discriminant_Constraint
(Loc
,
5709 Constraints
=> New_List
(
5710 Make_Integer_Literal
(Loc
, Nb_Prim
))))));
5713 Make_Attribute_Definition_Clause
(Loc
,
5714 Name
=> New_Occurrence_Of
(SSD
, Loc
),
5715 Chars
=> Name_Alignment
,
5717 Make_Attribute_Reference
(Loc
,
5719 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5720 Attribute_Name
=> Name_Alignment
)));
5722 -- This table is initialized by Make_Select_Specific_Data_Table,
5723 -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
5725 Append_To
(TSD_Aggr_List
,
5726 Make_Attribute_Reference
(Loc
,
5727 Prefix
=> New_Occurrence_Of
(SSD
, Loc
),
5728 Attribute_Name
=> Name_Unchecked_Access
));
5730 Append_To
(TSD_Aggr_List
, Make_Null
(Loc
));
5734 -- Initialize the table of ancestor tags. In case of interface types
5735 -- this table is not needed.
5737 TSD_Tags_List
:= New_List
;
5739 -- If we are not statically allocating the dispatch table then we must
5740 -- fill position 0 with null because we still have not generated the
5743 if not Building_Static_DT
(Typ
)
5744 or else Is_Interface
(Typ
)
5746 Append_To
(TSD_Tags_List
,
5747 Unchecked_Convert_To
(RTE
(RE_Tag
),
5748 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5750 -- Otherwise we can safely reference the tag
5753 Append_To
(TSD_Tags_List
,
5754 New_Occurrence_Of
(DT_Ptr
, Loc
));
5757 -- Fill the rest of the table with the tags of the ancestors
5760 Current_Typ
: Entity_Id
;
5761 Parent_Typ
: Entity_Id
;
5769 Parent_Typ
:= Etype
(Current_Typ
);
5771 if Is_Private_Type
(Parent_Typ
) then
5772 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
5775 exit when Parent_Typ
= Current_Typ
;
5777 if Is_CPP_Class
(Parent_Typ
) then
5779 -- The tags defined in the C++ side will be inherited when
5780 -- the object is constructed (Exp_Ch3.Build_Init_Procedure)
5782 Append_To
(TSD_Tags_List
,
5783 Unchecked_Convert_To
(RTE
(RE_Tag
),
5784 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5786 Append_To
(TSD_Tags_List
,
5788 (Node
(First_Elmt
(Access_Disp_Table
(Parent_Typ
))),
5793 Current_Typ
:= Parent_Typ
;
5796 pragma Assert
(Pos
= I_Depth
+ 1);
5799 Append_To
(TSD_Aggr_List
,
5800 Make_Aggregate
(Loc
,
5801 Expressions
=> TSD_Tags_List
));
5803 -- Build the TSD object
5806 Make_Object_Declaration
(Loc
,
5807 Defining_Identifier
=> TSD
,
5808 Aliased_Present
=> True,
5809 Constant_Present
=> Building_Static_DT
(Typ
),
5810 Object_Definition
=>
5811 Make_Subtype_Indication
(Loc
,
5812 Subtype_Mark
=> New_Occurrence_Of
(
5813 RTE
(RE_Type_Specific_Data
), Loc
),
5815 Make_Index_Or_Discriminant_Constraint
(Loc
,
5816 Constraints
=> New_List
(
5817 Make_Integer_Literal
(Loc
, I_Depth
)))),
5819 Expression
=> Make_Aggregate
(Loc
,
5820 Expressions
=> TSD_Aggr_List
)));
5822 Set_Is_True_Constant
(TSD
, Building_Static_DT
(Typ
));
5824 -- The debugging information for type Ada.Tags.Type_Specific_Data is
5825 -- needed by the debugger in order to display values of tagged types.
5827 Set_Needs_Debug_Info
(TSD
, Needs_Debug_Info
(Typ
));
5829 -- Initialize or declare the dispatch table object
5831 if not Has_DT
(Typ
) then
5832 DT_Constr_List
:= New_List
;
5833 DT_Aggr_List
:= New_List
;
5838 Make_Attribute_Reference
(Loc
,
5839 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
5840 Attribute_Name
=> Name_Address
);
5842 Append_To
(DT_Constr_List
, New_Node
);
5843 Append_To
(DT_Aggr_List
, New_Copy
(New_Node
));
5844 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
5846 -- In case of locally defined tagged types we have already declared
5847 -- and uninitialized object for the dispatch table, which is now
5848 -- initialized by means of the following assignment:
5850 -- DT := (TSD'Address, 0);
5852 if not Building_Static_DT
(Typ
) then
5854 Make_Assignment_Statement
(Loc
,
5855 Name
=> New_Occurrence_Of
(DT
, Loc
),
5856 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5858 -- In case of library level tagged types we declare and export now
5859 -- the constant object containing the dummy dispatch table. There
5860 -- is no need to declare the tag here because it has been previously
5861 -- declared by Make_Tags
5863 -- DT : aliased constant No_Dispatch_Table :=
5864 -- (NDT_TSD => TSD'Address;
5865 -- NDT_Prims_Ptr => 0);
5869 Make_Object_Declaration
(Loc
,
5870 Defining_Identifier
=> DT
,
5871 Aliased_Present
=> True,
5872 Constant_Present
=> True,
5873 Object_Definition
=>
5874 New_Occurrence_Of
(RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
),
5875 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5877 Export_DT
(Typ
, DT
);
5880 -- Common case: Typ has a dispatch table
5884 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
5885 -- (predef-prim-op-1'address,
5886 -- predef-prim-op-2'address,
5888 -- predef-prim-op-n'address);
5890 -- DT : Dispatch_Table (Nb_Prims) :=
5891 -- (Signature => <sig-value>,
5892 -- Tag_Kind => <tag_kind-value>,
5893 -- Predef_Prims => Predef_Prims'First'Address,
5894 -- Offset_To_Top => 0,
5895 -- TSD => TSD'Address;
5896 -- Prims_Ptr => (prim-op-1'address,
5897 -- prim-op-2'address,
5899 -- prim-op-n'address));
5900 -- for DT'Alignment use Address'Alignment
5904 Nb_P_Prims
: constant Nat
:= Number_Of_Predefined_Prims
(Typ
);
5905 Prim_Table
: array (Nat
range 1 .. Nb_P_Prims
) of Entity_Id
;
5908 SS_Thunk_Id
: Entity_Id
;
5909 SS_Thunk_Code
: Node_Id
;
5912 Prim_Ops_Aggr_List
:= New_List
;
5913 Prim_Table
:= (others => Empty
);
5915 if Building_Static_DT
(Typ
) then
5916 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5917 while Present
(Prim_Elmt
) loop
5918 Prim
:= Node
(Prim_Elmt
);
5920 if Is_Predefined_Dispatching_Operation
(Prim
)
5921 and then not Is_Abstract_Subprogram
(Prim
)
5922 and then not Is_Eliminated
(Prim
)
5923 and then not Generate_SCIL
5924 and then No
(Prim_Table
(UI_To_Int
(DT_Position
(Prim
))))
5926 E
:= Ultimate_Alias
(Prim
);
5927 pragma Assert
(not Is_Abstract_Subprogram
(E
));
5929 Expand_Secondary_Stack_Thunk
5930 (E
, SS_Thunk_Id
, SS_Thunk_Code
);
5932 if Present
(SS_Thunk_Id
) then
5934 Append_To
(Result
, SS_Thunk_Code
);
5937 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) := E
;
5940 Next_Elmt
(Prim_Elmt
);
5944 for J
in Prim_Table
'Range loop
5945 if Present
(Prim_Table
(J
)) then
5947 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
5948 Make_Attribute_Reference
(Loc
,
5950 New_Occurrence_Of
(Prim_Table
(J
), Loc
),
5951 Attribute_Name
=> Name_Unrestricted_Access
));
5953 New_Node
:= Make_Null
(Loc
);
5956 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
5960 Make_Aggregate
(Loc
,
5961 Expressions
=> Prim_Ops_Aggr_List
);
5964 Make_Subtype_Declaration
(Loc
,
5965 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
5966 Subtype_Indication
=>
5967 New_Occurrence_Of
(RTE
(RE_Address_Array
), Loc
));
5969 Append_To
(Result
, Decl
);
5972 Make_Object_Declaration
(Loc
,
5973 Defining_Identifier
=> Predef_Prims
,
5974 Aliased_Present
=> True,
5975 Constant_Present
=> Building_Static_DT
(Typ
),
5976 Object_Definition
=>
5977 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
),
5978 Expression
=> New_Node
));
5980 -- Remember aggregates initializing dispatch tables
5982 Append_Elmt
(New_Node
, DT_Aggr
);
5985 -- Stage 1: Initialize the discriminant and the record components
5987 DT_Constr_List
:= New_List
;
5988 DT_Aggr_List
:= New_List
;
5990 -- Num_Prims. If the tagged type has no primitives we add a dummy
5991 -- slot whose address will be the tag of this type.
5994 New_Node
:= Make_Integer_Literal
(Loc
, 1);
5996 New_Node
:= Make_Integer_Literal
(Loc
, Nb_Prim
);
5999 Append_To
(DT_Constr_List
, New_Node
);
6000 Append_To
(DT_Aggr_List
, New_Copy
(New_Node
));
6004 if RTE_Record_Component_Available
(RE_Signature
) then
6005 Append_To
(DT_Aggr_List
,
6006 New_Occurrence_Of
(RTE
(RE_Primary_DT
), Loc
));
6011 if RTE_Record_Component_Available
(RE_Tag_Kind
) then
6012 Append_To
(DT_Aggr_List
, Tagged_Kind
(Typ
));
6017 Append_To
(DT_Aggr_List
,
6018 Make_Attribute_Reference
(Loc
,
6019 Prefix
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
6020 Attribute_Name
=> Name_Address
));
6024 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
6028 Append_To
(DT_Aggr_List
,
6029 Make_Attribute_Reference
(Loc
,
6030 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6031 Attribute_Name
=> Name_Address
));
6033 -- Stage 2: Initialize the table of user-defined primitive operations
6035 Prim_Ops_Aggr_List
:= New_List
;
6038 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
6040 elsif not Building_Static_DT
(Typ
) then
6041 for J
in 1 .. Nb_Prim
loop
6042 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
6047 CPP_Nb_Prims
: constant Nat
:= CPP_Num_Prims
(Typ
);
6050 Prim_Elmt
: Elmt_Id
;
6052 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
6053 SS_Thunk_Id
: Entity_Id
;
6054 SS_Thunk_Code
: Node_Id
;
6057 Prim_Table
:= (others => Empty
);
6059 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6060 while Present
(Prim_Elmt
) loop
6061 Prim
:= Node
(Prim_Elmt
);
6063 -- Retrieve the ultimate alias of the primitive for proper
6064 -- handling of renamings and eliminated primitives.
6066 E
:= Ultimate_Alias
(Prim
);
6068 -- If the alias is not a primitive operation then Prim does
6069 -- not rename another primitive, but rather an operation
6070 -- declared elsewhere (e.g. in another scope) and therefore
6071 -- Prim is a new primitive.
6073 if No
(Find_Dispatching_Type
(E
)) then
6077 Prim_Pos
:= UI_To_Int
(DT_Position
(E
));
6079 -- Skip predefined primitives because they are located in a
6080 -- separate dispatch table.
6082 if not Is_Predefined_Dispatching_Operation
(Prim
)
6083 and then not Is_Predefined_Dispatching_Operation
(E
)
6085 -- Skip entities with attribute Interface_Alias because
6086 -- those are only required to build secondary dispatch
6089 and then No
(Interface_Alias
(Prim
))
6091 -- Skip abstract and eliminated primitives
6093 and then not Is_Abstract_Subprogram
(E
)
6094 and then not Is_Eliminated
(E
)
6096 -- For derivations of CPP types skip primitives located in
6097 -- the C++ part of the dispatch table because their slots
6098 -- are initialized by the IC routine.
6100 and then (not Is_CPP_Class
(Root_Type
(Typ
))
6101 or else Prim_Pos
> CPP_Nb_Prims
)
6103 -- Skip ignored Ghost subprograms as those will be removed
6104 -- from the executable.
6106 and then not Is_Ignored_Ghost_Entity
(E
)
6109 (UI_To_Int
(DT_Position
(Prim
)) <= Nb_Prim
);
6111 Expand_Secondary_Stack_Thunk
6112 (E
, SS_Thunk_Id
, SS_Thunk_Code
);
6114 if Present
(SS_Thunk_Id
) then
6116 Append_To
(Result
, SS_Thunk_Code
);
6119 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) := E
;
6122 Next_Elmt
(Prim_Elmt
);
6125 for J
in Prim_Table
'Range loop
6126 if Present
(Prim_Table
(J
)) then
6128 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
6129 Make_Attribute_Reference
(Loc
,
6131 New_Occurrence_Of
(Prim_Table
(J
), Loc
),
6132 Attribute_Name
=> Name_Unrestricted_Access
));
6134 New_Node
:= Make_Null
(Loc
);
6137 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
6143 Make_Aggregate
(Loc
,
6144 Expressions
=> Prim_Ops_Aggr_List
);
6146 Append_To
(DT_Aggr_List
, New_Node
);
6148 -- Remember aggregates initializing dispatch tables
6150 Append_Elmt
(New_Node
, DT_Aggr
);
6152 -- In case of locally defined tagged types we have already declared
6153 -- and uninitialized object for the dispatch table, which is now
6154 -- initialized by means of an assignment.
6156 if not Building_Static_DT
(Typ
) then
6158 Make_Assignment_Statement
(Loc
,
6159 Name
=> New_Occurrence_Of
(DT
, Loc
),
6160 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
6162 -- In case of library level tagged types we declare now and export
6163 -- the constant object containing the dispatch table.
6167 Make_Object_Declaration
(Loc
,
6168 Defining_Identifier
=> DT
,
6169 Aliased_Present
=> True,
6170 Constant_Present
=> True,
6171 Object_Definition
=>
6172 Make_Subtype_Indication
(Loc
,
6173 Subtype_Mark
=> New_Occurrence_Of
6174 (RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
6175 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
6176 Constraints
=> DT_Constr_List
)),
6177 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
6179 Export_DT
(Typ
, DT
);
6183 -- Initialize the table of ancestor tags if not building static
6186 if not Building_Static_DT
(Typ
)
6187 and then not Is_Interface
(Typ
)
6188 and then not Is_CPP_Class
(Typ
)
6191 Make_Assignment_Statement
(Loc
,
6193 Make_Indexed_Component
(Loc
,
6195 Make_Selected_Component
(Loc
,
6196 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6199 (RTE_Record_Component
(RE_Tags_Table
), Loc
)),
6201 New_List
(Make_Integer_Literal
(Loc
, 0))),
6205 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
)));
6208 -- Inherit the dispatch tables of the parent. There is no need to
6209 -- inherit anything from the parent when building static dispatch tables
6210 -- because the whole dispatch table (including inherited primitives) has
6211 -- been already built.
6213 if Building_Static_DT
(Typ
) then
6216 -- If the ancestor is a CPP_Class type we inherit the dispatch tables
6217 -- in the init proc, and we don't need to fill them in here.
6219 elsif Is_CPP_Class
(Parent_Typ
) then
6222 -- Otherwise we fill in the dispatch tables here
6225 if Typ
/= Parent_Typ
6226 and then not Is_Interface
(Typ
)
6227 and then not Restriction_Active
(No_Dispatching_Calls
)
6229 -- Inherit the dispatch table
6231 if not Is_Interface
(Typ
)
6232 and then not Is_Interface
(Parent_Typ
)
6233 and then not Is_CPP_Class
(Parent_Typ
)
6236 Nb_Prims
: constant Int
:=
6237 UI_To_Int
(DT_Entry_Count
6238 (First_Tag_Component
(Parent_Typ
)));
6241 Append_To
(Elab_Code
,
6242 Build_Inherit_Predefined_Prims
(Loc
,
6248 (Access_Disp_Table
(Parent_Typ
)))), Loc
),
6254 (Access_Disp_Table
(Typ
)))), Loc
),
6256 Number_Of_Predefined_Prims
(Parent_Typ
)));
6258 if Nb_Prims
/= 0 then
6259 Append_To
(Elab_Code
,
6260 Build_Inherit_Prims
(Loc
,
6266 (Access_Disp_Table
(Parent_Typ
))), Loc
),
6267 New_Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
6268 Num_Prims
=> Nb_Prims
));
6273 -- Inherit the secondary dispatch tables of the ancestor
6275 if not Is_CPP_Class
(Parent_Typ
) then
6277 Sec_DT_Ancestor
: Elmt_Id
:=
6283 Sec_DT_Typ
: Elmt_Id
:=
6287 (Access_Disp_Table
(Typ
))));
6289 procedure Copy_Secondary_DTs
(Typ
: Entity_Id
);
6290 -- Local procedure required to climb through the ancestors
6291 -- and copy the contents of all their secondary dispatch
6294 ------------------------
6295 -- Copy_Secondary_DTs --
6296 ------------------------
6298 procedure Copy_Secondary_DTs
(Typ
: Entity_Id
) is
6303 -- Climb to the ancestor (if any) handling private types
6305 if Present
(Full_View
(Etype
(Typ
))) then
6306 if Full_View
(Etype
(Typ
)) /= Typ
then
6307 Copy_Secondary_DTs
(Full_View
(Etype
(Typ
)));
6310 elsif Etype
(Typ
) /= Typ
then
6311 Copy_Secondary_DTs
(Etype
(Typ
));
6314 if Present
(Interfaces
(Typ
))
6315 and then not Is_Empty_Elmt_List
(Interfaces
(Typ
))
6317 Iface
:= First_Elmt
(Interfaces
(Typ
));
6318 E
:= First_Entity
(Typ
);
6320 and then Present
(Node
(Sec_DT_Ancestor
))
6321 and then Ekind
(Node
(Sec_DT_Ancestor
)) = E_Constant
6323 if Is_Tag
(E
) and then Chars
(E
) /= Name_uTag
then
6325 Num_Prims
: constant Int
:=
6326 UI_To_Int
(DT_Entry_Count
(E
));
6329 if not Is_Interface
(Etype
(Typ
)) then
6331 -- Inherit first secondary dispatch table
6333 Append_To
(Elab_Code
,
6334 Build_Inherit_Predefined_Prims
(Loc
,
6336 Unchecked_Convert_To
(RTE
(RE_Tag
),
6339 (Next_Elmt
(Sec_DT_Ancestor
)),
6342 Unchecked_Convert_To
(RTE
(RE_Tag
),
6344 (Node
(Next_Elmt
(Sec_DT_Typ
)),
6347 Number_Of_Predefined_Prims
6350 if Num_Prims
/= 0 then
6351 Append_To
(Elab_Code
,
6352 Build_Inherit_Prims
(Loc
,
6353 Typ
=> Node
(Iface
),
6355 Unchecked_Convert_To
6358 (Node
(Sec_DT_Ancestor
),
6361 Unchecked_Convert_To
6364 (Node
(Sec_DT_Typ
), Loc
)),
6365 Num_Prims
=> Num_Prims
));
6369 Next_Elmt
(Sec_DT_Ancestor
);
6370 Next_Elmt
(Sec_DT_Typ
);
6372 -- Skip the secondary dispatch table of
6373 -- predefined primitives
6375 Next_Elmt
(Sec_DT_Ancestor
);
6376 Next_Elmt
(Sec_DT_Typ
);
6378 if not Is_Interface
(Etype
(Typ
)) then
6380 -- Inherit second secondary dispatch table
6382 Append_To
(Elab_Code
,
6383 Build_Inherit_Predefined_Prims
(Loc
,
6385 Unchecked_Convert_To
(RTE
(RE_Tag
),
6388 (Next_Elmt
(Sec_DT_Ancestor
)),
6391 Unchecked_Convert_To
(RTE
(RE_Tag
),
6393 (Node
(Next_Elmt
(Sec_DT_Typ
)),
6396 Number_Of_Predefined_Prims
6399 if Num_Prims
/= 0 then
6400 Append_To
(Elab_Code
,
6401 Build_Inherit_Prims
(Loc
,
6402 Typ
=> Node
(Iface
),
6404 Unchecked_Convert_To
6407 (Node
(Sec_DT_Ancestor
),
6410 Unchecked_Convert_To
6413 (Node
(Sec_DT_Typ
), Loc
)),
6414 Num_Prims
=> Num_Prims
));
6419 Next_Elmt
(Sec_DT_Ancestor
);
6420 Next_Elmt
(Sec_DT_Typ
);
6422 -- Skip the secondary dispatch table of
6423 -- predefined primitives
6425 Next_Elmt
(Sec_DT_Ancestor
);
6426 Next_Elmt
(Sec_DT_Typ
);
6434 end Copy_Secondary_DTs
;
6437 if Present
(Node
(Sec_DT_Ancestor
))
6438 and then Ekind
(Node
(Sec_DT_Ancestor
)) = E_Constant
6440 -- Handle private types
6442 if Present
(Full_View
(Typ
)) then
6443 Copy_Secondary_DTs
(Full_View
(Typ
));
6445 Copy_Secondary_DTs
(Typ
);
6453 -- Generate code to check if the external tag of this type is the same
6454 -- as the external tag of some other declaration.
6456 -- Check_TSD (TSD'Unrestricted_Access);
6458 -- This check is a consequence of AI05-0113-1/06, so it officially
6459 -- applies to Ada 2005 (and Ada 2012). It might be argued that it is
6460 -- a desirable check to add in Ada 95 mode, but we hesitate to make
6461 -- this change, as it would be incompatible, and could conceivably
6462 -- cause a problem in existing Ada 95 code.
6464 -- We check for No_Run_Time_Mode here, because we do not want to pick
6465 -- up the RE_Check_TSD entity and call it in No_Run_Time mode.
6467 -- We cannot perform this check if the generation of its expanded name
6468 -- was discarded or if No_Tagged_Type_Registration is active.
6470 if not No_Run_Time_Mode
6471 and then not Discard_Names
6472 and then Ada_Version
>= Ada_2005
6473 and then not Duplicated_Tag_Checks_Suppressed
(Typ
)
6474 and then not Restriction_Active
(No_Tagged_Type_Registration
)
6475 and then RTE_Available
(RE_Check_TSD
)
6477 Append_To
(Elab_Code
,
6478 Make_Procedure_Call_Statement
(Loc
,
6480 New_Occurrence_Of
(RTE
(RE_Check_TSD
), Loc
),
6481 Parameter_Associations
=> New_List
(
6482 Make_Attribute_Reference
(Loc
,
6483 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6484 Attribute_Name
=> Name_Unchecked_Access
))));
6487 -- Generate code to register the Tag in the External_Tag hash table for
6488 -- the pure Ada type only.
6490 -- Register_Tag (Dt_Ptr);
6492 -- Skip this action in the following cases:
6493 -- 1) if Register_Tag is not available.
6494 -- 2) in No_Run_Time mode.
6495 -- 3) if Typ is not defined at the library level (this is required
6496 -- to avoid adding concurrency control to the hash table used
6497 -- by the run-time to register the tags).
6498 -- 4) No_Tagged_Type_Registration is active.
6500 if not No_Run_Time_Mode
6501 and then Is_Library_Level_Entity
(Typ
)
6502 and then not Restriction_Active
(No_Tagged_Type_Registration
)
6503 and then RTE_Available
(RE_Register_Tag
)
6505 Append_To
(Elab_Code
,
6506 Make_Procedure_Call_Statement
(Loc
,
6508 New_Occurrence_Of
(RTE
(RE_Register_Tag
), Loc
),
6509 Parameter_Associations
=>
6510 New_List
(New_Occurrence_Of
(DT_Ptr
, Loc
))));
6513 Append_List_To
(Result
, Elab_Code
);
6515 -- Populate the two auxiliary tables used for dispatching asynchronous,
6516 -- conditional and timed selects for synchronized types that implement
6517 -- a limited interface. Skip this step in Ravenscar profile or when
6518 -- general dispatching is forbidden.
6520 if Ada_Version
>= Ada_2005
6521 and then Is_Concurrent_Record_Type
(Typ
)
6522 and then Has_Interfaces
(Typ
)
6523 and then not Restriction_Active
(No_Dispatching_Calls
)
6524 and then not Restriction_Active
(No_Select_Statements
)
6526 Append_List_To
(Result
,
6527 Make_Select_Specific_Data_Table
(Typ
));
6530 -- Remember entities containing dispatch tables
6532 Append_Elmt
(Predef_Prims
, DT_Decl
);
6533 Append_Elmt
(DT
, DT_Decl
);
6535 Analyze_List
(Result
, Suppress
=> All_Checks
);
6537 -- Mark entities containing dispatch tables. Required by the backend to
6538 -- handle them properly.
6540 if Has_DT
(Typ
) then
6545 -- Object declarations
6547 Elmt
:= First_Elmt
(DT_Decl
);
6548 while Present
(Elmt
) loop
6549 Set_Is_Dispatch_Table_Entity
(Node
(Elmt
));
6550 pragma Assert
(Ekind
(Etype
(Node
(Elmt
))) = E_Array_Subtype
6551 or else Ekind
(Etype
(Node
(Elmt
))) = E_Record_Subtype
);
6552 Set_Is_Dispatch_Table_Entity
(Etype
(Node
(Elmt
)));
6556 -- Aggregates initializing dispatch tables
6558 Elmt
:= First_Elmt
(DT_Aggr
);
6559 while Present
(Elmt
) loop
6560 Set_Is_Dispatch_Table_Entity
(Etype
(Node
(Elmt
)));
6568 Set_Has_Dispatch_Table
(Typ
);
6570 -- Register the tagged type in the call graph nodes table
6572 Register_CG_Node
(Typ
);
6575 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
6580 -------------------------------------
6581 -- Make_Select_Specific_Data_Table --
6582 -------------------------------------
6584 function Make_Select_Specific_Data_Table
6585 (Typ
: Entity_Id
) return List_Id
6587 Assignments
: constant List_Id
:= New_List
;
6588 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6590 Conc_Typ
: Entity_Id
;
6591 Decls
: List_Id
:= No_List
;
6593 Prim_Als
: Entity_Id
;
6594 Prim_Elmt
: Elmt_Id
;
6598 type Examined_Array
is array (Int
range <>) of Boolean;
6600 function Find_Entry_Index
(E
: Entity_Id
) return Uint
;
6601 -- Given an entry, find its index in the visible declarations of the
6602 -- corresponding concurrent type of Typ.
6604 ----------------------
6605 -- Find_Entry_Index --
6606 ----------------------
6608 function Find_Entry_Index
(E
: Entity_Id
) return Uint
is
6609 Index
: Uint
:= Uint_0
;
6610 Subp_Decl
: Node_Id
;
6613 Subp_Decl
:= First
(Decls
);
6614 while Present
(Subp_Decl
) loop
6615 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
6618 if Defining_Identifier
(Subp_Decl
) = E
then
6628 end Find_Entry_Index
;
6634 -- Start of processing for Make_Select_Specific_Data_Table
6637 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
6639 if Present
(Corresponding_Concurrent_Type
(Typ
)) then
6640 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
6642 if Present
(Full_View
(Conc_Typ
)) then
6643 Conc_Typ
:= Full_View
(Conc_Typ
);
6646 if Ekind
(Conc_Typ
) = E_Protected_Type
then
6647 Decls
:= Visible_Declarations
(Protected_Definition
(
6648 Parent
(Conc_Typ
)));
6650 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
6651 Decls
:= Visible_Declarations
(Task_Definition
(
6652 Parent
(Conc_Typ
)));
6656 -- Count the non-predefined primitive operations
6658 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6659 while Present
(Prim_Elmt
) loop
6660 Prim
:= Node
(Prim_Elmt
);
6662 if not (Is_Predefined_Dispatching_Operation
(Prim
)
6663 or else Is_Predefined_Dispatching_Alias
(Prim
))
6665 Nb_Prim
:= Nb_Prim
+ 1;
6668 Next_Elmt
(Prim_Elmt
);
6672 Examined
: Examined_Array
(1 .. Nb_Prim
) := (others => False);
6675 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6676 while Present
(Prim_Elmt
) loop
6677 Prim
:= Node
(Prim_Elmt
);
6679 -- Look for primitive overriding an abstract interface subprogram
6681 if Present
(Interface_Alias
(Prim
))
6684 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
6685 Use_Full_View
=> True)
6686 and then not Examined
(UI_To_Int
(DT_Position
(Alias
(Prim
))))
6688 Prim_Pos
:= DT_Position
(Alias
(Prim
));
6689 pragma Assert
(UI_To_Int
(Prim_Pos
) <= Nb_Prim
);
6690 Examined
(UI_To_Int
(Prim_Pos
)) := True;
6692 -- Set the primitive operation kind regardless of subprogram
6694 -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
6696 if Tagged_Type_Expansion
then
6699 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
);
6703 Make_Attribute_Reference
(Loc
,
6704 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6705 Attribute_Name
=> Name_Tag
);
6708 Append_To
(Assignments
,
6709 Make_Procedure_Call_Statement
(Loc
,
6710 Name
=> New_Occurrence_Of
(RTE
(RE_Set_Prim_Op_Kind
), Loc
),
6711 Parameter_Associations
=> New_List
(
6713 Make_Integer_Literal
(Loc
, Prim_Pos
),
6714 Prim_Op_Kind
(Alias
(Prim
), Typ
))));
6716 -- Retrieve the root of the alias chain
6718 Prim_Als
:= Ultimate_Alias
(Prim
);
6720 -- In the case of an entry wrapper, set the entry index
6722 if Ekind
(Prim
) = E_Procedure
6723 and then Is_Primitive_Wrapper
(Prim_Als
)
6724 and then Ekind
(Wrapped_Entity
(Prim_Als
)) = E_Entry
6727 -- Ada.Tags.Set_Entry_Index
6728 -- (DT_Ptr, <position>, <index>);
6730 if Tagged_Type_Expansion
then
6733 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
);
6736 Make_Attribute_Reference
(Loc
,
6737 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6738 Attribute_Name
=> Name_Tag
);
6741 Append_To
(Assignments
,
6742 Make_Procedure_Call_Statement
(Loc
,
6744 New_Occurrence_Of
(RTE
(RE_Set_Entry_Index
), Loc
),
6745 Parameter_Associations
=> New_List
(
6747 Make_Integer_Literal
(Loc
, Prim_Pos
),
6748 Make_Integer_Literal
(Loc
,
6749 Find_Entry_Index
(Wrapped_Entity
(Prim_Als
))))));
6753 Next_Elmt
(Prim_Elmt
);
6758 end Make_Select_Specific_Data_Table
;
6764 function Make_Tags
(Typ
: Entity_Id
) return List_Id
is
6765 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6766 Result
: constant List_Id
:= New_List
;
6769 (Tag_Typ
: Entity_Id
;
6771 Is_Secondary_DT
: Boolean);
6772 -- Import the dispatch table DT of tagged type Tag_Typ. Required to
6773 -- generate forward references and statically allocate the table. For
6774 -- primary dispatch tables that require no dispatch table generate:
6776 -- DT : static aliased constant Non_Dispatch_Table_Wrapper;
6777 -- pragma Import (Ada, DT);
6779 -- Otherwise generate:
6781 -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
6782 -- pragma Import (Ada, DT);
6789 (Tag_Typ
: Entity_Id
;
6791 Is_Secondary_DT
: Boolean)
6793 DT_Constr_List
: List_Id
;
6797 Set_Is_Imported
(DT
);
6798 Mutate_Ekind
(DT
, E_Constant
);
6799 Set_Related_Type
(DT
, Typ
);
6801 -- The scope must be set now to call Get_External_Name
6803 Set_Scope
(DT
, Current_Scope
);
6805 Get_External_Name
(DT
);
6806 Set_Interface_Name
(DT
,
6807 Make_String_Literal
(Loc
, Strval
=> String_From_Name_Buffer
));
6809 -- Ensure proper Sprint output of this implicit importation
6811 Set_Is_Internal
(DT
);
6813 -- Save this entity to allow Make_DT to generate its exportation
6815 Append_Elmt
(DT
, Dispatch_Table_Wrappers
(Typ
));
6817 -- No dispatch table required
6819 if not Is_Secondary_DT
and then not Has_DT
(Tag_Typ
) then
6821 Make_Object_Declaration
(Loc
,
6822 Defining_Identifier
=> DT
,
6823 Aliased_Present
=> True,
6824 Constant_Present
=> True,
6825 Object_Definition
=>
6827 (RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
)));
6830 -- Calculate the number of primitives of the dispatch table and
6831 -- the size of the Type_Specific_Data record.
6834 UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Tag_Typ
)));
6836 -- If the tagged type has no primitives we add a dummy slot whose
6837 -- address will be the tag of this type.
6841 New_List
(Make_Integer_Literal
(Loc
, 1));
6844 New_List
(Make_Integer_Literal
(Loc
, Nb_Prim
));
6848 Make_Object_Declaration
(Loc
,
6849 Defining_Identifier
=> DT
,
6850 Aliased_Present
=> True,
6851 Constant_Present
=> True,
6852 Object_Definition
=>
6853 Make_Subtype_Indication
(Loc
,
6855 New_Occurrence_Of
(RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
6856 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
6857 Constraints
=> DT_Constr_List
))));
6863 Tname
: constant Name_Id
:= Chars
(Typ
);
6864 AI_Tag_Comp
: Elmt_Id
;
6865 DT
: Node_Id
:= Empty
;
6867 Predef_Prims_Ptr
: Node_Id
;
6868 Iface_DT
: Node_Id
:= Empty
;
6869 Iface_DT_Ptr
: Node_Id
;
6873 Typ_Comps
: Elist_Id
;
6875 -- Start of processing for Make_Tags
6878 pragma Assert
(No
(Access_Disp_Table
(Typ
)));
6879 Set_Access_Disp_Table
(Typ
, New_Elmt_List
);
6881 -- If the elaboration of this tagged type needs a boolean flag then
6882 -- define now its entity. It is initialized to True to indicate that
6883 -- elaboration is still pending; set to False by the IP routine.
6885 -- TypFxx : boolean := True;
6887 if Elab_Flag_Needed
(Typ
) then
6888 Set_Access_Disp_Table_Elab_Flag
(Typ
,
6889 Make_Defining_Identifier
(Loc
,
6890 Chars
=> New_External_Name
(Tname
, 'F')));
6893 Make_Object_Declaration
(Loc
,
6894 Defining_Identifier
=> Access_Disp_Table_Elab_Flag
(Typ
),
6895 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
6896 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
6899 -- 1) Generate the primary tag entities
6901 -- Primary dispatch table containing user-defined primitives
6903 DT_Ptr
:= Make_Defining_Identifier
(Loc
, New_External_Name
(Tname
, 'P'));
6904 Set_Etype
(DT_Ptr
, RTE
(RE_Tag
));
6905 Append_Elmt
(DT_Ptr
, Access_Disp_Table
(Typ
));
6907 -- Minimum decoration
6909 Mutate_Ekind
(DT_Ptr
, E_Variable
);
6910 Set_Related_Type
(DT_Ptr
, Typ
);
6912 -- Notify back end that the types are associated with a dispatch table
6914 Set_Is_Dispatch_Table_Entity
(RTE
(RE_Prim_Ptr
));
6915 Set_Is_Dispatch_Table_Entity
(RTE
(RE_Predef_Prims_Table_Ptr
));
6917 -- For CPP types there is no need to build the dispatch tables since
6918 -- they are imported from the C++ side. If the CPP type has an IP then
6919 -- we declare now the variable that will store the copy of the C++ tag.
6920 -- If the CPP type is an interface, we need the variable as well because
6921 -- it becomes the pointer to the corresponding secondary table.
6923 if Is_CPP_Class
(Typ
) then
6924 if Has_CPP_Constructors
(Typ
) or else Is_Interface
(Typ
) then
6926 Make_Object_Declaration
(Loc
,
6927 Defining_Identifier
=> DT_Ptr
,
6928 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
6930 Unchecked_Convert_To
(RTE
(RE_Tag
),
6931 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
6933 Set_Is_Statically_Allocated
(DT_Ptr
,
6934 Is_Library_Level_Tagged_Type
(Typ
));
6940 -- Primary dispatch table containing predefined primitives
6943 Make_Defining_Identifier
(Loc
,
6944 Chars
=> New_External_Name
(Tname
, 'Y'));
6945 Set_Etype
(Predef_Prims_Ptr
, RTE
(RE_Address
));
6946 Append_Elmt
(Predef_Prims_Ptr
, Access_Disp_Table
(Typ
));
6948 -- Import the forward declaration of the Dispatch Table wrapper
6949 -- record (Make_DT will take care of exporting it).
6951 if Building_Static_DT
(Typ
) then
6952 Set_Dispatch_Table_Wrappers
(Typ
, New_Elmt_List
);
6955 Make_Defining_Identifier
(Loc
,
6956 Chars
=> New_External_Name
(Tname
, 'T'));
6958 Import_DT
(Typ
, DT
, Is_Secondary_DT
=> False);
6960 if Has_DT
(Typ
) then
6962 Make_Object_Declaration
(Loc
,
6963 Defining_Identifier
=> DT_Ptr
,
6964 Constant_Present
=> True,
6965 Object_Definition
=>
6966 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
6968 Unchecked_Convert_To
(RTE
(RE_Tag
),
6969 Make_Attribute_Reference
(Loc
,
6971 Make_Selected_Component
(Loc
,
6972 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
6975 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
6976 Attribute_Name
=> Name_Address
))));
6978 -- Generate the SCIL node for the previous object declaration
6979 -- because it has a tag initialization.
6981 if Generate_SCIL
then
6983 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
6984 Set_SCIL_Entity
(New_Node
, Typ
);
6985 Set_SCIL_Node
(Last
(Result
), New_Node
);
6989 Make_Object_Declaration
(Loc
,
6990 Defining_Identifier
=> Predef_Prims_Ptr
,
6991 Constant_Present
=> True,
6992 Object_Definition
=>
6993 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
6995 Make_Attribute_Reference
(Loc
,
6997 Make_Selected_Component
(Loc
,
6998 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
7001 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
7002 Attribute_Name
=> Name_Address
)));
7004 -- No dispatch table required
7008 Make_Object_Declaration
(Loc
,
7009 Defining_Identifier
=> DT_Ptr
,
7010 Constant_Present
=> True,
7011 Object_Definition
=>
7012 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
7014 Unchecked_Convert_To
(RTE
(RE_Tag
),
7015 Make_Attribute_Reference
(Loc
,
7017 Make_Selected_Component
(Loc
,
7018 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
7021 (RTE_Record_Component
(RE_NDT_Prims_Ptr
),
7023 Attribute_Name
=> Name_Address
))));
7026 Set_Is_True_Constant
(DT_Ptr
);
7027 Set_Is_Statically_Allocated
(DT_Ptr
);
7031 -- 2) Generate the secondary tag entities
7033 -- Collect the components associated with secondary dispatch tables
7035 if Has_Interfaces
(Typ
) then
7036 Collect_Interface_Components
(Typ
, Typ_Comps
);
7038 -- For each interface type we build a unique external name associated
7039 -- with its secondary dispatch table. This name is used to declare an
7040 -- object that references this secondary dispatch table, whose value
7041 -- will be used for the elaboration of Typ objects, and also for the
7042 -- elaboration of objects of types derived from Typ that do not
7043 -- override the primitives of this interface type.
7047 -- Note: The value of Suffix_Index must be in sync with the values of
7048 -- Suffix_Index in secondary dispatch tables generated by Make_DT.
7050 if Is_CPP_Class
(Typ
) then
7051 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
7052 while Present
(AI_Tag_Comp
) loop
7053 Get_Secondary_DT_External_Name
7054 (Typ
, Related_Type
(Node
(AI_Tag_Comp
)), Suffix_Index
);
7055 Typ_Name
:= Name_Find
;
7057 -- Declare variables to store copy of the C++ secondary tags
7060 Make_Defining_Identifier
(Loc
,
7061 Chars
=> New_External_Name
(Typ_Name
, 'P'));
7062 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7063 Mutate_Ekind
(Iface_DT_Ptr
, E_Variable
);
7064 Set_Is_Tag
(Iface_DT_Ptr
);
7066 Set_Has_Thunks
(Iface_DT_Ptr
);
7068 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7069 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7072 Make_Object_Declaration
(Loc
,
7073 Defining_Identifier
=> Iface_DT_Ptr
,
7074 Object_Definition
=> New_Occurrence_Of
7075 (RTE
(RE_Interface_Tag
), Loc
),
7077 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
7078 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
7080 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7081 Is_Library_Level_Tagged_Type
(Typ
));
7083 Next_Elmt
(AI_Tag_Comp
);
7086 -- This is not a CPP_Class type
7089 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
7090 while Present
(AI_Tag_Comp
) loop
7091 Get_Secondary_DT_External_Name
7092 (Typ
, Related_Type
(Node
(AI_Tag_Comp
)), Suffix_Index
);
7093 Typ_Name
:= Name_Find
;
7095 if Building_Static_DT
(Typ
) then
7097 Make_Defining_Identifier
(Loc
,
7098 Chars
=> New_External_Name
(Typ_Name
, 'T'));
7100 (Tag_Typ
=> Related_Type
(Node
(AI_Tag_Comp
)),
7102 Is_Secondary_DT
=> True);
7105 -- Secondary dispatch table referencing thunks to user-defined
7106 -- primitives covered by this interface.
7109 Make_Defining_Identifier
(Loc
,
7110 Chars
=> New_External_Name
(Typ_Name
, 'P'));
7111 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7112 Mutate_Ekind
(Iface_DT_Ptr
, E_Constant
);
7113 Set_Is_Tag
(Iface_DT_Ptr
);
7114 Set_Has_Thunks
(Iface_DT_Ptr
);
7115 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7116 Is_Library_Level_Tagged_Type
(Typ
));
7117 Set_Is_True_Constant
(Iface_DT_Ptr
);
7119 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7120 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7122 if Building_Static_DT
(Typ
) then
7124 Make_Object_Declaration
(Loc
,
7125 Defining_Identifier
=> Iface_DT_Ptr
,
7126 Constant_Present
=> True,
7127 Object_Definition
=> New_Occurrence_Of
7128 (RTE
(RE_Interface_Tag
), Loc
),
7130 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
7131 Make_Attribute_Reference
(Loc
,
7133 Make_Selected_Component
(Loc
,
7135 New_Occurrence_Of
(Iface_DT
, Loc
),
7138 (RTE_Record_Component
(RE_Prims_Ptr
),
7140 Attribute_Name
=> Name_Address
))));
7143 -- Secondary dispatch table referencing thunks to predefined
7147 Make_Defining_Identifier
(Loc
,
7148 Chars
=> New_External_Name
(Typ_Name
, 'Y'));
7149 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Address
));
7150 Mutate_Ekind
(Iface_DT_Ptr
, E_Constant
);
7151 Set_Is_Tag
(Iface_DT_Ptr
);
7152 Set_Has_Thunks
(Iface_DT_Ptr
);
7153 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7154 Is_Library_Level_Tagged_Type
(Typ
));
7155 Set_Is_True_Constant
(Iface_DT_Ptr
);
7157 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7158 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7160 -- Secondary dispatch table referencing user-defined primitives
7161 -- covered by this interface.
7164 Make_Defining_Identifier
(Loc
,
7165 Chars
=> New_External_Name
(Typ_Name
, 'D'));
7166 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7167 Mutate_Ekind
(Iface_DT_Ptr
, E_Constant
);
7168 Set_Is_Tag
(Iface_DT_Ptr
);
7169 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7170 Is_Library_Level_Tagged_Type
(Typ
));
7171 Set_Is_True_Constant
(Iface_DT_Ptr
);
7173 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7174 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7176 -- Secondary dispatch table referencing predefined primitives
7179 Make_Defining_Identifier
(Loc
,
7180 Chars
=> New_External_Name
(Typ_Name
, 'Z'));
7181 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Address
));
7182 Mutate_Ekind
(Iface_DT_Ptr
, E_Constant
);
7183 Set_Is_Tag
(Iface_DT_Ptr
);
7184 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7185 Is_Library_Level_Tagged_Type
(Typ
));
7186 Set_Is_True_Constant
(Iface_DT_Ptr
);
7188 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7189 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7191 Next_Elmt
(AI_Tag_Comp
);
7196 -- 3) At the end of Access_Disp_Table, if the type has user-defined
7197 -- primitives, we add the entity of an access type declaration that
7198 -- is used by Build_Get_Prim_Op_Address to expand dispatching calls
7199 -- through the primary dispatch table.
7201 if DT_Entry_Count
(First_Tag_Component
(Typ
)) = 0 then
7202 Analyze_List
(Result
);
7205 -- subtype Typ_DT is Address_Array (1 .. Nb_Prims);
7206 -- type Typ_DT_Acc is access Typ_DT;
7210 Name_DT_Prims
: constant Name_Id
:=
7211 New_External_Name
(Tname
, 'G');
7212 Name_DT_Prims_Acc
: constant Name_Id
:=
7213 New_External_Name
(Tname
, 'H');
7214 DT_Prims
: constant Entity_Id
:=
7215 Make_Defining_Identifier
(Loc
,
7217 DT_Prims_Acc
: constant Entity_Id
:=
7218 Make_Defining_Identifier
(Loc
,
7222 Make_Subtype_Declaration
(Loc
,
7223 Defining_Identifier
=> DT_Prims
,
7224 Subtype_Indication
=>
7225 Make_Subtype_Indication
(Loc
,
7227 New_Occurrence_Of
(RTE
(RE_Address_Array
), Loc
),
7229 Make_Index_Or_Discriminant_Constraint
(Loc
, New_List
(
7231 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
7233 Make_Integer_Literal
(Loc
,
7235 (First_Tag_Component
(Typ
)))))))));
7238 Make_Full_Type_Declaration
(Loc
,
7239 Defining_Identifier
=> DT_Prims_Acc
,
7241 Make_Access_To_Object_Definition
(Loc
,
7242 Subtype_Indication
=>
7243 New_Occurrence_Of
(DT_Prims
, Loc
))));
7245 Append_Elmt
(DT_Prims_Acc
, Access_Disp_Table
(Typ
));
7247 -- Analyze the resulting list and suppress the generation of the
7248 -- Init_Proc associated with the above array declaration because
7249 -- this type is never used in object declarations. It is only used
7250 -- to simplify the expansion associated with dispatching calls.
7252 Analyze_List
(Result
);
7253 Set_Suppress_Initialization
(Base_Type
(DT_Prims
));
7255 -- Disable backend optimizations based on assumptions about the
7256 -- aliasing status of objects designated by the access to the
7257 -- dispatch table. Required to handle dispatch tables imported
7260 Set_No_Strict_Aliasing
(Base_Type
(DT_Prims_Acc
));
7262 -- Add the freezing nodes of these declarations; required to avoid
7263 -- generating these freezing nodes in wrong scopes (for example in
7264 -- the IC routine of a derivation of Typ).
7266 -- What is an "IC routine"? Is "init_proc" meant here???
7268 Append_List_To
(Result
, Freeze_Entity
(DT_Prims
, Typ
));
7269 Append_List_To
(Result
, Freeze_Entity
(DT_Prims_Acc
, Typ
));
7271 -- Mark entity of dispatch table. Required by the back end to
7272 -- handle them properly.
7274 Set_Is_Dispatch_Table_Entity
(DT_Prims
);
7278 -- Mark entities of dispatch table. Required by the back end to handle
7281 if Present
(DT
) then
7282 Set_Is_Dispatch_Table_Entity
(DT
);
7283 Set_Is_Dispatch_Table_Entity
(Etype
(DT
));
7286 if Present
(Iface_DT
) then
7287 Set_Is_Dispatch_Table_Entity
(Iface_DT
);
7288 Set_Is_Dispatch_Table_Entity
(Etype
(Iface_DT
));
7291 if Is_CPP_Class
(Root_Type
(Typ
)) then
7292 Mutate_Ekind
(DT_Ptr
, E_Variable
);
7294 Mutate_Ekind
(DT_Ptr
, E_Constant
);
7297 Set_Is_Tag
(DT_Ptr
);
7298 Set_Related_Type
(DT_Ptr
, Typ
);
7307 function New_Value
(From
: Node_Id
) return Node_Id
is
7308 Res
: constant Node_Id
:= Duplicate_Subexpr
(From
);
7310 if Is_Access_Type
(Etype
(From
)) then
7311 return Make_Explicit_Dereference
(Sloc
(From
), Prefix
=> Res
);
7321 function Prim_Op_Kind
7323 Typ
: Entity_Id
) return Node_Id
7325 Full_Typ
: Entity_Id
:= Typ
;
7326 Loc
: constant Source_Ptr
:= Sloc
(Prim
);
7327 Prim_Op
: Entity_Id
;
7330 -- Retrieve the original primitive operation
7332 Prim_Op
:= Ultimate_Alias
(Prim
);
7334 if Ekind
(Typ
) = E_Record_Type
7335 and then Present
(Corresponding_Concurrent_Type
(Typ
))
7337 Full_Typ
:= Corresponding_Concurrent_Type
(Typ
);
7340 -- When a private tagged type is completed by a concurrent type,
7341 -- retrieve the full view.
7343 if Is_Private_Type
(Full_Typ
) then
7344 Full_Typ
:= Full_View
(Full_Typ
);
7347 if Ekind
(Prim_Op
) = E_Function
then
7349 -- Protected function
7351 if Ekind
(Full_Typ
) = E_Protected_Type
then
7352 return New_Occurrence_Of
(RTE
(RE_POK_Protected_Function
), Loc
);
7356 elsif Ekind
(Full_Typ
) = E_Task_Type
then
7357 return New_Occurrence_Of
(RTE
(RE_POK_Task_Function
), Loc
);
7362 return New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
);
7366 pragma Assert
(Ekind
(Prim_Op
) = E_Procedure
);
7368 if Ekind
(Full_Typ
) = E_Protected_Type
then
7372 if Is_Primitive_Wrapper
(Prim_Op
)
7373 and then Ekind
(Wrapped_Entity
(Prim_Op
)) = E_Entry
7375 return New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
);
7377 -- Protected procedure
7381 New_Occurrence_Of
(RTE
(RE_POK_Protected_Procedure
), Loc
);
7384 elsif Ekind
(Full_Typ
) = E_Task_Type
then
7388 if Is_Primitive_Wrapper
(Prim_Op
)
7389 and then Ekind
(Wrapped_Entity
(Prim_Op
)) = E_Entry
7391 return New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
);
7393 -- Task "procedure". These are the internally Expander-generated
7394 -- procedures (task body for instance).
7397 return New_Occurrence_Of
(RTE
(RE_POK_Task_Procedure
), Loc
);
7400 -- Regular procedure
7403 return New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
);
7408 -----------------------------------
7409 -- Register_Predefined_Primitive --
7410 -----------------------------------
7412 function Register_Predefined_Primitive
7414 Prim
: Entity_Id
) return List_Id
7416 L
: constant List_Id
:= New_List
;
7417 Tagged_Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Prim
);
7420 Iface_DT_Ptr
: Elmt_Id
;
7421 SS_Thunk_Id
: Entity_Id
;
7422 SS_Thunk_Code
: Node_Id
;
7423 Thunk_Id
: Entity_Id
;
7424 Thunk_Code
: List_Id
;
7427 if No
(Access_Disp_Table
(Tagged_Typ
))
7428 or else not Has_Interfaces
(Tagged_Typ
)
7429 or else not RTE_Available
(RE_Interface_Tag
)
7430 or else Restriction_Active
(No_Dispatching_Calls
)
7435 -- Skip the first two access-to-dispatch-table pointers since they
7436 -- leads to the primary dispatch table (predefined DT and user
7437 -- defined DT). We are only concerned with the secondary dispatch
7438 -- table pointers. Note that the access-to- dispatch-table pointer
7439 -- corresponds to the first implemented interface retrieved below.
7442 Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Tagged_Typ
))));
7444 while Present
(Iface_DT_Ptr
)
7445 and then Ekind
(Node
(Iface_DT_Ptr
)) = E_Constant
7447 pragma Assert
(Has_Thunks
(Node
(Iface_DT_Ptr
)));
7449 Expand_Interface_Thunk
7450 (Prim
, Thunk_Id
, Thunk_Code
, Related_Type
(Node
(Iface_DT_Ptr
)));
7452 if Present
(Thunk_Id
) then
7453 Append_List_To
(L
, Thunk_Code
);
7456 Expand_Secondary_Stack_Thunk
(E
, SS_Thunk_Id
, SS_Thunk_Code
);
7458 if Present
(SS_Thunk_Id
) then
7460 Append_To
(L
, SS_Thunk_Code
);
7464 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7466 New_Occurrence_Of
(Node
(Next_Elmt
(Iface_DT_Ptr
)), Loc
),
7467 Position
=> DT_Position
(Prim
),
7469 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7470 Make_Attribute_Reference
(Loc
,
7471 Prefix
=> New_Occurrence_Of
(Thunk_Id
, Loc
),
7472 Attribute_Name
=> Name_Unrestricted_Access
))));
7475 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7478 (Node
(Next_Elmt
(Next_Elmt
(Next_Elmt
(Iface_DT_Ptr
)))),
7480 Position
=> DT_Position
(Prim
),
7482 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7483 Make_Attribute_Reference
(Loc
,
7484 Prefix
=> New_Occurrence_Of
(E
, Loc
),
7485 Attribute_Name
=> Name_Unrestricted_Access
))));
7488 -- Skip the tag of the predefined primitives dispatch table
7490 Next_Elmt
(Iface_DT_Ptr
);
7491 pragma Assert
(Has_Thunks
(Node
(Iface_DT_Ptr
)));
7493 -- Skip tag of the no-thunks dispatch table
7495 Next_Elmt
(Iface_DT_Ptr
);
7496 pragma Assert
(not Has_Thunks
(Node
(Iface_DT_Ptr
)));
7498 -- Skip tag of predefined primitives no-thunks dispatch table
7500 Next_Elmt
(Iface_DT_Ptr
);
7501 pragma Assert
(not Has_Thunks
(Node
(Iface_DT_Ptr
)));
7503 Next_Elmt
(Iface_DT_Ptr
);
7507 end Register_Predefined_Primitive
;
7509 ------------------------
7510 -- Register_Primitive --
7511 ------------------------
7513 function Register_Primitive
7515 Prim
: Entity_Id
) return List_Id
7517 L
: constant List_Id
:= New_List
;
7521 Iface_Prim
: Entity_Id
;
7522 Iface_Typ
: Entity_Id
;
7523 Iface_DT_Ptr
: Entity_Id
;
7524 Iface_DT_Elmt
: Elmt_Id
;
7526 SS_Thunk_Id
: Entity_Id
;
7527 SS_Thunk_Code
: Node_Id
;
7529 Tag_Typ
: Entity_Id
;
7530 Thunk_Id
: Entity_Id
;
7531 Thunk_Code
: List_Id
;
7534 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
7536 -- Do not register eliminated primitives in the dispatch table
7538 if not RTE_Available
(RE_Tag
)
7539 or else Is_Eliminated
(Ultimate_Alias
(Prim
))
7540 or else Generate_SCIL
7545 -- Primitive associated with a tagged type
7547 if No
(Interface_Alias
(Prim
)) then
7548 Tag_Typ
:= Scope
(DTC_Entity
(Prim
));
7549 Pos
:= DT_Position
(Prim
);
7550 Tag
:= First_Tag_Component
(Tag_Typ
);
7553 Expand_Secondary_Stack_Thunk
(E
, SS_Thunk_Id
, SS_Thunk_Code
);
7555 if Present
(SS_Thunk_Id
) then
7557 Append_To
(L
, SS_Thunk_Code
);
7560 if Is_Predefined_Dispatching_Operation
(Prim
)
7561 or else Is_Predefined_Dispatching_Alias
(Prim
)
7564 Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Tag_Typ
))));
7567 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7568 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7571 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7572 Make_Attribute_Reference
(Loc
,
7573 Prefix
=> New_Occurrence_Of
(E
, Loc
),
7574 Attribute_Name
=> Name_Unrestricted_Access
))));
7576 -- Register copy of the pointer to the 'size primitive in the TSD
7578 if Chars
(Prim
) = Name_uSize
7579 and then RTE_Record_Component_Available
(RE_Size_Func
)
7581 Append_To
(L
, Build_Set_Size_Function
(Loc
, Tag_Typ
, Prim
));
7585 pragma Assert
(Pos
/= Uint_0
and then Pos
<= DT_Entry_Count
(Tag
));
7587 -- Skip registration of primitives located in the C++ part of the
7588 -- dispatch table. Their slot is set by the IC routine.
7590 if not Is_CPP_Class
(Root_Type
(Tag_Typ
))
7591 or else Pos
> CPP_Num_Prims
(Tag_Typ
)
7593 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Tag_Typ
)));
7595 Build_Set_Prim_Op_Address
(Loc
,
7597 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7600 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7601 Make_Attribute_Reference
(Loc
,
7602 Prefix
=> New_Occurrence_Of
(E
, Loc
),
7603 Attribute_Name
=> Name_Unrestricted_Access
))));
7607 -- Ada 2005 (AI-251): Primitive associated with an interface type
7609 -- Generate the code of the thunk only if the interface type is not an
7610 -- immediate ancestor of Typ; otherwise the dispatch table associated
7611 -- with the interface is the primary dispatch table and we have nothing
7615 Tag_Typ
:= Find_Dispatching_Type
(Alias
(Prim
));
7616 Iface_Typ
:= Find_Dispatching_Type
(Interface_Alias
(Prim
));
7618 pragma Assert
(Is_Interface
(Iface_Typ
));
7620 -- No action needed for interfaces that are ancestors of Typ because
7621 -- their primitives are located in the primary dispatch table.
7623 if Is_Ancestor
(Iface_Typ
, Tag_Typ
, Use_Full_View
=> True) then
7626 -- No action needed for primitives located in the C++ part of the
7627 -- dispatch table. Their slot is set by the IC routine.
7629 elsif Is_CPP_Class
(Root_Type
(Tag_Typ
))
7630 and then DT_Position
(Alias
(Prim
)) <= CPP_Num_Prims
(Tag_Typ
)
7631 and then not Is_Predefined_Dispatching_Operation
(Prim
)
7632 and then not Is_Predefined_Dispatching_Alias
(Prim
)
7637 Expand_Interface_Thunk
(Prim
, Thunk_Id
, Thunk_Code
, Iface_Typ
);
7639 if Present
(Thunk_Id
)
7640 and then not Is_Ancestor
(Iface_Typ
, Tag_Typ
, Use_Full_View
=> True)
7642 -- Generate the code necessary to fill the appropriate entry of
7643 -- the secondary dispatch table of Prim's controlling type with
7644 -- Thunk_Id's address.
7646 Iface_DT_Elmt
:= Find_Interface_ADT
(Tag_Typ
, Iface_Typ
);
7647 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7648 pragma Assert
(Has_Thunks
(Iface_DT_Ptr
));
7650 Iface_Prim
:= Interface_Alias
(Prim
);
7651 Pos
:= DT_Position
(Iface_Prim
);
7652 Tag
:= First_Tag_Component
(Iface_Typ
);
7654 Append_List_To
(L
, Thunk_Code
);
7656 E
:= Ultimate_Alias
(Prim
);
7657 Expand_Secondary_Stack_Thunk
(E
, SS_Thunk_Id
, SS_Thunk_Code
);
7659 if Present
(SS_Thunk_Id
) then
7661 Append_To
(L
, SS_Thunk_Code
);
7664 if Is_Predefined_Dispatching_Operation
(Prim
)
7665 or else Is_Predefined_Dispatching_Alias
(Prim
)
7668 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7670 New_Occurrence_Of
(Node
(Next_Elmt
(Iface_DT_Elmt
)), Loc
),
7673 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7674 Make_Attribute_Reference
(Loc
,
7675 Prefix
=> New_Occurrence_Of
(Thunk_Id
, Loc
),
7676 Attribute_Name
=> Name_Unrestricted_Access
))));
7678 Next_Elmt
(Iface_DT_Elmt
);
7679 Next_Elmt
(Iface_DT_Elmt
);
7680 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7681 pragma Assert
(not Has_Thunks
(Iface_DT_Ptr
));
7684 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7686 New_Occurrence_Of
(Node
(Next_Elmt
(Iface_DT_Elmt
)), Loc
),
7689 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7690 Make_Attribute_Reference
(Loc
,
7691 Prefix
=> New_Occurrence_Of
(E
, Loc
),
7692 Attribute_Name
=> Name_Unrestricted_Access
))));
7695 pragma Assert
(Pos
/= Uint_0
7696 and then Pos
<= DT_Entry_Count
(Tag
));
7699 Build_Set_Prim_Op_Address
(Loc
,
7701 Tag_Node
=> New_Occurrence_Of
(Iface_DT_Ptr
, Loc
),
7704 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7705 Make_Attribute_Reference
(Loc
,
7706 Prefix
=> New_Occurrence_Of
(Thunk_Id
, Loc
),
7707 Attribute_Name
=> Name_Unrestricted_Access
))));
7709 Next_Elmt
(Iface_DT_Elmt
);
7710 Next_Elmt
(Iface_DT_Elmt
);
7711 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7712 pragma Assert
(not Has_Thunks
(Iface_DT_Ptr
));
7715 Build_Set_Prim_Op_Address
(Loc
,
7717 Tag_Node
=> New_Occurrence_Of
(Iface_DT_Ptr
, Loc
),
7720 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7721 Make_Attribute_Reference
(Loc
,
7722 Prefix
=> New_Occurrence_Of
(E
, Loc
),
7723 Attribute_Name
=> Name_Unrestricted_Access
))));
7730 end Register_Primitive
;
7732 -------------------------
7733 -- Set_All_DT_Position --
7734 -------------------------
7736 procedure Set_All_DT_Position
(Typ
: Entity_Id
) is
7738 function In_Predef_Prims_DT
(Prim
: Entity_Id
) return Boolean;
7739 -- Returns True if Prim is located in the dispatch table of
7740 -- predefined primitives
7742 procedure Validate_Position
(Prim
: Entity_Id
);
7743 -- Check that position assigned to Prim is completely safe (it has not
7744 -- been assigned to a previously defined primitive operation of Typ).
7746 ------------------------
7747 -- In_Predef_Prims_DT --
7748 ------------------------
7750 function In_Predef_Prims_DT
(Prim
: Entity_Id
) return Boolean is
7752 -- Predefined primitives
7754 if Is_Predefined_Dispatching_Operation
(Prim
) then
7757 -- Renamings of predefined primitives
7759 elsif Present
(Alias
(Prim
))
7760 and then Is_Predefined_Dispatching_Operation
(Ultimate_Alias
(Prim
))
7762 if Chars
(Ultimate_Alias
(Prim
)) /= Name_Op_Eq
then
7765 -- An overriding operation that is a user-defined renaming of
7766 -- predefined equality inherits its slot from the overridden
7767 -- operation. Otherwise it is treated as a predefined op and
7768 -- occupies the same predefined slot as equality. A call to it is
7769 -- transformed into a call to its alias, which is the predefined
7770 -- equality op. A dispatching call thus uses the proper slot if
7771 -- operation is further inherited and called with class-wide
7776 not Comes_From_Source
(Prim
)
7777 or else No
(Overridden_Operation
(Prim
));
7780 -- User-defined primitives
7785 end In_Predef_Prims_DT
;
7787 -----------------------
7788 -- Validate_Position --
7789 -----------------------
7791 procedure Validate_Position
(Prim
: Entity_Id
) is
7796 -- Aliased primitives are safe
7798 if Present
(Alias
(Prim
)) then
7802 Op_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
7803 while Present
(Op_Elmt
) loop
7804 Op
:= Node
(Op_Elmt
);
7806 -- No need to check against itself
7811 -- Primitive operations covering abstract interfaces are
7814 elsif Present
(Interface_Alias
(Op
)) then
7817 -- Predefined dispatching operations are completely safe. They
7818 -- are allocated at fixed positions in a separate table.
7820 elsif Is_Predefined_Dispatching_Operation
(Op
)
7821 or else Is_Predefined_Dispatching_Alias
(Op
)
7825 -- Aliased subprograms are safe
7827 elsif Present
(Alias
(Op
)) then
7830 elsif DT_Position
(Op
) = DT_Position
(Prim
)
7831 and then not Is_Predefined_Dispatching_Operation
(Op
)
7832 and then not Is_Predefined_Dispatching_Operation
(Prim
)
7833 and then not Is_Predefined_Dispatching_Alias
(Op
)
7834 and then not Is_Predefined_Dispatching_Alias
(Prim
)
7836 -- Handle aliased subprograms
7845 if Present
(Overridden_Operation
(Op_1
)) then
7846 Op_1
:= Overridden_Operation
(Op_1
);
7847 elsif Present
(Alias
(Op_1
)) then
7848 Op_1
:= Alias
(Op_1
);
7856 if Present
(Overridden_Operation
(Op_2
)) then
7857 Op_2
:= Overridden_Operation
(Op_2
);
7858 elsif Present
(Alias
(Op_2
)) then
7859 Op_2
:= Alias
(Op_2
);
7865 if Op_1
/= Op_2
then
7866 raise Program_Error
;
7871 Next_Elmt
(Op_Elmt
);
7873 end Validate_Position
;
7877 Parent_Typ
: constant Entity_Id
:= Etype
(Typ
);
7878 First_Prim
: constant Elmt_Id
:= First_Elmt
(Primitive_Operations
(Typ
));
7879 The_Tag
: constant Entity_Id
:= First_Tag_Component
(Typ
);
7885 Prim_Elmt
: Elmt_Id
;
7887 -- Start of processing for Set_All_DT_Position
7890 pragma Assert
(Present
(First_Tag_Component
(Typ
)));
7892 -- Set the DT_Position for each primitive operation. Perform some sanity
7893 -- checks to avoid building inconsistent dispatch tables.
7895 -- First stage: Set DTC entity of all the primitive operations. This is
7896 -- required to properly read the DT_Position attribute in latter stages.
7898 Prim_Elmt
:= First_Prim
;
7900 while Present
(Prim_Elmt
) loop
7901 Prim
:= Node
(Prim_Elmt
);
7903 -- Predefined primitives have a separate dispatch table
7905 if not In_Predef_Prims_DT
(Prim
) then
7906 Count_Prim
:= Count_Prim
+ 1;
7909 Set_DTC_Entity_Value
(Typ
, Prim
);
7911 -- Clear any previous value of the DT_Position attribute. In this
7912 -- way we ensure that the final position of all the primitives is
7913 -- established by the following stages of this algorithm.
7915 Set_DT_Position_Value
(Prim
, No_Uint
);
7917 Next_Elmt
(Prim_Elmt
);
7921 Fixed_Prim
: array (Int
range 0 .. Count_Prim
) of Boolean :=
7926 procedure Handle_Inherited_Private_Subprograms
(Typ
: Entity_Id
);
7927 -- Called if Typ is declared in a nested package or a public child
7928 -- package to handle inherited primitives that were inherited by Typ
7929 -- in the visible part, but whose declaration was deferred because
7930 -- the parent operation was private and not visible at that point.
7932 procedure Set_Fixed_Prim
(Pos
: Nat
);
7933 -- Sets to true an element of the Fixed_Prim table to indicate
7934 -- that this entry of the dispatch table of Typ is occupied.
7936 ------------------------------------------
7937 -- Handle_Inherited_Private_Subprograms --
7938 ------------------------------------------
7940 procedure Handle_Inherited_Private_Subprograms
(Typ
: Entity_Id
) is
7943 Op_Elmt_2
: Elmt_Id
;
7944 Prim_Op
: Entity_Id
;
7945 Parent_Subp
: Entity_Id
;
7948 Op_List
:= Primitive_Operations
(Typ
);
7950 Op_Elmt
:= First_Elmt
(Op_List
);
7951 while Present
(Op_Elmt
) loop
7952 Prim_Op
:= Node
(Op_Elmt
);
7954 -- Search primitives that are implicit operations with an
7955 -- internal name whose parent operation has a normal name.
7957 if Present
(Alias
(Prim_Op
))
7958 and then Find_Dispatching_Type
(Alias
(Prim_Op
)) /= Typ
7959 and then not Comes_From_Source
(Prim_Op
)
7960 and then Is_Internal_Name
(Chars
(Prim_Op
))
7961 and then not Is_Internal_Name
(Chars
(Alias
(Prim_Op
)))
7963 Parent_Subp
:= Alias
(Prim_Op
);
7965 -- Check if the type has an explicit overriding for this
7968 Op_Elmt_2
:= Next_Elmt
(Op_Elmt
);
7969 while Present
(Op_Elmt_2
) loop
7970 if Chars
(Node
(Op_Elmt_2
)) = Chars
(Parent_Subp
)
7971 and then Type_Conformant
(Prim_Op
, Node
(Op_Elmt_2
))
7973 Set_DT_Position_Value
(Prim_Op
,
7974 DT_Position
(Parent_Subp
));
7975 Set_DT_Position_Value
(Node
(Op_Elmt_2
),
7976 DT_Position
(Parent_Subp
));
7977 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(Prim_Op
)));
7979 goto Next_Primitive
;
7982 Next_Elmt
(Op_Elmt_2
);
7987 Next_Elmt
(Op_Elmt
);
7989 end Handle_Inherited_Private_Subprograms
;
7991 --------------------
7992 -- Set_Fixed_Prim --
7993 --------------------
7995 procedure Set_Fixed_Prim
(Pos
: Nat
) is
7997 pragma Assert
(Pos
<= Count_Prim
);
7998 Fixed_Prim
(Pos
) := True;
8000 when Constraint_Error
=>
8001 raise Program_Error
;
8005 -- In case of nested packages and public child package it may be
8006 -- necessary a special management on inherited subprograms so that
8007 -- the dispatch table is properly filled.
8009 if Ekind
(Scope
(Scope
(Typ
))) = E_Package
8010 and then Scope
(Scope
(Typ
)) /= Standard_Standard
8011 and then ((Is_Derived_Type
(Typ
) and then not Is_Private_Type
(Typ
))
8013 (Nkind
(Parent
(Typ
)) = N_Private_Extension_Declaration
8014 and then Is_Generic_Type
(Typ
)))
8015 and then In_Open_Scopes
(Scope
(Etype
(Typ
)))
8016 and then Is_Base_Type
(Typ
)
8018 Handle_Inherited_Private_Subprograms
(Typ
);
8021 -- Second stage: Register fixed entries
8024 Prim_Elmt
:= First_Prim
;
8025 while Present
(Prim_Elmt
) loop
8026 Prim
:= Node
(Prim_Elmt
);
8028 -- Predefined primitives have a separate table and all its
8029 -- entries are at predefined fixed positions.
8031 if In_Predef_Prims_DT
(Prim
) then
8032 if Is_Predefined_Dispatching_Operation
(Prim
) then
8033 Set_DT_Position_Value
(Prim
,
8034 Default_Prim_Op_Position
(Prim
));
8036 else pragma Assert
(Present
(Alias
(Prim
)));
8037 Set_DT_Position_Value
(Prim
,
8038 Default_Prim_Op_Position
(Ultimate_Alias
(Prim
)));
8041 -- Overriding primitives of ancestor abstract interfaces
8043 elsif Present
(Interface_Alias
(Prim
))
8044 and then Is_Ancestor
8045 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
8046 Use_Full_View
=> True)
8048 pragma Assert
(No
(DT_Position
(Prim
)));
8049 pragma Assert
(Present
(DTC_Entity
(Interface_Alias
(Prim
))));
8051 E
:= Interface_Alias
(Prim
);
8052 Set_DT_Position_Value
(Prim
, DT_Position
(E
));
8055 (No
(DT_Position
(Alias
(Prim
)))
8056 or else DT_Position
(Alias
(Prim
)) = DT_Position
(E
));
8057 Set_DT_Position_Value
(Alias
(Prim
), DT_Position
(E
));
8058 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(Prim
)));
8060 -- Overriding primitives must use the same entry as the overridden
8061 -- primitive. Note that the Alias of the operation is set when the
8062 -- operation is declared by a renaming, in which case it is not
8063 -- overriding. If it renames another primitive it will use the
8064 -- same dispatch table slot, but if it renames an operation in a
8065 -- nested package it's a new primitive and will have its own slot.
8067 elsif No
(Interface_Alias
(Prim
))
8068 and then Present
(Alias
(Prim
))
8069 and then Chars
(Prim
) = Chars
(Alias
(Prim
))
8070 and then Nkind
(Unit_Declaration_Node
(Prim
)) /=
8071 N_Subprogram_Renaming_Declaration
8074 Par_Type
: constant Entity_Id
:=
8075 Find_Dispatching_Type
(Alias
(Prim
));
8078 if Present
(Par_Type
)
8079 and then Par_Type
/= Typ
8080 and then Is_Ancestor
(Par_Type
, Typ
, Use_Full_View
=> True)
8081 and then Present
(DTC_Entity
(Alias
(Prim
)))
8084 Set_DT_Position_Value
(Prim
, DT_Position
(E
));
8086 if not Is_Predefined_Dispatching_Alias
(E
) then
8087 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(E
)));
8093 Next_Elmt
(Prim_Elmt
);
8096 -- Third stage: Fix the position of all the new primitives. Entries
8097 -- associated with primitives covering interfaces are handled in a
8100 Prim_Elmt
:= First_Prim
;
8101 while Present
(Prim_Elmt
) loop
8102 Prim
:= Node
(Prim_Elmt
);
8104 -- Skip primitives previously set entries
8106 if Present
(DT_Position
(Prim
)) then
8109 -- Primitives covering interface primitives are handled later
8111 elsif Present
(Interface_Alias
(Prim
)) then
8115 -- Take the next available position in the DT
8118 Nb_Prim
:= Nb_Prim
+ 1;
8119 pragma Assert
(Nb_Prim
<= Count_Prim
);
8120 exit when not Fixed_Prim
(Nb_Prim
);
8123 Set_DT_Position_Value
(Prim
, UI_From_Int
(Nb_Prim
));
8124 Set_Fixed_Prim
(Nb_Prim
);
8127 Next_Elmt
(Prim_Elmt
);
8131 -- Fourth stage: Complete the decoration of primitives covering
8132 -- interfaces (that is, propagate the DT_Position attribute from
8133 -- the aliased primitive)
8135 Prim_Elmt
:= First_Prim
;
8136 while Present
(Prim_Elmt
) loop
8137 Prim
:= Node
(Prim_Elmt
);
8139 if No
(DT_Position
(Prim
))
8140 and then Present
(Interface_Alias
(Prim
))
8142 pragma Assert
(Present
(Alias
(Prim
))
8143 and then Find_Dispatching_Type
(Alias
(Prim
)) = Typ
);
8145 -- Check if this entry will be placed in the primary DT
8148 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
8149 Use_Full_View
=> True)
8151 pragma Assert
(Present
(DT_Position
(Alias
(Prim
))));
8152 Set_DT_Position_Value
(Prim
, DT_Position
(Alias
(Prim
)));
8154 -- Otherwise it will be placed in the secondary DT
8158 (Present
(DT_Position
(Interface_Alias
(Prim
))));
8159 Set_DT_Position_Value
(Prim
,
8160 DT_Position
(Interface_Alias
(Prim
)));
8164 Next_Elmt
(Prim_Elmt
);
8167 -- Generate listing showing the contents of the dispatch tables. This
8168 -- action is done before some further static checks because in case of
8169 -- critical errors caused by a wrong dispatch table we need to see the
8170 -- contents of such table.
8172 if Debug_Flag_ZZ
then
8176 -- Final stage: Ensure that the table is correct plus some further
8177 -- verifications concerning the primitives.
8179 Prim_Elmt
:= First_Prim
;
8181 while Present
(Prim_Elmt
) loop
8182 Prim
:= Node
(Prim_Elmt
);
8184 -- At this point all the primitives MUST have a position in the
8187 if No
(DT_Position
(Prim
)) then
8188 raise Program_Error
;
8191 -- Calculate real size of the dispatch table
8193 if not In_Predef_Prims_DT
(Prim
)
8194 and then UI_To_Int
(DT_Position
(Prim
)) > DT_Length
8196 DT_Length
:= UI_To_Int
(DT_Position
(Prim
));
8199 -- Ensure that the assigned position to non-predefined dispatching
8200 -- operations in the dispatch table is correct.
8202 if not Is_Predefined_Dispatching_Operation
(Prim
)
8203 and then not Is_Predefined_Dispatching_Alias
(Prim
)
8205 Validate_Position
(Prim
);
8208 -- An abstract operation cannot be declared in the private part for a
8209 -- visible abstract type, because it can't be overridden outside this
8210 -- package hierarchy. For explicit declarations this is checked at
8211 -- the point of declaration, but for inherited operations it must be
8212 -- done when building the dispatch table.
8214 -- Ada 2005 (AI-251): Primitives associated with interfaces are
8215 -- excluded from this check because interfaces must be visible in
8216 -- the public and private part (RM 7.3 (7.3/2))
8218 -- We disable this check in Relaxed_RM_Semantics mode, to accommodate
8221 if not Relaxed_RM_Semantics
8222 and then Is_Abstract_Type
(Typ
)
8223 and then Is_Abstract_Subprogram
(Prim
)
8224 and then Present
(Alias
(Prim
))
8225 and then not Is_Interface
8226 (Find_Dispatching_Type
(Ultimate_Alias
(Prim
)))
8227 and then No
(Interface_Alias
(Prim
))
8228 and then Is_Derived_Type
(Typ
)
8229 and then In_Private_Part
(Current_Scope
)
8231 List_Containing
(Parent
(Prim
)) =
8232 Private_Declarations
(Package_Specification
(Current_Scope
))
8233 and then Original_View_In_Visible_Part
(Typ
)
8235 -- We exclude Input and Output stream operations because
8236 -- Limited_Controlled inherits useless Input and Output stream
8237 -- operations from Root_Controlled, which can never be overridden.
8238 -- Move this check to sem???
8240 if not Is_TSS
(Prim
, TSS_Stream_Input
)
8242 not Is_TSS
(Prim
, TSS_Stream_Output
)
8245 ("abstract inherited private operation&" &
8246 " must be overridden (RM 3.9.3(10))",
8247 Parent
(Typ
), Prim
);
8251 Next_Elmt
(Prim_Elmt
);
8254 -- Set the final size of the Dispatch Table
8256 Set_DT_Entry_Count
(The_Tag
, UI_From_Int
(DT_Length
));
8258 -- The derived type must have at least as many components as its parent
8259 -- (for root types Etype points to itself and the test cannot fail).
8261 if DT_Entry_Count
(The_Tag
) <
8262 DT_Entry_Count
(First_Tag_Component
(Parent_Typ
))
8264 raise Program_Error
;
8266 end Set_All_DT_Position
;
8268 --------------------------
8269 -- Set_CPP_Constructors --
8270 --------------------------
8272 procedure Set_CPP_Constructors
(Typ
: Entity_Id
) is
8274 function Gen_Parameters_Profile
(E
: Entity_Id
) return List_Id
;
8275 -- Duplicate the parameters profile of the imported C++ constructor
8276 -- adding the "this" pointer to the object as the additional first
8277 -- parameter under the usual form _Init : in out Typ.
8279 ----------------------------
8280 -- Gen_Parameters_Profile --
8281 ----------------------------
8283 function Gen_Parameters_Profile
(E
: Entity_Id
) return List_Id
is
8284 Loc
: constant Source_Ptr
:= Sloc
(E
);
8291 Make_Parameter_Specification
(Loc
,
8292 Defining_Identifier
=>
8293 Make_Defining_Identifier
(Loc
, Name_uInit
),
8295 Out_Present
=> True,
8296 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
8298 P
:= First
(Parameter_Specifications
(Parent
(E
)));
8299 while Present
(P
) loop
8301 Make_Parameter_Specification
(Loc
,
8302 Defining_Identifier
=>
8303 Make_Defining_Identifier
(Loc
,
8304 Chars
=> Chars
(Defining_Identifier
(P
))),
8305 Parameter_Type
=> New_Copy_Tree
(Parameter_Type
(P
)),
8306 Expression
=> New_Copy_Tree
(Expression
(P
))));
8311 end Gen_Parameters_Profile
;
8317 Found
: Boolean := False;
8323 Covers_Default_Constructor
: Entity_Id
:= Empty
;
8325 -- Start of processing for Set_CPP_Constructor
8328 pragma Assert
(Is_CPP_Class
(Typ
));
8330 -- Look for the constructor entities
8332 E
:= Next_Entity
(Typ
);
8333 while Present
(E
) loop
8334 if Ekind
(E
) = E_Function
8335 and then Is_Constructor
(E
)
8339 Parms
:= Gen_Parameters_Profile
(E
);
8340 IP
:= Make_Defining_Identifier
(Loc
, Make_Init_Proc_Name
(Typ
));
8342 -- Case 1: Constructor of untagged type
8344 -- If the C++ class has no virtual methods then the matching Ada
8345 -- type is an untagged record type. In such case there is no need
8346 -- to generate a wrapper of the C++ constructor because the _tag
8347 -- component is not available.
8349 if not Is_Tagged_Type
(Typ
) then
8351 (Make_Subprogram_Declaration
(Loc
,
8353 Make_Procedure_Specification
(Loc
,
8354 Defining_Unit_Name
=> IP
,
8355 Parameter_Specifications
=> Parms
)));
8357 Set_Init_Proc
(Typ
, IP
);
8358 Set_Is_Imported
(IP
);
8359 Set_Is_Constructor
(IP
);
8360 Set_Interface_Name
(IP
, Interface_Name
(E
));
8361 Set_Convention
(IP
, Convention_CPP
);
8363 Set_Has_Completion
(IP
);
8365 -- Case 2: Constructor of a tagged type
8367 -- In this case we generate the IP routine as a wrapper of the
8368 -- C++ constructor because IP must also save a copy of the _tag
8369 -- generated in the C++ side. The copy of the _tag is used by
8370 -- Build_CPP_Init_Procedure to elaborate derivations of C++ types.
8373 -- procedure IP (_init : in out Typ; ...) is
8374 -- procedure ConstructorP (_init : in out Typ; ...);
8375 -- pragma Import (ConstructorP);
8377 -- ConstructorP (_init, ...);
8378 -- if Typ._tag = null then
8379 -- Typ._tag := _init._tag;
8385 Body_Stmts
: constant List_Id
:= New_List
;
8386 Constructor_Id
: Entity_Id
;
8387 Constructor_Decl_Node
: Node_Id
;
8388 Init_Tags_List
: List_Id
;
8391 Constructor_Id
:= Make_Temporary
(Loc
, 'P');
8393 Constructor_Decl_Node
:=
8394 Make_Subprogram_Declaration
(Loc
,
8395 Make_Procedure_Specification
(Loc
,
8396 Defining_Unit_Name
=> Constructor_Id
,
8397 Parameter_Specifications
=> Parms
));
8399 Set_Is_Imported
(Constructor_Id
);
8400 Set_Is_Constructor
(Constructor_Id
);
8401 Set_Interface_Name
(Constructor_Id
, Interface_Name
(E
));
8402 Set_Convention
(Constructor_Id
, Convention_CPP
);
8403 Set_Is_Public
(Constructor_Id
);
8404 Set_Has_Completion
(Constructor_Id
);
8406 -- Build the init procedure as a wrapper of this constructor
8408 Parms
:= Gen_Parameters_Profile
(E
);
8410 -- Invoke the C++ constructor
8413 Actuals
: constant List_Id
:= New_List
;
8417 while Present
(P
) loop
8419 New_Occurrence_Of
(Defining_Identifier
(P
), Loc
));
8423 Append_To
(Body_Stmts
,
8424 Make_Procedure_Call_Statement
(Loc
,
8425 Name
=> New_Occurrence_Of
(Constructor_Id
, Loc
),
8426 Parameter_Associations
=> Actuals
));
8429 -- Initialize copies of C++ primary and secondary tags
8431 Init_Tags_List
:= New_List
;
8438 Tag_Elmt
:= First_Elmt
(Access_Disp_Table
(Typ
));
8439 Tag_Comp
:= First_Tag_Component
(Typ
);
8441 while Present
(Tag_Elmt
)
8442 and then Is_Tag
(Node
(Tag_Elmt
))
8444 -- Skip the following assertion with primary tags
8445 -- because Related_Type is not set on primary tag
8449 (Tag_Comp
= First_Tag_Component
(Typ
)
8450 or else Related_Type
(Node
(Tag_Elmt
))
8451 = Related_Type
(Tag_Comp
));
8453 Append_To
(Init_Tags_List
,
8454 Make_Assignment_Statement
(Loc
,
8456 New_Occurrence_Of
(Node
(Tag_Elmt
), Loc
),
8458 Make_Selected_Component
(Loc
,
8460 Make_Identifier
(Loc
, Name_uInit
),
8462 New_Occurrence_Of
(Tag_Comp
, Loc
))));
8464 Tag_Comp
:= Next_Tag_Component
(Tag_Comp
);
8465 Next_Elmt
(Tag_Elmt
);
8469 Append_To
(Body_Stmts
,
8470 Make_If_Statement
(Loc
,
8475 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))),
8478 Unchecked_Convert_To
(RTE
(RE_Tag
),
8479 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))),
8480 Then_Statements
=> Init_Tags_List
));
8483 Make_Subprogram_Body
(Loc
,
8485 Make_Procedure_Specification
(Loc
,
8486 Defining_Unit_Name
=> IP
,
8487 Parameter_Specifications
=> Parms
),
8488 Declarations
=> New_List
(Constructor_Decl_Node
),
8489 Handled_Statement_Sequence
=>
8490 Make_Handled_Sequence_Of_Statements
(Loc
,
8491 Statements
=> Body_Stmts
,
8492 Exception_Handlers
=> No_List
));
8494 Discard_Node
(IP_Body
);
8495 Set_Init_Proc
(Typ
, IP
);
8499 -- If this constructor has parameters and all its parameters have
8500 -- defaults then it covers the default constructor. The semantic
8501 -- analyzer ensures that only one constructor with defaults covers
8502 -- the default constructor.
8504 if Present
(Parameter_Specifications
(Parent
(E
)))
8505 and then Needs_No_Actuals
(E
)
8507 Covers_Default_Constructor
:= IP
;
8514 -- If there are no constructors, mark the type as abstract since we
8515 -- won't be able to declare objects of that type.
8518 Set_Is_Abstract_Type
(Typ
);
8521 -- Handle constructor that has all its parameters with defaults and
8522 -- hence it covers the default constructor. We generate a wrapper IP
8523 -- which calls the covering constructor.
8525 if Present
(Covers_Default_Constructor
) then
8527 Body_Stmts
: List_Id
;
8530 Loc
:= Sloc
(Covers_Default_Constructor
);
8532 Body_Stmts
:= New_List
(
8533 Make_Procedure_Call_Statement
(Loc
,
8535 New_Occurrence_Of
(Covers_Default_Constructor
, Loc
),
8536 Parameter_Associations
=> New_List
(
8537 Make_Identifier
(Loc
, Name_uInit
))));
8539 IP
:= Make_Defining_Identifier
(Loc
, Make_Init_Proc_Name
(Typ
));
8542 Make_Subprogram_Body
(Loc
,
8544 Make_Procedure_Specification
(Loc
,
8545 Defining_Unit_Name
=> IP
,
8546 Parameter_Specifications
=> New_List
(
8547 Make_Parameter_Specification
(Loc
,
8548 Defining_Identifier
=>
8549 Make_Defining_Identifier
(Loc
, Name_uInit
),
8550 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)))),
8552 Declarations
=> No_List
,
8554 Handled_Statement_Sequence
=>
8555 Make_Handled_Sequence_Of_Statements
(Loc
,
8556 Statements
=> Body_Stmts
,
8557 Exception_Handlers
=> No_List
));
8559 Discard_Node
(IP_Body
);
8560 Set_Init_Proc
(Typ
, IP
);
8564 -- If the CPP type has constructors then it must import also the default
8565 -- C++ constructor. It is required for default initialization of objects
8566 -- of the type. It is also required to elaborate objects of Ada types
8567 -- that are defined as derivations of this CPP type.
8569 if Has_CPP_Constructors
(Typ
)
8570 and then No
(Init_Proc
(Typ
))
8572 Error_Msg_N
("??default constructor must be imported from C++", Typ
);
8574 end Set_CPP_Constructors
;
8576 ---------------------------
8577 -- Set_DT_Position_Value --
8578 ---------------------------
8580 procedure Set_DT_Position_Value
(Prim
: Entity_Id
; Value
: Uint
) is
8582 Set_DT_Position
(Prim
, Value
);
8584 -- Propagate the value to the wrapped subprogram (if one is present)
8586 if Ekind
(Prim
) in E_Function | E_Procedure
8587 and then Is_Primitive_Wrapper
(Prim
)
8588 and then Present
(Wrapped_Entity
(Prim
))
8589 and then Is_Dispatching_Operation
(Wrapped_Entity
(Prim
))
8591 Set_DT_Position
(Wrapped_Entity
(Prim
), Value
);
8593 end Set_DT_Position_Value
;
8595 --------------------------
8596 -- Set_DTC_Entity_Value --
8597 --------------------------
8599 procedure Set_DTC_Entity_Value
8600 (Tagged_Type
: Entity_Id
;
8604 if Present
(Interface_Alias
(Prim
))
8605 and then Is_Interface
8606 (Find_Dispatching_Type
(Interface_Alias
(Prim
)))
8608 Set_DTC_Entity
(Prim
,
8611 Iface
=> Find_Dispatching_Type
(Interface_Alias
(Prim
))));
8613 Set_DTC_Entity
(Prim
,
8614 First_Tag_Component
(Tagged_Type
));
8617 -- Propagate the value to the wrapped subprogram (if one is present)
8619 if Ekind
(Prim
) in E_Function | E_Procedure
8620 and then Is_Primitive_Wrapper
(Prim
)
8621 and then Present
(Wrapped_Entity
(Prim
))
8622 and then Is_Dispatching_Operation
(Wrapped_Entity
(Prim
))
8624 Set_DTC_Entity
(Wrapped_Entity
(Prim
), DTC_Entity
(Prim
));
8626 end Set_DTC_Entity_Value
;
8632 function Tagged_Kind
(T
: Entity_Id
) return Node_Id
is
8633 Conc_Typ
: Entity_Id
;
8634 Loc
: constant Source_Ptr
:= Sloc
(T
);
8638 (Is_Tagged_Type
(T
) and then RTE_Available
(RE_Tagged_Kind
));
8642 if Is_Abstract_Type
(T
) then
8643 if Is_Limited_Record
(T
) then
8644 return New_Occurrence_Of
8645 (RTE
(RE_TK_Abstract_Limited_Tagged
), Loc
);
8647 return New_Occurrence_Of
8648 (RTE
(RE_TK_Abstract_Tagged
), Loc
);
8653 elsif Is_Concurrent_Record_Type
(T
) then
8654 Conc_Typ
:= Corresponding_Concurrent_Type
(T
);
8656 if Present
(Full_View
(Conc_Typ
)) then
8657 Conc_Typ
:= Full_View
(Conc_Typ
);
8660 if Ekind
(Conc_Typ
) = E_Protected_Type
then
8661 return New_Occurrence_Of
(RTE
(RE_TK_Protected
), Loc
);
8663 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
8664 return New_Occurrence_Of
(RTE
(RE_TK_Task
), Loc
);
8667 -- Regular tagged kinds
8670 if Is_Limited_Record
(T
) then
8671 return New_Occurrence_Of
(RTE
(RE_TK_Limited_Tagged
), Loc
);
8673 return New_Occurrence_Of
(RTE
(RE_TK_Tagged
), Loc
);
8682 procedure Write_DT
(Typ
: Entity_Id
) is
8687 -- Protect this procedure against wrong usage. Required because it will
8688 -- be used directly from GDB
8690 if not (Typ
<= Last_Node_Id
)
8691 or else not Is_Tagged_Type
(Typ
)
8693 Write_Str
("wrong usage: Write_DT must be used with tagged types");
8698 Write_Int
(Int
(Typ
));
8700 Write_Name
(Chars
(Typ
));
8702 if Is_Interface
(Typ
) then
8703 Write_Str
(" is interface");
8708 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
8709 while Present
(Elmt
) loop
8710 Prim
:= Node
(Elmt
);
8713 -- Indicate if this primitive will be allocated in the primary
8714 -- dispatch table or in a secondary dispatch table associated
8715 -- with an abstract interface type
8717 if Present
(DTC_Entity
(Prim
)) then
8718 if Is_RTE
(Etype
(DTC_Entity
(Prim
)), RE_Tag
) then
8725 -- Output the node of this primitive operation and its name
8727 Write_Int
(Int
(Prim
));
8730 if Is_Predefined_Dispatching_Operation
(Prim
) then
8731 Write_Str
("(predefined) ");
8734 if Is_Wrapper
(Prim
) then
8735 Write_Str
("(wrapper) ");
8738 -- Prefix the name of the primitive with its corresponding tagged
8739 -- type to facilitate seeing inherited primitives.
8741 if Present
(Alias
(Prim
)) then
8743 (Chars
(Find_Dispatching_Type
(Ultimate_Alias
(Prim
))));
8745 Write_Name
(Chars
(Typ
));
8749 Write_Name
(Chars
(Prim
));
8751 -- Indicate if this primitive has an aliased primitive
8753 if Present
(Alias
(Prim
)) then
8754 Write_Str
(" (alias = ");
8755 Write_Int
(Int
(Alias
(Prim
)));
8757 -- If the DTC_Entity attribute is already set we can also output
8758 -- the name of the interface covered by this primitive (if any).
8760 if Ekind
(Alias
(Prim
)) in E_Function | E_Procedure
8761 and then Present
(DTC_Entity
(Alias
(Prim
)))
8762 and then Is_Interface
(Scope
(DTC_Entity
(Alias
(Prim
))))
8764 Write_Str
(" from interface ");
8765 Write_Name
(Chars
(Scope
(DTC_Entity
(Alias
(Prim
)))));
8768 if Present
(Interface_Alias
(Prim
)) then
8769 Write_Str
(", AI_Alias of ");
8771 if Is_Null_Interface_Primitive
(Interface_Alias
(Prim
)) then
8772 Write_Str
("null primitive ");
8776 (Chars
(Find_Dispatching_Type
(Interface_Alias
(Prim
))));
8778 Write_Int
(Int
(Interface_Alias
(Prim
)));
8784 -- Display the final position of this primitive in its associated
8785 -- (primary or secondary) dispatch table.
8787 if Present
(DTC_Entity
(Prim
))
8788 and then Present
(DT_Position
(Prim
))
8790 Write_Str
(" at #");
8791 Write_Int
(UI_To_Int
(DT_Position
(Prim
)));
8794 if Is_Abstract_Subprogram
(Prim
) then
8795 Write_Str
(" is abstract;");
8797 -- Check if this is a null primitive
8799 elsif Comes_From_Source
(Prim
)
8800 and then Ekind
(Prim
) = E_Procedure
8801 and then Null_Present
(Parent
(Prim
))
8803 Write_Str
(" is null;");
8806 if Is_Eliminated
(Ultimate_Alias
(Prim
)) then
8807 Write_Str
(" (eliminated)");
8810 if Is_Imported
(Prim
)
8811 and then Convention
(Prim
) = Convention_CPP
8813 Write_Str
(" (C++)");