1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, 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
;
74 package body Exp_Disp
is
76 -----------------------
77 -- Local Subprograms --
78 -----------------------
80 function Default_Prim_Op_Position
(E
: Entity_Id
) return Uint
;
81 -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
82 -- of the default primitive operations.
84 procedure Expand_Interface_Thunk
86 Thunk_Id
: out Entity_Id
;
87 Thunk_Code
: out List_Id
;
89 -- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we
90 -- generate additional subprograms (thunks) associated with each primitive
91 -- Prim to have a layout compatible with the C++ ABI. The thunk displaces
92 -- the pointers to the actuals that depend on the controlling type before
93 -- transferring control to the target subprogram. If there is no need to
94 -- generate the thunk, then Thunk_Id is set to Empty. Otherwise Thunk_Id
95 -- is set to the defining identifier of the thunk and Thunk_Code to the
96 -- code generated for the thunk respectively.
98 procedure Expand_Secondary_Stack_Thunk
100 Thunk_Id
: out Entity_Id
;
101 Thunk_Code
: out Node_Id
);
102 -- When a primitive function of a tagged type can dispatch on result and
103 -- the tagged type is not returned on the secondary stack, we generate an
104 -- additional function (thunk) that calls the primitive function with the
105 -- same actuals and move its result onto the secondary stack. This thunk
106 -- is intended to be put into the slot of the primitive function in the
107 -- dispatch table, so as to be invoked in lieu of the primitive function
108 -- in dispatching calls. If there is no need to generate the thunk, then
109 -- Thunk_Id is set to Empty. Otherwise Thunk_Id is set to the defining
110 -- identifier of the thunk and Thunk_Code to the code generated for the
111 -- thunk respectively.
113 function Has_DT
(Typ
: Entity_Id
) return Boolean;
114 pragma Inline
(Has_DT
);
115 -- Returns true if we generate a dispatch table for tagged type Typ
117 function Is_Predefined_Dispatching_Alias
(Prim
: Entity_Id
) return Boolean;
118 -- Returns true if Prim is not a predefined dispatching primitive but it is
119 -- an alias of a predefined dispatching primitive (i.e. through a renaming)
121 function New_Value
(From
: Node_Id
) return Node_Id
;
122 -- From is the original Expression. New_Value is equivalent to a call to
123 -- Duplicate_Subexpr with an explicit dereference when From is an access
126 function Prim_Op_Kind
128 Typ
: Entity_Id
) return Node_Id
;
129 -- Ada 2005 (AI-345): Determine the primitive operation kind of Prim
130 -- according to its type Typ. Return a reference to an RE_Prim_Op_Kind
131 -- enumeration value.
133 function Tagged_Kind
(T
: Entity_Id
) return Node_Id
;
134 -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
135 -- to an RE_Tagged_Kind enumeration value.
137 ----------------------
138 -- Apply_Tag_Checks --
139 ----------------------
141 procedure Apply_Tag_Checks
(Call_Node
: Node_Id
) is
142 Loc
: constant Source_Ptr
:= Sloc
(Call_Node
);
143 Ctrl_Arg
: constant Node_Id
:= Controlling_Argument
(Call_Node
);
144 Ctrl_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Ctrl_Arg
));
145 Param_List
: constant List_Id
:= Parameter_Associations
(Call_Node
);
151 Eq_Prim_Op
: Entity_Id
:= Empty
;
154 if No_Run_Time_Mode
then
155 Error_Msg_CRT
("tagged types", Call_Node
);
159 -- Apply_Tag_Checks is called directly from the semantics, so we
160 -- need a check to see whether expansion is active before proceeding.
161 -- In addition, there is no need to expand the call when compiling
162 -- under restriction No_Dispatching_Calls; the semantic analyzer has
163 -- previously notified the violation of this restriction.
165 if not Expander_Active
166 or else Restriction_Active
(No_Dispatching_Calls
)
171 -- Set subprogram. If this is an inherited operation that was
172 -- overridden, the body that is being called is its alias.
174 Subp
:= Entity
(Name
(Call_Node
));
176 if Present
(Alias
(Subp
))
177 and then Is_Inherited_Operation
(Subp
)
178 and then No
(DTC_Entity
(Subp
))
180 Subp
:= Alias
(Subp
);
183 -- Definition of the class-wide type and the tagged type
185 -- If the controlling argument is itself a tag rather than a tagged
186 -- object, then use the class-wide type associated with the subprogram's
187 -- controlling type. This case can occur when a call to an inherited
188 -- primitive has an actual that originated from a default parameter
189 -- given by a tag-indeterminate call and when there is no other
190 -- controlling argument providing the tag (AI-239 requires dispatching).
191 -- This capability of dispatching directly by tag is also needed by the
192 -- implementation of AI-260 (for the generic dispatching constructors).
194 if Is_RTE
(Ctrl_Typ
, RE_Tag
)
195 or else Is_RTE
(Ctrl_Typ
, RE_Interface_Tag
)
197 CW_Typ
:= Class_Wide_Type
(Find_Dispatching_Type
(Subp
));
199 -- Class_Wide_Type is applied to the expressions used to initialize
200 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
201 -- there are cases where the controlling type is resolved to a specific
202 -- type (such as for designated types of arguments such as CW'Access).
204 elsif Is_Access_Type
(Ctrl_Typ
) then
205 CW_Typ
:= Class_Wide_Type
(Designated_Type
(Ctrl_Typ
));
208 CW_Typ
:= Class_Wide_Type
(Ctrl_Typ
);
211 Typ
:= Find_Specific_Type
(CW_Typ
);
213 if not Is_Limited_Type
(Typ
) then
214 Eq_Prim_Op
:= Find_Prim_Op
(Typ
, Name_Op_Eq
);
217 -- Dispatching call to C++ primitive
219 if Is_CPP_Class
(Typ
) then
222 -- Dispatching call to Ada primitive
224 elsif Present
(Param_List
) then
226 -- Generate the Tag checks when appropriate
228 Param
:= First_Actual
(Call_Node
);
229 while Present
(Param
) loop
231 -- No tag check with itself
233 if Param
= Ctrl_Arg
then
236 -- No tag check for parameter whose type is neither tagged nor
237 -- access to tagged (for access parameters)
239 elsif No
(Find_Controlling_Arg
(Param
)) then
242 -- No tag check for function dispatching on result if the
243 -- Tag given by the context is this one
245 elsif Find_Controlling_Arg
(Param
) = Ctrl_Arg
then
248 -- "=" is the only dispatching operation allowed to get operands
249 -- with incompatible tags (it just returns false). We use
250 -- Duplicate_Subexpr_Move_Checks instead of calling Relocate_Node
251 -- because the value will be duplicated to check the tags.
253 elsif Subp
= Eq_Prim_Op
then
256 -- No check in presence of suppress flags
258 elsif Tag_Checks_Suppressed
(Etype
(Param
))
259 or else (Is_Access_Type
(Etype
(Param
))
260 and then Tag_Checks_Suppressed
261 (Designated_Type
(Etype
(Param
))))
265 -- Optimization: no tag checks if the parameters are identical
267 elsif Is_Entity_Name
(Param
)
268 and then Is_Entity_Name
(Ctrl_Arg
)
269 and then Entity
(Param
) = Entity
(Ctrl_Arg
)
273 -- Now we need to generate the Tag check
276 -- Generate code for tag equality check
278 -- Perhaps should have Checks.Apply_Tag_Equality_Check???
280 Insert_Action
(Ctrl_Arg
,
281 Make_Implicit_If_Statement
(Call_Node
,
285 Make_Selected_Component
(Loc
,
286 Prefix
=> New_Value
(Ctrl_Arg
),
289 (First_Tag_Component
(Typ
), Loc
)),
292 Make_Selected_Component
(Loc
,
294 Unchecked_Convert_To
(Typ
, New_Value
(Param
)),
297 (First_Tag_Component
(Typ
), Loc
))),
300 New_List
(New_Constraint_Error
(Loc
))));
306 end Apply_Tag_Checks
;
308 ------------------------
309 -- Building_Static_DT --
310 ------------------------
312 function Building_Static_DT
(Typ
: Entity_Id
) return Boolean is
313 Root_Typ
: Entity_Id
:= Root_Type
(Typ
);
317 -- Handle private types
319 if Present
(Full_View
(Root_Typ
)) then
320 Root_Typ
:= Full_View
(Root_Typ
);
324 Building_Static_Dispatch_Tables
325 and then Is_Library_Level_Tagged_Type
(Typ
)
327 -- If the type is derived from a CPP class we cannot statically
328 -- build the dispatch tables because we must inherit primitives
329 -- from the CPP side.
331 and then not Is_CPP_Class
(Root_Typ
);
333 if not Static_DT
then
334 Check_Restriction
(Static_Dispatch_Tables
, Typ
);
338 end Building_Static_DT
;
340 ----------------------------------
341 -- Building_Static_Secondary_DT --
342 ----------------------------------
344 function Building_Static_Secondary_DT
(Typ
: Entity_Id
) return Boolean is
345 Full_Typ
: Entity_Id
:= Typ
;
346 Root_Typ
: Entity_Id
:= Root_Type
(Typ
);
350 -- Handle private types
352 if Present
(Full_View
(Typ
)) then
353 Full_Typ
:= Full_View
(Typ
);
356 if Present
(Full_View
(Root_Typ
)) then
357 Root_Typ
:= Full_View
(Root_Typ
);
361 Building_Static_DT
(Full_Typ
)
362 and then not Is_Interface
(Full_Typ
)
363 and then Has_Interfaces
(Full_Typ
)
364 and then (Full_Typ
= Root_Typ
365 or else not Is_Variable_Size_Record
(Etype
(Full_Typ
)));
368 and then not Is_Interface
(Full_Typ
)
369 and then Has_Interfaces
(Full_Typ
)
371 Check_Restriction
(Static_Dispatch_Tables
, Typ
);
375 end Building_Static_Secondary_DT
;
377 ----------------------------------
378 -- Build_Static_Dispatch_Tables --
379 ----------------------------------
381 procedure Build_Static_Dispatch_Tables
(N
: Node_Id
) is
382 Target_List
: List_Id
;
384 procedure Build_Dispatch_Tables
(List
: List_Id
);
385 -- Build the static dispatch table of tagged types found in the list of
386 -- declarations. The generated nodes are added at the end of Target_List
388 procedure Build_Package_Dispatch_Tables
(N
: Node_Id
);
389 -- Build static dispatch tables associated with package declaration N
391 procedure Make_And_Insert_Dispatch_Table
(Typ
: Entity_Id
);
392 -- Build the dispatch table of the tagged type Typ and insert it at the
393 -- end of Target_List after wrapping it in the Actions list of a freeze
394 -- node, so that it is skipped by Sem_Elab (Expand_Freeze_Record_Type
395 -- does the same for nonstatic dispatch tables).
397 ---------------------------
398 -- Build_Dispatch_Tables --
399 ---------------------------
401 procedure Build_Dispatch_Tables
(List
: List_Id
) is
406 while Present
(D
) loop
408 -- Handle nested packages and package bodies recursively. The
409 -- generated code is placed on the Target_List established for
410 -- the enclosing compilation unit.
412 if Nkind
(D
) = N_Package_Declaration
then
413 Build_Package_Dispatch_Tables
(D
);
415 elsif Nkind
(D
) = N_Package_Body
then
416 Build_Dispatch_Tables
(Declarations
(D
));
418 elsif Nkind
(D
) = N_Package_Body_Stub
419 and then Present
(Library_Unit
(D
))
421 Build_Dispatch_Tables
422 (Declarations
(Proper_Body
(Unit
(Library_Unit
(D
)))));
424 -- Handle full type declarations and derivations of library level
428 N_Full_Type_Declaration | N_Derived_Type_Definition
429 and then Is_Library_Level_Tagged_Type
(Defining_Entity
(D
))
430 and then Ekind
(Defining_Entity
(D
)) /= E_Record_Subtype
431 and then not Is_Private_Type
(Defining_Entity
(D
))
433 -- We do not generate dispatch tables for the internal types
434 -- created for a type extension with unknown discriminants
435 -- The needed information is shared with the source type,
436 -- See Expand_N_Record_Extension.
438 if Is_Underlying_Record_View
(Defining_Entity
(D
))
440 (not Comes_From_Source
(Defining_Entity
(D
))
442 Has_Unknown_Discriminants
(Etype
(Defining_Entity
(D
)))
444 not Comes_From_Source
445 (First_Subtype
(Defining_Entity
(D
))))
449 Make_And_Insert_Dispatch_Table
(Defining_Entity
(D
));
452 -- Handle private types of library level tagged types. We must
453 -- exchange the private and full-view to ensure the correct
454 -- expansion. If the full view is a synchronized type ignore
455 -- the type because the table will be built for the corresponding
456 -- record type, that has its own declaration.
458 elsif (Nkind
(D
) = N_Private_Type_Declaration
459 or else Nkind
(D
) = N_Private_Extension_Declaration
)
460 and then Present
(Full_View
(Defining_Entity
(D
)))
463 E1
: constant Entity_Id
:= Defining_Entity
(D
);
464 E2
: constant Entity_Id
:= Full_View
(E1
);
467 if Is_Library_Level_Tagged_Type
(E2
)
468 and then Ekind
(E2
) /= E_Record_Subtype
469 and then not Is_Concurrent_Type
(E2
)
471 Exchange_Declarations
(E1
);
472 Make_And_Insert_Dispatch_Table
(E1
);
473 Exchange_Declarations
(E2
);
480 end Build_Dispatch_Tables
;
482 -----------------------------------
483 -- Build_Package_Dispatch_Tables --
484 -----------------------------------
486 procedure Build_Package_Dispatch_Tables
(N
: Node_Id
) is
487 Spec
: constant Node_Id
:= Specification
(N
);
488 Id
: constant Entity_Id
:= Defining_Entity
(N
);
489 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
490 Priv_Decls
: constant List_Id
:= Private_Declarations
(Spec
);
495 if Present
(Priv_Decls
) then
496 Build_Dispatch_Tables
(Vis_Decls
);
497 Build_Dispatch_Tables
(Priv_Decls
);
499 elsif Present
(Vis_Decls
) then
500 Build_Dispatch_Tables
(Vis_Decls
);
504 end Build_Package_Dispatch_Tables
;
506 ------------------------------------
507 -- Make_And_Insert_Dispatch_Table --
508 ------------------------------------
510 procedure Make_And_Insert_Dispatch_Table
(Typ
: Entity_Id
) is
511 F_Typ
: constant Entity_Id
:= Create_Itype
(E_Class_Wide_Type
, Typ
);
512 -- The code generator discards freeze nodes of CW types after
513 -- evaluating their side effects, so create an artificial one.
515 F_Nod
: constant Node_Id
:= Make_Freeze_Entity
(Sloc
(Typ
));
518 Set_Is_Frozen
(F_Typ
);
519 Set_Entity
(F_Nod
, F_Typ
);
520 Set_Actions
(F_Nod
, Make_DT
(Typ
));
522 Insert_After_And_Analyze
(Last
(Target_List
), F_Nod
);
523 end Make_And_Insert_Dispatch_Table
;
525 -- Start of processing for Build_Static_Dispatch_Tables
528 if Nkind
(N
) = N_Package_Declaration
then
530 Spec
: constant Node_Id
:= Specification
(N
);
531 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
532 Priv_Decls
: constant List_Id
:= Private_Declarations
(Spec
);
535 if Present
(Priv_Decls
)
536 and then Is_Non_Empty_List
(Priv_Decls
)
538 Target_List
:= Priv_Decls
;
540 elsif not Present
(Vis_Decls
) then
541 Target_List
:= New_List
;
542 Set_Private_Declarations
(Spec
, Target_List
);
544 Target_List
:= Vis_Decls
;
547 Build_Package_Dispatch_Tables
(N
);
550 else pragma Assert
(Nkind
(N
) = N_Package_Body
);
552 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(N
);
555 Push_Scope
(Spec_Id
);
556 Target_List
:= Declarations
(N
);
557 Build_Dispatch_Tables
(Target_List
);
561 end Build_Static_Dispatch_Tables
;
563 ------------------------------
564 -- Convert_Tag_To_Interface --
565 ------------------------------
567 function Convert_Tag_To_Interface
569 Expr
: Node_Id
) return Node_Id
571 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
572 Anon_Type
: Entity_Id
;
576 pragma Assert
(Is_Class_Wide_Type
(Typ
)
577 and then Is_Interface
(Typ
)
579 ((Nkind
(Expr
) = N_Selected_Component
580 and then Is_Tag
(Entity
(Selector_Name
(Expr
))))
582 (Nkind
(Expr
) = N_Function_Call
583 and then Is_RTE
(Entity
(Name
(Expr
)), RE_Displace
))));
585 Anon_Type
:= Create_Itype
(E_Anonymous_Access_Type
, Expr
);
586 Set_Directly_Designated_Type
(Anon_Type
, Typ
);
587 Set_Etype
(Anon_Type
, Anon_Type
);
588 Set_Can_Never_Be_Null
(Anon_Type
);
590 -- Decorate the size and alignment attributes of the anonymous access
591 -- type, as required by the back end.
593 Layout_Type
(Anon_Type
);
595 if Nkind
(Expr
) = N_Selected_Component
596 and then Is_Tag
(Entity
(Selector_Name
(Expr
)))
599 Make_Explicit_Dereference
(Loc
,
600 Unchecked_Convert_To
(Anon_Type
,
601 Make_Attribute_Reference
(Loc
,
603 Attribute_Name
=> Name_Address
)));
606 Make_Explicit_Dereference
(Loc
,
607 Unchecked_Convert_To
(Anon_Type
, Expr
));
611 end Convert_Tag_To_Interface
;
617 function CPP_Num_Prims
(Typ
: Entity_Id
) return Nat
is
619 Tag_Comp
: Entity_Id
;
622 if not Is_Tagged_Type
(Typ
)
623 or else not Is_CPP_Class
(Root_Type
(Typ
))
628 CPP_Typ
:= Enclosing_CPP_Parent
(Typ
);
629 Tag_Comp
:= First_Tag_Component
(CPP_Typ
);
631 -- If number of primitives already set in the tag component, use it
633 if Present
(Tag_Comp
)
634 and then Present
(DT_Entry_Count
(Tag_Comp
))
636 return UI_To_Int
(DT_Entry_Count
(Tag_Comp
));
638 -- Otherwise, count the primitives of the enclosing CPP type
641 return List_Length
(Primitive_Operations
(CPP_Typ
));
646 ------------------------------
647 -- Default_Prim_Op_Position --
648 ------------------------------
650 function Default_Prim_Op_Position
(E
: Entity_Id
) return Uint
is
651 TSS_Name
: TSS_Name_Type
;
654 Get_Name_String
(Chars
(E
));
657 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
659 if Chars
(E
) = Name_uSize
then
662 elsif TSS_Name
= TSS_Stream_Read
then
665 elsif TSS_Name
= TSS_Stream_Write
then
668 elsif TSS_Name
= TSS_Stream_Input
then
671 elsif TSS_Name
= TSS_Stream_Output
then
674 elsif Chars
(E
) = Name_Op_Eq
then
677 elsif Chars
(E
) = Name_uAssign
then
680 elsif TSS_Name
= TSS_Deep_Adjust
then
683 elsif TSS_Name
= TSS_Deep_Finalize
then
686 elsif TSS_Name
= TSS_Put_Image
then
689 -- In VM targets unconditionally allow obtaining the position associated
690 -- with predefined interface primitives since in these platforms any
691 -- tagged type has these primitives.
693 elsif Ada_Version
>= Ada_2005
or else not Tagged_Type_Expansion
then
694 if Chars
(E
) = Name_uDisp_Asynchronous_Select
then
697 elsif Chars
(E
) = Name_uDisp_Conditional_Select
then
700 elsif Chars
(E
) = Name_uDisp_Get_Prim_Op_Kind
then
703 elsif Chars
(E
) = Name_uDisp_Get_Task_Id
then
706 elsif Chars
(E
) = Name_uDisp_Requeue
then
709 elsif Chars
(E
) = Name_uDisp_Timed_Select
then
715 end Default_Prim_Op_Position
;
717 ----------------------
718 -- Elab_Flag_Needed --
719 ----------------------
721 function Elab_Flag_Needed
(Typ
: Entity_Id
) return Boolean is
723 return Ada_Version
>= Ada_2005
724 and then not Is_Interface
(Typ
)
725 and then Has_Interfaces
(Typ
)
726 and then not Building_Static_DT
(Typ
);
727 end Elab_Flag_Needed
;
729 -----------------------------
730 -- Expand_Dispatching_Call --
731 -----------------------------
733 procedure Expand_Dispatching_Call
(Call_Node
: Node_Id
) is
734 Loc
: constant Source_Ptr
:= Sloc
(Call_Node
);
735 Call_Typ
: constant Entity_Id
:= Etype
(Call_Node
);
737 Ctrl_Arg
: constant Node_Id
:= Controlling_Argument
(Call_Node
);
738 Ctrl_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Ctrl_Arg
));
739 Param_List
: constant List_Id
:= Parameter_Associations
(Call_Node
);
744 New_Call_Name
: Node_Id
;
745 New_Params
: List_Id
:= No_List
;
747 Subp_Ptr_Typ
: Entity_Id
;
748 Subp_Typ
: Entity_Id
;
750 Eq_Prim_Op
: Entity_Id
:= Empty
;
751 Controlling_Tag
: Node_Id
;
753 function New_Value
(From
: Node_Id
) return Node_Id
;
754 -- From is the original Expression. New_Value is equivalent to a call
755 -- to Duplicate_Subexpr with an explicit dereference when From is an
762 function New_Value
(From
: Node_Id
) return Node_Id
is
763 Res
: constant Node_Id
:= Duplicate_Subexpr
(From
);
765 if Is_Access_Type
(Etype
(From
)) then
767 Make_Explicit_Dereference
(Sloc
(From
),
777 SCIL_Node
: Node_Id
:= Empty
;
778 SCIL_Related_Node
: Node_Id
:= Call_Node
;
780 -- Start of processing for Expand_Dispatching_Call
783 if No_Run_Time_Mode
then
784 Error_Msg_CRT
("tagged types", Call_Node
);
788 -- Expand_Dispatching_Call is called directly from the semantics, so we
789 -- only proceed if the expander is active.
791 if not Expander_Active
793 -- And there is no need to expand the call if we are compiling under
794 -- restriction No_Dispatching_Calls; the semantic analyzer has
795 -- previously notified the violation of this restriction.
797 or else Restriction_Active
(No_Dispatching_Calls
)
799 -- No action needed if the dispatching call has been already expanded
801 or else Is_Expanded_Dispatching_Call
(Name
(Call_Node
))
806 -- Set subprogram. If this is an inherited operation that was
807 -- overridden, the body that is being called is its alias.
809 Subp
:= Entity
(Name
(Call_Node
));
811 if Present
(Alias
(Subp
))
812 and then Is_Inherited_Operation
(Subp
)
813 and then No
(DTC_Entity
(Subp
))
815 Subp
:= Alias
(Subp
);
818 -- Definition of the class-wide type and the tagged type
820 -- If the controlling argument is itself a tag rather than a tagged
821 -- object, then use the class-wide type associated with the subprogram's
822 -- controlling type. This case can occur when a call to an inherited
823 -- primitive has an actual that originated from a default parameter
824 -- given by a tag-indeterminate call and when there is no other
825 -- controlling argument providing the tag (AI-239 requires dispatching).
826 -- This capability of dispatching directly by tag is also needed by the
827 -- implementation of AI-260 (for the generic dispatching constructors).
829 if Is_RTE
(Ctrl_Typ
, RE_Tag
)
830 or else Is_RTE
(Ctrl_Typ
, RE_Interface_Tag
)
832 CW_Typ
:= Class_Wide_Type
(Find_Dispatching_Type
(Subp
));
834 -- Class_Wide_Type is applied to the expressions used to initialize
835 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
836 -- there are cases where the controlling type is resolved to a specific
837 -- type (such as for designated types of arguments such as CW'Access).
839 elsif Is_Access_Type
(Ctrl_Typ
) then
840 CW_Typ
:= Class_Wide_Type
(Designated_Type
(Ctrl_Typ
));
843 CW_Typ
:= Class_Wide_Type
(Ctrl_Typ
);
846 Typ
:= Find_Specific_Type
(CW_Typ
);
848 -- The tagged type of a dispatching call must be frozen at this stage
850 pragma Assert
(Is_Frozen
(Typ
));
852 if not Is_Limited_Type
(Typ
) then
853 Eq_Prim_Op
:= Find_Prim_Op
(Typ
, Name_Op_Eq
);
856 -- Dispatching call to C++ primitive. Create a new parameter list
857 -- with no tag checks.
859 New_Params
:= New_List
;
861 if Is_CPP_Class
(Typ
) then
862 Param
:= First_Actual
(Call_Node
);
863 while Present
(Param
) loop
864 Append_To
(New_Params
, Relocate_Node
(Param
));
868 -- Dispatching call to Ada primitive
870 elsif Present
(Param_List
) then
871 Apply_Tag_Checks
(Call_Node
);
873 Param
:= First_Actual
(Call_Node
);
874 while Present
(Param
) loop
876 -- Cases in which we may have generated run-time checks. Note that
877 -- we strip any qualification from Param before comparing with the
878 -- already-stripped controlling argument.
880 if Unqualify
(Param
) = Ctrl_Arg
or else Subp
= Eq_Prim_Op
then
881 Append_To
(New_Params
,
882 Duplicate_Subexpr_Move_Checks
(Param
));
884 elsif Nkind
(Parent
(Param
)) /= N_Parameter_Association
885 or else not Is_Accessibility_Actual
(Parent
(Param
))
887 Append_To
(New_Params
, Relocate_Node
(Param
));
894 -- Generate the appropriate subprogram designated type
896 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, Call_Node
);
897 Copy_Strub_Mode
(Subp_Typ
, Subp
);
898 Set_Convention
(Subp_Typ
, Convention
(Subp
));
900 -- If this is a function and it has a controlling tagged result, then
901 -- the call is dispatching on result and returns the class-wide type.
903 if Ekind
(Subp
) = E_Function
904 and then Has_Controlling_Result
(Subp
)
905 and then Is_Tagged_Type
(Etype
(Subp
))
907 Set_Etype
(Subp_Typ
, Class_Wide_Type
(Etype
(Subp
)));
908 Set_Returns_By_Ref
(Subp_Typ
, True);
910 Set_Etype
(Subp_Typ
, Etype
(Subp
));
911 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
914 -- Notify gigi that the designated type is a dispatching primitive
916 Set_Is_Dispatch_Table_Entity
(Subp_Typ
);
918 -- Create a new list of parameters which is a copy of the old formal
919 -- list including the creation of a new set of matching entities.
922 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
923 New_Formal
: Entity_Id
;
924 Last_Formal
: Entity_Id
:= Empty
;
927 if Present
(Old_Formal
) then
928 New_Formal
:= New_Copy
(Old_Formal
);
929 Set_First_Entity
(Subp_Typ
, New_Formal
);
930 Param
:= First_Actual
(Call_Node
);
933 Set_Scope
(New_Formal
, Subp_Typ
);
935 -- Change all the controlling argument types to be class-wide
936 -- to avoid a recursion in dispatching.
938 if Is_Controlling_Formal
(New_Formal
) then
939 Set_Etype
(New_Formal
, Etype
(Param
));
942 -- If the type of the formal is an itype, there was code here
943 -- introduced in 1998 in revision 1.46, to create a new itype
944 -- by copy. This seems useless, and in fact leads to semantic
945 -- errors when the itype is the completion of a type derived
946 -- from a private type.
948 Last_Formal
:= New_Formal
;
949 Next_Formal
(Old_Formal
);
950 exit when No
(Old_Formal
);
952 Link_Entities
(New_Formal
, New_Copy
(Old_Formal
));
953 Next_Entity
(New_Formal
);
957 Unlink_Next_Entity
(New_Formal
);
958 Set_Last_Entity
(Subp_Typ
, Last_Formal
);
961 -- Now that the explicit formals have been duplicated, any extra
962 -- formals needed by the subprogram must be duplicated; we know
963 -- that extra formals are available because they were added when
964 -- the tagged type was frozen (see Expand_Freeze_Record_Type).
966 pragma Assert
(Is_Frozen
(Typ
));
968 -- Warning: The addition of the extra formals cannot be performed
969 -- here invoking Create_Extra_Formals since we must ensure that all
970 -- the extra formals of the pointer type and the target subprogram
971 -- match (and for functions that return a tagged type the profile of
972 -- the built subprogram type always returns a class-wide type, which
973 -- may affect the addition of some extra formals).
975 if Present
(Last_Formal
)
976 and then Present
(Extra_Formal
(Last_Formal
))
978 Old_Formal
:= Extra_Formal
(Last_Formal
);
979 New_Formal
:= New_Copy
(Old_Formal
);
980 Set_Scope
(New_Formal
, Subp_Typ
);
982 Set_Extra_Formal
(Last_Formal
, New_Formal
);
983 Set_Extra_Formals
(Subp_Typ
, New_Formal
);
985 if Ekind
(Subp
) = E_Function
986 and then Present
(Extra_Accessibility_Of_Result
(Subp
))
987 and then Extra_Accessibility_Of_Result
(Subp
) = Old_Formal
989 Set_Extra_Accessibility_Of_Result
(Subp_Typ
, New_Formal
);
992 Old_Formal
:= Extra_Formal
(Old_Formal
);
993 while Present
(Old_Formal
) loop
994 Set_Extra_Formal
(New_Formal
, New_Copy
(Old_Formal
));
995 New_Formal
:= Extra_Formal
(New_Formal
);
996 Set_Scope
(New_Formal
, Subp_Typ
);
998 if Ekind
(Subp
) = E_Function
999 and then Present
(Extra_Accessibility_Of_Result
(Subp
))
1000 and then Extra_Accessibility_Of_Result
(Subp
) = Old_Formal
1002 Set_Extra_Accessibility_Of_Result
(Subp_Typ
, New_Formal
);
1005 Old_Formal
:= Extra_Formal
(Old_Formal
);
1010 -- Generate the appropriate subprogram pointer type and decorate it
1012 Subp_Ptr_Typ
:= Create_Itype
(E_Access_Subprogram_Type
, Call_Node
);
1013 Set_Etype
(Subp_Ptr_Typ
, Subp_Ptr_Typ
);
1014 Set_Directly_Designated_Type
(Subp_Ptr_Typ
, Subp_Typ
);
1015 Set_Convention
(Subp_Ptr_Typ
, Convention
(Subp_Typ
));
1016 Layout_Type
(Subp_Ptr_Typ
);
1018 -- If the controlling argument is a value of type Ada.Tag or an abstract
1019 -- interface class-wide type then use it directly. Otherwise, the tag
1020 -- must be extracted from the controlling object.
1022 if Is_RTE
(Ctrl_Typ
, RE_Tag
)
1023 or else Is_RTE
(Ctrl_Typ
, RE_Interface_Tag
)
1025 Controlling_Tag
:= Duplicate_Subexpr
(Ctrl_Arg
);
1027 -- Extract the tag from an unchecked type conversion. Done to avoid
1028 -- the expansion of additional code just to obtain the value of such
1029 -- tag because the current management of interface type conversions
1030 -- generates in some cases this unchecked type conversion with the
1031 -- tag of the object (see Expand_Interface_Conversion).
1033 elsif Nkind
(Ctrl_Arg
) = N_Unchecked_Type_Conversion
1035 (Is_RTE
(Etype
(Expression
(Ctrl_Arg
)), RE_Tag
)
1037 Is_RTE
(Etype
(Expression
(Ctrl_Arg
)), RE_Interface_Tag
))
1039 Controlling_Tag
:= Duplicate_Subexpr
(Expression
(Ctrl_Arg
));
1041 -- Ada 2005 (AI-251): Abstract interface class-wide type
1043 elsif Is_Interface
(Ctrl_Typ
)
1044 and then Is_Class_Wide_Type
(Ctrl_Typ
)
1046 Controlling_Tag
:= Duplicate_Subexpr
(Ctrl_Arg
);
1048 elsif Is_Access_Type
(Ctrl_Typ
) then
1050 Make_Selected_Component
(Loc
,
1052 Make_Explicit_Dereference
(Loc
,
1053 Duplicate_Subexpr_Move_Checks
(Ctrl_Arg
)),
1054 Selector_Name
=> New_Occurrence_Of
(DTC_Entity
(Subp
), Loc
));
1058 Make_Selected_Component
(Loc
,
1059 Prefix
=> Duplicate_Subexpr_Move_Checks
(Ctrl_Arg
),
1060 Selector_Name
=> New_Occurrence_Of
(DTC_Entity
(Subp
), Loc
));
1063 -- Handle dispatching calls to predefined primitives
1065 if Is_Predefined_Dispatching_Operation
(Subp
)
1066 or else Is_Predefined_Dispatching_Alias
(Subp
)
1068 Build_Get_Predefined_Prim_Op_Address
(Loc
,
1069 Tag_Node
=> Controlling_Tag
,
1070 Position
=> DT_Position
(Subp
),
1071 New_Node
=> New_Node
);
1073 -- Handle dispatching calls to user-defined primitives
1076 Build_Get_Prim_Op_Address
(Loc
,
1077 Typ
=> Underlying_Type
(Find_Dispatching_Type
(Subp
)),
1078 Tag_Node
=> Controlling_Tag
,
1079 Position
=> DT_Position
(Subp
),
1080 New_Node
=> New_Node
);
1084 Unchecked_Convert_To
(Subp_Ptr_Typ
, New_Node
);
1086 -- Generate the SCIL node for this dispatching call. Done now because
1087 -- attribute SCIL_Controlling_Tag must be set after the new call name
1088 -- is built to reference the nodes that will see the SCIL backend
1089 -- (because Build_Get_Prim_Op_Address generates an unchecked type
1090 -- conversion which relocates the controlling tag node).
1092 if Generate_SCIL
then
1093 SCIL_Node
:= Make_SCIL_Dispatching_Call
(Sloc
(Call_Node
));
1094 Set_SCIL_Entity
(SCIL_Node
, Typ
);
1095 Set_SCIL_Target_Prim
(SCIL_Node
, Subp
);
1097 -- Common case: the controlling tag is the tag of an object
1098 -- (for example, obj.tag)
1100 if Nkind
(Controlling_Tag
) = N_Selected_Component
then
1101 Set_SCIL_Controlling_Tag
(SCIL_Node
, Controlling_Tag
);
1103 -- Handle renaming of selected component
1105 elsif Nkind
(Controlling_Tag
) = N_Identifier
1106 and then Nkind
(Parent
(Entity
(Controlling_Tag
))) =
1107 N_Object_Renaming_Declaration
1108 and then Nkind
(Name
(Parent
(Entity
(Controlling_Tag
)))) =
1109 N_Selected_Component
1111 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1112 Name
(Parent
(Entity
(Controlling_Tag
))));
1114 -- If the controlling tag is an identifier, the SCIL node references
1115 -- the corresponding object or parameter declaration
1117 elsif Nkind
(Controlling_Tag
) = N_Identifier
1118 and then Nkind
(Parent
(Entity
(Controlling_Tag
))) in
1119 N_Object_Declaration | N_Parameter_Specification
1121 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1122 Parent
(Entity
(Controlling_Tag
)));
1124 -- If the controlling tag is a dereference, the SCIL node references
1125 -- the corresponding object or parameter declaration
1127 elsif Nkind
(Controlling_Tag
) = N_Explicit_Dereference
1128 and then Nkind
(Prefix
(Controlling_Tag
)) = N_Identifier
1129 and then Nkind
(Parent
(Entity
(Prefix
(Controlling_Tag
)))) in
1130 N_Object_Declaration | N_Parameter_Specification
1132 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1133 Parent
(Entity
(Prefix
(Controlling_Tag
))));
1135 -- For a direct reference of the tag of the type the SCIL node
1136 -- references the internal object declaration containing the tag
1139 elsif Nkind
(Controlling_Tag
) = N_Attribute_Reference
1140 and then Attribute_Name
(Controlling_Tag
) = Name_Tag
1142 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1146 (Access_Disp_Table
(Entity
(Prefix
(Controlling_Tag
)))))));
1148 -- Interfaces are not supported. For now we leave the SCIL node
1149 -- decorated with the Controlling_Tag. More work needed here???
1151 elsif Is_Interface
(Etype
(Controlling_Tag
)) then
1152 Set_SCIL_Controlling_Tag
(SCIL_Node
, Controlling_Tag
);
1155 pragma Assert
(False);
1160 if Nkind
(Call_Node
) = N_Function_Call
then
1162 Make_Function_Call
(Loc
,
1163 Name
=> New_Call_Name
,
1164 Parameter_Associations
=> New_Params
);
1166 -- If this is a dispatching "=", we must first compare the tags so
1167 -- we generate: x.tag = y.tag and then x = y
1169 if Subp
= Eq_Prim_Op
then
1170 Param
:= First_Actual
(Call_Node
);
1176 Make_Selected_Component
(Loc
,
1177 Prefix
=> New_Value
(Param
),
1179 New_Occurrence_Of
(First_Tag_Component
(Typ
),
1183 Make_Selected_Component
(Loc
,
1185 Unchecked_Convert_To
(Typ
,
1186 New_Value
(Next_Actual
(Param
))),
1189 (First_Tag_Component
(Typ
), Loc
))),
1190 Right_Opnd
=> New_Call
);
1192 SCIL_Related_Node
:= Right_Opnd
(New_Call
);
1197 Make_Procedure_Call_Statement
(Loc
,
1198 Name
=> New_Call_Name
,
1199 Parameter_Associations
=> New_Params
);
1202 -- Register the dispatching call in the call graph nodes table
1204 Register_CG_Node
(Call_Node
);
1206 Rewrite
(Call_Node
, New_Call
);
1208 -- Associate the SCIL node of this dispatching call
1210 if Generate_SCIL
then
1211 Set_SCIL_Node
(SCIL_Related_Node
, SCIL_Node
);
1214 -- Suppress all checks during the analysis of the expanded code to avoid
1215 -- the generation of spurious warnings under ZFP run-time.
1217 Analyze_And_Resolve
(Call_Node
, Call_Typ
, Suppress
=> All_Checks
);
1218 end Expand_Dispatching_Call
;
1220 ---------------------------------
1221 -- Expand_Interface_Conversion --
1222 ---------------------------------
1224 procedure Expand_Interface_Conversion
(N
: Node_Id
) is
1225 function Underlying_Record_Type
(Typ
: Entity_Id
) return Entity_Id
;
1226 -- Return the underlying record type of Typ
1228 ----------------------------
1229 -- Underlying_Record_Type --
1230 ----------------------------
1232 function Underlying_Record_Type
(Typ
: Entity_Id
) return Entity_Id
is
1233 E
: Entity_Id
:= Typ
;
1236 -- Handle access types
1238 if Is_Access_Type
(E
) then
1239 E
:= Directly_Designated_Type
(E
);
1242 -- Handle class-wide types. This conversion can appear explicitly in
1243 -- the source code. Example: I'Class (Obj)
1245 if Is_Class_Wide_Type
(E
) then
1249 -- If the target type is a tagged synchronized type, the dispatch
1250 -- table info is in the corresponding record type.
1252 if Is_Concurrent_Type
(E
) then
1253 E
:= Corresponding_Record_Type
(E
);
1256 -- Handle private types
1258 E
:= Underlying_Type
(E
);
1262 return Base_Type
(E
);
1263 end Underlying_Record_Type
;
1267 Loc
: constant Source_Ptr
:= Sloc
(N
);
1268 Etyp
: constant Entity_Id
:= Etype
(N
);
1269 Operand
: constant Node_Id
:= Expression
(N
);
1270 Operand_Typ
: Entity_Id
:= Etype
(Operand
);
1272 Iface_Typ
: constant Entity_Id
:= Underlying_Record_Type
(Etype
(N
));
1273 Iface_Tag
: Entity_Id
;
1274 Is_Static
: Boolean;
1276 -- Start of processing for Expand_Interface_Conversion
1279 -- Freeze the entity associated with the target interface to have
1280 -- available the attribute Access_Disp_Table.
1282 Freeze_Before
(N
, Iface_Typ
);
1284 -- Ada 2005 (AI-345): Handle synchronized interface type derivations
1286 if Is_Concurrent_Type
(Operand_Typ
) then
1287 Operand_Typ
:= Base_Type
(Corresponding_Record_Type
(Operand_Typ
));
1290 -- No displacement of the pointer to the object needed when the type of
1291 -- the operand is not an interface type and the interface is one of
1292 -- its parent types (since they share the primary dispatch table).
1295 Opnd
: Entity_Id
:= Operand_Typ
;
1298 if Is_Access_Type
(Opnd
) then
1299 Opnd
:= Designated_Type
(Opnd
);
1302 Opnd
:= Underlying_Record_Type
(Opnd
);
1304 if not Is_Interface
(Opnd
)
1305 and then Is_Ancestor
(Iface_Typ
, Opnd
, Use_Full_View
=> True)
1309 -- When the target type is an interface type that is an ancestor of
1310 -- the operand type, it is generally safe to skip generating code to
1311 -- displace the pointer to the object to reference the secondary
1312 -- dispatch table of the target interface type. Two scenarios are
1314 -- 1) The operand type is a regular tagged type
1315 -- 2) The operand type is an interface type
1316 -- In the former case the target interface and the regular tagged
1317 -- type share the primary dispatch table of the object; in the latter
1318 -- case the operand interface has all the primitives of the ancestor
1319 -- interface type (and exactly in the same dispatch table slots).
1321 -- The exception to this general rule is when the underlying object
1322 -- is built by means of a dispatching constructor (since in such case
1323 -- the expansion of the constructor call is a direct call to an
1324 -- object primitive, i.e. without thunks, and the expansion of
1325 -- the constructor call adds this explicit conversion to the target
1326 -- interface type to force the displacement of the pointer to the
1327 -- object to reference the corresponding secondary dispatch table
1328 -- (cf. Make_DT and Expand_Dispatching_Constructor_Call)).
1330 -- At this stage we cannot identify whether the underlying object is
1331 -- a BIP object and hence we cannot skip generating the code to try
1332 -- displacing the pointer to the object. However, under configurable
1333 -- runtime it is safe to skip generating code to displace the pointer
1334 -- to the object, because generic dispatching constructors are not
1337 elsif Is_Interface
(Iface_Typ
)
1338 and then Is_Ancestor
(Iface_Typ
, Opnd
, Use_Full_View
=> True)
1339 and then not RTE_Available
(RE_Displace
)
1345 -- Evaluate if we can statically displace the pointer to the object
1348 Opnd_Typ
: constant Node_Id
:= Underlying_Record_Type
(Operand_Typ
);
1352 not Is_Interface
(Opnd_Typ
)
1353 and then Interface_Present_In_Ancestor
1356 and then (Etype
(Opnd_Typ
) = Opnd_Typ
1358 Is_Variable_Size_Record
(Etype
(Opnd_Typ
)));
1361 if not Tagged_Type_Expansion
then
1364 -- A static conversion to an interface type that is not class-wide is
1365 -- curious but legal if the interface operation is a null procedure.
1366 -- If the operation is abstract it will be rejected later.
1369 and then Is_Interface
(Etype
(N
))
1370 and then not Is_Class_Wide_Type
(Etype
(N
))
1371 and then Comes_From_Source
(N
)
1373 Rewrite
(N
, Unchecked_Convert_To
(Etype
(N
), N
));
1378 if not Is_Static
then
1380 -- Give error if configurable run-time and Displace not available
1382 if not RTE_Available
(RE_Displace
) then
1383 Error_Msg_CRT
("dynamic interface conversion", N
);
1387 -- Handle conversion of access-to-class-wide interface types. Target
1388 -- can be an access to an object or an access to another class-wide
1389 -- interface (see -1- and -2- in the following example):
1391 -- type Iface1_Ref is access all Iface1'Class;
1392 -- type Iface2_Ref is access all Iface1'Class;
1394 -- Acc1 : Iface1_Ref := new ...
1395 -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1
1396 -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
1398 if Is_Access_Type
(Operand_Typ
) then
1400 Unchecked_Convert_To
(Etype
(N
),
1401 Make_Function_Call
(Loc
,
1402 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
1403 Parameter_Associations
=> New_List
(
1405 Unchecked_Convert_To
(RTE
(RE_Address
),
1406 Relocate_Node
(Expression
(N
))),
1409 (Node
(First_Elmt
(Access_Disp_Table
(Iface_Typ
))),
1417 Make_Function_Call
(Loc
,
1418 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
1419 Parameter_Associations
=> New_List
(
1420 Make_Attribute_Reference
(Loc
,
1421 Prefix
=> Relocate_Node
(Expression
(N
)),
1422 Attribute_Name
=> Name_Address
),
1425 (Node
(First_Elmt
(Access_Disp_Table
(Iface_Typ
))),
1430 -- If target is a class-wide interface, change the type of the data
1431 -- returned by IW_Convert to indicate this is a dispatching call.
1434 New_Itype
: Entity_Id
;
1437 New_Itype
:= Create_Itype
(E_Anonymous_Access_Type
, N
);
1438 Set_Etype
(New_Itype
, New_Itype
);
1439 Set_Directly_Designated_Type
(New_Itype
, Etyp
);
1442 Make_Explicit_Dereference
(Loc
,
1444 Unchecked_Convert_To
(New_Itype
, Relocate_Node
(N
))));
1446 Freeze_Itype
(New_Itype
, N
);
1452 Iface_Tag
:= Find_Interface_Tag
(Operand_Typ
, Iface_Typ
);
1453 pragma Assert
(Present
(Iface_Tag
));
1455 -- Keep separate access types to interfaces because one internal
1456 -- function is used to handle the null value (see following comments)
1458 if not Is_Access_Type
(Etype
(N
)) then
1460 -- Statically displace the pointer to the object to reference the
1461 -- component containing the secondary dispatch table.
1464 Convert_Tag_To_Interface
(Class_Wide_Type
(Iface_Typ
),
1465 Make_Selected_Component
(Loc
,
1466 Prefix
=> Relocate_Node
(Expression
(N
)),
1467 Selector_Name
=> New_Occurrence_Of
(Iface_Tag
, Loc
))));
1470 -- Build internal function to handle the case in which the actual is
1471 -- null. If the actual is null returns null because no displacement
1472 -- is required; otherwise performs a type conversion that will be
1473 -- expanded in the code that returns the value of the displaced
1476 -- function Func (O : Address) return Iface_Typ is
1477 -- type Op_Typ is access all Operand_Typ;
1478 -- Aux : Op_Typ := To_Op_Typ (O);
1480 -- if O = Null_Address then
1483 -- return Iface_Typ!(Aux.Iface_Tag'Address);
1488 Desig_Typ
: Entity_Id
;
1490 New_Typ_Decl
: Node_Id
;
1494 Desig_Typ
:= Etype
(Expression
(N
));
1496 if Is_Access_Type
(Desig_Typ
) then
1498 Available_View
(Directly_Designated_Type
(Desig_Typ
));
1501 if Is_Concurrent_Type
(Desig_Typ
) then
1502 Desig_Typ
:= Base_Type
(Corresponding_Record_Type
(Desig_Typ
));
1506 Make_Full_Type_Declaration
(Loc
,
1507 Defining_Identifier
=> Make_Temporary
(Loc
, 'T'),
1509 Make_Access_To_Object_Definition
(Loc
,
1510 All_Present
=> True,
1511 Null_Exclusion_Present
=> False,
1512 Constant_Present
=> False,
1513 Subtype_Indication
=>
1514 New_Occurrence_Of
(Desig_Typ
, Loc
)));
1517 Make_Simple_Return_Statement
(Loc
,
1518 Unchecked_Convert_To
(Etype
(N
),
1519 Make_Attribute_Reference
(Loc
,
1521 Make_Selected_Component
(Loc
,
1523 Unchecked_Convert_To
1524 (Defining_Identifier
(New_Typ_Decl
),
1525 Make_Identifier
(Loc
, Name_uO
)),
1527 New_Occurrence_Of
(Iface_Tag
, Loc
)),
1528 Attribute_Name
=> Name_Address
))));
1530 -- If the type is null-excluding, no need for the null branch.
1531 -- Otherwise we need to check for it and return null.
1533 if not Can_Never_Be_Null
(Etype
(N
)) then
1535 Make_If_Statement
(Loc
,
1538 Left_Opnd
=> Make_Identifier
(Loc
, Name_uO
),
1539 Right_Opnd
=> New_Occurrence_Of
1540 (RTE
(RE_Null_Address
), Loc
)),
1542 Then_Statements
=> New_List
(
1543 Make_Simple_Return_Statement
(Loc
, Make_Null
(Loc
))),
1544 Else_Statements
=> Stats
));
1547 Fent
:= Make_Temporary
(Loc
, 'F');
1549 Make_Subprogram_Body
(Loc
,
1551 Make_Function_Specification
(Loc
,
1552 Defining_Unit_Name
=> Fent
,
1554 Parameter_Specifications
=> New_List
(
1555 Make_Parameter_Specification
(Loc
,
1556 Defining_Identifier
=>
1557 Make_Defining_Identifier
(Loc
, Name_uO
),
1559 New_Occurrence_Of
(RTE
(RE_Address
), Loc
))),
1561 Result_Definition
=>
1562 New_Occurrence_Of
(Etype
(N
), Loc
)),
1564 Declarations
=> New_List
(New_Typ_Decl
),
1566 Handled_Statement_Sequence
=>
1567 Make_Handled_Sequence_Of_Statements
(Loc
, Stats
));
1569 -- Place function body before the expression containing the
1570 -- conversion. We suppress all checks because the body of the
1571 -- internally generated function already takes care of the case
1572 -- in which the actual is null; therefore there is no need to
1573 -- double check that the pointer is not null when the program
1574 -- executes the alternative that performs the type conversion).
1576 Insert_Action
(N
, Func
, Suppress
=> All_Checks
);
1578 if Is_Access_Type
(Etype
(Expression
(N
))) then
1580 -- Generate: Func (Address!(Expression))
1583 Make_Function_Call
(Loc
,
1584 Name
=> New_Occurrence_Of
(Fent
, Loc
),
1585 Parameter_Associations
=> New_List
(
1586 Unchecked_Convert_To
(RTE
(RE_Address
),
1587 Relocate_Node
(Expression
(N
))))));
1590 -- Generate: Func (Operand_Typ!(Expression)'Address)
1593 Make_Function_Call
(Loc
,
1594 Name
=> New_Occurrence_Of
(Fent
, Loc
),
1595 Parameter_Associations
=> New_List
(
1596 Make_Attribute_Reference
(Loc
,
1597 Prefix
=> Unchecked_Convert_To
(Operand_Typ
,
1598 Relocate_Node
(Expression
(N
))),
1599 Attribute_Name
=> Name_Address
))));
1605 end Expand_Interface_Conversion
;
1607 ------------------------------
1608 -- Expand_Interface_Actuals --
1609 ------------------------------
1611 procedure Expand_Interface_Actuals
(Call_Node
: Node_Id
) is
1613 Actual_Dup
: Node_Id
;
1614 Actual_Typ
: Entity_Id
;
1616 Conversion
: Node_Id
;
1618 Formal_Typ
: Entity_Id
;
1620 Formal_DDT
: Entity_Id
:= Empty
; -- initialize to prevent warning
1621 Actual_DDT
: Entity_Id
:= Empty
; -- initialize to prevent warning
1624 -- This subprogram is called directly from the semantics, so we need a
1625 -- check to see whether expansion is active before proceeding.
1627 if not Expander_Active
then
1631 -- Call using access to subprogram with explicit dereference
1633 if Nkind
(Name
(Call_Node
)) = N_Explicit_Dereference
then
1634 Subp
:= Etype
(Name
(Call_Node
));
1636 -- Call using selected component
1638 elsif Nkind
(Name
(Call_Node
)) = N_Selected_Component
then
1639 Subp
:= Entity
(Selector_Name
(Name
(Call_Node
)));
1641 -- Call using direct name
1644 Subp
:= Entity
(Name
(Call_Node
));
1647 -- Ada 2005 (AI-251): Look for interface type formals to force "this"
1650 Formal
:= First_Formal
(Subp
);
1651 Actual
:= First_Actual
(Call_Node
);
1652 while Present
(Formal
) loop
1653 Formal_Typ
:= Etype
(Formal
);
1655 if Has_Non_Limited_View
(Formal_Typ
) then
1656 Formal_Typ
:= Non_Limited_View
(Formal_Typ
);
1659 if Ekind
(Formal_Typ
) = E_Record_Type_With_Private
then
1660 Formal_Typ
:= Full_View
(Formal_Typ
);
1663 if Is_Access_Type
(Formal_Typ
) then
1664 Formal_DDT
:= Directly_Designated_Type
(Formal_Typ
);
1666 if Has_Non_Limited_View
(Formal_DDT
) then
1667 Formal_DDT
:= Non_Limited_View
(Formal_DDT
);
1671 Actual_Typ
:= Etype
(Actual
);
1673 if Has_Non_Limited_View
(Actual_Typ
) then
1674 Actual_Typ
:= Non_Limited_View
(Actual_Typ
);
1677 if Is_Access_Type
(Actual_Typ
) then
1678 Actual_DDT
:= Directly_Designated_Type
(Actual_Typ
);
1680 if Has_Non_Limited_View
(Actual_DDT
) then
1681 Actual_DDT
:= Non_Limited_View
(Actual_DDT
);
1685 if Is_Interface
(Formal_Typ
)
1686 and then Is_Class_Wide_Type
(Formal_Typ
)
1688 -- No need to displace the pointer if the type of the actual
1689 -- coincides with the type of the formal.
1691 if Actual_Typ
= Formal_Typ
then
1694 -- No need to displace the pointer if the interface type is a
1695 -- parent of the type of the actual because in this case the
1696 -- interface primitives are located in the primary dispatch table.
1698 elsif Is_Ancestor
(Formal_Typ
, Actual_Typ
,
1699 Use_Full_View
=> True)
1703 -- Implicit conversion to the class-wide formal type to force the
1704 -- displacement of the pointer.
1707 -- Normally, expansion of actuals for calls to build-in-place
1708 -- functions happens as part of Expand_Actuals, but in this
1709 -- case the call will be wrapped in a conversion and soon after
1710 -- expanded further to handle the displacement for a class-wide
1711 -- interface conversion, so if this is a BIP call then we need
1712 -- to handle it now.
1714 if Is_Build_In_Place_Function_Call
(Actual
) then
1715 Make_Build_In_Place_Call_In_Anonymous_Context
(Actual
);
1718 Conversion
:= Convert_To
(Formal_Typ
, Relocate_Node
(Actual
));
1719 Rewrite
(Actual
, Conversion
);
1720 Analyze_And_Resolve
(Actual
, Formal_Typ
);
1723 -- Access to class-wide interface type
1725 elsif Is_Access_Type
(Formal_Typ
)
1726 and then Is_Interface
(Formal_DDT
)
1727 and then Is_Class_Wide_Type
(Formal_DDT
)
1728 and then Interface_Present_In_Ancestor
1730 Iface
=> Etype
(Formal_DDT
))
1732 -- Handle attributes 'Access and 'Unchecked_Access
1734 if Nkind
(Actual
) = N_Attribute_Reference
1736 (Attribute_Name
(Actual
) = Name_Access
1737 or else Attribute_Name
(Actual
) = Name_Unchecked_Access
)
1739 -- This case must have been handled by the analysis and
1740 -- expansion of 'Access. The only exception is when types
1741 -- match and no further expansion is required.
1743 pragma Assert
(Base_Type
(Etype
(Prefix
(Actual
)))
1744 = Base_Type
(Formal_DDT
));
1747 -- No need to displace the pointer if the type of the actual
1748 -- coincides with the type of the formal.
1750 elsif Actual_DDT
= Formal_DDT
then
1753 -- No need to displace the pointer if the interface type is
1754 -- a parent of the type of the actual because in this case the
1755 -- interface primitives are located in the primary dispatch table.
1757 elsif Is_Ancestor
(Formal_DDT
, Actual_DDT
,
1758 Use_Full_View
=> True)
1763 Actual_Dup
:= Relocate_Node
(Actual
);
1765 if From_Limited_With
(Actual_Typ
) then
1767 -- If the type of the actual parameter comes from a limited
1768 -- with_clause and the nonlimited view is already available,
1769 -- we replace the anonymous access type by a duplicate
1770 -- declaration whose designated type is the nonlimited view.
1772 if Has_Non_Limited_View
(Actual_DDT
) then
1773 Anon
:= New_Copy
(Actual_Typ
);
1775 if Is_Itype
(Anon
) then
1776 Set_Scope
(Anon
, Current_Scope
);
1779 Set_Directly_Designated_Type
1780 (Anon
, Non_Limited_View
(Actual_DDT
));
1781 Set_Etype
(Actual_Dup
, Anon
);
1785 Conversion
:= Convert_To
(Formal_Typ
, Actual_Dup
);
1786 Rewrite
(Actual
, Conversion
);
1787 Analyze_And_Resolve
(Actual
, Formal_Typ
);
1791 Next_Actual
(Actual
);
1792 Next_Formal
(Formal
);
1794 end Expand_Interface_Actuals
;
1796 ----------------------------
1797 -- Expand_Interface_Thunk --
1798 ----------------------------
1800 procedure Expand_Interface_Thunk
1802 Thunk_Id
: out Entity_Id
;
1803 Thunk_Code
: out List_Id
;
1806 Actuals
: constant List_Id
:= New_List
;
1807 Decl
: constant List_Id
:= New_List
;
1808 Formals
: constant List_Id
:= New_List
;
1809 Loc
: constant Source_Ptr
:= Sloc
(Prim
);
1810 Target
: constant Entity_Id
:= Ultimate_Alias
(Prim
);
1811 Is_Predef_Op
: constant Boolean :=
1812 Is_Predefined_Dispatching_Operation
(Prim
)
1813 or else Is_Predefined_Dispatching_Operation
(Target
);
1820 Iface_Formal
: Entity_Id
;
1822 Offset_To_Top
: Node_Id
;
1823 Target_Formal
: Entity_Id
;
1827 Thunk_Code
:= Empty_List
;
1829 -- No thunk needed if the primitive has been eliminated
1831 if Is_Eliminated
(Target
) then
1834 -- No thunk needed if the primitive has no formals. In this case, this
1835 -- must be a function with a controlling result.
1837 elsif No
(First_Formal
(Target
)) then
1838 pragma Assert
(Ekind
(Target
) = E_Function
1839 and then Has_Controlling_Result
(Target
));
1844 -- Duplicate the formals of the target primitive. In the thunk, the type
1845 -- of the controlling formal is the covered interface type (instead of
1846 -- the target tagged type). Done to avoid problems with discriminated
1847 -- tagged types because, if the controlling type has discriminants with
1848 -- default values, then the type conversions done inside the body of
1849 -- the thunk (after the displacement of the pointer to the base of the
1850 -- actual object) generate code that modify its contents.
1852 -- Note: This special management is not done for predefined primitives
1853 -- because they don't have available the Interface_Alias attribute (see
1854 -- Sem_Ch3.Add_Internal_Interface_Entities).
1856 if Is_Predef_Op
then
1857 Iface_Formal
:= Empty
;
1859 Iface_Formal
:= First_Formal
(Interface_Alias
(Prim
));
1862 Formal
:= First_Formal
(Target
);
1863 while Present
(Formal
) loop
1864 -- Use the interface type as the type of the controlling formal (see
1867 if not Is_Controlling_Formal
(Formal
) then
1868 Ftyp
:= Etype
(Formal
);
1869 Expr
:= New_Copy_Tree
(Expression
(Parent
(Formal
)));
1871 -- For predefined primitives the controlling type of the thunk is
1872 -- the interface type passed by the caller (since they don't have
1873 -- available the Interface_Alias attribute; see comment above).
1875 elsif Is_Predef_Op
then
1880 Ftyp
:= Etype
(Iface_Formal
);
1883 -- Sanity check performed to ensure the proper controlling type
1884 -- when the thunk has exactly one controlling parameter and it
1885 -- comes first. In such a case, the GCC back end reuses the C++
1886 -- thunks machinery which perform a computation equivalent to
1887 -- the code generated by the expander; for other cases the GCC
1888 -- back end translates the expanded code unmodified. However, as
1889 -- a generalization, the check is performed for all controlling
1892 if Is_Access_Type
(Ftyp
) then
1893 pragma Assert
(Base_Type
(Designated_Type
(Ftyp
)) = Iface
);
1896 Ftyp
:= Base_Type
(Ftyp
);
1897 pragma Assert
(Ftyp
= Iface
);
1902 Make_Parameter_Specification
(Loc
,
1903 Defining_Identifier
=>
1904 Make_Defining_Identifier
(Sloc
(Formal
),
1905 Chars
=> Chars
(Formal
)),
1906 Aliased_Present
=> Aliased_Present
(Parent
(Formal
)),
1907 In_Present
=> In_Present
(Parent
(Formal
)),
1908 Out_Present
=> Out_Present
(Parent
(Formal
)),
1909 Parameter_Type
=> New_Occurrence_Of
(Ftyp
, Loc
),
1910 Expression
=> Expr
));
1912 if not Is_Predef_Op
then
1913 Next_Formal
(Iface_Formal
);
1916 Next_Formal
(Formal
);
1919 Target_Formal
:= First_Formal
(Target
);
1920 Formal
:= First
(Formals
);
1921 while Present
(Formal
) loop
1923 -- If the parent is a constrained discriminated type, then the
1924 -- primitive operation will have been defined on a first subtype.
1925 -- For proper matching with controlling type, use base type.
1927 if Ekind
(Target_Formal
) = E_In_Parameter
1928 and then Ekind
(Etype
(Target_Formal
)) = E_Anonymous_Access_Type
1931 Base_Type
(Directly_Designated_Type
(Etype
(Target_Formal
)));
1933 Ftyp
:= Base_Type
(Etype
(Target_Formal
));
1936 -- For concurrent types, the relevant information is found in the
1937 -- Corresponding_Record_Type, rather than the type entity itself.
1939 if Is_Concurrent_Type
(Ftyp
) then
1940 Ftyp
:= Corresponding_Record_Type
(Ftyp
);
1943 if Ekind
(Target_Formal
) = E_In_Parameter
1944 and then Ekind
(Etype
(Target_Formal
)) = E_Anonymous_Access_Type
1945 and then Is_Controlling_Formal
(Target_Formal
)
1948 -- type T is access all <<type of the target formal>>
1949 -- S : Storage_Offset := Storage_Offset!(Formal)
1950 -- + Offset_To_Top (address!(Formal))
1953 Make_Full_Type_Declaration
(Loc
,
1954 Defining_Identifier
=> Make_Temporary
(Loc
, 'T'),
1956 Make_Access_To_Object_Definition
(Loc
,
1957 All_Present
=> True,
1958 Null_Exclusion_Present
=> False,
1959 Constant_Present
=> False,
1960 Subtype_Indication
=>
1961 New_Occurrence_Of
(Ftyp
, Loc
)));
1964 Unchecked_Convert_To
(RTE
(RE_Address
),
1965 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
1967 if not RTE_Available
(RE_Offset_To_Top
) then
1969 Build_Offset_To_Top
(Loc
, New_Arg
);
1972 Make_Function_Call
(Loc
,
1973 Name
=> New_Occurrence_Of
(RTE
(RE_Offset_To_Top
), Loc
),
1974 Parameter_Associations
=> New_List
(New_Arg
));
1978 Make_Object_Declaration
(Loc
,
1979 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
1980 Constant_Present
=> True,
1981 Object_Definition
=>
1982 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
1986 Unchecked_Convert_To
1987 (RTE
(RE_Storage_Offset
),
1989 (Defining_Identifier
(Formal
), Loc
)),
1993 Append_To
(Decl
, Decl_2
);
1994 Append_To
(Decl
, Decl_1
);
1996 -- Reference the new actual. Generate:
2000 Unchecked_Convert_To
2001 (Defining_Identifier
(Decl_2
),
2002 New_Occurrence_Of
(Defining_Identifier
(Decl_1
), Loc
)));
2004 elsif Is_Controlling_Formal
(Target_Formal
) then
2007 -- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
2008 -- + Offset_To_Top (Formal'Address)
2009 -- S2 : Addr_Ptr := Addr_Ptr!(S1)
2012 Make_Attribute_Reference
(Loc
,
2014 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
),
2018 if not RTE_Available
(RE_Offset_To_Top
) then
2020 Build_Offset_To_Top
(Loc
, New_Arg
);
2023 Make_Function_Call
(Loc
,
2024 Name
=> New_Occurrence_Of
(RTE
(RE_Offset_To_Top
), Loc
),
2025 Parameter_Associations
=> New_List
(New_Arg
));
2029 Make_Object_Declaration
(Loc
,
2030 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
2031 Constant_Present
=> True,
2032 Object_Definition
=>
2033 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
2037 Unchecked_Convert_To
2038 (RTE
(RE_Storage_Offset
),
2039 Make_Attribute_Reference
(Loc
,
2042 (Defining_Identifier
(Formal
), Loc
),
2043 Attribute_Name
=> Name_Address
)),
2048 Make_Object_Declaration
(Loc
,
2049 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
2050 Constant_Present
=> True,
2051 Object_Definition
=>
2052 New_Occurrence_Of
(RTE
(RE_Addr_Ptr
), Loc
),
2054 Unchecked_Convert_To
2056 New_Occurrence_Of
(Defining_Identifier
(Decl_1
), Loc
)));
2058 Append_To
(Decl
, Decl_1
);
2059 Append_To
(Decl
, Decl_2
);
2061 -- Reference the new actual, generate:
2062 -- Target_Formal (S2.all)
2065 Unchecked_Convert_To
(Ftyp
,
2066 Make_Explicit_Dereference
(Loc
,
2067 New_Occurrence_Of
(Defining_Identifier
(Decl_2
), Loc
))));
2069 -- Ensure proper matching of access types. Required to avoid
2070 -- reporting spurious errors.
2072 elsif Is_Access_Type
(Etype
(Target_Formal
)) then
2074 Unchecked_Convert_To
(Base_Type
(Etype
(Target_Formal
)),
2075 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
)));
2077 -- No special management required for this actual
2081 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
2084 Next_Formal
(Target_Formal
);
2088 Thunk_Id
:= Make_Temporary
(Loc
, 'T');
2090 -- Note: any change to this symbol name needs to be coordinated
2091 -- with GNATcoverage, as that tool relies on it to identify
2092 -- thunks and exclude them from source coverage analysis.
2094 Mutate_Ekind
(Thunk_Id
, Ekind
(Prim
));
2095 Set_Is_Thunk
(Thunk_Id
);
2096 Set_Has_Controlling_Result
(Thunk_Id
, False);
2097 Set_Convention
(Thunk_Id
, Convention
(Prim
));
2098 Set_Needs_Debug_Info
(Thunk_Id
, Needs_Debug_Info
(Target
));
2099 Set_Thunk_Entity
(Thunk_Id
, Target
);
2101 Thunk_Code
:= New_List
;
2105 if Ekind
(Target
) = E_Procedure
then
2106 Append_To
(Thunk_Code
,
2107 Make_Subprogram_Body
(Loc
,
2109 Make_Procedure_Specification
(Loc
,
2110 Defining_Unit_Name
=> Thunk_Id
,
2111 Parameter_Specifications
=> Formals
),
2112 Declarations
=> Decl
,
2113 Handled_Statement_Sequence
=>
2114 Make_Handled_Sequence_Of_Statements
(Loc
,
2115 Statements
=> New_List
(
2116 Make_Procedure_Call_Statement
(Loc
,
2117 Name
=> New_Occurrence_Of
(Target
, Loc
),
2118 Parameter_Associations
=> Actuals
)))));
2122 else pragma Assert
(Ekind
(Target
) = E_Function
);
2124 Call_Node
: Node_Id
;
2125 Result_Def
: Node_Id
;
2126 SS_Thunk_Id
: Entity_Id
;
2127 SS_Thunk_Code
: Node_Id
;
2131 Make_Function_Call
(Loc
,
2132 Name
=> New_Occurrence_Of
(Target
, Loc
),
2133 Parameter_Associations
=> Actuals
);
2135 if not Is_Interface
(Etype
(Prim
)) then
2136 Result_Def
:= New_Copy
(Result_Definition
(Parent
(Target
)));
2138 -- Thunk of function returning a class-wide interface object. No
2139 -- extra displacement needed since the displacement is generated
2140 -- in the return statement of Prim. Example:
2142 -- type Iface is interface ...
2143 -- function F (O : Iface) return Iface'Class;
2145 -- type T is new ... and Iface with ...
2146 -- function F (O : T) return Iface'Class;
2148 elsif Is_Class_Wide_Type
(Etype
(Prim
)) then
2149 Result_Def
:= New_Occurrence_Of
(Etype
(Prim
), Loc
);
2151 -- Thunk of function returning an interface object. Displacement
2154 -- type Iface is interface ...
2155 -- function F (O : Iface) return Iface;
2157 -- type T is new ... and Iface with ...
2158 -- function F (O : T) return T;
2161 Expand_Secondary_Stack_Thunk
2162 (Target
, SS_Thunk_Id
, SS_Thunk_Code
);
2164 if Present
(SS_Thunk_Id
) then
2165 Set_Thunk_Entity
(Thunk_Id
, SS_Thunk_Id
);
2167 Make_Function_Call
(Loc
,
2169 New_Occurrence_Of
(SS_Thunk_Id
, Loc
),
2170 Parameter_Associations
=> Actuals
);
2171 Append_To
(Thunk_Code
, SS_Thunk_Code
);
2175 New_Occurrence_Of
(Class_Wide_Type
(Etype
(Prim
)), Loc
);
2177 -- Adding implicit conversion to force the displacement of
2178 -- the pointer to the object to reference the corresponding
2179 -- secondary dispatch table.
2182 Make_Type_Conversion
(Loc
,
2184 New_Occurrence_Of
(Class_Wide_Type
(Etype
(Prim
)), Loc
),
2185 Expression
=> Relocate_Node
(Call_Node
));
2188 Append_To
(Thunk_Code
,
2189 Make_Subprogram_Body
(Loc
,
2191 Make_Function_Specification
(Loc
,
2192 Defining_Unit_Name
=> Thunk_Id
,
2193 Parameter_Specifications
=> Formals
,
2194 Result_Definition
=> Result_Def
),
2195 Declarations
=> Decl
,
2196 Handled_Statement_Sequence
=>
2197 Make_Handled_Sequence_Of_Statements
(Loc
,
2198 Statements
=> New_List
(
2199 Make_Simple_Return_Statement
(Loc
, Call_Node
)))));
2202 end Expand_Interface_Thunk
;
2204 ------------------------------------
2205 -- Expand_Secondary_Stack_Thunk --
2206 ------------------------------------
2208 procedure Expand_Secondary_Stack_Thunk
2210 Thunk_Id
: out Entity_Id
;
2211 Thunk_Code
: out Node_Id
)
2213 Actuals
: constant List_Id
:= New_List
;
2214 Formals
: constant List_Id
:= New_List
;
2215 Loc
: constant Source_Ptr
:= Sloc
(Prim
);
2216 Typ
: constant Entity_Id
:= Etype
(Prim
);
2218 Call_Node
: Node_Id
;
2221 Prim_Formal
: Entity_Id
;
2222 Result_Def
: Node_Id
;
2226 Thunk_Code
:= Empty
;
2228 -- No thunk needed if the primitive has been eliminated
2230 if Is_Eliminated
(Prim
) then
2233 -- No thunk needed for procedures or functions not dispatching on result
2235 elsif Ekind
(Prim
) = E_Procedure
2236 or else not Has_Controlling_Result
(Prim
)
2240 -- No thunk needed if the result type is an access type
2242 elsif Is_Access_Type
(Typ
) then
2245 -- No thunk needed if the tagged type is returned in place
2247 elsif Is_Build_In_Place_Result_Type
(Typ
) then
2250 -- No thunk needed if the tagged type is returned on the secondary stack
2252 elsif Needs_Secondary_Stack
(Typ
) then
2256 pragma Assert
(Is_Tagged_Type
(Typ
));
2258 -- Duplicate the formals of the target primitive and build the actuals
2260 Prim_Formal
:= First_Formal
(Prim
);
2261 while Present
(Prim_Formal
) loop
2262 Expr
:= New_Copy_Tree
(Expression
(Parent
(Prim_Formal
)));
2265 Make_Defining_Identifier
(Sloc
(Prim_Formal
),
2266 Chars
=> Chars
(Prim_Formal
));
2269 Make_Parameter_Specification
(Loc
,
2270 Defining_Identifier
=> Formal
,
2271 Aliased_Present
=> Aliased_Present
(Parent
(Prim_Formal
)),
2272 In_Present
=> In_Present
(Parent
(Prim_Formal
)),
2273 Out_Present
=> Out_Present
(Parent
(Prim_Formal
)),
2274 Parameter_Type
=> New_Occurrence_Of
(Etype
(Prim_Formal
), Loc
),
2275 Expression
=> Expr
));
2277 -- Ensure proper matching of access types. Required to avoid
2278 -- reporting spurious errors.
2280 if Is_Access_Type
(Etype
(Prim_Formal
)) then
2282 Unchecked_Convert_To
(Base_Type
(Etype
(Prim_Formal
)),
2283 New_Occurrence_Of
(Formal
, Loc
)));
2285 -- No special management required for this actual
2288 Append_To
(Actuals
, New_Occurrence_Of
(Formal
, Loc
));
2291 Next_Formal
(Prim_Formal
);
2294 Thunk_Id
:= Make_Temporary
(Loc
, 'T');
2296 -- Note: any change to this symbol name needs to be coordinated
2297 -- with GNATcoverage, as that tool relies on it to identify
2298 -- thunks and exclude them from source coverage analysis.
2300 Mutate_Ekind
(Thunk_Id
, E_Function
);
2301 Set_Is_Thunk
(Thunk_Id
);
2302 Set_Has_Controlling_Result
(Thunk_Id
, True);
2303 Set_Convention
(Thunk_Id
, Convention
(Prim
));
2304 Set_Needs_Debug_Info
(Thunk_Id
, Needs_Debug_Info
(Prim
));
2305 Set_Thunk_Entity
(Thunk_Id
, Prim
);
2307 Result_Def
:= New_Copy
(Result_Definition
(Parent
(Prim
)));
2310 Make_Function_Call
(Loc
,
2311 Name
=> New_Occurrence_Of
(Prim
, Loc
),
2312 Parameter_Associations
=> Actuals
);
2315 Make_Subprogram_Body
(Loc
,
2317 Make_Function_Specification
(Loc
,
2318 Defining_Unit_Name
=> Thunk_Id
,
2319 Parameter_Specifications
=> Formals
,
2320 Result_Definition
=> Result_Def
),
2321 Declarations
=> Empty_List
,
2322 Handled_Statement_Sequence
=>
2323 Make_Handled_Sequence_Of_Statements
(Loc
,
2324 Statements
=> New_List
(
2325 Make_Simple_Return_Statement
(Loc
, Call_Node
))));
2326 end Expand_Secondary_Stack_Thunk
;
2328 --------------------------
2329 -- Has_CPP_Constructors --
2330 --------------------------
2332 function Has_CPP_Constructors
(Typ
: Entity_Id
) return Boolean is
2336 -- Look for the constructor entities
2338 E
:= Next_Entity
(Typ
);
2339 while Present
(E
) loop
2340 if Ekind
(E
) = E_Function
and then Is_Constructor
(E
) then
2348 end Has_CPP_Constructors
;
2354 function Has_DT
(Typ
: Entity_Id
) return Boolean is
2356 return not Is_Interface
(Typ
)
2357 and then not Restriction_Active
(No_Dispatching_Calls
);
2360 ----------------------------------
2361 -- Is_Expanded_Dispatching_Call --
2362 ----------------------------------
2364 function Is_Expanded_Dispatching_Call
(N
: Node_Id
) return Boolean is
2366 return Nkind
(N
) in N_Subprogram_Call
2367 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
2368 and then Is_Dispatch_Table_Entity
(Etype
(Name
(N
)));
2369 end Is_Expanded_Dispatching_Call
;
2371 -------------------------------------
2372 -- Is_Predefined_Dispatching_Alias --
2373 -------------------------------------
2375 function Is_Predefined_Dispatching_Alias
(Prim
: Entity_Id
) return Boolean
2378 return not Is_Predefined_Dispatching_Operation
(Prim
)
2379 and then Present
(Alias
(Prim
))
2380 and then Is_Predefined_Dispatching_Operation
(Ultimate_Alias
(Prim
));
2381 end Is_Predefined_Dispatching_Alias
;
2383 ----------------------------------------
2384 -- Make_Disp_Asynchronous_Select_Body --
2385 ----------------------------------------
2387 -- For interface types, generate:
2389 -- procedure _Disp_Asynchronous_Select
2390 -- (T : in out <Typ>;
2392 -- P : System.Address;
2393 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2398 -- C := Ada.Tags.POK_Function;
2399 -- end _Disp_Asynchronous_Select;
2401 -- For protected types, generate:
2403 -- procedure _Disp_Asynchronous_Select
2404 -- (T : in out <Typ>;
2406 -- P : System.Address;
2407 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2411 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2412 -- Bnn : System.Tasking.Protected_Objects.Operations.
2413 -- Communication_Block;
2415 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2416 -- (T._object'Access,
2417 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2419 -- System.Tasking.Asynchronous_Call,
2421 -- B := System.Storage_Elements.Dummy_Communication_Block (Bnn);
2422 -- end _Disp_Asynchronous_Select;
2424 -- For task types, generate:
2426 -- procedure _Disp_Asynchronous_Select
2427 -- (T : in out <Typ>;
2429 -- P : System.Address;
2430 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2434 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2436 -- System.Tasking.Rendezvous.Task_Entry_Call
2438 -- System.Tasking.Task_Entry_Index (I),
2440 -- System.Tasking.Asynchronous_Call,
2442 -- end _Disp_Asynchronous_Select;
2444 function Make_Disp_Asynchronous_Select_Body
2445 (Typ
: Entity_Id
) return Node_Id
2447 Com_Block
: Entity_Id
;
2448 Conc_Typ
: Entity_Id
:= Empty
;
2449 Decls
: constant List_Id
:= New_List
;
2450 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2452 Stmts
: constant List_Id
:= New_List
;
2456 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2458 -- Null body is generated for interface types
2460 if Is_Interface
(Typ
) then
2462 Make_Subprogram_Body
(Loc
,
2464 Make_Disp_Asynchronous_Select_Spec
(Typ
),
2465 Declarations
=> New_List
,
2466 Handled_Statement_Sequence
=>
2467 Make_Handled_Sequence_Of_Statements
(Loc
,
2469 Make_Assignment_Statement
(Loc
,
2470 Name
=> Make_Identifier
(Loc
, Name_uF
),
2471 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
2474 if Is_Concurrent_Record_Type
(Typ
) then
2475 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
2479 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2481 -- where I will be used to capture the entry index of the primitive
2482 -- wrapper at position S.
2484 if Tagged_Type_Expansion
then
2486 Unchecked_Convert_To
(RTE
(RE_Tag
),
2488 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
2491 Make_Attribute_Reference
(Loc
,
2492 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
2493 Attribute_Name
=> Name_Tag
);
2497 Make_Object_Declaration
(Loc
,
2498 Defining_Identifier
=>
2499 Make_Defining_Identifier
(Loc
, Name_uI
),
2500 Object_Definition
=>
2501 New_Occurrence_Of
(Standard_Integer
, Loc
),
2503 Make_Function_Call
(Loc
,
2505 New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
2506 Parameter_Associations
=>
2507 New_List
(Tag_Node
, Make_Identifier
(Loc
, Name_uS
)))));
2509 if Ekind
(Conc_Typ
) = E_Protected_Type
then
2512 -- Bnn : Communication_Block;
2514 Com_Block
:= Make_Temporary
(Loc
, 'B');
2516 Make_Object_Declaration
(Loc
,
2517 Defining_Identifier
=> Com_Block
,
2518 Object_Definition
=>
2519 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
2521 -- Build T._object'Access for calls below
2524 Make_Attribute_Reference
(Loc
,
2525 Attribute_Name
=> Name_Unchecked_Access
,
2527 Make_Selected_Component
(Loc
,
2528 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2529 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
2531 case Corresponding_Runtime_Package
(Conc_Typ
) is
2532 when System_Tasking_Protected_Objects_Entries
=>
2535 -- Protected_Entry_Call
2536 -- (T._object'Access, -- Object
2537 -- Protected_Entry_Index! (I), -- E
2538 -- P, -- Uninterpreted_Data
2539 -- Asynchronous_Call, -- Mode
2540 -- Bnn); -- Communication_Block
2542 -- where T is the protected object, I is the entry index, P
2543 -- is the wrapped parameters and B is the name of the
2544 -- communication block.
2547 Make_Procedure_Call_Statement
(Loc
,
2549 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
2550 Parameter_Associations
=>
2554 Unchecked_Convert_To
( -- entry index
2555 RTE
(RE_Protected_Entry_Index
),
2556 Make_Identifier
(Loc
, Name_uI
)),
2558 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2559 New_Occurrence_Of
-- Asynchronous_Call
2560 (RTE
(RE_Asynchronous_Call
), Loc
),
2561 New_Occurrence_Of
-- comm block
2562 (Com_Block
, Loc
))));
2565 raise Program_Error
;
2569 -- B := Dummy_Communication_Block (Bnn);
2572 Make_Assignment_Statement
(Loc
,
2573 Name
=> Make_Identifier
(Loc
, Name_uB
),
2575 Unchecked_Convert_To
2576 (RTE
(RE_Dummy_Communication_Block
),
2577 New_Occurrence_Of
(Com_Block
, Loc
))));
2583 Make_Assignment_Statement
(Loc
,
2584 Name
=> Make_Identifier
(Loc
, Name_uF
),
2585 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
2588 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
2592 -- (T._task_id, -- Acceptor
2593 -- Task_Entry_Index! (I), -- E
2594 -- P, -- Uninterpreted_Data
2595 -- Asynchronous_Call, -- Mode
2596 -- F); -- Rendezvous_Successful
2598 -- where T is the task object, I is the entry index, P is the
2599 -- wrapped parameters and F is the status flag.
2602 Make_Procedure_Call_Statement
(Loc
,
2604 New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
2605 Parameter_Associations
=>
2607 Make_Selected_Component
(Loc
, -- T._task_id
2608 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2609 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
2611 Unchecked_Convert_To
( -- entry index
2612 RTE
(RE_Task_Entry_Index
),
2613 Make_Identifier
(Loc
, Name_uI
)),
2615 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2616 New_Occurrence_Of
-- Asynchronous_Call
2617 (RTE
(RE_Asynchronous_Call
), Loc
),
2618 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
2622 -- Ensure that the statements list is non-empty
2625 Make_Assignment_Statement
(Loc
,
2626 Name
=> Make_Identifier
(Loc
, Name_uF
),
2627 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
2631 Make_Subprogram_Body
(Loc
,
2633 Make_Disp_Asynchronous_Select_Spec
(Typ
),
2634 Declarations
=> Decls
,
2635 Handled_Statement_Sequence
=>
2636 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
2637 end Make_Disp_Asynchronous_Select_Body
;
2639 ----------------------------------------
2640 -- Make_Disp_Asynchronous_Select_Spec --
2641 ----------------------------------------
2643 function Make_Disp_Asynchronous_Select_Spec
2644 (Typ
: Entity_Id
) return Node_Id
2646 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2647 B_Id
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
2648 Def_Id
: constant Entity_Id
:=
2649 Make_Defining_Identifier
(Loc
,
2650 Name_uDisp_Asynchronous_Select
);
2651 Params
: constant List_Id
:= New_List
;
2654 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2656 -- T : in out Typ; -- Object parameter
2657 -- S : Integer; -- Primitive operation slot
2658 -- P : Address; -- Wrapped parameters
2659 -- B : out Dummy_Communication_Block; -- Communication block dummy
2660 -- F : out Boolean; -- Status flag
2662 -- The B parameter may be left uninitialized
2664 Set_Warnings_Off
(B_Id
);
2666 Append_List_To
(Params
, New_List
(
2668 Make_Parameter_Specification
(Loc
,
2669 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
2670 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
2672 Out_Present
=> True),
2674 Make_Parameter_Specification
(Loc
,
2675 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
2676 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
2678 Make_Parameter_Specification
(Loc
,
2679 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
2680 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2682 Make_Parameter_Specification
(Loc
,
2683 Defining_Identifier
=> B_Id
,
2685 New_Occurrence_Of
(RTE
(RE_Dummy_Communication_Block
), Loc
),
2686 Out_Present
=> True),
2688 Make_Parameter_Specification
(Loc
,
2689 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
2690 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
2691 Out_Present
=> True)));
2694 Make_Procedure_Specification
(Loc
,
2695 Defining_Unit_Name
=> Def_Id
,
2696 Parameter_Specifications
=> Params
);
2697 end Make_Disp_Asynchronous_Select_Spec
;
2699 ---------------------------------------
2700 -- Make_Disp_Conditional_Select_Body --
2701 ---------------------------------------
2703 -- For interface types, generate:
2705 -- procedure _Disp_Conditional_Select
2706 -- (T : in out <Typ>;
2708 -- P : System.Address;
2709 -- C : out Ada.Tags.Prim_Op_Kind;
2714 -- C := Ada.Tags.POK_Function;
2715 -- end _Disp_Conditional_Select;
2717 -- For protected types, generate:
2719 -- procedure _Disp_Conditional_Select
2720 -- (T : in out <Typ>;
2722 -- P : System.Address;
2723 -- C : out Ada.Tags.Prim_Op_Kind;
2727 -- Bnn : System.Tasking.Protected_Objects.Operations.
2728 -- Communication_Block;
2731 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S));
2733 -- if C = Ada.Tags.POK_Procedure
2734 -- or else C = Ada.Tags.POK_Protected_Procedure
2735 -- or else C = Ada.Tags.POK_Task_Procedure
2741 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2742 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2743 -- (T.object'Access,
2744 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2746 -- System.Tasking.Conditional_Call,
2748 -- F := not Cancelled (Bnn);
2749 -- end _Disp_Conditional_Select;
2751 -- For task types, generate:
2753 -- procedure _Disp_Conditional_Select
2754 -- (T : in out <Typ>;
2756 -- P : System.Address;
2757 -- C : out Ada.Tags.Prim_Op_Kind;
2763 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2764 -- System.Tasking.Rendezvous.Task_Entry_Call
2766 -- System.Tasking.Task_Entry_Index (I),
2768 -- System.Tasking.Conditional_Call,
2770 -- end _Disp_Conditional_Select;
2772 function Make_Disp_Conditional_Select_Body
2773 (Typ
: Entity_Id
) return Node_Id
2775 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2776 Blk_Nam
: Entity_Id
;
2777 Conc_Typ
: Entity_Id
:= Empty
;
2778 Decls
: constant List_Id
:= New_List
;
2780 Stmts
: constant List_Id
:= New_List
;
2784 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2786 -- Null body is generated for interface types
2788 if Is_Interface
(Typ
) then
2790 Make_Subprogram_Body
(Loc
,
2792 Make_Disp_Conditional_Select_Spec
(Typ
),
2793 Declarations
=> No_List
,
2794 Handled_Statement_Sequence
=>
2795 Make_Handled_Sequence_Of_Statements
(Loc
,
2796 New_List
(Make_Assignment_Statement
(Loc
,
2797 Name
=> Make_Identifier
(Loc
, Name_uF
),
2798 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
2801 if Is_Concurrent_Record_Type
(Typ
) then
2802 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
2807 -- where I will be used to capture the entry index of the primitive
2808 -- wrapper at position S.
2811 Make_Object_Declaration
(Loc
,
2812 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uI
),
2813 Object_Definition
=>
2814 New_Occurrence_Of
(Standard_Integer
, Loc
)));
2817 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S);
2819 -- if C = POK_Procedure
2820 -- or else C = POK_Protected_Procedure
2821 -- or else C = POK_Task_Procedure;
2827 Build_Common_Dispatching_Select_Statements
(Typ
, Stmts
);
2830 -- Bnn : Communication_Block;
2832 -- where Bnn is the name of the communication block used in the
2833 -- call to Protected_Entry_Call.
2835 Blk_Nam
:= Make_Temporary
(Loc
, 'B');
2837 Make_Object_Declaration
(Loc
,
2838 Defining_Identifier
=> Blk_Nam
,
2839 Object_Definition
=>
2840 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
2843 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2845 -- I is the entry index and S is the dispatch table slot
2847 if Tagged_Type_Expansion
then
2849 Unchecked_Convert_To
(RTE
(RE_Tag
),
2851 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
2855 Make_Attribute_Reference
(Loc
,
2856 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
2857 Attribute_Name
=> Name_Tag
);
2861 Make_Assignment_Statement
(Loc
,
2862 Name
=> Make_Identifier
(Loc
, Name_uI
),
2864 Make_Function_Call
(Loc
,
2866 New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
2867 Parameter_Associations
=> New_List
(
2869 Make_Identifier
(Loc
, Name_uS
)))));
2871 if Ekind
(Conc_Typ
) = E_Protected_Type
then
2873 Obj_Ref
:= -- T._object'Access
2874 Make_Attribute_Reference
(Loc
,
2875 Attribute_Name
=> Name_Unchecked_Access
,
2877 Make_Selected_Component
(Loc
,
2878 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2879 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
2881 case Corresponding_Runtime_Package
(Conc_Typ
) is
2882 when System_Tasking_Protected_Objects_Entries
=>
2885 -- Protected_Entry_Call
2886 -- (T._object'Access, -- Object
2887 -- Protected_Entry_Index! (I), -- E
2888 -- P, -- Uninterpreted_Data
2889 -- Conditional_Call, -- Mode
2892 -- where T is the protected object, I is the entry index, P
2893 -- are the wrapped parameters and Bnn is the name of the
2894 -- communication block.
2897 Make_Procedure_Call_Statement
(Loc
,
2899 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
2900 Parameter_Associations
=> New_List
(
2903 Unchecked_Convert_To
( -- entry index
2904 RTE
(RE_Protected_Entry_Index
),
2905 Make_Identifier
(Loc
, Name_uI
)),
2907 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2909 New_Occurrence_Of
-- Conditional_Call
2910 (RTE
(RE_Conditional_Call
), Loc
),
2911 New_Occurrence_Of
-- Bnn
2914 when System_Tasking_Protected_Objects_Single_Entry
=>
2916 -- If we are compiling for a restricted run-time, the call
2917 -- uses the simpler form.
2920 Make_Procedure_Call_Statement
(Loc
,
2923 (RTE
(RE_Protected_Single_Entry_Call
), Loc
),
2924 Parameter_Associations
=> New_List
(
2927 Make_Attribute_Reference
(Loc
,
2928 Prefix
=> Make_Identifier
(Loc
, Name_uP
),
2929 Attribute_Name
=> Name_Address
),
2932 (RTE
(RE_Conditional_Call
), Loc
))));
2934 raise Program_Error
;
2938 -- F := not Cancelled (Bnn);
2940 -- where F is the success flag. The status of Cancelled is negated
2941 -- in order to match the behavior of the version for task types.
2944 Make_Assignment_Statement
(Loc
,
2945 Name
=> Make_Identifier
(Loc
, Name_uF
),
2949 Make_Function_Call
(Loc
,
2951 New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
2952 Parameter_Associations
=> New_List
(
2953 New_Occurrence_Of
(Blk_Nam
, Loc
))))));
2955 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
2959 -- (T._task_id, -- Acceptor
2960 -- Task_Entry_Index! (I), -- E
2961 -- P, -- Uninterpreted_Data
2962 -- Conditional_Call, -- Mode
2963 -- F); -- Rendezvous_Successful
2965 -- where T is the task object, I is the entry index, P are the
2966 -- wrapped parameters and F is the status flag.
2969 Make_Procedure_Call_Statement
(Loc
,
2971 New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
2972 Parameter_Associations
=> New_List
(
2974 Make_Selected_Component
(Loc
, -- T._task_id
2975 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2976 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
2978 Unchecked_Convert_To
( -- entry index
2979 RTE
(RE_Task_Entry_Index
),
2980 Make_Identifier
(Loc
, Name_uI
)),
2982 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2983 New_Occurrence_Of
-- Conditional_Call
2984 (RTE
(RE_Conditional_Call
), Loc
),
2985 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
2989 -- Initialize out parameters
2992 Make_Assignment_Statement
(Loc
,
2993 Name
=> Make_Identifier
(Loc
, Name_uF
),
2994 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
2996 Make_Assignment_Statement
(Loc
,
2997 Name
=> Make_Identifier
(Loc
, Name_uC
),
2998 Expression
=> New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
)));
3002 Make_Subprogram_Body
(Loc
,
3004 Make_Disp_Conditional_Select_Spec
(Typ
),
3005 Declarations
=> Decls
,
3006 Handled_Statement_Sequence
=>
3007 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
3008 end Make_Disp_Conditional_Select_Body
;
3010 ---------------------------------------
3011 -- Make_Disp_Conditional_Select_Spec --
3012 ---------------------------------------
3014 function Make_Disp_Conditional_Select_Spec
3015 (Typ
: Entity_Id
) return Node_Id
3017 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3018 Def_Id
: constant Node_Id
:=
3019 Make_Defining_Identifier
(Loc
,
3020 Name_uDisp_Conditional_Select
);
3021 Params
: constant List_Id
:= New_List
;
3024 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3026 -- T : in out Typ; -- Object parameter
3027 -- S : Integer; -- Primitive operation slot
3028 -- P : Address; -- Wrapped parameters
3029 -- C : out Prim_Op_Kind; -- Call kind
3030 -- F : out Boolean; -- Status flag
3032 Append_List_To
(Params
, New_List
(
3034 Make_Parameter_Specification
(Loc
,
3035 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
3036 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
3038 Out_Present
=> True),
3040 Make_Parameter_Specification
(Loc
,
3041 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
3042 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3044 Make_Parameter_Specification
(Loc
,
3045 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
3046 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3048 Make_Parameter_Specification
(Loc
,
3049 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
3051 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
3052 Out_Present
=> True),
3054 Make_Parameter_Specification
(Loc
,
3055 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
3056 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3057 Out_Present
=> True)));
3060 Make_Procedure_Specification
(Loc
,
3061 Defining_Unit_Name
=> Def_Id
,
3062 Parameter_Specifications
=> Params
);
3063 end Make_Disp_Conditional_Select_Spec
;
3065 -------------------------------------
3066 -- Make_Disp_Get_Prim_Op_Kind_Body --
3067 -------------------------------------
3069 function Make_Disp_Get_Prim_Op_Kind_Body
(Typ
: Entity_Id
) return Node_Id
is
3070 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3074 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3076 if Is_Interface
(Typ
) then
3078 Make_Subprogram_Body
(Loc
,
3080 Make_Disp_Get_Prim_Op_Kind_Spec
(Typ
),
3081 Declarations
=> New_List
,
3082 Handled_Statement_Sequence
=>
3083 Make_Handled_Sequence_Of_Statements
(Loc
,
3084 New_List
(Make_Null_Statement
(Loc
))));
3088 -- C := get_prim_op_kind (tag! (<type>VP), S);
3090 -- where C is the out parameter capturing the call kind and S is the
3091 -- dispatch table slot number.
3093 if Tagged_Type_Expansion
then
3095 Unchecked_Convert_To
(RTE
(RE_Tag
),
3097 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
3101 Make_Attribute_Reference
(Loc
,
3102 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
3103 Attribute_Name
=> Name_Tag
);
3107 Make_Subprogram_Body
(Loc
,
3109 Make_Disp_Get_Prim_Op_Kind_Spec
(Typ
),
3110 Declarations
=> New_List
,
3111 Handled_Statement_Sequence
=>
3112 Make_Handled_Sequence_Of_Statements
(Loc
,
3114 Make_Assignment_Statement
(Loc
,
3115 Name
=> Make_Identifier
(Loc
, Name_uC
),
3117 Make_Function_Call
(Loc
,
3119 New_Occurrence_Of
(RTE
(RE_Get_Prim_Op_Kind
), Loc
),
3120 Parameter_Associations
=> New_List
(
3122 Make_Identifier
(Loc
, Name_uS
)))))));
3123 end Make_Disp_Get_Prim_Op_Kind_Body
;
3125 -------------------------------------
3126 -- Make_Disp_Get_Prim_Op_Kind_Spec --
3127 -------------------------------------
3129 function Make_Disp_Get_Prim_Op_Kind_Spec
3130 (Typ
: Entity_Id
) return Node_Id
3132 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3133 Def_Id
: constant Node_Id
:=
3134 Make_Defining_Identifier
(Loc
, Name_uDisp_Get_Prim_Op_Kind
);
3135 Params
: constant List_Id
:= New_List
;
3138 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3140 -- T : in out Typ; -- Object parameter
3141 -- S : Integer; -- Primitive operation slot
3142 -- C : out Prim_Op_Kind; -- Call kind
3144 Append_List_To
(Params
, New_List
(
3146 Make_Parameter_Specification
(Loc
,
3147 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
3148 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
3150 Out_Present
=> True),
3152 Make_Parameter_Specification
(Loc
,
3153 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
3154 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3156 Make_Parameter_Specification
(Loc
,
3157 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
3159 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
3160 Out_Present
=> True)));
3163 Make_Procedure_Specification
(Loc
,
3164 Defining_Unit_Name
=> Def_Id
,
3165 Parameter_Specifications
=> Params
);
3166 end Make_Disp_Get_Prim_Op_Kind_Spec
;
3168 --------------------------------
3169 -- Make_Disp_Get_Task_Id_Body --
3170 --------------------------------
3172 function Make_Disp_Get_Task_Id_Body
3173 (Typ
: Entity_Id
) return Node_Id
3175 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3179 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3181 if Is_Concurrent_Record_Type
(Typ
)
3182 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) = E_Task_Type
3185 -- return To_Address (_T._task_id);
3188 Make_Simple_Return_Statement
(Loc
,
3190 Unchecked_Convert_To
3192 Make_Selected_Component
(Loc
,
3193 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
3194 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
))));
3196 -- A null body is constructed for non-task types
3200 -- return Null_Address;
3203 Make_Simple_Return_Statement
(Loc
,
3204 Expression
=> New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
3208 Make_Subprogram_Body
(Loc
,
3209 Specification
=> Make_Disp_Get_Task_Id_Spec
(Typ
),
3210 Declarations
=> New_List
,
3211 Handled_Statement_Sequence
=>
3212 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Ret
)));
3213 end Make_Disp_Get_Task_Id_Body
;
3215 --------------------------------
3216 -- Make_Disp_Get_Task_Id_Spec --
3217 --------------------------------
3219 function Make_Disp_Get_Task_Id_Spec
3220 (Typ
: Entity_Id
) return Node_Id
3222 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3225 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3228 Make_Function_Specification
(Loc
,
3229 Defining_Unit_Name
=>
3230 Make_Defining_Identifier
(Loc
, Name_uDisp_Get_Task_Id
),
3231 Parameter_Specifications
=> New_List
(
3232 Make_Parameter_Specification
(Loc
,
3233 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
3234 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
3235 Result_Definition
=>
3236 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
3237 end Make_Disp_Get_Task_Id_Spec
;
3239 ----------------------------
3240 -- Make_Disp_Requeue_Body --
3241 ----------------------------
3243 function Make_Disp_Requeue_Body
3244 (Typ
: Entity_Id
) return Node_Id
3246 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3247 Conc_Typ
: Entity_Id
:= Empty
;
3248 Stmts
: constant List_Id
:= New_List
;
3251 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3253 -- Null body is generated for interface types and nonconcurrent
3256 if Is_Interface
(Typ
)
3257 or else not Is_Concurrent_Record_Type
(Typ
)
3260 Make_Subprogram_Body
(Loc
,
3261 Specification
=> Make_Disp_Requeue_Spec
(Typ
),
3262 Declarations
=> No_List
,
3263 Handled_Statement_Sequence
=>
3264 Make_Handled_Sequence_Of_Statements
(Loc
,
3265 New_List
(Make_Null_Statement
(Loc
))));
3268 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
3270 if Ekind
(Conc_Typ
) = E_Protected_Type
then
3272 -- Generate statements:
3274 -- System.Tasking.Protected_Objects.Operations.
3275 -- Requeue_Protected_Entry
3276 -- (Protection_Entries_Access (P),
3277 -- O._object'Unchecked_Access,
3278 -- Protected_Entry_Index (I),
3281 -- System.Tasking.Protected_Objects.Operations.
3282 -- Requeue_Task_To_Protected_Entry
3283 -- (O._object'Unchecked_Access,
3284 -- Protected_Entry_Index (I),
3288 if Restriction_Active
(No_Entry_Queue
) then
3289 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
3292 Make_If_Statement
(Loc
,
3293 Condition
=> Make_Identifier
(Loc
, Name_uF
),
3298 -- Call to Requeue_Protected_Entry
3300 Make_Procedure_Call_Statement
(Loc
,
3303 (RTE
(RE_Requeue_Protected_Entry
), Loc
),
3304 Parameter_Associations
=>
3307 Unchecked_Convert_To
( -- PEA (P)
3308 RTE
(RE_Protection_Entries_Access
),
3309 Make_Identifier
(Loc
, Name_uP
)),
3311 Make_Attribute_Reference
(Loc
, -- O._object'Acc
3313 Name_Unchecked_Access
,
3315 Make_Selected_Component
(Loc
,
3317 Make_Identifier
(Loc
, Name_uO
),
3319 Make_Identifier
(Loc
, Name_uObject
))),
3321 Unchecked_Convert_To
( -- entry index
3322 RTE
(RE_Protected_Entry_Index
),
3323 Make_Identifier
(Loc
, Name_uI
)),
3325 Make_Identifier
(Loc
, Name_uA
)))), -- abort status
3330 -- Call to Requeue_Task_To_Protected_Entry
3332 Make_Procedure_Call_Statement
(Loc
,
3335 (RTE
(RE_Requeue_Task_To_Protected_Entry
), Loc
),
3336 Parameter_Associations
=>
3339 Make_Attribute_Reference
(Loc
, -- O._object'Acc
3340 Attribute_Name
=> Name_Unchecked_Access
,
3342 Make_Selected_Component
(Loc
,
3344 Make_Identifier
(Loc
, Name_uO
),
3346 Make_Identifier
(Loc
, Name_uObject
))),
3348 Unchecked_Convert_To
( -- entry index
3349 RTE
(RE_Protected_Entry_Index
),
3350 Make_Identifier
(Loc
, Name_uI
)),
3352 Make_Identifier
(Loc
, Name_uA
)))))); -- abort status
3356 pragma Assert
(Is_Task_Type
(Conc_Typ
));
3360 -- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry
3361 -- (Protection_Entries_Access (P),
3363 -- Task_Entry_Index (I),
3366 -- System.Tasking.Rendezvous.Requeue_Task_Entry
3368 -- Task_Entry_Index (I),
3373 Make_If_Statement
(Loc
,
3374 Condition
=> Make_Identifier
(Loc
, Name_uF
),
3376 Then_Statements
=> New_List
(
3378 -- Call to Requeue_Protected_To_Task_Entry
3380 Make_Procedure_Call_Statement
(Loc
,
3383 (RTE
(RE_Requeue_Protected_To_Task_Entry
), Loc
),
3385 Parameter_Associations
=> New_List
(
3387 Unchecked_Convert_To
( -- PEA (P)
3388 RTE
(RE_Protection_Entries_Access
),
3389 Make_Identifier
(Loc
, Name_uP
)),
3391 Make_Selected_Component
(Loc
, -- O._task_id
3392 Prefix
=> Make_Identifier
(Loc
, Name_uO
),
3393 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3395 Unchecked_Convert_To
( -- entry index
3396 RTE
(RE_Task_Entry_Index
),
3397 Make_Identifier
(Loc
, Name_uI
)),
3399 Make_Identifier
(Loc
, Name_uA
)))), -- abort status
3401 Else_Statements
=> New_List
(
3403 -- Call to Requeue_Task_Entry
3405 Make_Procedure_Call_Statement
(Loc
,
3407 New_Occurrence_Of
(RTE
(RE_Requeue_Task_Entry
), Loc
),
3409 Parameter_Associations
=> New_List
(
3411 Make_Selected_Component
(Loc
, -- O._task_id
3412 Prefix
=> Make_Identifier
(Loc
, Name_uO
),
3413 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3415 Unchecked_Convert_To
( -- entry index
3416 RTE
(RE_Task_Entry_Index
),
3417 Make_Identifier
(Loc
, Name_uI
)),
3419 Make_Identifier
(Loc
, Name_uA
)))))); -- abort status
3422 -- Even though no declarations are needed in both cases, we allocate
3423 -- a list for entities added by Freeze.
3426 Make_Subprogram_Body
(Loc
,
3427 Specification
=> Make_Disp_Requeue_Spec
(Typ
),
3428 Declarations
=> New_List
,
3429 Handled_Statement_Sequence
=>
3430 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
3431 end Make_Disp_Requeue_Body
;
3433 ----------------------------
3434 -- Make_Disp_Requeue_Spec --
3435 ----------------------------
3437 function Make_Disp_Requeue_Spec
3438 (Typ
: Entity_Id
) return Node_Id
3440 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3443 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3445 -- O : in out Typ; - Object parameter
3446 -- F : Boolean; - Protected (True) / task (False) flag
3447 -- P : Address; - Protection_Entries_Access value
3448 -- I : Entry_Index - Index of entry call
3449 -- A : Boolean - Abort flag
3451 -- Note that the Protection_Entries_Access value is represented as a
3452 -- System.Address in order to avoid dragging in the tasking runtime
3453 -- when compiling sources without tasking constructs.
3456 Make_Procedure_Specification
(Loc
,
3457 Defining_Unit_Name
=>
3458 Make_Defining_Identifier
(Loc
, Name_uDisp_Requeue
),
3460 Parameter_Specifications
=> New_List
(
3462 Make_Parameter_Specification
(Loc
, -- O
3463 Defining_Identifier
=>
3464 Make_Defining_Identifier
(Loc
, Name_uO
),
3466 New_Occurrence_Of
(Typ
, Loc
),
3468 Out_Present
=> True),
3470 Make_Parameter_Specification
(Loc
, -- F
3471 Defining_Identifier
=>
3472 Make_Defining_Identifier
(Loc
, Name_uF
),
3474 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
3476 Make_Parameter_Specification
(Loc
, -- P
3477 Defining_Identifier
=>
3478 Make_Defining_Identifier
(Loc
, Name_uP
),
3480 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3482 Make_Parameter_Specification
(Loc
, -- I
3483 Defining_Identifier
=>
3484 Make_Defining_Identifier
(Loc
, Name_uI
),
3486 New_Occurrence_Of
(Standard_Integer
, Loc
)),
3488 Make_Parameter_Specification
(Loc
, -- A
3489 Defining_Identifier
=>
3490 Make_Defining_Identifier
(Loc
, Name_uA
),
3492 New_Occurrence_Of
(Standard_Boolean
, Loc
))));
3493 end Make_Disp_Requeue_Spec
;
3495 ---------------------------------
3496 -- Make_Disp_Timed_Select_Body --
3497 ---------------------------------
3499 -- For interface types, generate:
3501 -- procedure _Disp_Timed_Select
3502 -- (T : in out <Typ>;
3504 -- P : System.Address;
3507 -- C : out Ada.Tags.Prim_Op_Kind;
3512 -- C := Ada.Tags.POK_Function;
3513 -- end _Disp_Timed_Select;
3515 -- For protected types, generate:
3517 -- procedure _Disp_Timed_Select
3518 -- (T : in out <Typ>;
3520 -- P : System.Address;
3523 -- C : out Ada.Tags.Prim_Op_Kind;
3529 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S);
3531 -- if C = Ada.Tags.POK_Procedure
3532 -- or else C = Ada.Tags.POK_Protected_Procedure
3533 -- or else C = Ada.Tags.POK_Task_Procedure
3539 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3540 -- System.Tasking.Protected_Objects.Operations.
3541 -- Timed_Protected_Entry_Call
3542 -- (T._object'Access,
3543 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
3548 -- end _Disp_Timed_Select;
3550 -- For task types, generate:
3552 -- procedure _Disp_Timed_Select
3553 -- (T : in out <Typ>;
3555 -- P : System.Address;
3558 -- C : out Ada.Tags.Prim_Op_Kind;
3564 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3565 -- System.Tasking.Rendezvous.Timed_Task_Entry_Call
3567 -- System.Tasking.Task_Entry_Index (I),
3572 -- end _Disp_Time_Select;
3574 function Make_Disp_Timed_Select_Body
3575 (Typ
: Entity_Id
) return Node_Id
3577 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3578 Conc_Typ
: Entity_Id
:= Empty
;
3579 Decls
: constant List_Id
:= New_List
;
3581 Stmts
: constant List_Id
:= New_List
;
3585 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3587 -- Null body is generated for interface types
3589 if Is_Interface
(Typ
) then
3591 Make_Subprogram_Body
(Loc
,
3592 Specification
=> Make_Disp_Timed_Select_Spec
(Typ
),
3593 Declarations
=> New_List
,
3594 Handled_Statement_Sequence
=>
3595 Make_Handled_Sequence_Of_Statements
(Loc
,
3597 Make_Assignment_Statement
(Loc
,
3598 Name
=> Make_Identifier
(Loc
, Name_uF
),
3599 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
3602 if Is_Concurrent_Record_Type
(Typ
) then
3603 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
3608 -- where I will be used to capture the entry index of the primitive
3609 -- wrapper at position S.
3612 Make_Object_Declaration
(Loc
,
3613 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uI
),
3614 Object_Definition
=>
3615 New_Occurrence_Of
(Standard_Integer
, Loc
)));
3618 -- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
3620 -- if C = POK_Procedure
3621 -- or else C = POK_Protected_Procedure
3622 -- or else C = POK_Task_Procedure;
3628 Build_Common_Dispatching_Select_Statements
(Typ
, Stmts
);
3631 -- I := Get_Entry_Index (tag! (<type>VP), S);
3633 -- I is the entry index and S is the dispatch table slot
3635 if Tagged_Type_Expansion
then
3637 Unchecked_Convert_To
(RTE
(RE_Tag
),
3639 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
3643 Make_Attribute_Reference
(Loc
,
3644 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
3645 Attribute_Name
=> Name_Tag
);
3649 Make_Assignment_Statement
(Loc
,
3650 Name
=> Make_Identifier
(Loc
, Name_uI
),
3652 Make_Function_Call
(Loc
,
3653 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
3654 Parameter_Associations
=> New_List
(
3656 Make_Identifier
(Loc
, Name_uS
)))));
3660 if Ekind
(Conc_Typ
) = E_Protected_Type
then
3662 -- Build T._object'Access
3665 Make_Attribute_Reference
(Loc
,
3666 Attribute_Name
=> Name_Unchecked_Access
,
3668 Make_Selected_Component
(Loc
,
3669 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
3670 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
3672 -- Normal case, No_Entry_Queue restriction not active. In this
3673 -- case we generate:
3675 -- Timed_Protected_Entry_Call
3676 -- (T._object'access,
3677 -- Protected_Entry_Index! (I),
3680 -- where T is the protected object, I is the entry index, P are
3681 -- the wrapped parameters, D is the delay amount, M is the delay
3682 -- mode and F is the status flag.
3684 -- Historically, there was also an implementation for single
3685 -- entry protected types (in s-tposen). However, it was removed
3686 -- by also testing for no No_Select_Statements restriction in
3687 -- Exp_Utils.Corresponding_Runtime_Package. This simplified the
3688 -- implementation of s-tposen.adb and provided consistency between
3689 -- all versions of System.Tasking.Protected_Objects.Single_Entry
3692 case Corresponding_Runtime_Package
(Conc_Typ
) is
3693 when System_Tasking_Protected_Objects_Entries
=>
3695 Make_Procedure_Call_Statement
(Loc
,
3698 (RTE
(RE_Timed_Protected_Entry_Call
), Loc
),
3699 Parameter_Associations
=> New_List
(
3702 Unchecked_Convert_To
( -- entry index
3703 RTE
(RE_Protected_Entry_Index
),
3704 Make_Identifier
(Loc
, Name_uI
)),
3706 Make_Identifier
(Loc
, Name_uP
), -- parameter block
3707 Make_Identifier
(Loc
, Name_uD
), -- delay
3708 Make_Identifier
(Loc
, Name_uM
), -- delay mode
3709 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
3712 raise Program_Error
;
3718 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
3721 -- Timed_Task_Entry_Call (
3723 -- Task_Entry_Index! (I),
3729 -- where T is the task object, I is the entry index, P are the
3730 -- wrapped parameters, D is the delay amount, M is the delay
3731 -- mode and F is the status flag.
3734 Make_Procedure_Call_Statement
(Loc
,
3736 New_Occurrence_Of
(RTE
(RE_Timed_Task_Entry_Call
), Loc
),
3738 Parameter_Associations
=> New_List
(
3739 Make_Selected_Component
(Loc
, -- T._task_id
3740 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
3741 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3743 Unchecked_Convert_To
( -- entry index
3744 RTE
(RE_Task_Entry_Index
),
3745 Make_Identifier
(Loc
, Name_uI
)),
3747 Make_Identifier
(Loc
, Name_uP
), -- parameter block
3748 Make_Identifier
(Loc
, Name_uD
), -- delay
3749 Make_Identifier
(Loc
, Name_uM
), -- delay mode
3750 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
3754 -- Initialize out parameters
3757 Make_Assignment_Statement
(Loc
,
3758 Name
=> Make_Identifier
(Loc
, Name_uF
),
3759 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3761 Make_Assignment_Statement
(Loc
,
3762 Name
=> Make_Identifier
(Loc
, Name_uC
),
3763 Expression
=> New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
)));
3767 Make_Subprogram_Body
(Loc
,
3768 Specification
=> Make_Disp_Timed_Select_Spec
(Typ
),
3769 Declarations
=> Decls
,
3770 Handled_Statement_Sequence
=>
3771 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
3772 end Make_Disp_Timed_Select_Body
;
3774 ---------------------------------
3775 -- Make_Disp_Timed_Select_Spec --
3776 ---------------------------------
3778 function Make_Disp_Timed_Select_Spec
3779 (Typ
: Entity_Id
) return Node_Id
3781 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3782 Def_Id
: constant Node_Id
:=
3783 Make_Defining_Identifier
(Loc
,
3784 Name_uDisp_Timed_Select
);
3785 Params
: constant List_Id
:= New_List
;
3788 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3790 -- T : in out Typ; -- Object parameter
3791 -- S : Integer; -- Primitive operation slot
3792 -- P : Address; -- Wrapped parameters
3793 -- D : Duration; -- Delay
3794 -- M : Integer; -- Delay Mode
3795 -- C : out Prim_Op_Kind; -- Call kind
3796 -- F : out Boolean; -- Status flag
3798 Append_List_To
(Params
, New_List
(
3800 Make_Parameter_Specification
(Loc
,
3801 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
3802 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
3804 Out_Present
=> True),
3806 Make_Parameter_Specification
(Loc
,
3807 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
3808 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3810 Make_Parameter_Specification
(Loc
,
3811 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
3812 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3814 Make_Parameter_Specification
(Loc
,
3815 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uD
),
3816 Parameter_Type
=> New_Occurrence_Of
(Standard_Duration
, Loc
)),
3818 Make_Parameter_Specification
(Loc
,
3819 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uM
),
3820 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3822 Make_Parameter_Specification
(Loc
,
3823 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
3825 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
3826 Out_Present
=> True)));
3829 Make_Parameter_Specification
(Loc
,
3830 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
3831 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3832 Out_Present
=> True));
3835 Make_Procedure_Specification
(Loc
,
3836 Defining_Unit_Name
=> Def_Id
,
3837 Parameter_Specifications
=> Params
);
3838 end Make_Disp_Timed_Select_Spec
;
3844 -- The frontend supports two models for expanding dispatch tables
3845 -- associated with library-level defined tagged types: statically and
3846 -- non-statically allocated dispatch tables. In the former case the object
3847 -- containing the dispatch table is constant and it is initialized by means
3848 -- of a positional aggregate. In the latter case, the object containing
3849 -- the dispatch table is a variable which is initialized by means of
3852 -- In case of locally defined tagged types, the object containing the
3853 -- object containing the dispatch table is always a variable (instead of a
3854 -- constant). This is currently required to give support to late overriding
3855 -- of primitives. For example:
3857 -- procedure Example is
3859 -- type T1 is tagged null record;
3860 -- procedure Prim (O : T1);
3863 -- type T2 is new Pkg.T1 with null record;
3864 -- procedure Prim (X : T2) is -- late overriding
3870 -- WARNING: This routine manages Ghost regions. Return statements must be
3871 -- replaced by gotos which jump to the end of the routine and restore the
3874 function Make_DT
(Typ
: Entity_Id
) return List_Id
is
3875 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3877 Max_Predef_Prims
: constant Int
:=
3881 (Parent
(RTE
(RE_Max_Predef_Prims
)))));
3883 DT_Decl
: constant Elist_Id
:= New_Elmt_List
;
3884 DT_Aggr
: constant Elist_Id
:= New_Elmt_List
;
3885 -- Entities marked with attribute Is_Dispatch_Table_Entity
3887 Dummy_Object
: Entity_Id
:= Empty
;
3888 -- Extra nonexistent object of type Typ internally used to compute the
3889 -- offset to the components that reference secondary dispatch tables.
3890 -- Used to compute the offset of components located at fixed position.
3892 procedure Export_DT
(Typ
: Entity_Id
; DT
: Entity_Id
; Index
: Nat
:= 0);
3893 -- Export the dispatch table DT of tagged type Typ. Required to generate
3894 -- forward references and statically allocate the table. For primary
3895 -- dispatch tables Index is 0; for secondary dispatch tables the value
3896 -- of index must match the Suffix_Index value assigned to the table by
3897 -- Make_Tags when generating its unique external name, and it is used to
3898 -- retrieve from the Dispatch_Table_Wrappers list associated with Typ
3899 -- the external name generated by Import_DT.
3901 procedure Make_Secondary_DT
3904 Iface_Comp
: Node_Id
;
3906 Num_Iface_Prims
: Nat
;
3907 Iface_DT_Ptr
: Entity_Id
;
3908 Predef_Prims_Ptr
: Entity_Id
;
3909 Build_Thunks
: Boolean;
3911 -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch
3912 -- Table of Typ associated with Iface. Each abstract interface of Typ
3913 -- has two secondary dispatch tables: one containing pointers to thunks
3914 -- and another containing pointers to the primitives covering the
3915 -- interface primitives. The former secondary table is generated when
3916 -- Build_Thunks is True, and provides common support for dispatching
3917 -- calls through interface types; the latter secondary table is
3918 -- generated when Build_Thunks is False, and provides support for
3919 -- Generic Dispatching Constructors that dispatch calls through
3920 -- interface types. When constructing this latter table the value of
3921 -- Suffix_Index is -1 to indicate that there is no need to export such
3922 -- table when building statically allocated dispatch tables; a positive
3923 -- value of Suffix_Index must match the Suffix_Index value assigned to
3924 -- this secondary dispatch table by Make_Tags when its unique external
3925 -- name was generated.
3927 function Number_Of_Predefined_Prims
(Typ
: Entity_Id
) return Nat
;
3928 -- Returns the number of predefined primitives of Typ
3934 procedure Export_DT
(Typ
: Entity_Id
; DT
: Entity_Id
; Index
: Nat
:= 0)
3940 Set_Is_Statically_Allocated
(DT
);
3941 Set_Is_True_Constant
(DT
);
3942 Set_Is_Exported
(DT
);
3945 Elmt
:= First_Elmt
(Dispatch_Table_Wrappers
(Typ
));
3946 while Count
/= Index
loop
3951 -- Related_Type (Node (Elmt)) should be equal to Typ here, but we
3952 -- can't assert that, because it is sometimes false in illegal
3953 -- programs. We can't check Serious_Errors_Detected, because the
3954 -- errors have not yet been detected.
3956 Get_External_Name
(Node
(Elmt
));
3957 Set_Interface_Name
(DT
,
3958 Make_String_Literal
(Loc
,
3959 Strval
=> String_From_Name_Buffer
));
3961 -- Ensure proper Sprint output of this implicit importation
3963 Set_Is_Internal
(DT
);
3967 -----------------------
3968 -- Make_Secondary_DT --
3969 -----------------------
3971 procedure Make_Secondary_DT
3974 Iface_Comp
: Node_Id
;
3976 Num_Iface_Prims
: Nat
;
3977 Iface_DT_Ptr
: Entity_Id
;
3978 Predef_Prims_Ptr
: Entity_Id
;
3979 Build_Thunks
: Boolean;
3982 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3983 Exporting_Table
: constant Boolean :=
3984 Building_Static_DT
(Typ
)
3985 and then Suffix_Index
> 0;
3986 Iface_DT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
3987 Predef_Prims
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
3988 DT_Constr_List
: List_Id
;
3989 DT_Aggr_List
: List_Id
;
3990 Empty_DT
: Boolean := False;
3994 OSD_Aggr_List
: List_Id
;
3996 Prim_Elmt
: Elmt_Id
;
3997 Prim_Ops_Aggr_List
: List_Id
;
4000 -- Handle cases in which we do not generate statically allocated
4003 if not Building_Static_DT
(Typ
) then
4004 Mutate_Ekind
(Predef_Prims
, E_Variable
);
4005 Mutate_Ekind
(Iface_DT
, E_Variable
);
4007 -- Statically allocated dispatch tables and related entities are
4011 Mutate_Ekind
(Predef_Prims
, E_Constant
);
4012 Set_Is_Statically_Allocated
(Predef_Prims
);
4013 Set_Is_True_Constant
(Predef_Prims
);
4015 Mutate_Ekind
(Iface_DT
, E_Constant
);
4016 Set_Is_Statically_Allocated
(Iface_DT
);
4017 Set_Is_True_Constant
(Iface_DT
);
4020 -- Calculate the number of slots of the dispatch table. If the number
4021 -- of primitives of Typ is 0 we reserve a dummy single entry for its
4022 -- DT because at run time the pointer to this dummy entry will be
4025 if Num_Iface_Prims
= 0 then
4029 Nb_Prim
:= Num_Iface_Prims
;
4034 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
4035 -- (predef-prim-op-thunk-1'address,
4036 -- predef-prim-op-thunk-2'address,
4038 -- predef-prim-op-thunk-n'address);
4040 -- Create the thunks associated with the predefined primitives and
4041 -- save their entity to fill the aggregate.
4044 Nb_P_Prims
: constant Nat
:= Number_Of_Predefined_Prims
(Typ
);
4045 Prim_Table
: array (Nat
range 1 .. Nb_P_Prims
) of Entity_Id
;
4048 SS_Thunk_Id
: Entity_Id
;
4049 SS_Thunk_Code
: Node_Id
;
4050 Thunk_Id
: Entity_Id
;
4051 Thunk_Code
: List_Id
;
4054 Prim_Ops_Aggr_List
:= New_List
;
4055 Prim_Table
:= (others => Empty
);
4057 if Building_Static_DT
(Typ
) then
4058 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4059 while Present
(Prim_Elmt
) loop
4060 Prim
:= Node
(Prim_Elmt
);
4062 if Is_Predefined_Dispatching_Operation
(Prim
)
4063 and then not Is_Abstract_Subprogram
(Prim
)
4064 and then not Is_Eliminated
(Prim
)
4065 and then not Generate_SCIL
4066 and then No
(Prim_Table
(UI_To_Int
(DT_Position
(Prim
))))
4068 if not Build_Thunks
then
4069 E
:= Ultimate_Alias
(Prim
);
4070 Expand_Secondary_Stack_Thunk
4071 (E
, SS_Thunk_Id
, SS_Thunk_Code
);
4073 if Present
(SS_Thunk_Id
) then
4075 Append_To
(Result
, SS_Thunk_Code
);
4078 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) := E
;
4081 Expand_Interface_Thunk
4082 (Prim
, Thunk_Id
, Thunk_Code
, Iface
);
4084 if Present
(Thunk_Id
) then
4085 Append_List_To
(Result
, Thunk_Code
);
4086 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) :=
4092 Next_Elmt
(Prim_Elmt
);
4096 for J
in Prim_Table
'Range loop
4097 if Present
(Prim_Table
(J
)) then
4099 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
4100 Make_Attribute_Reference
(Loc
,
4101 Prefix
=> New_Occurrence_Of
(Prim_Table
(J
), Loc
),
4102 Attribute_Name
=> Name_Unrestricted_Access
));
4104 New_Node
:= Make_Null
(Loc
);
4107 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
4111 Make_Aggregate
(Loc
, Expressions
=> Prim_Ops_Aggr_List
);
4113 -- Remember aggregates initializing dispatch tables
4115 Append_Elmt
(New_Node
, DT_Aggr
);
4118 Make_Subtype_Declaration
(Loc
,
4119 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
4120 Subtype_Indication
=>
4121 New_Occurrence_Of
(RTE
(RE_Address_Array
), Loc
));
4123 Append_To
(Result
, Decl
);
4126 Make_Object_Declaration
(Loc
,
4127 Defining_Identifier
=> Predef_Prims
,
4128 Constant_Present
=> Building_Static_DT
(Typ
),
4129 Aliased_Present
=> True,
4130 Object_Definition
=> New_Occurrence_Of
4131 (Defining_Identifier
(Decl
), Loc
),
4132 Expression
=> New_Node
));
4137 -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
4138 -- (OSD_Table => (1 => <value>,
4141 -- for OSD'Alignment use Address'Alignment;
4143 -- Iface_DT : Dispatch_Table (Nb_Prims) :=
4144 -- ([ Signature => <sig-value> ],
4145 -- Tag_Kind => <tag_kind-value>,
4146 -- Predef_Prims => Predef_Prims'Address,
4147 -- Offset_To_Top => 0,
4148 -- OSD => OSD'Address,
4149 -- Prims_Ptr => (prim-op-1'address,
4150 -- prim-op-2'address,
4152 -- prim-op-n'address));
4154 -- Stage 3: Initialize the discriminant and the record components
4156 DT_Constr_List
:= New_List
;
4157 DT_Aggr_List
:= New_List
;
4161 Append_To
(DT_Constr_List
, Make_Integer_Literal
(Loc
, Nb_Prim
));
4162 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, Nb_Prim
));
4166 if RTE_Record_Component_Available
(RE_Signature
) then
4167 Append_To
(DT_Aggr_List
,
4168 New_Occurrence_Of
(RTE
(RE_Secondary_DT
), Loc
));
4173 if RTE_Record_Component_Available
(RE_Tag_Kind
) then
4174 Append_To
(DT_Aggr_List
, Tagged_Kind
(Typ
));
4179 Append_To
(DT_Aggr_List
,
4180 Make_Attribute_Reference
(Loc
,
4181 Prefix
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
4182 Attribute_Name
=> Name_Address
));
4184 -- Interface component located at variable offset; the value of
4185 -- Offset_To_Top will be set by the init subprogram.
4187 if No
(Dummy_Object
)
4188 or else Is_Variable_Size_Record
(Etype
(Scope
(Iface_Comp
)))
4190 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
4192 -- Interface component located at fixed offset
4195 Append_To
(DT_Aggr_List
,
4197 Make_Attribute_Reference
(Loc
,
4199 Make_Selected_Component
(Loc
,
4201 New_Occurrence_Of
(Dummy_Object
, Loc
),
4203 New_Occurrence_Of
(Iface_Comp
, Loc
)),
4204 Attribute_Name
=> Name_Position
)));
4207 -- Generate the Object Specific Data table required to dispatch calls
4208 -- through synchronized interfaces.
4211 or else Is_Abstract_Type
(Typ
)
4212 or else Is_Controlled
(Typ
)
4213 or else Restriction_Active
(No_Dispatching_Calls
)
4214 or else not Is_Limited_Type
(Typ
)
4215 or else not Has_Interfaces
(Typ
)
4216 or else not Build_Thunks
4217 or else not RTE_Record_Component_Available
(RE_OSD_Table
)
4219 -- No OSD table required
4221 Append_To
(DT_Aggr_List
,
4222 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
4225 OSD_Aggr_List
:= New_List
;
4228 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
4230 Prim_Alias
: Entity_Id
;
4231 Prim_Elmt
: Elmt_Id
;
4235 SS_Thunk_Id
: Entity_Id
;
4236 SS_Thunk_Code
: Node_Id
;
4239 Prim_Table
:= (others => Empty
);
4240 Prim_Alias
:= Empty
;
4243 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4244 while Present
(Prim_Elmt
) loop
4245 Prim
:= Node
(Prim_Elmt
);
4247 if Present
(Interface_Alias
(Prim
))
4248 and then Find_Dispatching_Type
4249 (Interface_Alias
(Prim
)) = Iface
4251 Prim_Alias
:= Interface_Alias
(Prim
);
4252 E
:= Ultimate_Alias
(Prim
);
4253 Pos
:= UI_To_Int
(DT_Position
(Prim_Alias
));
4255 if No
(Prim_Table
(Pos
)) then
4256 Expand_Secondary_Stack_Thunk
4257 (E
, SS_Thunk_Id
, SS_Thunk_Code
);
4259 if Present
(SS_Thunk_Id
) then
4261 Append_To
(Result
, SS_Thunk_Code
);
4264 Prim_Table
(Pos
) := E
;
4266 Append_To
(OSD_Aggr_List
,
4267 Make_Component_Association
(Loc
,
4268 Choices
=> New_List
(
4269 Make_Integer_Literal
(Loc
,
4270 DT_Position
(Prim_Alias
))),
4272 Make_Integer_Literal
(Loc
,
4273 DT_Position
(Alias
(Prim
)))));
4279 Next_Elmt
(Prim_Elmt
);
4281 pragma Assert
(Count
= Nb_Prim
);
4284 OSD
:= Make_Temporary
(Loc
, 'I');
4287 Make_Object_Declaration
(Loc
,
4288 Defining_Identifier
=> OSD
,
4289 Constant_Present
=> True,
4290 Object_Definition
=>
4291 Make_Subtype_Indication
(Loc
,
4293 New_Occurrence_Of
(RTE
(RE_Object_Specific_Data
), Loc
),
4295 Make_Index_Or_Discriminant_Constraint
(Loc
,
4296 Constraints
=> New_List
(
4297 Make_Integer_Literal
(Loc
, Nb_Prim
)))),
4300 Make_Aggregate
(Loc
,
4301 Component_Associations
=> New_List
(
4302 Make_Component_Association
(Loc
,
4303 Choices
=> New_List
(
4305 (RTE_Record_Component
(RE_OSD_Num_Prims
), Loc
)),
4307 Make_Integer_Literal
(Loc
, Nb_Prim
)),
4309 Make_Component_Association
(Loc
,
4310 Choices
=> New_List
(
4312 (RTE_Record_Component
(RE_OSD_Table
), Loc
)),
4313 Expression
=> Make_Aggregate
(Loc
,
4314 Component_Associations
=> OSD_Aggr_List
))))));
4317 Make_Attribute_Definition_Clause
(Loc
,
4318 Name
=> New_Occurrence_Of
(OSD
, Loc
),
4319 Chars
=> Name_Alignment
,
4321 Make_Attribute_Reference
(Loc
,
4323 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4324 Attribute_Name
=> Name_Alignment
)));
4326 -- In secondary dispatch tables the Typeinfo component contains
4327 -- the address of the Object Specific Data (see a-tags.ads).
4329 Append_To
(DT_Aggr_List
,
4330 Make_Attribute_Reference
(Loc
,
4331 Prefix
=> New_Occurrence_Of
(OSD
, Loc
),
4332 Attribute_Name
=> Name_Address
));
4335 -- Initialize the table of primitive operations
4337 Prim_Ops_Aggr_List
:= New_List
;
4340 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
4342 elsif Is_Abstract_Type
(Typ
)
4343 or else not Building_Static_DT
(Typ
)
4345 for J
in 1 .. Nb_Prim
loop
4346 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
4351 CPP_Nb_Prims
: constant Nat
:= CPP_Num_Prims
(Typ
);
4354 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
4355 SS_Thunk_Id
: Entity_Id
;
4356 SS_Thunk_Code
: Node_Id
;
4357 Thunk_Id
: Entity_Id
;
4358 Thunk_Code
: List_Id
;
4361 Prim_Table
:= (others => Empty
);
4363 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4364 while Present
(Prim_Elmt
) loop
4365 Prim
:= Node
(Prim_Elmt
);
4366 E
:= Ultimate_Alias
(Prim
);
4367 Prim_Pos
:= UI_To_Int
(DT_Position
(E
));
4369 -- Do not reference predefined primitives because they are
4370 -- located in a separate dispatch table; skip abstract and
4371 -- eliminated primitives; skip primitives located in the C++
4372 -- part of the dispatch table because their slot is set by
4375 if not Is_Predefined_Dispatching_Operation
(Prim
)
4376 and then Present
(Interface_Alias
(Prim
))
4377 and then not Is_Abstract_Subprogram
(Alias
(Prim
))
4378 and then not Is_Eliminated
(Alias
(Prim
))
4379 and then (not Is_CPP_Class
(Root_Type
(Typ
))
4380 or else Prim_Pos
> CPP_Nb_Prims
)
4381 and then Find_Dispatching_Type
4382 (Interface_Alias
(Prim
)) = Iface
4384 -- Generate the code of the thunk only if the abstract
4385 -- interface type is not an immediate ancestor of
4386 -- Tagged_Type. Otherwise the DT associated with the
4387 -- interface is the primary DT.
4389 and then not Is_Ancestor
(Iface
, Typ
,
4390 Use_Full_View
=> True)
4392 if not Build_Thunks
then
4394 Expand_Secondary_Stack_Thunk
4395 (E
, SS_Thunk_Id
, SS_Thunk_Code
);
4397 if Present
(SS_Thunk_Id
) then
4399 Append_To
(Result
, SS_Thunk_Code
);
4403 UI_To_Int
(DT_Position
(Interface_Alias
(Prim
)));
4404 Prim_Table
(Prim_Pos
) := E
;
4407 Expand_Interface_Thunk
4408 (Prim
, Thunk_Id
, Thunk_Code
, Iface
);
4410 if Present
(Thunk_Id
) then
4412 UI_To_Int
(DT_Position
(Interface_Alias
(Prim
)));
4414 Prim_Table
(Prim_Pos
) := Thunk_Id
;
4415 Append_List_To
(Result
, Thunk_Code
);
4420 Next_Elmt
(Prim_Elmt
);
4423 for J
in Prim_Table
'Range loop
4424 if Present
(Prim_Table
(J
)) then
4426 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
4427 Make_Attribute_Reference
(Loc
,
4428 Prefix
=> New_Occurrence_Of
(Prim_Table
(J
), Loc
),
4429 Attribute_Name
=> Name_Unrestricted_Access
));
4432 New_Node
:= Make_Null
(Loc
);
4435 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
4441 Make_Aggregate
(Loc
,
4442 Expressions
=> Prim_Ops_Aggr_List
);
4444 Append_To
(DT_Aggr_List
, New_Node
);
4446 -- Remember aggregates initializing dispatch tables
4448 Append_Elmt
(New_Node
, DT_Aggr
);
4450 -- Note: Secondary dispatch tables are declared constant only if
4451 -- we can compute their offset field by means of the extra dummy
4452 -- object; otherwise they cannot be declared constant and the
4453 -- Offset_To_Top component is initialized by the IP routine.
4456 Make_Object_Declaration
(Loc
,
4457 Defining_Identifier
=> Iface_DT
,
4458 Aliased_Present
=> True,
4459 Constant_Present
=> Building_Static_Secondary_DT
(Typ
),
4461 Object_Definition
=>
4462 Make_Subtype_Indication
(Loc
,
4463 Subtype_Mark
=> New_Occurrence_Of
4464 (RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
4465 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
4466 Constraints
=> DT_Constr_List
)),
4469 Make_Aggregate
(Loc
,
4470 Expressions
=> DT_Aggr_List
)));
4472 if Exporting_Table
then
4473 Export_DT
(Typ
, Iface_DT
, Suffix_Index
);
4475 -- Generate code to create the pointer to the dispatch table
4477 -- Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address);
4479 -- Note: This declaration is not added here if the table is exported
4480 -- because in such case Make_Tags has already added this declaration.
4484 Make_Object_Declaration
(Loc
,
4485 Defining_Identifier
=> Iface_DT_Ptr
,
4486 Constant_Present
=> True,
4488 Object_Definition
=>
4489 New_Occurrence_Of
(RTE
(RE_Interface_Tag
), Loc
),
4492 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
4493 Make_Attribute_Reference
(Loc
,
4495 Make_Selected_Component
(Loc
,
4496 Prefix
=> New_Occurrence_Of
(Iface_DT
, Loc
),
4499 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
4500 Attribute_Name
=> Name_Address
))));
4504 Make_Object_Declaration
(Loc
,
4505 Defining_Identifier
=> Predef_Prims_Ptr
,
4506 Constant_Present
=> True,
4508 Object_Definition
=>
4509 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
4512 Make_Attribute_Reference
(Loc
,
4514 Make_Selected_Component
(Loc
,
4515 Prefix
=> New_Occurrence_Of
(Iface_DT
, Loc
),
4518 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
4519 Attribute_Name
=> Name_Address
)));
4521 -- Remember entities containing dispatch tables
4523 Append_Elmt
(Predef_Prims
, DT_Decl
);
4524 Append_Elmt
(Iface_DT
, DT_Decl
);
4525 end Make_Secondary_DT
;
4527 --------------------------------
4528 -- Number_Of_Predefined_Prims --
4529 --------------------------------
4531 function Number_Of_Predefined_Prims
(Typ
: Entity_Id
) return Nat
is
4532 Nb_Predef_Prims
: Nat
:= 0;
4535 if not Generate_SCIL
then
4538 Prim_Elmt
: Elmt_Id
;
4542 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4543 while Present
(Prim_Elmt
) loop
4544 Prim
:= Node
(Prim_Elmt
);
4546 if Is_Predefined_Dispatching_Operation
(Prim
)
4547 and then not Is_Abstract_Subprogram
(Prim
)
4549 Pos
:= UI_To_Int
(DT_Position
(Prim
));
4551 if Pos
> Nb_Predef_Prims
then
4552 Nb_Predef_Prims
:= Pos
;
4556 Next_Elmt
(Prim_Elmt
);
4561 pragma Assert
(Nb_Predef_Prims
<= Max_Predef_Prims
);
4562 return Nb_Predef_Prims
;
4563 end Number_Of_Predefined_Prims
;
4567 Elab_Code
: constant List_Id
:= New_List
;
4568 Result
: constant List_Id
:= New_List
;
4569 Tname
: constant Name_Id
:= Chars
(Typ
);
4571 -- When pragmas Discard_Names and No_Tagged_Streams simultaneously apply
4572 -- we initialize the Expanded_Name and the External_Tag of this tagged
4573 -- type with an empty string. This is useful to avoid exposing entity
4574 -- names at binary level. It can be done when both pragmas apply because
4575 -- (1) Discard_Names allows initializing Expanded_Name with an
4576 -- implementation defined value (Ada RM Section C.5 (7/2)).
4577 -- (2) External_Tag (combined with Internal_Tag) is used for object
4578 -- streaming and No_Tagged_Streams inhibits the generation of
4581 Discard_Names
: constant Boolean :=
4582 Present
(No_Tagged_Streams_Pragma
(Typ
))
4584 (Global_Discard_Names
or else Einfo
.Entities
.Discard_Names
(Typ
));
4586 -- The following name entries are used by Make_DT to generate a number
4587 -- of entities related to a tagged type. These entities may be generated
4588 -- in a scope other than that of the tagged type declaration, and if
4589 -- the entities for two tagged types with the same name happen to be
4590 -- generated in the same scope, we have to take care to use different
4591 -- names. This is achieved by means of a unique serial number appended
4592 -- to each generated entity name.
4594 Name_DT
: constant Name_Id
:=
4595 New_External_Name
(Tname
, 'T', Suffix_Index
=> -1);
4596 Name_Exname
: constant Name_Id
:=
4597 New_External_Name
(Tname
, 'E', Suffix_Index
=> -1);
4598 Name_HT_Link
: constant Name_Id
:=
4599 New_External_Name
(Tname
, 'H', Suffix_Index
=> -1);
4600 Name_Predef_Prims
: constant Name_Id
:=
4601 New_External_Name
(Tname
, 'R', Suffix_Index
=> -1);
4602 Name_SSD
: constant Name_Id
:=
4603 New_External_Name
(Tname
, 'S', Suffix_Index
=> -1);
4604 Name_TSD
: constant Name_Id
:=
4605 New_External_Name
(Tname
, 'B', Suffix_Index
=> -1);
4607 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
4608 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
4609 -- Save the Ghost-related attributes to restore on exit
4612 AI_Tag_Elmt
: Elmt_Id
;
4613 AI_Tag_Comp
: Elmt_Id
;
4615 DT_Aggr_List
: List_Id
;
4616 DT_Constr_List
: List_Id
;
4619 HT_Link
: Entity_Id
;
4622 Iface_Table_Node
: Node_Id
;
4623 Name_ITable
: Name_Id
;
4626 Num_Ifaces
: Nat
:= 0;
4627 Parent_Typ
: Entity_Id
;
4628 Predef_Prims
: Entity_Id
;
4630 Prim_Elmt
: Elmt_Id
;
4631 Prim_Ops_Aggr_List
: List_Id
;
4634 Typ_Comps
: Elist_Id
;
4635 Typ_Ifaces
: Elist_Id
;
4637 TSD_Aggr_List
: List_Id
;
4638 TSD_Tags_List
: List_Id
;
4640 -- Start of processing for Make_DT
4643 pragma Assert
(Is_Frozen
(Typ
));
4645 -- The tagged type being processed may be subject to pragma Ghost. Set
4646 -- the mode now to ensure that any nodes generated during dispatch table
4647 -- creation are properly marked as Ghost.
4649 Set_Ghost_Mode
(Typ
);
4651 -- Handle cases in which there is no need to build the dispatch table
4653 if Has_Dispatch_Table
(Typ
)
4654 or else No
(Access_Disp_Table
(Typ
))
4655 or else Is_CPP_Class
(Typ
)
4659 elsif No_Run_Time_Mode
then
4660 Error_Msg_CRT
("tagged types", Typ
);
4663 elsif not RTE_Available
(RE_Tag
) then
4665 Make_Object_Declaration
(Loc
,
4666 Defining_Identifier
=>
4667 Node
(First_Elmt
(Access_Disp_Table
(Typ
))),
4668 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
4669 Constant_Present
=> True,
4671 Unchecked_Convert_To
(RTE
(RE_Tag
),
4672 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
4674 Analyze_List
(Result
, Suppress
=> All_Checks
);
4675 Error_Msg_CRT
("tagged types", Typ
);
4679 -- Ensure that the value of Max_Predef_Prims defined in a-tags is
4680 -- correct. Valid values are 10 under configurable runtime or 16
4681 -- with full runtime.
4683 if RTE_Available
(RE_Interface_Data
) then
4684 if Max_Predef_Prims
/= 16 then
4685 Error_Msg_N
("run-time library configuration error", Typ
);
4689 if Max_Predef_Prims
/= 10 then
4690 Error_Msg_N
("run-time library configuration error", Typ
);
4691 Error_Msg_CRT
("tagged types", Typ
);
4696 DT
:= Make_Defining_Identifier
(Loc
, Name_DT
);
4697 Exname
:= Make_Defining_Identifier
(Loc
, Name_Exname
);
4698 HT_Link
:= Make_Defining_Identifier
(Loc
, Name_HT_Link
);
4699 Predef_Prims
:= Make_Defining_Identifier
(Loc
, Name_Predef_Prims
);
4700 SSD
:= Make_Defining_Identifier
(Loc
, Name_SSD
);
4701 TSD
:= Make_Defining_Identifier
(Loc
, Name_TSD
);
4703 -- Initialize Parent_Typ handling private types
4705 Parent_Typ
:= Etype
(Typ
);
4707 if Present
(Full_View
(Parent_Typ
)) then
4708 Parent_Typ
:= Full_View
(Parent_Typ
);
4711 if not Is_Interface
(Typ
) and then Has_Interfaces
(Typ
) then
4713 Cannot_Have_Null_Disc
: Boolean := False;
4714 Dummy_Object_Typ
: constant Entity_Id
:= Typ
;
4715 Name_Dummy_Object
: constant Name_Id
:=
4716 New_External_Name
(Tname
,
4717 'P', Suffix_Index
=> -1);
4719 Dummy_Object
:= Make_Defining_Identifier
(Loc
, Name_Dummy_Object
);
4721 -- Define the extra object imported and constant to avoid linker
4722 -- errors (since this object is never declared). Required because
4723 -- we implement RM 13.3(19) for exported and imported (variable)
4724 -- objects by making them volatile.
4726 Set_Is_Imported
(Dummy_Object
);
4727 Mutate_Ekind
(Dummy_Object
, E_Constant
);
4728 Set_Is_True_Constant
(Dummy_Object
);
4729 Set_Related_Type
(Dummy_Object
, Typ
);
4731 -- The scope must be set now to call Get_External_Name
4733 Set_Scope
(Dummy_Object
, Current_Scope
);
4735 Get_External_Name
(Dummy_Object
);
4736 Set_Interface_Name
(Dummy_Object
,
4737 Make_String_Literal
(Loc
, Strval
=> String_From_Name_Buffer
));
4739 -- Ensure proper Sprint output of this implicit importation
4741 Set_Is_Internal
(Dummy_Object
);
4743 if not Has_Discriminants
(Dummy_Object_Typ
) then
4745 Make_Object_Declaration
(Loc
,
4746 Defining_Identifier
=> Dummy_Object
,
4747 Constant_Present
=> True,
4748 Object_Definition
=> New_Occurrence_Of
4749 (Dummy_Object_Typ
, Loc
)));
4752 Constr_List
: constant List_Id
:= New_List
;
4756 Discrim
:= First_Discriminant
(Dummy_Object_Typ
);
4757 while Present
(Discrim
) loop
4758 if Is_Discrete_Type
(Etype
(Discrim
)) then
4759 Append_To
(Constr_List
,
4760 Make_Attribute_Reference
(Loc
,
4762 New_Occurrence_Of
(Etype
(Discrim
), Loc
),
4763 Attribute_Name
=> Name_First
));
4766 pragma Assert
(Is_Access_Type
(Etype
(Discrim
)));
4767 Cannot_Have_Null_Disc
:=
4768 Cannot_Have_Null_Disc
4769 or else Can_Never_Be_Null
(Etype
(Discrim
));
4770 Append_To
(Constr_List
, Make_Null
(Loc
));
4773 Next_Discriminant
(Discrim
);
4777 Make_Object_Declaration
(Loc
,
4778 Defining_Identifier
=> Dummy_Object
,
4779 Constant_Present
=> True,
4780 Object_Definition
=>
4781 Make_Subtype_Indication
(Loc
,
4783 New_Occurrence_Of
(Dummy_Object_Typ
, Loc
),
4785 Make_Index_Or_Discriminant_Constraint
(Loc
,
4786 Constraints
=> Constr_List
))));
4790 -- Given that the dummy object will not be declared at run time,
4791 -- analyze its declaration with expansion disabled and warnings
4792 -- and error messages ignored.
4794 Expander_Mode_Save_And_Set
(False);
4795 Ignore_Errors_Enable
:= Ignore_Errors_Enable
+ 1;
4796 Analyze
(Last
(Result
), Suppress
=> All_Checks
);
4797 Ignore_Errors_Enable
:= Ignore_Errors_Enable
- 1;
4798 Expander_Mode_Restore
;
4802 -- Ada 2005 (AI-251): Build the secondary dispatch tables
4804 if Has_Interfaces
(Typ
) then
4805 Collect_Interface_Components
(Typ
, Typ_Comps
);
4807 -- Each secondary dispatch table is assigned an unique positive
4808 -- suffix index; such value also corresponds with the location of
4809 -- its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
4811 -- Note: This value must be kept sync with the Suffix_Index values
4812 -- generated by Make_Tags
4816 Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
4818 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
4819 while Present
(AI_Tag_Comp
) loop
4820 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'P'));
4822 -- Build the secondary table containing pointers to thunks
4827 Base_Type
(Related_Type
(Node
(AI_Tag_Comp
))),
4828 Iface_Comp
=> Node
(AI_Tag_Comp
),
4829 Suffix_Index
=> Suffix_Index
,
4831 UI_To_Int
(DT_Entry_Count
(Node
(AI_Tag_Comp
))),
4832 Iface_DT_Ptr
=> Node
(AI_Tag_Elmt
),
4833 Predef_Prims_Ptr
=> Node
(Next_Elmt
(AI_Tag_Elmt
)),
4834 Build_Thunks
=> True,
4837 -- Skip secondary dispatch table referencing thunks to predefined
4840 Next_Elmt
(AI_Tag_Elmt
);
4841 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'Y'));
4843 -- Secondary dispatch table referencing user-defined primitives
4844 -- covered by this interface.
4846 Next_Elmt
(AI_Tag_Elmt
);
4847 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'D'));
4849 -- Build the secondary table containing pointers to primitives
4850 -- (used to give support to Generic Dispatching Constructors).
4855 (Related_Type
(Node
(AI_Tag_Comp
))),
4856 Iface_Comp
=> Node
(AI_Tag_Comp
),
4858 Num_Iface_Prims
=> UI_To_Int
4859 (DT_Entry_Count
(Node
(AI_Tag_Comp
))),
4860 Iface_DT_Ptr
=> Node
(AI_Tag_Elmt
),
4861 Predef_Prims_Ptr
=> Node
(Next_Elmt
(AI_Tag_Elmt
)),
4862 Build_Thunks
=> False,
4865 -- Skip secondary dispatch table referencing predefined primitives
4867 Next_Elmt
(AI_Tag_Elmt
);
4868 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'Z'));
4870 Suffix_Index
:= Suffix_Index
+ 1;
4871 Next_Elmt
(AI_Tag_Elmt
);
4872 Next_Elmt
(AI_Tag_Comp
);
4876 -- Get the _tag entity and number of primitives of its dispatch table
4878 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
4879 Nb_Prim
:= UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Typ
)));
4881 if Generate_SCIL
then
4885 Set_Is_Statically_Allocated
(DT
, Is_Library_Level_Tagged_Type
(Typ
));
4886 Set_Is_Statically_Allocated
(SSD
, Is_Library_Level_Tagged_Type
(Typ
));
4887 Set_Is_Statically_Allocated
(TSD
, Is_Library_Level_Tagged_Type
(Typ
));
4888 Set_Is_Statically_Allocated
(Predef_Prims
,
4889 Is_Library_Level_Tagged_Type
(Typ
));
4891 -- In case of locally defined tagged type we declare the object
4892 -- containing the dispatch table by means of a variable. Its
4893 -- initialization is done later by means of an assignment. This is
4894 -- required to generate its External_Tag.
4896 if not Building_Static_DT
(Typ
) then
4899 -- DT : No_Dispatch_Table_Wrapper;
4900 -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
4902 if not Has_DT
(Typ
) then
4904 Make_Object_Declaration
(Loc
,
4905 Defining_Identifier
=> DT
,
4906 Aliased_Present
=> True,
4907 Constant_Present
=> False,
4908 Object_Definition
=>
4910 (RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
)));
4913 Make_Object_Declaration
(Loc
,
4914 Defining_Identifier
=> DT_Ptr
,
4915 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
4916 Constant_Present
=> True,
4918 Unchecked_Convert_To
(RTE
(RE_Tag
),
4919 Make_Attribute_Reference
(Loc
,
4921 Make_Selected_Component
(Loc
,
4922 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
4925 (RTE_Record_Component
(RE_NDT_Prims_Ptr
), Loc
)),
4926 Attribute_Name
=> Name_Address
))));
4928 Set_Is_Statically_Allocated
(DT_Ptr
,
4929 Is_Library_Level_Tagged_Type
(Typ
));
4931 -- Generate the SCIL node for the previous object declaration
4932 -- because it has a tag initialization.
4934 if Generate_SCIL
then
4936 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
4937 Set_SCIL_Entity
(New_Node
, Typ
);
4938 Set_SCIL_Node
(Last
(Result
), New_Node
);
4942 -- Gnat2scil has its own implementation of dispatch tables,
4943 -- different than what is being implemented here. Generating
4944 -- further dispatch table initialization code would just
4945 -- cause gnat2scil to generate useless Scil which CodePeer
4946 -- would waste time and space analyzing, so we skip it.
4950 -- DT : Dispatch_Table_Wrapper (Nb_Prim);
4951 -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
4954 -- If the tagged type has no primitives we add a dummy slot
4955 -- whose address will be the tag of this type.
4959 New_List
(Make_Integer_Literal
(Loc
, 1));
4962 New_List
(Make_Integer_Literal
(Loc
, Nb_Prim
));
4966 Make_Object_Declaration
(Loc
,
4967 Defining_Identifier
=> DT
,
4968 Aliased_Present
=> True,
4969 Constant_Present
=> False,
4970 Object_Definition
=>
4971 Make_Subtype_Indication
(Loc
,
4973 New_Occurrence_Of
(RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
4975 Make_Index_Or_Discriminant_Constraint
(Loc
,
4976 Constraints
=> DT_Constr_List
))));
4979 Make_Object_Declaration
(Loc
,
4980 Defining_Identifier
=> DT_Ptr
,
4981 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
4982 Constant_Present
=> True,
4984 Unchecked_Convert_To
(RTE
(RE_Tag
),
4985 Make_Attribute_Reference
(Loc
,
4987 Make_Selected_Component
(Loc
,
4988 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
4991 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
4992 Attribute_Name
=> Name_Address
))));
4994 Set_Is_Statically_Allocated
(DT_Ptr
,
4995 Is_Library_Level_Tagged_Type
(Typ
));
4997 -- Generate the SCIL node for the previous object declaration
4998 -- because it has a tag initialization.
5000 if Generate_SCIL
then
5002 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
5003 Set_SCIL_Entity
(New_Node
, Typ
);
5004 Set_SCIL_Node
(Last
(Result
), New_Node
);
5008 -- Gnat2scil has its own implementation of dispatch tables,
5009 -- different than what is being implemented here. Generating
5010 -- further dispatch table initialization code would just
5011 -- cause gnat2scil to generate useless Scil which CodePeer
5012 -- would waste time and space analyzing, so we skip it.
5016 Make_Object_Declaration
(Loc
,
5017 Defining_Identifier
=>
5018 Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
)))),
5019 Constant_Present
=> True,
5020 Object_Definition
=>
5021 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
5023 Make_Attribute_Reference
(Loc
,
5025 Make_Selected_Component
(Loc
,
5026 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
5029 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
5030 Attribute_Name
=> Name_Address
)));
5034 -- Generate: Expanded_Name : constant String := "";
5036 if Discard_Names
then
5038 Make_Object_Declaration
(Loc
,
5039 Defining_Identifier
=> Exname
,
5040 Constant_Present
=> True,
5041 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
5043 Make_String_Literal
(Loc
, "")));
5045 -- Generate: Exname : constant String := full_qualified_name (typ);
5046 -- The type itself may be an anonymous parent type, so use the first
5047 -- subtype to have a user-recognizable name.
5051 Make_Object_Declaration
(Loc
,
5052 Defining_Identifier
=> Exname
,
5053 Constant_Present
=> True,
5054 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
5056 Make_String_Literal
(Loc
,
5057 Fully_Qualified_Name_String
(First_Subtype
(Typ
)))));
5060 Set_Is_Statically_Allocated
(Exname
);
5061 Set_Is_True_Constant
(Exname
);
5063 -- Declare the object used by Ada.Tags.Register_Tag, unless
5064 -- No_Tagged_Type_Registration is active.
5066 if not Restriction_Active
(No_Tagged_Type_Registration
)
5067 and then RTE_Available
(RE_Register_Tag
)
5070 Make_Object_Declaration
(Loc
,
5071 Defining_Identifier
=> HT_Link
,
5072 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
5073 Expression
=> New_Occurrence_Of
(RTE
(RE_No_Tag
), Loc
)));
5076 -- Generate code to create the storage for the type specific data object
5077 -- with enough space to store the tags of the ancestors plus the tags
5078 -- of all the implemented interfaces (as described in a-tags.adb).
5080 -- TSD : Type_Specific_Data (I_Depth) :=
5081 -- (Idepth => I_Depth,
5082 -- Access_Level => Type_Access_Level (Typ),
5083 -- Alignment => Typ'Alignment,
5084 -- Expanded_Name => Cstring_Ptr!(Exname'Address))
5085 -- External_Tag => Cstring_Ptr!(Exname'Address))
5086 -- HT_Link => HT_Link'Address,
5087 -- Transportable => <<boolean-value>>,
5088 -- Is_Abstract => <<boolean-value>>,
5089 -- Needs_Finalization => <<boolean-value>>,
5090 -- [ Size_Func => Size_Prim'Access, ]
5091 -- [ Interfaces_Table => <<access-value>>, ]
5092 -- [ SSD => SSD_Table'Address ]
5093 -- Tags_Table => (0 => null,
5097 TSD_Aggr_List
:= New_List
;
5099 -- Idepth: Count ancestors to compute the inheritance depth. For private
5100 -- extensions, always go to the full view in order to compute the real
5101 -- inheritance depth.
5104 Current_Typ
: Entity_Id
;
5105 Parent_Typ
: Entity_Id
;
5111 Parent_Typ
:= Etype
(Current_Typ
);
5113 if Is_Private_Type
(Parent_Typ
) then
5114 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
5117 exit when Parent_Typ
= Current_Typ
;
5119 I_Depth
:= I_Depth
+ 1;
5120 Current_Typ
:= Parent_Typ
;
5124 Append_To
(TSD_Aggr_List
,
5125 Make_Integer_Literal
(Loc
, I_Depth
));
5129 Append_To
(TSD_Aggr_List
,
5130 Make_Integer_Literal
(Loc
, Type_Access_Level
(Typ
)));
5134 -- For CPP types we cannot rely on the value of 'Alignment provided
5135 -- by the backend to initialize this TSD field.
5137 if Convention
(Typ
) = Convention_CPP
5138 or else Is_CPP_Class
(Root_Type
(Typ
))
5140 Append_To
(TSD_Aggr_List
,
5141 Make_Integer_Literal
(Loc
, 0));
5143 Append_To
(TSD_Aggr_List
,
5144 Make_Attribute_Reference
(Loc
,
5145 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
5146 Attribute_Name
=> Name_Alignment
));
5151 Append_To
(TSD_Aggr_List
,
5152 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5153 Make_Attribute_Reference
(Loc
,
5154 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5155 Attribute_Name
=> Name_Address
)));
5157 -- External_Tag of a local tagged type
5159 -- <typ>A : constant String :=
5160 -- "Internal tag at 16#tag-addr#: <full-name-of-typ>";
5162 -- The reason we generate this strange name is that we do not want to
5163 -- enter local tagged types in the global hash table used to compute
5164 -- the Internal_Tag attribute for two reasons:
5166 -- 1. It is hard to avoid a tasking race condition for entering the
5167 -- entry into the hash table.
5169 -- 2. It would cause a storage leak, unless we rig up considerable
5170 -- mechanism to remove the entry from the hash table on exit.
5172 -- So what we do is to generate the above external tag name, where the
5173 -- hex address is the address of the local dispatch table (i.e. exactly
5174 -- the value we want if Internal_Tag is computed from this string).
5176 -- Of course this value will only be valid if the tagged type is still
5177 -- in scope, but it clearly must be erroneous to compute the internal
5178 -- tag of a tagged type that is out of scope.
5180 -- We don't do this processing if an explicit external tag has been
5181 -- specified. That's an odd case for which we have already issued a
5182 -- warning, where we will not be able to compute the internal tag.
5184 if not Discard_Names
5185 and then not Is_Library_Level_Entity
(Typ
)
5186 and then not Has_External_Tag_Rep_Clause
(Typ
)
5189 Exname
: constant Entity_Id
:=
5190 Make_Defining_Identifier
(Loc
,
5191 Chars
=> New_External_Name
(Tname
, 'A'));
5192 Full_Name
: constant String_Id
:=
5193 Fully_Qualified_Name_String
(First_Subtype
(Typ
));
5194 Str1_Id
: String_Id
;
5195 Str2_Id
: String_Id
;
5199 -- Str1 = "Internal tag at 16#";
5202 Store_String_Chars
("Internal tag at 16#");
5203 Str1_Id
:= End_String
;
5206 -- Str2 = "#: <type-full-name>";
5209 Store_String_Chars
("#: ");
5210 Store_String_Chars
(Full_Name
);
5211 Str2_Id
:= End_String
;
5214 -- Exname : constant String :=
5215 -- Str1 & Address_Image (Tag) & Str2;
5217 if RTE_Available
(RE_Address_Image
) then
5219 Make_Object_Declaration
(Loc
,
5220 Defining_Identifier
=> Exname
,
5221 Constant_Present
=> True,
5222 Object_Definition
=> New_Occurrence_Of
5223 (Standard_String
, Loc
),
5225 Make_Op_Concat
(Loc
,
5226 Left_Opnd
=> Make_String_Literal
(Loc
, Str1_Id
),
5228 Make_Op_Concat
(Loc
,
5230 Make_Function_Call
(Loc
,
5233 (RTE
(RE_Address_Image
), Loc
),
5234 Parameter_Associations
=> New_List
(
5235 Unchecked_Convert_To
(RTE
(RE_Address
),
5236 New_Occurrence_Of
(DT_Ptr
, Loc
)))),
5238 Make_String_Literal
(Loc
, Str2_Id
)))));
5241 -- Exname : constant String := Str1 & Str2;
5245 Make_Object_Declaration
(Loc
,
5246 Defining_Identifier
=> Exname
,
5247 Constant_Present
=> True,
5248 Object_Definition
=>
5249 New_Occurrence_Of
(Standard_String
, Loc
),
5251 Make_Op_Concat
(Loc
,
5252 Left_Opnd
=> Make_String_Literal
(Loc
, Str1_Id
),
5253 Right_Opnd
=> Make_String_Literal
(Loc
, Str2_Id
))));
5257 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5258 Make_Attribute_Reference
(Loc
,
5259 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5260 Attribute_Name
=> Name_Address
));
5263 -- External tag of a library-level tagged type: Check for a definition
5264 -- of External_Tag. The clause is considered only if it applies to this
5265 -- specific tagged type, as opposed to one of its ancestors.
5266 -- If the type is an unconstrained type extension, we are building the
5267 -- dispatch table of its anonymous base type, so the external tag, if
5268 -- any was specified, must be retrieved from the first subtype. Go to
5269 -- the full view in case the clause is in the private part.
5273 Def
: constant Node_Id
:= Get_Attribute_Definition_Clause
5274 (Underlying_Type
(First_Subtype
(Typ
)),
5275 Attribute_External_Tag
);
5277 Old_Val
: String_Id
;
5278 New_Val
: String_Id
;
5283 or else Entity
(Name
(Def
)) /= First_Subtype
(Typ
)
5286 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5287 Make_Attribute_Reference
(Loc
,
5288 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5289 Attribute_Name
=> Name_Address
));
5291 Old_Val
:= Strval
(Expr_Value_S
(Expression
(Def
)));
5293 -- For the rep clause "for <typ>'external_tag use y" generate:
5295 -- <typ>A : constant string := y;
5297 -- <typ>A'Address is used to set the External_Tag component
5300 -- Create a new nul terminated string if it is not already
5302 if String_Length
(Old_Val
) > 0
5304 Get_String_Char
(Old_Val
, String_Length
(Old_Val
)) = 0
5308 Start_String
(Old_Val
);
5309 Store_String_Char
(Get_Char_Code
(ASCII
.NUL
));
5310 New_Val
:= End_String
;
5313 E
:= Make_Defining_Identifier
(Loc
,
5314 New_External_Name
(Chars
(Typ
), 'A'));
5317 Make_Object_Declaration
(Loc
,
5318 Defining_Identifier
=> E
,
5319 Constant_Present
=> True,
5320 Object_Definition
=>
5321 New_Occurrence_Of
(Standard_String
, Loc
),
5323 Make_String_Literal
(Loc
, New_Val
)));
5326 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5327 Make_Attribute_Reference
(Loc
,
5328 Prefix
=> New_Occurrence_Of
(E
, Loc
),
5329 Attribute_Name
=> Name_Address
));
5334 Append_To
(TSD_Aggr_List
, New_Node
);
5338 if not Restriction_Active
(No_Tagged_Type_Registration
)
5339 and then RTE_Available
(RE_Register_Tag
)
5341 Append_To
(TSD_Aggr_List
,
5342 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
5343 Make_Attribute_Reference
(Loc
,
5344 Prefix
=> New_Occurrence_Of
(HT_Link
, Loc
),
5345 Attribute_Name
=> Name_Address
)));
5347 elsif RTE_Record_Component_Available
(RE_HT_Link
) then
5348 Append_To
(TSD_Aggr_List
,
5349 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
5350 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5353 -- Transportable: Set for types that can be used in remote calls
5354 -- with respect to E.4(18) legality rules.
5357 Transportable
: Entity_Id
;
5363 or else Is_Shared_Passive
(Typ
)
5365 ((Is_Remote_Types
(Typ
)
5366 or else Is_Remote_Call_Interface
(Typ
))
5367 and then Original_View_In_Visible_Part
(Typ
))
5368 or else not Comes_From_Source
(Typ
));
5370 Append_To
(TSD_Aggr_List
,
5371 New_Occurrence_Of
(Transportable
, Loc
));
5374 -- Is_Abstract (Ada 2012: AI05-0173). This functionality is not
5375 -- available in the HIE runtime.
5377 if RTE_Record_Component_Available
(RE_Is_Abstract
) then
5379 Is_Abstract
: Entity_Id
;
5381 Is_Abstract
:= Boolean_Literals
(Is_Abstract_Type
(Typ
));
5382 Append_To
(TSD_Aggr_List
,
5383 New_Occurrence_Of
(Is_Abstract
, Loc
));
5387 -- Needs_Finalization: Set if the type is controlled or has controlled
5391 Needs_Fin
: Entity_Id
;
5393 Needs_Fin
:= Boolean_Literals
(Needs_Finalization
(Typ
));
5394 Append_To
(TSD_Aggr_List
, New_Occurrence_Of
(Needs_Fin
, Loc
));
5399 if RTE_Record_Component_Available
(RE_Size_Func
) then
5401 -- Initialize this field to Null_Address if we are not building
5402 -- static dispatch tables static or if the size function is not
5403 -- available. In the former case we cannot initialize this field
5404 -- until the function is frozen and registered in the dispatch
5405 -- table (see Register_Primitive).
5407 if not Building_Static_DT
(Typ
) or else not Has_DT
(Typ
) then
5408 Append_To
(TSD_Aggr_List
,
5409 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5410 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5414 Prim_Elmt
: Elmt_Id
;
5416 Size_Comp
: Node_Id
:= Empty
;
5419 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5420 while Present
(Prim_Elmt
) loop
5421 Prim
:= Node
(Prim_Elmt
);
5423 if Chars
(Prim
) = Name_uSize
then
5424 Prim
:= Ultimate_Alias
(Prim
);
5426 if Is_Abstract_Subprogram
(Prim
) then
5428 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5429 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
5432 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5433 Make_Attribute_Reference
(Loc
,
5434 Prefix
=> New_Occurrence_Of
(Prim
, Loc
),
5435 Attribute_Name
=> Name_Unrestricted_Access
));
5441 Next_Elmt
(Prim_Elmt
);
5444 pragma Assert
(Present
(Size_Comp
));
5445 Append_To
(TSD_Aggr_List
, Size_Comp
);
5450 -- Interfaces_Table (required for AI-405)
5452 if RTE_Record_Component_Available
(RE_Interfaces_Table
) then
5454 -- Count the number of interface types implemented by Typ
5456 Collect_Interfaces
(Typ
, Typ_Ifaces
);
5458 AI
:= First_Elmt
(Typ_Ifaces
);
5459 while Present
(AI
) loop
5460 Num_Ifaces
:= Num_Ifaces
+ 1;
5464 if Num_Ifaces
= 0 then
5465 Iface_Table_Node
:= Make_Null
(Loc
);
5467 -- Generate the Interface_Table object
5471 TSD_Ifaces_List
: constant List_Id
:= New_List
;
5473 Offset_To_Top
: Node_Id
;
5474 Sec_DT_Tag
: Node_Id
;
5476 Dummy_Object_Ifaces_List
: Elist_Id
:= No_Elist
;
5477 Dummy_Object_Ifaces_Comp_List
: Elist_Id
:= No_Elist
;
5478 Dummy_Object_Ifaces_Tag_List
: Elist_Id
:= No_Elist
;
5479 -- Interfaces information of the dummy object
5482 -- Collect interfaces information if we need to compute the
5483 -- offset to the top using the dummy object.
5485 if Present
(Dummy_Object
) then
5486 Collect_Interfaces_Info
(Typ
,
5487 Ifaces_List
=> Dummy_Object_Ifaces_List
,
5488 Components_List
=> Dummy_Object_Ifaces_Comp_List
,
5489 Tags_List
=> Dummy_Object_Ifaces_Tag_List
);
5492 AI
:= First_Elmt
(Typ_Ifaces
);
5493 while Present
(AI
) loop
5494 if Is_Ancestor
(Node
(AI
), Typ
, Use_Full_View
=> True) then
5495 Sec_DT_Tag
:= New_Occurrence_Of
(DT_Ptr
, Loc
);
5500 (Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
5501 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5503 while Is_Tag
(Node
(Elmt
))
5505 Is_Ancestor
(Node
(AI
), Related_Type
(Node
(Elmt
)),
5506 Use_Full_View
=> True)
5508 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5510 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5512 pragma Assert
(not Has_Thunks
(Node
(Elmt
)));
5514 pragma Assert
(not Has_Thunks
(Node
(Elmt
)));
5518 pragma Assert
(Ekind
(Node
(Elmt
)) = E_Constant
5520 Has_Thunks
(Node
(Next_Elmt
(Next_Elmt
(Elmt
)))));
5524 (Node
(Next_Elmt
(Next_Elmt
(Elmt
))), Loc
);
5527 -- Use the dummy object to compute Offset_To_Top of
5528 -- components located at fixed position.
5530 if Present
(Dummy_Object
) then
5532 Iface
: constant Node_Id
:= Node
(AI
);
5533 Iface_Comp
: Node_Id
:= Empty
;
5534 Iface_Comp_Elmt
: Elmt_Id
;
5535 Iface_Elmt
: Elmt_Id
;
5539 First_Elmt
(Dummy_Object_Ifaces_List
);
5541 First_Elmt
(Dummy_Object_Ifaces_Comp_List
);
5543 while Present
(Iface_Elmt
) loop
5544 if Node
(Iface_Elmt
) = Iface
then
5545 Iface_Comp
:= Node
(Iface_Comp_Elmt
);
5549 Next_Elmt
(Iface_Elmt
);
5550 Next_Elmt
(Iface_Comp_Elmt
);
5553 pragma Assert
(Present
(Iface_Comp
));
5556 Is_Variable_Size_Record
(Etype
(Scope
(Iface_Comp
)))
5560 Make_Attribute_Reference
(Loc
,
5562 Make_Selected_Component
(Loc
,
5564 New_Occurrence_Of
(Dummy_Object
, Loc
),
5566 New_Occurrence_Of
(Iface_Comp
, Loc
)),
5567 Attribute_Name
=> Name_Position
));
5569 Offset_To_Top
:= Make_Integer_Literal
(Loc
, 0);
5573 Offset_To_Top
:= Make_Integer_Literal
(Loc
, 0);
5576 Append_To
(TSD_Ifaces_List
,
5577 Make_Aggregate
(Loc
,
5578 Expressions
=> New_List
(
5582 Unchecked_Convert_To
(RTE
(RE_Tag
),
5584 (Node
(First_Elmt
(Access_Disp_Table
(Node
(AI
)))),
5587 -- Static_Offset_To_Top
5589 New_Occurrence_Of
(Standard_True
, Loc
),
5591 -- Offset_To_Top_Value
5595 -- Offset_To_Top_Func
5601 Unchecked_Convert_To
(RTE
(RE_Tag
), Sec_DT_Tag
))));
5606 Name_ITable
:= New_External_Name
(Tname
, 'I');
5607 ITable
:= Make_Defining_Identifier
(Loc
, Name_ITable
);
5608 Set_Is_Statically_Allocated
(ITable
,
5609 Is_Library_Level_Tagged_Type
(Typ
));
5611 -- The table of interfaces is constant if we are building a
5612 -- static dispatch table; otherwise is not constant because
5613 -- its slots are filled at run time by the IP routine.
5616 Make_Object_Declaration
(Loc
,
5617 Defining_Identifier
=> ITable
,
5618 Aliased_Present
=> True,
5619 Constant_Present
=> Building_Static_Secondary_DT
(Typ
),
5620 Object_Definition
=>
5621 Make_Subtype_Indication
(Loc
,
5623 New_Occurrence_Of
(RTE
(RE_Interface_Data
), Loc
),
5625 Make_Index_Or_Discriminant_Constraint
(Loc
,
5626 Constraints
=> New_List
(
5627 Make_Integer_Literal
(Loc
, Num_Ifaces
)))),
5630 Make_Aggregate
(Loc
,
5631 Expressions
=> New_List
(
5632 Make_Integer_Literal
(Loc
, Num_Ifaces
),
5633 Make_Aggregate
(Loc
, TSD_Ifaces_List
)))));
5636 Make_Attribute_Reference
(Loc
,
5637 Prefix
=> New_Occurrence_Of
(ITable
, Loc
),
5638 Attribute_Name
=> Name_Unchecked_Access
);
5642 Append_To
(TSD_Aggr_List
, Iface_Table_Node
);
5645 -- Generate the Select Specific Data table for synchronized types that
5646 -- implement synchronized interfaces. The size of the table is
5647 -- constrained by the number of non-predefined primitive operations.
5649 if RTE_Record_Component_Available
(RE_SSD
) then
5650 if Ada_Version
>= Ada_2005
5651 and then Has_DT
(Typ
)
5652 and then Is_Concurrent_Record_Type
(Typ
)
5653 and then Has_Interfaces
(Typ
)
5654 and then Nb_Prim
> 0
5655 and then not Is_Abstract_Type
(Typ
)
5656 and then not Is_Controlled
(Typ
)
5657 and then not Restriction_Active
(No_Dispatching_Calls
)
5658 and then not Restriction_Active
(No_Select_Statements
)
5661 Make_Object_Declaration
(Loc
,
5662 Defining_Identifier
=> SSD
,
5663 Aliased_Present
=> True,
5664 Object_Definition
=>
5665 Make_Subtype_Indication
(Loc
,
5666 Subtype_Mark
=> New_Occurrence_Of
(
5667 RTE
(RE_Select_Specific_Data
), Loc
),
5669 Make_Index_Or_Discriminant_Constraint
(Loc
,
5670 Constraints
=> New_List
(
5671 Make_Integer_Literal
(Loc
, Nb_Prim
))))));
5674 Make_Attribute_Definition_Clause
(Loc
,
5675 Name
=> New_Occurrence_Of
(SSD
, Loc
),
5676 Chars
=> Name_Alignment
,
5678 Make_Attribute_Reference
(Loc
,
5680 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5681 Attribute_Name
=> Name_Alignment
)));
5683 -- This table is initialized by Make_Select_Specific_Data_Table,
5684 -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
5686 Append_To
(TSD_Aggr_List
,
5687 Make_Attribute_Reference
(Loc
,
5688 Prefix
=> New_Occurrence_Of
(SSD
, Loc
),
5689 Attribute_Name
=> Name_Unchecked_Access
));
5691 Append_To
(TSD_Aggr_List
, Make_Null
(Loc
));
5695 -- Initialize the table of ancestor tags. In case of interface types
5696 -- this table is not needed.
5698 TSD_Tags_List
:= New_List
;
5700 -- If we are not statically allocating the dispatch table then we must
5701 -- fill position 0 with null because we still have not generated the
5704 if not Building_Static_DT
(Typ
)
5705 or else Is_Interface
(Typ
)
5707 Append_To
(TSD_Tags_List
,
5708 Unchecked_Convert_To
(RTE
(RE_Tag
),
5709 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5711 -- Otherwise we can safely reference the tag
5714 Append_To
(TSD_Tags_List
,
5715 New_Occurrence_Of
(DT_Ptr
, Loc
));
5718 -- Fill the rest of the table with the tags of the ancestors
5721 Current_Typ
: Entity_Id
;
5722 Parent_Typ
: Entity_Id
;
5730 Parent_Typ
:= Etype
(Current_Typ
);
5732 if Is_Private_Type
(Parent_Typ
) then
5733 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
5736 exit when Parent_Typ
= Current_Typ
;
5738 if Is_CPP_Class
(Parent_Typ
) then
5740 -- The tags defined in the C++ side will be inherited when
5741 -- the object is constructed (Exp_Ch3.Build_Init_Procedure)
5743 Append_To
(TSD_Tags_List
,
5744 Unchecked_Convert_To
(RTE
(RE_Tag
),
5745 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5747 Append_To
(TSD_Tags_List
,
5749 (Node
(First_Elmt
(Access_Disp_Table
(Parent_Typ
))),
5754 Current_Typ
:= Parent_Typ
;
5757 pragma Assert
(Pos
= I_Depth
+ 1);
5760 Append_To
(TSD_Aggr_List
,
5761 Make_Aggregate
(Loc
,
5762 Expressions
=> TSD_Tags_List
));
5764 -- Build the TSD object
5767 Make_Object_Declaration
(Loc
,
5768 Defining_Identifier
=> TSD
,
5769 Aliased_Present
=> True,
5770 Constant_Present
=> Building_Static_DT
(Typ
),
5771 Object_Definition
=>
5772 Make_Subtype_Indication
(Loc
,
5773 Subtype_Mark
=> New_Occurrence_Of
(
5774 RTE
(RE_Type_Specific_Data
), Loc
),
5776 Make_Index_Or_Discriminant_Constraint
(Loc
,
5777 Constraints
=> New_List
(
5778 Make_Integer_Literal
(Loc
, I_Depth
)))),
5780 Expression
=> Make_Aggregate
(Loc
,
5781 Expressions
=> TSD_Aggr_List
)));
5783 Set_Is_True_Constant
(TSD
, Building_Static_DT
(Typ
));
5785 -- The debugging information for type Ada.Tags.Type_Specific_Data is
5786 -- needed by the debugger in order to display values of tagged types.
5788 Set_Needs_Debug_Info
(TSD
, Needs_Debug_Info
(Typ
));
5790 -- Initialize or declare the dispatch table object
5792 if not Has_DT
(Typ
) then
5793 DT_Constr_List
:= New_List
;
5794 DT_Aggr_List
:= New_List
;
5799 Make_Attribute_Reference
(Loc
,
5800 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
5801 Attribute_Name
=> Name_Address
);
5803 Append_To
(DT_Constr_List
, New_Node
);
5804 Append_To
(DT_Aggr_List
, New_Copy
(New_Node
));
5805 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
5807 -- In case of locally defined tagged types we have already declared
5808 -- and uninitialized object for the dispatch table, which is now
5809 -- initialized by means of the following assignment:
5811 -- DT := (TSD'Address, 0);
5813 if not Building_Static_DT
(Typ
) then
5815 Make_Assignment_Statement
(Loc
,
5816 Name
=> New_Occurrence_Of
(DT
, Loc
),
5817 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5819 -- In case of library level tagged types we declare and export now
5820 -- the constant object containing the dummy dispatch table. There
5821 -- is no need to declare the tag here because it has been previously
5822 -- declared by Make_Tags
5824 -- DT : aliased constant No_Dispatch_Table :=
5825 -- (NDT_TSD => TSD'Address;
5826 -- NDT_Prims_Ptr => 0);
5830 Make_Object_Declaration
(Loc
,
5831 Defining_Identifier
=> DT
,
5832 Aliased_Present
=> True,
5833 Constant_Present
=> True,
5834 Object_Definition
=>
5835 New_Occurrence_Of
(RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
),
5836 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5838 Export_DT
(Typ
, DT
);
5841 -- Common case: Typ has a dispatch table
5845 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
5846 -- (predef-prim-op-1'address,
5847 -- predef-prim-op-2'address,
5849 -- predef-prim-op-n'address);
5851 -- DT : Dispatch_Table (Nb_Prims) :=
5852 -- (Signature => <sig-value>,
5853 -- Tag_Kind => <tag_kind-value>,
5854 -- Predef_Prims => Predef_Prims'First'Address,
5855 -- Offset_To_Top => 0,
5856 -- TSD => TSD'Address;
5857 -- Prims_Ptr => (prim-op-1'address,
5858 -- prim-op-2'address,
5860 -- prim-op-n'address));
5861 -- for DT'Alignment use Address'Alignment
5865 Nb_P_Prims
: constant Nat
:= Number_Of_Predefined_Prims
(Typ
);
5866 Prim_Table
: array (Nat
range 1 .. Nb_P_Prims
) of Entity_Id
;
5869 SS_Thunk_Id
: Entity_Id
;
5870 SS_Thunk_Code
: Node_Id
;
5873 Prim_Ops_Aggr_List
:= New_List
;
5874 Prim_Table
:= (others => Empty
);
5876 if Building_Static_DT
(Typ
) then
5877 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5878 while Present
(Prim_Elmt
) loop
5879 Prim
:= Node
(Prim_Elmt
);
5881 if Is_Predefined_Dispatching_Operation
(Prim
)
5882 and then not Is_Abstract_Subprogram
(Prim
)
5883 and then not Is_Eliminated
(Prim
)
5884 and then not Generate_SCIL
5885 and then No
(Prim_Table
(UI_To_Int
(DT_Position
(Prim
))))
5887 E
:= Ultimate_Alias
(Prim
);
5888 pragma Assert
(not Is_Abstract_Subprogram
(E
));
5890 Expand_Secondary_Stack_Thunk
5891 (E
, SS_Thunk_Id
, SS_Thunk_Code
);
5893 if Present
(SS_Thunk_Id
) then
5895 Append_To
(Result
, SS_Thunk_Code
);
5898 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) := E
;
5901 Next_Elmt
(Prim_Elmt
);
5905 for J
in Prim_Table
'Range loop
5906 if Present
(Prim_Table
(J
)) then
5908 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
5909 Make_Attribute_Reference
(Loc
,
5911 New_Occurrence_Of
(Prim_Table
(J
), Loc
),
5912 Attribute_Name
=> Name_Unrestricted_Access
));
5914 New_Node
:= Make_Null
(Loc
);
5917 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
5921 Make_Aggregate
(Loc
,
5922 Expressions
=> Prim_Ops_Aggr_List
);
5925 Make_Subtype_Declaration
(Loc
,
5926 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
5927 Subtype_Indication
=>
5928 New_Occurrence_Of
(RTE
(RE_Address_Array
), Loc
));
5930 Append_To
(Result
, Decl
);
5933 Make_Object_Declaration
(Loc
,
5934 Defining_Identifier
=> Predef_Prims
,
5935 Aliased_Present
=> True,
5936 Constant_Present
=> Building_Static_DT
(Typ
),
5937 Object_Definition
=>
5938 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
),
5939 Expression
=> New_Node
));
5941 -- Remember aggregates initializing dispatch tables
5943 Append_Elmt
(New_Node
, DT_Aggr
);
5946 -- Stage 1: Initialize the discriminant and the record components
5948 DT_Constr_List
:= New_List
;
5949 DT_Aggr_List
:= New_List
;
5951 -- Num_Prims. If the tagged type has no primitives we add a dummy
5952 -- slot whose address will be the tag of this type.
5955 New_Node
:= Make_Integer_Literal
(Loc
, 1);
5957 New_Node
:= Make_Integer_Literal
(Loc
, Nb_Prim
);
5960 Append_To
(DT_Constr_List
, New_Node
);
5961 Append_To
(DT_Aggr_List
, New_Copy
(New_Node
));
5965 if RTE_Record_Component_Available
(RE_Signature
) then
5966 Append_To
(DT_Aggr_List
,
5967 New_Occurrence_Of
(RTE
(RE_Primary_DT
), Loc
));
5972 if RTE_Record_Component_Available
(RE_Tag_Kind
) then
5973 Append_To
(DT_Aggr_List
, Tagged_Kind
(Typ
));
5978 Append_To
(DT_Aggr_List
,
5979 Make_Attribute_Reference
(Loc
,
5980 Prefix
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
5981 Attribute_Name
=> Name_Address
));
5985 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
5989 Append_To
(DT_Aggr_List
,
5990 Make_Attribute_Reference
(Loc
,
5991 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
5992 Attribute_Name
=> Name_Address
));
5994 -- Stage 2: Initialize the table of user-defined primitive operations
5996 Prim_Ops_Aggr_List
:= New_List
;
5999 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
6001 elsif not Building_Static_DT
(Typ
) then
6002 for J
in 1 .. Nb_Prim
loop
6003 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
6008 CPP_Nb_Prims
: constant Nat
:= CPP_Num_Prims
(Typ
);
6011 Prim_Elmt
: Elmt_Id
;
6013 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
6014 SS_Thunk_Id
: Entity_Id
;
6015 SS_Thunk_Code
: Node_Id
;
6018 Prim_Table
:= (others => Empty
);
6020 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6021 while Present
(Prim_Elmt
) loop
6022 Prim
:= Node
(Prim_Elmt
);
6024 -- Retrieve the ultimate alias of the primitive for proper
6025 -- handling of renamings and eliminated primitives.
6027 E
:= Ultimate_Alias
(Prim
);
6029 -- If the alias is not a primitive operation then Prim does
6030 -- not rename another primitive, but rather an operation
6031 -- declared elsewhere (e.g. in another scope) and therefore
6032 -- Prim is a new primitive.
6034 if No
(Find_Dispatching_Type
(E
)) then
6038 Prim_Pos
:= UI_To_Int
(DT_Position
(E
));
6040 -- Skip predefined primitives because they are located in a
6041 -- separate dispatch table.
6043 if not Is_Predefined_Dispatching_Operation
(Prim
)
6044 and then not Is_Predefined_Dispatching_Operation
(E
)
6046 -- Skip entities with attribute Interface_Alias because
6047 -- those are only required to build secondary dispatch
6050 and then No
(Interface_Alias
(Prim
))
6052 -- Skip abstract and eliminated primitives
6054 and then not Is_Abstract_Subprogram
(E
)
6055 and then not Is_Eliminated
(E
)
6057 -- For derivations of CPP types skip primitives located in
6058 -- the C++ part of the dispatch table because their slots
6059 -- are initialized by the IC routine.
6061 and then (not Is_CPP_Class
(Root_Type
(Typ
))
6062 or else Prim_Pos
> CPP_Nb_Prims
)
6064 -- Skip ignored Ghost subprograms as those will be removed
6065 -- from the executable.
6067 and then not Is_Ignored_Ghost_Entity
(E
)
6070 (UI_To_Int
(DT_Position
(Prim
)) <= Nb_Prim
);
6072 Expand_Secondary_Stack_Thunk
6073 (E
, SS_Thunk_Id
, SS_Thunk_Code
);
6075 if Present
(SS_Thunk_Id
) then
6077 Append_To
(Result
, SS_Thunk_Code
);
6080 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) := E
;
6083 Next_Elmt
(Prim_Elmt
);
6086 for J
in Prim_Table
'Range loop
6087 if Present
(Prim_Table
(J
)) then
6089 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
6090 Make_Attribute_Reference
(Loc
,
6092 New_Occurrence_Of
(Prim_Table
(J
), Loc
),
6093 Attribute_Name
=> Name_Unrestricted_Access
));
6095 New_Node
:= Make_Null
(Loc
);
6098 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
6104 Make_Aggregate
(Loc
,
6105 Expressions
=> Prim_Ops_Aggr_List
);
6107 Append_To
(DT_Aggr_List
, New_Node
);
6109 -- Remember aggregates initializing dispatch tables
6111 Append_Elmt
(New_Node
, DT_Aggr
);
6113 -- In case of locally defined tagged types we have already declared
6114 -- and uninitialized object for the dispatch table, which is now
6115 -- initialized by means of an assignment.
6117 if not Building_Static_DT
(Typ
) then
6119 Make_Assignment_Statement
(Loc
,
6120 Name
=> New_Occurrence_Of
(DT
, Loc
),
6121 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
6123 -- In case of library level tagged types we declare now and export
6124 -- the constant object containing the dispatch table.
6128 Make_Object_Declaration
(Loc
,
6129 Defining_Identifier
=> DT
,
6130 Aliased_Present
=> True,
6131 Constant_Present
=> True,
6132 Object_Definition
=>
6133 Make_Subtype_Indication
(Loc
,
6134 Subtype_Mark
=> New_Occurrence_Of
6135 (RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
6136 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
6137 Constraints
=> DT_Constr_List
)),
6138 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
6140 Export_DT
(Typ
, DT
);
6144 -- Initialize the table of ancestor tags if not building static
6147 if not Building_Static_DT
(Typ
)
6148 and then not Is_Interface
(Typ
)
6149 and then not Is_CPP_Class
(Typ
)
6152 Make_Assignment_Statement
(Loc
,
6154 Make_Indexed_Component
(Loc
,
6156 Make_Selected_Component
(Loc
,
6157 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6160 (RTE_Record_Component
(RE_Tags_Table
), Loc
)),
6162 New_List
(Make_Integer_Literal
(Loc
, 0))),
6166 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
)));
6169 -- Inherit the dispatch tables of the parent. There is no need to
6170 -- inherit anything from the parent when building static dispatch tables
6171 -- because the whole dispatch table (including inherited primitives) has
6172 -- been already built.
6174 if Building_Static_DT
(Typ
) then
6177 -- If the ancestor is a CPP_Class type we inherit the dispatch tables
6178 -- in the init proc, and we don't need to fill them in here.
6180 elsif Is_CPP_Class
(Parent_Typ
) then
6183 -- Otherwise we fill in the dispatch tables here
6186 if Typ
/= Parent_Typ
6187 and then not Is_Interface
(Typ
)
6188 and then not Restriction_Active
(No_Dispatching_Calls
)
6190 -- Inherit the dispatch table
6192 if not Is_Interface
(Typ
)
6193 and then not Is_Interface
(Parent_Typ
)
6194 and then not Is_CPP_Class
(Parent_Typ
)
6197 Nb_Prims
: constant Int
:=
6198 UI_To_Int
(DT_Entry_Count
6199 (First_Tag_Component
(Parent_Typ
)));
6202 Append_To
(Elab_Code
,
6203 Build_Inherit_Predefined_Prims
(Loc
,
6209 (Access_Disp_Table
(Parent_Typ
)))), Loc
),
6215 (Access_Disp_Table
(Typ
)))), Loc
),
6217 Number_Of_Predefined_Prims
(Parent_Typ
)));
6219 if Nb_Prims
/= 0 then
6220 Append_To
(Elab_Code
,
6221 Build_Inherit_Prims
(Loc
,
6227 (Access_Disp_Table
(Parent_Typ
))), Loc
),
6228 New_Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
6229 Num_Prims
=> Nb_Prims
));
6234 -- Inherit the secondary dispatch tables of the ancestor
6236 if not Is_CPP_Class
(Parent_Typ
) then
6238 Sec_DT_Ancestor
: Elmt_Id
:=
6244 Sec_DT_Typ
: Elmt_Id
:=
6248 (Access_Disp_Table
(Typ
))));
6250 procedure Copy_Secondary_DTs
(Typ
: Entity_Id
);
6251 -- Local procedure required to climb through the ancestors
6252 -- and copy the contents of all their secondary dispatch
6255 ------------------------
6256 -- Copy_Secondary_DTs --
6257 ------------------------
6259 procedure Copy_Secondary_DTs
(Typ
: Entity_Id
) is
6264 -- Climb to the ancestor (if any) handling private types
6266 if Present
(Full_View
(Etype
(Typ
))) then
6267 if Full_View
(Etype
(Typ
)) /= Typ
then
6268 Copy_Secondary_DTs
(Full_View
(Etype
(Typ
)));
6271 elsif Etype
(Typ
) /= Typ
then
6272 Copy_Secondary_DTs
(Etype
(Typ
));
6275 if Present
(Interfaces
(Typ
))
6276 and then not Is_Empty_Elmt_List
(Interfaces
(Typ
))
6278 Iface
:= First_Elmt
(Interfaces
(Typ
));
6279 E
:= First_Entity
(Typ
);
6281 and then Present
(Node
(Sec_DT_Ancestor
))
6282 and then Ekind
(Node
(Sec_DT_Ancestor
)) = E_Constant
6284 if Is_Tag
(E
) and then Chars
(E
) /= Name_uTag
then
6286 Num_Prims
: constant Int
:=
6287 UI_To_Int
(DT_Entry_Count
(E
));
6290 if not Is_Interface
(Etype
(Typ
)) then
6292 -- Inherit first secondary dispatch table
6294 Append_To
(Elab_Code
,
6295 Build_Inherit_Predefined_Prims
(Loc
,
6297 Unchecked_Convert_To
(RTE
(RE_Tag
),
6300 (Next_Elmt
(Sec_DT_Ancestor
)),
6303 Unchecked_Convert_To
(RTE
(RE_Tag
),
6305 (Node
(Next_Elmt
(Sec_DT_Typ
)),
6308 Number_Of_Predefined_Prims
6311 if Num_Prims
/= 0 then
6312 Append_To
(Elab_Code
,
6313 Build_Inherit_Prims
(Loc
,
6314 Typ
=> Node
(Iface
),
6316 Unchecked_Convert_To
6319 (Node
(Sec_DT_Ancestor
),
6322 Unchecked_Convert_To
6325 (Node
(Sec_DT_Typ
), Loc
)),
6326 Num_Prims
=> Num_Prims
));
6330 Next_Elmt
(Sec_DT_Ancestor
);
6331 Next_Elmt
(Sec_DT_Typ
);
6333 -- Skip the secondary dispatch table of
6334 -- predefined primitives
6336 Next_Elmt
(Sec_DT_Ancestor
);
6337 Next_Elmt
(Sec_DT_Typ
);
6339 if not Is_Interface
(Etype
(Typ
)) then
6341 -- Inherit second secondary dispatch table
6343 Append_To
(Elab_Code
,
6344 Build_Inherit_Predefined_Prims
(Loc
,
6346 Unchecked_Convert_To
(RTE
(RE_Tag
),
6349 (Next_Elmt
(Sec_DT_Ancestor
)),
6352 Unchecked_Convert_To
(RTE
(RE_Tag
),
6354 (Node
(Next_Elmt
(Sec_DT_Typ
)),
6357 Number_Of_Predefined_Prims
6360 if Num_Prims
/= 0 then
6361 Append_To
(Elab_Code
,
6362 Build_Inherit_Prims
(Loc
,
6363 Typ
=> Node
(Iface
),
6365 Unchecked_Convert_To
6368 (Node
(Sec_DT_Ancestor
),
6371 Unchecked_Convert_To
6374 (Node
(Sec_DT_Typ
), Loc
)),
6375 Num_Prims
=> Num_Prims
));
6380 Next_Elmt
(Sec_DT_Ancestor
);
6381 Next_Elmt
(Sec_DT_Typ
);
6383 -- Skip the secondary dispatch table of
6384 -- predefined primitives
6386 Next_Elmt
(Sec_DT_Ancestor
);
6387 Next_Elmt
(Sec_DT_Typ
);
6395 end Copy_Secondary_DTs
;
6398 if Present
(Node
(Sec_DT_Ancestor
))
6399 and then Ekind
(Node
(Sec_DT_Ancestor
)) = E_Constant
6401 -- Handle private types
6403 if Present
(Full_View
(Typ
)) then
6404 Copy_Secondary_DTs
(Full_View
(Typ
));
6406 Copy_Secondary_DTs
(Typ
);
6414 -- Generate code to check if the external tag of this type is the same
6415 -- as the external tag of some other declaration.
6417 -- Check_TSD (TSD'Unrestricted_Access);
6419 -- This check is a consequence of AI05-0113-1/06, so it officially
6420 -- applies to Ada 2005 (and Ada 2012). It might be argued that it is
6421 -- a desirable check to add in Ada 95 mode, but we hesitate to make
6422 -- this change, as it would be incompatible, and could conceivably
6423 -- cause a problem in existing Ada 95 code.
6425 -- We check for No_Run_Time_Mode here, because we do not want to pick
6426 -- up the RE_Check_TSD entity and call it in No_Run_Time mode.
6428 -- We cannot perform this check if the generation of its expanded name
6429 -- was discarded or if No_Tagged_Type_Registration is active.
6431 if not No_Run_Time_Mode
6432 and then not Discard_Names
6433 and then Ada_Version
>= Ada_2005
6434 and then not Duplicated_Tag_Checks_Suppressed
(Typ
)
6435 and then not Restriction_Active
(No_Tagged_Type_Registration
)
6436 and then RTE_Available
(RE_Check_TSD
)
6438 Append_To
(Elab_Code
,
6439 Make_Procedure_Call_Statement
(Loc
,
6441 New_Occurrence_Of
(RTE
(RE_Check_TSD
), Loc
),
6442 Parameter_Associations
=> New_List
(
6443 Make_Attribute_Reference
(Loc
,
6444 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6445 Attribute_Name
=> Name_Unchecked_Access
))));
6448 -- Generate code to register the Tag in the External_Tag hash table for
6449 -- the pure Ada type only.
6451 -- Register_Tag (Dt_Ptr);
6453 -- Skip this action in the following cases:
6454 -- 1) if Register_Tag is not available.
6455 -- 2) in No_Run_Time mode.
6456 -- 3) if Typ is not defined at the library level (this is required
6457 -- to avoid adding concurrency control to the hash table used
6458 -- by the run-time to register the tags).
6459 -- 4) No_Tagged_Type_Registration is active.
6461 if not No_Run_Time_Mode
6462 and then Is_Library_Level_Entity
(Typ
)
6463 and then not Restriction_Active
(No_Tagged_Type_Registration
)
6464 and then RTE_Available
(RE_Register_Tag
)
6466 Append_To
(Elab_Code
,
6467 Make_Procedure_Call_Statement
(Loc
,
6469 New_Occurrence_Of
(RTE
(RE_Register_Tag
), Loc
),
6470 Parameter_Associations
=>
6471 New_List
(New_Occurrence_Of
(DT_Ptr
, Loc
))));
6474 Append_List_To
(Result
, Elab_Code
);
6476 -- Populate the two auxiliary tables used for dispatching asynchronous,
6477 -- conditional and timed selects for synchronized types that implement
6478 -- a limited interface. Skip this step in Ravenscar profile or when
6479 -- general dispatching is forbidden.
6481 if Ada_Version
>= Ada_2005
6482 and then Is_Concurrent_Record_Type
(Typ
)
6483 and then Has_Interfaces
(Typ
)
6484 and then not Restriction_Active
(No_Dispatching_Calls
)
6485 and then not Restriction_Active
(No_Select_Statements
)
6487 Append_List_To
(Result
,
6488 Make_Select_Specific_Data_Table
(Typ
));
6491 -- Remember entities containing dispatch tables
6493 Append_Elmt
(Predef_Prims
, DT_Decl
);
6494 Append_Elmt
(DT
, DT_Decl
);
6496 Analyze_List
(Result
, Suppress
=> All_Checks
);
6498 -- Mark entities containing dispatch tables. Required by the backend to
6499 -- handle them properly.
6501 if Has_DT
(Typ
) then
6506 -- Object declarations
6508 Elmt
:= First_Elmt
(DT_Decl
);
6509 while Present
(Elmt
) loop
6510 Set_Is_Dispatch_Table_Entity
(Node
(Elmt
));
6511 pragma Assert
(Ekind
(Etype
(Node
(Elmt
))) = E_Array_Subtype
6512 or else Ekind
(Etype
(Node
(Elmt
))) = E_Record_Subtype
);
6513 Set_Is_Dispatch_Table_Entity
(Etype
(Node
(Elmt
)));
6517 -- Aggregates initializing dispatch tables
6519 Elmt
:= First_Elmt
(DT_Aggr
);
6520 while Present
(Elmt
) loop
6521 Set_Is_Dispatch_Table_Entity
(Etype
(Node
(Elmt
)));
6529 Set_Has_Dispatch_Table
(Typ
);
6531 -- Register the tagged type in the call graph nodes table
6533 Register_CG_Node
(Typ
);
6536 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
6541 -------------------------------------
6542 -- Make_Select_Specific_Data_Table --
6543 -------------------------------------
6545 function Make_Select_Specific_Data_Table
6546 (Typ
: Entity_Id
) return List_Id
6548 Assignments
: constant List_Id
:= New_List
;
6549 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6551 Conc_Typ
: Entity_Id
;
6552 Decls
: List_Id
:= No_List
;
6554 Prim_Als
: Entity_Id
;
6555 Prim_Elmt
: Elmt_Id
;
6559 type Examined_Array
is array (Int
range <>) of Boolean;
6561 function Find_Entry_Index
(E
: Entity_Id
) return Uint
;
6562 -- Given an entry, find its index in the visible declarations of the
6563 -- corresponding concurrent type of Typ.
6565 ----------------------
6566 -- Find_Entry_Index --
6567 ----------------------
6569 function Find_Entry_Index
(E
: Entity_Id
) return Uint
is
6570 Index
: Uint
:= Uint_0
;
6571 Subp_Decl
: Node_Id
;
6574 Subp_Decl
:= First
(Decls
);
6575 while Present
(Subp_Decl
) loop
6576 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
6579 if Defining_Identifier
(Subp_Decl
) = E
then
6589 end Find_Entry_Index
;
6595 -- Start of processing for Make_Select_Specific_Data_Table
6598 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
6600 if Present
(Corresponding_Concurrent_Type
(Typ
)) then
6601 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
6603 if Present
(Full_View
(Conc_Typ
)) then
6604 Conc_Typ
:= Full_View
(Conc_Typ
);
6607 if Ekind
(Conc_Typ
) = E_Protected_Type
then
6608 Decls
:= Visible_Declarations
(Protected_Definition
(
6609 Parent
(Conc_Typ
)));
6611 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
6612 Decls
:= Visible_Declarations
(Task_Definition
(
6613 Parent
(Conc_Typ
)));
6617 -- Count the non-predefined primitive operations
6619 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6620 while Present
(Prim_Elmt
) loop
6621 Prim
:= Node
(Prim_Elmt
);
6623 if not (Is_Predefined_Dispatching_Operation
(Prim
)
6624 or else Is_Predefined_Dispatching_Alias
(Prim
))
6626 Nb_Prim
:= Nb_Prim
+ 1;
6629 Next_Elmt
(Prim_Elmt
);
6633 Examined
: Examined_Array
(1 .. Nb_Prim
) := (others => False);
6636 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6637 while Present
(Prim_Elmt
) loop
6638 Prim
:= Node
(Prim_Elmt
);
6640 -- Look for primitive overriding an abstract interface subprogram
6642 if Present
(Interface_Alias
(Prim
))
6645 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
6646 Use_Full_View
=> True)
6647 and then not Examined
(UI_To_Int
(DT_Position
(Alias
(Prim
))))
6649 Prim_Pos
:= DT_Position
(Alias
(Prim
));
6650 pragma Assert
(UI_To_Int
(Prim_Pos
) <= Nb_Prim
);
6651 Examined
(UI_To_Int
(Prim_Pos
)) := True;
6653 -- Set the primitive operation kind regardless of subprogram
6655 -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
6657 if Tagged_Type_Expansion
then
6660 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
);
6664 Make_Attribute_Reference
(Loc
,
6665 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6666 Attribute_Name
=> Name_Tag
);
6669 Append_To
(Assignments
,
6670 Make_Procedure_Call_Statement
(Loc
,
6671 Name
=> New_Occurrence_Of
(RTE
(RE_Set_Prim_Op_Kind
), Loc
),
6672 Parameter_Associations
=> New_List
(
6674 Make_Integer_Literal
(Loc
, Prim_Pos
),
6675 Prim_Op_Kind
(Alias
(Prim
), Typ
))));
6677 -- Retrieve the root of the alias chain
6679 Prim_Als
:= Ultimate_Alias
(Prim
);
6681 -- In the case of an entry wrapper, set the entry index
6683 if Ekind
(Prim
) = E_Procedure
6684 and then Is_Primitive_Wrapper
(Prim_Als
)
6685 and then Ekind
(Wrapped_Entity
(Prim_Als
)) = E_Entry
6688 -- Ada.Tags.Set_Entry_Index
6689 -- (DT_Ptr, <position>, <index>);
6691 if Tagged_Type_Expansion
then
6694 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
);
6697 Make_Attribute_Reference
(Loc
,
6698 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6699 Attribute_Name
=> Name_Tag
);
6702 Append_To
(Assignments
,
6703 Make_Procedure_Call_Statement
(Loc
,
6705 New_Occurrence_Of
(RTE
(RE_Set_Entry_Index
), Loc
),
6706 Parameter_Associations
=> New_List
(
6708 Make_Integer_Literal
(Loc
, Prim_Pos
),
6709 Make_Integer_Literal
(Loc
,
6710 Find_Entry_Index
(Wrapped_Entity
(Prim_Als
))))));
6714 Next_Elmt
(Prim_Elmt
);
6719 end Make_Select_Specific_Data_Table
;
6725 function Make_Tags
(Typ
: Entity_Id
) return List_Id
is
6726 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6727 Result
: constant List_Id
:= New_List
;
6730 (Tag_Typ
: Entity_Id
;
6732 Is_Secondary_DT
: Boolean);
6733 -- Import the dispatch table DT of tagged type Tag_Typ. Required to
6734 -- generate forward references and statically allocate the table. For
6735 -- primary dispatch tables that require no dispatch table generate:
6737 -- DT : static aliased constant Non_Dispatch_Table_Wrapper;
6738 -- pragma Import (Ada, DT);
6740 -- Otherwise generate:
6742 -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
6743 -- pragma Import (Ada, DT);
6750 (Tag_Typ
: Entity_Id
;
6752 Is_Secondary_DT
: Boolean)
6754 DT_Constr_List
: List_Id
;
6758 Set_Is_Imported
(DT
);
6759 Mutate_Ekind
(DT
, E_Constant
);
6760 Set_Related_Type
(DT
, Typ
);
6762 -- The scope must be set now to call Get_External_Name
6764 Set_Scope
(DT
, Current_Scope
);
6766 Get_External_Name
(DT
);
6767 Set_Interface_Name
(DT
,
6768 Make_String_Literal
(Loc
, Strval
=> String_From_Name_Buffer
));
6770 -- Ensure proper Sprint output of this implicit importation
6772 Set_Is_Internal
(DT
);
6774 -- Save this entity to allow Make_DT to generate its exportation
6776 Append_Elmt
(DT
, Dispatch_Table_Wrappers
(Typ
));
6778 -- No dispatch table required
6780 if not Is_Secondary_DT
and then not Has_DT
(Tag_Typ
) then
6782 Make_Object_Declaration
(Loc
,
6783 Defining_Identifier
=> DT
,
6784 Aliased_Present
=> True,
6785 Constant_Present
=> True,
6786 Object_Definition
=>
6788 (RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
)));
6791 -- Calculate the number of primitives of the dispatch table and
6792 -- the size of the Type_Specific_Data record.
6795 UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Tag_Typ
)));
6797 -- If the tagged type has no primitives we add a dummy slot whose
6798 -- address will be the tag of this type.
6802 New_List
(Make_Integer_Literal
(Loc
, 1));
6805 New_List
(Make_Integer_Literal
(Loc
, Nb_Prim
));
6809 Make_Object_Declaration
(Loc
,
6810 Defining_Identifier
=> DT
,
6811 Aliased_Present
=> True,
6812 Constant_Present
=> True,
6813 Object_Definition
=>
6814 Make_Subtype_Indication
(Loc
,
6816 New_Occurrence_Of
(RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
6817 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
6818 Constraints
=> DT_Constr_List
))));
6824 Tname
: constant Name_Id
:= Chars
(Typ
);
6825 AI_Tag_Comp
: Elmt_Id
;
6826 DT
: Node_Id
:= Empty
;
6828 Predef_Prims_Ptr
: Node_Id
;
6829 Iface_DT
: Node_Id
:= Empty
;
6830 Iface_DT_Ptr
: Node_Id
;
6834 Typ_Comps
: Elist_Id
;
6836 -- Start of processing for Make_Tags
6839 pragma Assert
(No
(Access_Disp_Table
(Typ
)));
6840 Set_Access_Disp_Table
(Typ
, New_Elmt_List
);
6842 -- If the elaboration of this tagged type needs a boolean flag then
6843 -- define now its entity. It is initialized to True to indicate that
6844 -- elaboration is still pending; set to False by the IP routine.
6846 -- TypFxx : boolean := True;
6848 if Elab_Flag_Needed
(Typ
) then
6849 Set_Access_Disp_Table_Elab_Flag
(Typ
,
6850 Make_Defining_Identifier
(Loc
,
6851 Chars
=> New_External_Name
(Tname
, 'F')));
6854 Make_Object_Declaration
(Loc
,
6855 Defining_Identifier
=> Access_Disp_Table_Elab_Flag
(Typ
),
6856 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
6857 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
6860 -- 1) Generate the primary tag entities
6862 -- Primary dispatch table containing user-defined primitives
6864 DT_Ptr
:= Make_Defining_Identifier
(Loc
, New_External_Name
(Tname
, 'P'));
6865 Set_Etype
(DT_Ptr
, RTE
(RE_Tag
));
6866 Append_Elmt
(DT_Ptr
, Access_Disp_Table
(Typ
));
6868 -- Minimum decoration
6870 Mutate_Ekind
(DT_Ptr
, E_Variable
);
6871 Set_Related_Type
(DT_Ptr
, Typ
);
6873 -- Notify back end that the types are associated with a dispatch table
6875 Set_Is_Dispatch_Table_Entity
(RTE
(RE_Prim_Ptr
));
6876 Set_Is_Dispatch_Table_Entity
(RTE
(RE_Predef_Prims_Table_Ptr
));
6878 -- For CPP types there is no need to build the dispatch tables since
6879 -- they are imported from the C++ side. If the CPP type has an IP then
6880 -- we declare now the variable that will store the copy of the C++ tag.
6881 -- If the CPP type is an interface, we need the variable as well because
6882 -- it becomes the pointer to the corresponding secondary table.
6884 if Is_CPP_Class
(Typ
) then
6885 if Has_CPP_Constructors
(Typ
) or else Is_Interface
(Typ
) then
6887 Make_Object_Declaration
(Loc
,
6888 Defining_Identifier
=> DT_Ptr
,
6889 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
6891 Unchecked_Convert_To
(RTE
(RE_Tag
),
6892 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
6894 Set_Is_Statically_Allocated
(DT_Ptr
,
6895 Is_Library_Level_Tagged_Type
(Typ
));
6901 -- Primary dispatch table containing predefined primitives
6904 Make_Defining_Identifier
(Loc
,
6905 Chars
=> New_External_Name
(Tname
, 'Y'));
6906 Set_Etype
(Predef_Prims_Ptr
, RTE
(RE_Address
));
6907 Append_Elmt
(Predef_Prims_Ptr
, Access_Disp_Table
(Typ
));
6909 -- Import the forward declaration of the Dispatch Table wrapper
6910 -- record (Make_DT will take care of exporting it).
6912 if Building_Static_DT
(Typ
) then
6913 Set_Dispatch_Table_Wrappers
(Typ
, New_Elmt_List
);
6916 Make_Defining_Identifier
(Loc
,
6917 Chars
=> New_External_Name
(Tname
, 'T'));
6919 Import_DT
(Typ
, DT
, Is_Secondary_DT
=> False);
6921 if Has_DT
(Typ
) then
6923 Make_Object_Declaration
(Loc
,
6924 Defining_Identifier
=> DT_Ptr
,
6925 Constant_Present
=> True,
6926 Object_Definition
=>
6927 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
6929 Unchecked_Convert_To
(RTE
(RE_Tag
),
6930 Make_Attribute_Reference
(Loc
,
6932 Make_Selected_Component
(Loc
,
6933 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
6936 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
6937 Attribute_Name
=> Name_Address
))));
6939 -- Generate the SCIL node for the previous object declaration
6940 -- because it has a tag initialization.
6942 if Generate_SCIL
then
6944 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
6945 Set_SCIL_Entity
(New_Node
, Typ
);
6946 Set_SCIL_Node
(Last
(Result
), New_Node
);
6950 Make_Object_Declaration
(Loc
,
6951 Defining_Identifier
=> Predef_Prims_Ptr
,
6952 Constant_Present
=> True,
6953 Object_Definition
=>
6954 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
6956 Make_Attribute_Reference
(Loc
,
6958 Make_Selected_Component
(Loc
,
6959 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
6962 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
6963 Attribute_Name
=> Name_Address
)));
6965 -- No dispatch table required
6969 Make_Object_Declaration
(Loc
,
6970 Defining_Identifier
=> DT_Ptr
,
6971 Constant_Present
=> True,
6972 Object_Definition
=>
6973 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
6975 Unchecked_Convert_To
(RTE
(RE_Tag
),
6976 Make_Attribute_Reference
(Loc
,
6978 Make_Selected_Component
(Loc
,
6979 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
6982 (RTE_Record_Component
(RE_NDT_Prims_Ptr
),
6984 Attribute_Name
=> Name_Address
))));
6987 Set_Is_True_Constant
(DT_Ptr
);
6988 Set_Is_Statically_Allocated
(DT_Ptr
);
6992 -- 2) Generate the secondary tag entities
6994 -- Collect the components associated with secondary dispatch tables
6996 if Has_Interfaces
(Typ
) then
6997 Collect_Interface_Components
(Typ
, Typ_Comps
);
6999 -- For each interface type we build a unique external name associated
7000 -- with its secondary dispatch table. This name is used to declare an
7001 -- object that references this secondary dispatch table, whose value
7002 -- will be used for the elaboration of Typ objects, and also for the
7003 -- elaboration of objects of types derived from Typ that do not
7004 -- override the primitives of this interface type.
7008 -- Note: The value of Suffix_Index must be in sync with the values of
7009 -- Suffix_Index in secondary dispatch tables generated by Make_DT.
7011 if Is_CPP_Class
(Typ
) then
7012 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
7013 while Present
(AI_Tag_Comp
) loop
7014 Get_Secondary_DT_External_Name
7015 (Typ
, Related_Type
(Node
(AI_Tag_Comp
)), Suffix_Index
);
7016 Typ_Name
:= Name_Find
;
7018 -- Declare variables to store copy of the C++ secondary tags
7021 Make_Defining_Identifier
(Loc
,
7022 Chars
=> New_External_Name
(Typ_Name
, 'P'));
7023 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7024 Mutate_Ekind
(Iface_DT_Ptr
, E_Variable
);
7025 Set_Is_Tag
(Iface_DT_Ptr
);
7027 Set_Has_Thunks
(Iface_DT_Ptr
);
7029 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7030 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7033 Make_Object_Declaration
(Loc
,
7034 Defining_Identifier
=> Iface_DT_Ptr
,
7035 Object_Definition
=> New_Occurrence_Of
7036 (RTE
(RE_Interface_Tag
), Loc
),
7038 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
7039 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
7041 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7042 Is_Library_Level_Tagged_Type
(Typ
));
7044 Next_Elmt
(AI_Tag_Comp
);
7047 -- This is not a CPP_Class type
7050 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
7051 while Present
(AI_Tag_Comp
) loop
7052 Get_Secondary_DT_External_Name
7053 (Typ
, Related_Type
(Node
(AI_Tag_Comp
)), Suffix_Index
);
7054 Typ_Name
:= Name_Find
;
7056 if Building_Static_DT
(Typ
) then
7058 Make_Defining_Identifier
(Loc
,
7059 Chars
=> New_External_Name
(Typ_Name
, 'T'));
7061 (Tag_Typ
=> Related_Type
(Node
(AI_Tag_Comp
)),
7063 Is_Secondary_DT
=> True);
7066 -- Secondary dispatch table referencing thunks to user-defined
7067 -- primitives covered by this interface.
7070 Make_Defining_Identifier
(Loc
,
7071 Chars
=> New_External_Name
(Typ_Name
, 'P'));
7072 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7073 Mutate_Ekind
(Iface_DT_Ptr
, E_Constant
);
7074 Set_Is_Tag
(Iface_DT_Ptr
);
7075 Set_Has_Thunks
(Iface_DT_Ptr
);
7076 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7077 Is_Library_Level_Tagged_Type
(Typ
));
7078 Set_Is_True_Constant
(Iface_DT_Ptr
);
7080 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7081 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7083 if Building_Static_DT
(Typ
) then
7085 Make_Object_Declaration
(Loc
,
7086 Defining_Identifier
=> Iface_DT_Ptr
,
7087 Constant_Present
=> True,
7088 Object_Definition
=> New_Occurrence_Of
7089 (RTE
(RE_Interface_Tag
), Loc
),
7091 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
7092 Make_Attribute_Reference
(Loc
,
7094 Make_Selected_Component
(Loc
,
7096 New_Occurrence_Of
(Iface_DT
, Loc
),
7099 (RTE_Record_Component
(RE_Prims_Ptr
),
7101 Attribute_Name
=> Name_Address
))));
7104 -- Secondary dispatch table referencing thunks to predefined
7108 Make_Defining_Identifier
(Loc
,
7109 Chars
=> New_External_Name
(Typ_Name
, 'Y'));
7110 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Address
));
7111 Mutate_Ekind
(Iface_DT_Ptr
, E_Constant
);
7112 Set_Is_Tag
(Iface_DT_Ptr
);
7113 Set_Has_Thunks
(Iface_DT_Ptr
);
7114 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7115 Is_Library_Level_Tagged_Type
(Typ
));
7116 Set_Is_True_Constant
(Iface_DT_Ptr
);
7118 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7119 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7121 -- Secondary dispatch table referencing user-defined primitives
7122 -- covered by this interface.
7125 Make_Defining_Identifier
(Loc
,
7126 Chars
=> New_External_Name
(Typ_Name
, 'D'));
7127 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7128 Mutate_Ekind
(Iface_DT_Ptr
, E_Constant
);
7129 Set_Is_Tag
(Iface_DT_Ptr
);
7130 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7131 Is_Library_Level_Tagged_Type
(Typ
));
7132 Set_Is_True_Constant
(Iface_DT_Ptr
);
7134 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7135 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7137 -- Secondary dispatch table referencing predefined primitives
7140 Make_Defining_Identifier
(Loc
,
7141 Chars
=> New_External_Name
(Typ_Name
, 'Z'));
7142 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Address
));
7143 Mutate_Ekind
(Iface_DT_Ptr
, E_Constant
);
7144 Set_Is_Tag
(Iface_DT_Ptr
);
7145 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7146 Is_Library_Level_Tagged_Type
(Typ
));
7147 Set_Is_True_Constant
(Iface_DT_Ptr
);
7149 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7150 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7152 Next_Elmt
(AI_Tag_Comp
);
7157 -- 3) At the end of Access_Disp_Table, if the type has user-defined
7158 -- primitives, we add the entity of an access type declaration that
7159 -- is used by Build_Get_Prim_Op_Address to expand dispatching calls
7160 -- through the primary dispatch table.
7162 if DT_Entry_Count
(First_Tag_Component
(Typ
)) = 0 then
7163 Analyze_List
(Result
);
7166 -- subtype Typ_DT is Address_Array (1 .. Nb_Prims);
7167 -- type Typ_DT_Acc is access Typ_DT;
7171 Name_DT_Prims
: constant Name_Id
:=
7172 New_External_Name
(Tname
, 'G');
7173 Name_DT_Prims_Acc
: constant Name_Id
:=
7174 New_External_Name
(Tname
, 'H');
7175 DT_Prims
: constant Entity_Id
:=
7176 Make_Defining_Identifier
(Loc
,
7178 DT_Prims_Acc
: constant Entity_Id
:=
7179 Make_Defining_Identifier
(Loc
,
7183 Make_Subtype_Declaration
(Loc
,
7184 Defining_Identifier
=> DT_Prims
,
7185 Subtype_Indication
=>
7186 Make_Subtype_Indication
(Loc
,
7188 New_Occurrence_Of
(RTE
(RE_Address_Array
), Loc
),
7190 Make_Index_Or_Discriminant_Constraint
(Loc
, New_List
(
7192 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
7194 Make_Integer_Literal
(Loc
,
7196 (First_Tag_Component
(Typ
)))))))));
7199 Make_Full_Type_Declaration
(Loc
,
7200 Defining_Identifier
=> DT_Prims_Acc
,
7202 Make_Access_To_Object_Definition
(Loc
,
7203 Subtype_Indication
=>
7204 New_Occurrence_Of
(DT_Prims
, Loc
))));
7206 Append_Elmt
(DT_Prims_Acc
, Access_Disp_Table
(Typ
));
7208 -- Analyze the resulting list and suppress the generation of the
7209 -- Init_Proc associated with the above array declaration because
7210 -- this type is never used in object declarations. It is only used
7211 -- to simplify the expansion associated with dispatching calls.
7213 Analyze_List
(Result
);
7214 Set_Suppress_Initialization
(Base_Type
(DT_Prims
));
7216 -- Disable backend optimizations based on assumptions about the
7217 -- aliasing status of objects designated by the access to the
7218 -- dispatch table. Required to handle dispatch tables imported
7221 Set_No_Strict_Aliasing
(Base_Type
(DT_Prims_Acc
));
7223 -- Add the freezing nodes of these declarations; required to avoid
7224 -- generating these freezing nodes in wrong scopes (for example in
7225 -- the IC routine of a derivation of Typ).
7227 -- What is an "IC routine"? Is "init_proc" meant here???
7229 Append_List_To
(Result
, Freeze_Entity
(DT_Prims
, Typ
));
7230 Append_List_To
(Result
, Freeze_Entity
(DT_Prims_Acc
, Typ
));
7232 -- Mark entity of dispatch table. Required by the back end to
7233 -- handle them properly.
7235 Set_Is_Dispatch_Table_Entity
(DT_Prims
);
7239 -- Mark entities of dispatch table. Required by the back end to handle
7242 if Present
(DT
) then
7243 Set_Is_Dispatch_Table_Entity
(DT
);
7244 Set_Is_Dispatch_Table_Entity
(Etype
(DT
));
7247 if Present
(Iface_DT
) then
7248 Set_Is_Dispatch_Table_Entity
(Iface_DT
);
7249 Set_Is_Dispatch_Table_Entity
(Etype
(Iface_DT
));
7252 if Is_CPP_Class
(Root_Type
(Typ
)) then
7253 Mutate_Ekind
(DT_Ptr
, E_Variable
);
7255 Mutate_Ekind
(DT_Ptr
, E_Constant
);
7258 Set_Is_Tag
(DT_Ptr
);
7259 Set_Related_Type
(DT_Ptr
, Typ
);
7268 function New_Value
(From
: Node_Id
) return Node_Id
is
7269 Res
: constant Node_Id
:= Duplicate_Subexpr
(From
);
7271 if Is_Access_Type
(Etype
(From
)) then
7272 return Make_Explicit_Dereference
(Sloc
(From
), Prefix
=> Res
);
7282 function Prim_Op_Kind
7284 Typ
: Entity_Id
) return Node_Id
7286 Full_Typ
: Entity_Id
:= Typ
;
7287 Loc
: constant Source_Ptr
:= Sloc
(Prim
);
7288 Prim_Op
: Entity_Id
;
7291 -- Retrieve the original primitive operation
7293 Prim_Op
:= Ultimate_Alias
(Prim
);
7295 if Ekind
(Typ
) = E_Record_Type
7296 and then Present
(Corresponding_Concurrent_Type
(Typ
))
7298 Full_Typ
:= Corresponding_Concurrent_Type
(Typ
);
7301 -- When a private tagged type is completed by a concurrent type,
7302 -- retrieve the full view.
7304 if Is_Private_Type
(Full_Typ
) then
7305 Full_Typ
:= Full_View
(Full_Typ
);
7308 if Ekind
(Prim_Op
) = E_Function
then
7310 -- Protected function
7312 if Ekind
(Full_Typ
) = E_Protected_Type
then
7313 return New_Occurrence_Of
(RTE
(RE_POK_Protected_Function
), Loc
);
7317 elsif Ekind
(Full_Typ
) = E_Task_Type
then
7318 return New_Occurrence_Of
(RTE
(RE_POK_Task_Function
), Loc
);
7323 return New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
);
7327 pragma Assert
(Ekind
(Prim_Op
) = E_Procedure
);
7329 if Ekind
(Full_Typ
) = E_Protected_Type
then
7333 if Is_Primitive_Wrapper
(Prim_Op
)
7334 and then Ekind
(Wrapped_Entity
(Prim_Op
)) = E_Entry
7336 return New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
);
7338 -- Protected procedure
7342 New_Occurrence_Of
(RTE
(RE_POK_Protected_Procedure
), Loc
);
7345 elsif Ekind
(Full_Typ
) = E_Task_Type
then
7349 if Is_Primitive_Wrapper
(Prim_Op
)
7350 and then Ekind
(Wrapped_Entity
(Prim_Op
)) = E_Entry
7352 return New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
);
7354 -- Task "procedure". These are the internally Expander-generated
7355 -- procedures (task body for instance).
7358 return New_Occurrence_Of
(RTE
(RE_POK_Task_Procedure
), Loc
);
7361 -- Regular procedure
7364 return New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
);
7369 -----------------------------------
7370 -- Register_Predefined_Primitive --
7371 -----------------------------------
7373 function Register_Predefined_Primitive
7375 Prim
: Entity_Id
) return List_Id
7377 L
: constant List_Id
:= New_List
;
7378 Tagged_Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Prim
);
7381 Iface_DT_Ptr
: Elmt_Id
;
7382 SS_Thunk_Id
: Entity_Id
;
7383 SS_Thunk_Code
: Node_Id
;
7384 Thunk_Id
: Entity_Id
;
7385 Thunk_Code
: List_Id
;
7388 if No
(Access_Disp_Table
(Tagged_Typ
))
7389 or else not Has_Interfaces
(Tagged_Typ
)
7390 or else not RTE_Available
(RE_Interface_Tag
)
7391 or else Restriction_Active
(No_Dispatching_Calls
)
7396 -- Skip the first two access-to-dispatch-table pointers since they
7397 -- leads to the primary dispatch table (predefined DT and user
7398 -- defined DT). We are only concerned with the secondary dispatch
7399 -- table pointers. Note that the access-to- dispatch-table pointer
7400 -- corresponds to the first implemented interface retrieved below.
7403 Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Tagged_Typ
))));
7405 while Present
(Iface_DT_Ptr
)
7406 and then Ekind
(Node
(Iface_DT_Ptr
)) = E_Constant
7408 pragma Assert
(Has_Thunks
(Node
(Iface_DT_Ptr
)));
7410 Expand_Interface_Thunk
7411 (Prim
, Thunk_Id
, Thunk_Code
, Related_Type
(Node
(Iface_DT_Ptr
)));
7413 if Present
(Thunk_Id
) then
7414 Append_List_To
(L
, Thunk_Code
);
7417 Expand_Secondary_Stack_Thunk
(E
, SS_Thunk_Id
, SS_Thunk_Code
);
7419 if Present
(SS_Thunk_Id
) then
7421 Append_To
(L
, SS_Thunk_Code
);
7425 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7427 New_Occurrence_Of
(Node
(Next_Elmt
(Iface_DT_Ptr
)), Loc
),
7428 Position
=> DT_Position
(Prim
),
7430 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7431 Make_Attribute_Reference
(Loc
,
7432 Prefix
=> New_Occurrence_Of
(Thunk_Id
, Loc
),
7433 Attribute_Name
=> Name_Unrestricted_Access
))));
7436 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7439 (Node
(Next_Elmt
(Next_Elmt
(Next_Elmt
(Iface_DT_Ptr
)))),
7441 Position
=> DT_Position
(Prim
),
7443 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7444 Make_Attribute_Reference
(Loc
,
7445 Prefix
=> New_Occurrence_Of
(E
, Loc
),
7446 Attribute_Name
=> Name_Unrestricted_Access
))));
7449 -- Skip the tag of the predefined primitives dispatch table
7451 Next_Elmt
(Iface_DT_Ptr
);
7452 pragma Assert
(Has_Thunks
(Node
(Iface_DT_Ptr
)));
7454 -- Skip tag of the no-thunks dispatch table
7456 Next_Elmt
(Iface_DT_Ptr
);
7457 pragma Assert
(not Has_Thunks
(Node
(Iface_DT_Ptr
)));
7459 -- Skip tag of predefined primitives no-thunks dispatch table
7461 Next_Elmt
(Iface_DT_Ptr
);
7462 pragma Assert
(not Has_Thunks
(Node
(Iface_DT_Ptr
)));
7464 Next_Elmt
(Iface_DT_Ptr
);
7468 end Register_Predefined_Primitive
;
7470 ------------------------
7471 -- Register_Primitive --
7472 ------------------------
7474 function Register_Primitive
7476 Prim
: Entity_Id
) return List_Id
7478 L
: constant List_Id
:= New_List
;
7482 Iface_Prim
: Entity_Id
;
7483 Iface_Typ
: Entity_Id
;
7484 Iface_DT_Ptr
: Entity_Id
;
7485 Iface_DT_Elmt
: Elmt_Id
;
7487 SS_Thunk_Id
: Entity_Id
;
7488 SS_Thunk_Code
: Node_Id
;
7490 Tag_Typ
: Entity_Id
;
7491 Thunk_Id
: Entity_Id
;
7492 Thunk_Code
: List_Id
;
7495 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
7497 -- Do not register eliminated primitives in the dispatch table
7499 if not RTE_Available
(RE_Tag
)
7500 or else Is_Eliminated
(Ultimate_Alias
(Prim
))
7501 or else Generate_SCIL
7506 -- Primitive associated with a tagged type
7508 if No
(Interface_Alias
(Prim
)) then
7509 Tag_Typ
:= Scope
(DTC_Entity
(Prim
));
7510 Pos
:= DT_Position
(Prim
);
7511 Tag
:= First_Tag_Component
(Tag_Typ
);
7514 Expand_Secondary_Stack_Thunk
(E
, SS_Thunk_Id
, SS_Thunk_Code
);
7516 if Present
(SS_Thunk_Id
) then
7518 Append_To
(L
, SS_Thunk_Code
);
7521 if Is_Predefined_Dispatching_Operation
(Prim
)
7522 or else Is_Predefined_Dispatching_Alias
(Prim
)
7525 Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Tag_Typ
))));
7528 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7529 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7532 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7533 Make_Attribute_Reference
(Loc
,
7534 Prefix
=> New_Occurrence_Of
(E
, Loc
),
7535 Attribute_Name
=> Name_Unrestricted_Access
))));
7537 -- Register copy of the pointer to the 'size primitive in the TSD
7539 if Chars
(Prim
) = Name_uSize
7540 and then RTE_Record_Component_Available
(RE_Size_Func
)
7542 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Tag_Typ
)));
7544 Build_Set_Size_Function
(Loc
,
7545 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7546 Size_Func
=> Prim
));
7550 pragma Assert
(Pos
/= Uint_0
and then Pos
<= DT_Entry_Count
(Tag
));
7552 -- Skip registration of primitives located in the C++ part of the
7553 -- dispatch table. Their slot is set by the IC routine.
7555 if not Is_CPP_Class
(Root_Type
(Tag_Typ
))
7556 or else Pos
> CPP_Num_Prims
(Tag_Typ
)
7558 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Tag_Typ
)));
7560 Build_Set_Prim_Op_Address
(Loc
,
7562 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7565 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7566 Make_Attribute_Reference
(Loc
,
7567 Prefix
=> New_Occurrence_Of
(E
, Loc
),
7568 Attribute_Name
=> Name_Unrestricted_Access
))));
7572 -- Ada 2005 (AI-251): Primitive associated with an interface type
7574 -- Generate the code of the thunk only if the interface type is not an
7575 -- immediate ancestor of Typ; otherwise the dispatch table associated
7576 -- with the interface is the primary dispatch table and we have nothing
7580 Tag_Typ
:= Find_Dispatching_Type
(Alias
(Prim
));
7581 Iface_Typ
:= Find_Dispatching_Type
(Interface_Alias
(Prim
));
7583 pragma Assert
(Is_Interface
(Iface_Typ
));
7585 -- No action needed for interfaces that are ancestors of Typ because
7586 -- their primitives are located in the primary dispatch table.
7588 if Is_Ancestor
(Iface_Typ
, Tag_Typ
, Use_Full_View
=> True) then
7591 -- No action needed for primitives located in the C++ part of the
7592 -- dispatch table. Their slot is set by the IC routine.
7594 elsif Is_CPP_Class
(Root_Type
(Tag_Typ
))
7595 and then DT_Position
(Alias
(Prim
)) <= CPP_Num_Prims
(Tag_Typ
)
7596 and then not Is_Predefined_Dispatching_Operation
(Prim
)
7597 and then not Is_Predefined_Dispatching_Alias
(Prim
)
7602 Expand_Interface_Thunk
(Prim
, Thunk_Id
, Thunk_Code
, Iface_Typ
);
7604 if Present
(Thunk_Id
)
7605 and then not Is_Ancestor
(Iface_Typ
, Tag_Typ
, Use_Full_View
=> True)
7607 -- Generate the code necessary to fill the appropriate entry of
7608 -- the secondary dispatch table of Prim's controlling type with
7609 -- Thunk_Id's address.
7611 Iface_DT_Elmt
:= Find_Interface_ADT
(Tag_Typ
, Iface_Typ
);
7612 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7613 pragma Assert
(Has_Thunks
(Iface_DT_Ptr
));
7615 Iface_Prim
:= Interface_Alias
(Prim
);
7616 Pos
:= DT_Position
(Iface_Prim
);
7617 Tag
:= First_Tag_Component
(Iface_Typ
);
7619 Append_List_To
(L
, Thunk_Code
);
7621 E
:= Ultimate_Alias
(Prim
);
7622 Expand_Secondary_Stack_Thunk
(E
, SS_Thunk_Id
, SS_Thunk_Code
);
7624 if Present
(SS_Thunk_Id
) then
7626 Append_To
(L
, SS_Thunk_Code
);
7629 if Is_Predefined_Dispatching_Operation
(Prim
)
7630 or else Is_Predefined_Dispatching_Alias
(Prim
)
7633 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7635 New_Occurrence_Of
(Node
(Next_Elmt
(Iface_DT_Elmt
)), Loc
),
7638 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7639 Make_Attribute_Reference
(Loc
,
7640 Prefix
=> New_Occurrence_Of
(Thunk_Id
, Loc
),
7641 Attribute_Name
=> Name_Unrestricted_Access
))));
7643 Next_Elmt
(Iface_DT_Elmt
);
7644 Next_Elmt
(Iface_DT_Elmt
);
7645 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7646 pragma Assert
(not Has_Thunks
(Iface_DT_Ptr
));
7649 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7651 New_Occurrence_Of
(Node
(Next_Elmt
(Iface_DT_Elmt
)), Loc
),
7654 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7655 Make_Attribute_Reference
(Loc
,
7656 Prefix
=> New_Occurrence_Of
(E
, Loc
),
7657 Attribute_Name
=> Name_Unrestricted_Access
))));
7660 pragma Assert
(Pos
/= Uint_0
7661 and then Pos
<= DT_Entry_Count
(Tag
));
7664 Build_Set_Prim_Op_Address
(Loc
,
7666 Tag_Node
=> New_Occurrence_Of
(Iface_DT_Ptr
, Loc
),
7669 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7670 Make_Attribute_Reference
(Loc
,
7671 Prefix
=> New_Occurrence_Of
(Thunk_Id
, Loc
),
7672 Attribute_Name
=> Name_Unrestricted_Access
))));
7674 Next_Elmt
(Iface_DT_Elmt
);
7675 Next_Elmt
(Iface_DT_Elmt
);
7676 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7677 pragma Assert
(not Has_Thunks
(Iface_DT_Ptr
));
7680 Build_Set_Prim_Op_Address
(Loc
,
7682 Tag_Node
=> New_Occurrence_Of
(Iface_DT_Ptr
, Loc
),
7685 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7686 Make_Attribute_Reference
(Loc
,
7687 Prefix
=> New_Occurrence_Of
(E
, Loc
),
7688 Attribute_Name
=> Name_Unrestricted_Access
))));
7695 end Register_Primitive
;
7697 -------------------------
7698 -- Set_All_DT_Position --
7699 -------------------------
7701 procedure Set_All_DT_Position
(Typ
: Entity_Id
) is
7703 function In_Predef_Prims_DT
(Prim
: Entity_Id
) return Boolean;
7704 -- Returns True if Prim is located in the dispatch table of
7705 -- predefined primitives
7707 procedure Validate_Position
(Prim
: Entity_Id
);
7708 -- Check that position assigned to Prim is completely safe (it has not
7709 -- been assigned to a previously defined primitive operation of Typ).
7711 ------------------------
7712 -- In_Predef_Prims_DT --
7713 ------------------------
7715 function In_Predef_Prims_DT
(Prim
: Entity_Id
) return Boolean is
7717 -- Predefined primitives
7719 if Is_Predefined_Dispatching_Operation
(Prim
) then
7722 -- Renamings of predefined primitives
7724 elsif Present
(Alias
(Prim
))
7725 and then Is_Predefined_Dispatching_Operation
(Ultimate_Alias
(Prim
))
7727 if Chars
(Ultimate_Alias
(Prim
)) /= Name_Op_Eq
then
7730 -- An overriding operation that is a user-defined renaming of
7731 -- predefined equality inherits its slot from the overridden
7732 -- operation. Otherwise it is treated as a predefined op and
7733 -- occupies the same predefined slot as equality. A call to it is
7734 -- transformed into a call to its alias, which is the predefined
7735 -- equality op. A dispatching call thus uses the proper slot if
7736 -- operation is further inherited and called with class-wide
7741 not Comes_From_Source
(Prim
)
7742 or else No
(Overridden_Operation
(Prim
));
7745 -- User-defined primitives
7750 end In_Predef_Prims_DT
;
7752 -----------------------
7753 -- Validate_Position --
7754 -----------------------
7756 procedure Validate_Position
(Prim
: Entity_Id
) is
7761 -- Aliased primitives are safe
7763 if Present
(Alias
(Prim
)) then
7767 Op_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
7768 while Present
(Op_Elmt
) loop
7769 Op
:= Node
(Op_Elmt
);
7771 -- No need to check against itself
7776 -- Primitive operations covering abstract interfaces are
7779 elsif Present
(Interface_Alias
(Op
)) then
7782 -- Predefined dispatching operations are completely safe. They
7783 -- are allocated at fixed positions in a separate table.
7785 elsif Is_Predefined_Dispatching_Operation
(Op
)
7786 or else Is_Predefined_Dispatching_Alias
(Op
)
7790 -- Aliased subprograms are safe
7792 elsif Present
(Alias
(Op
)) then
7795 elsif DT_Position
(Op
) = DT_Position
(Prim
)
7796 and then not Is_Predefined_Dispatching_Operation
(Op
)
7797 and then not Is_Predefined_Dispatching_Operation
(Prim
)
7798 and then not Is_Predefined_Dispatching_Alias
(Op
)
7799 and then not Is_Predefined_Dispatching_Alias
(Prim
)
7801 -- Handle aliased subprograms
7810 if Present
(Overridden_Operation
(Op_1
)) then
7811 Op_1
:= Overridden_Operation
(Op_1
);
7812 elsif Present
(Alias
(Op_1
)) then
7813 Op_1
:= Alias
(Op_1
);
7821 if Present
(Overridden_Operation
(Op_2
)) then
7822 Op_2
:= Overridden_Operation
(Op_2
);
7823 elsif Present
(Alias
(Op_2
)) then
7824 Op_2
:= Alias
(Op_2
);
7830 if Op_1
/= Op_2
then
7831 raise Program_Error
;
7836 Next_Elmt
(Op_Elmt
);
7838 end Validate_Position
;
7842 Parent_Typ
: constant Entity_Id
:= Etype
(Typ
);
7843 First_Prim
: constant Elmt_Id
:= First_Elmt
(Primitive_Operations
(Typ
));
7844 The_Tag
: constant Entity_Id
:= First_Tag_Component
(Typ
);
7846 Adjusted
: Boolean := False;
7847 Finalized
: Boolean := False;
7853 Prim_Elmt
: Elmt_Id
;
7855 -- Start of processing for Set_All_DT_Position
7858 pragma Assert
(Present
(First_Tag_Component
(Typ
)));
7860 -- Set the DT_Position for each primitive operation. Perform some sanity
7861 -- checks to avoid building inconsistent dispatch tables.
7863 -- First stage: Set DTC entity of all the primitive operations. This is
7864 -- required to properly read the DT_Position attribute in latter stages.
7866 Prim_Elmt
:= First_Prim
;
7868 while Present
(Prim_Elmt
) loop
7869 Prim
:= Node
(Prim_Elmt
);
7871 -- Predefined primitives have a separate dispatch table
7873 if not In_Predef_Prims_DT
(Prim
) then
7874 Count_Prim
:= Count_Prim
+ 1;
7877 Set_DTC_Entity_Value
(Typ
, Prim
);
7879 -- Clear any previous value of the DT_Position attribute. In this
7880 -- way we ensure that the final position of all the primitives is
7881 -- established by the following stages of this algorithm.
7883 Set_DT_Position_Value
(Prim
, No_Uint
);
7885 Next_Elmt
(Prim_Elmt
);
7889 Fixed_Prim
: array (Int
range 0 .. Count_Prim
) of Boolean :=
7894 procedure Handle_Inherited_Private_Subprograms
(Typ
: Entity_Id
);
7895 -- Called if Typ is declared in a nested package or a public child
7896 -- package to handle inherited primitives that were inherited by Typ
7897 -- in the visible part, but whose declaration was deferred because
7898 -- the parent operation was private and not visible at that point.
7900 procedure Set_Fixed_Prim
(Pos
: Nat
);
7901 -- Sets to true an element of the Fixed_Prim table to indicate
7902 -- that this entry of the dispatch table of Typ is occupied.
7904 ------------------------------------------
7905 -- Handle_Inherited_Private_Subprograms --
7906 ------------------------------------------
7908 procedure Handle_Inherited_Private_Subprograms
(Typ
: Entity_Id
) is
7911 Op_Elmt_2
: Elmt_Id
;
7912 Prim_Op
: Entity_Id
;
7913 Parent_Subp
: Entity_Id
;
7916 Op_List
:= Primitive_Operations
(Typ
);
7918 Op_Elmt
:= First_Elmt
(Op_List
);
7919 while Present
(Op_Elmt
) loop
7920 Prim_Op
:= Node
(Op_Elmt
);
7922 -- Search primitives that are implicit operations with an
7923 -- internal name whose parent operation has a normal name.
7925 if Present
(Alias
(Prim_Op
))
7926 and then Find_Dispatching_Type
(Alias
(Prim_Op
)) /= Typ
7927 and then not Comes_From_Source
(Prim_Op
)
7928 and then Is_Internal_Name
(Chars
(Prim_Op
))
7929 and then not Is_Internal_Name
(Chars
(Alias
(Prim_Op
)))
7931 Parent_Subp
:= Alias
(Prim_Op
);
7933 -- Check if the type has an explicit overriding for this
7936 Op_Elmt_2
:= Next_Elmt
(Op_Elmt
);
7937 while Present
(Op_Elmt_2
) loop
7938 if Chars
(Node
(Op_Elmt_2
)) = Chars
(Parent_Subp
)
7939 and then Type_Conformant
(Prim_Op
, Node
(Op_Elmt_2
))
7941 Set_DT_Position_Value
(Prim_Op
,
7942 DT_Position
(Parent_Subp
));
7943 Set_DT_Position_Value
(Node
(Op_Elmt_2
),
7944 DT_Position
(Parent_Subp
));
7945 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(Prim_Op
)));
7947 goto Next_Primitive
;
7950 Next_Elmt
(Op_Elmt_2
);
7955 Next_Elmt
(Op_Elmt
);
7957 end Handle_Inherited_Private_Subprograms
;
7959 --------------------
7960 -- Set_Fixed_Prim --
7961 --------------------
7963 procedure Set_Fixed_Prim
(Pos
: Nat
) is
7965 pragma Assert
(Pos
<= Count_Prim
);
7966 Fixed_Prim
(Pos
) := True;
7968 when Constraint_Error
=>
7969 raise Program_Error
;
7973 -- In case of nested packages and public child package it may be
7974 -- necessary a special management on inherited subprograms so that
7975 -- the dispatch table is properly filled.
7977 if Ekind
(Scope
(Scope
(Typ
))) = E_Package
7978 and then Scope
(Scope
(Typ
)) /= Standard_Standard
7979 and then ((Is_Derived_Type
(Typ
) and then not Is_Private_Type
(Typ
))
7981 (Nkind
(Parent
(Typ
)) = N_Private_Extension_Declaration
7982 and then Is_Generic_Type
(Typ
)))
7983 and then In_Open_Scopes
(Scope
(Etype
(Typ
)))
7984 and then Is_Base_Type
(Typ
)
7986 Handle_Inherited_Private_Subprograms
(Typ
);
7989 -- Second stage: Register fixed entries
7992 Prim_Elmt
:= First_Prim
;
7993 while Present
(Prim_Elmt
) loop
7994 Prim
:= Node
(Prim_Elmt
);
7996 -- Predefined primitives have a separate table and all its
7997 -- entries are at predefined fixed positions.
7999 if In_Predef_Prims_DT
(Prim
) then
8000 if Is_Predefined_Dispatching_Operation
(Prim
) then
8001 Set_DT_Position_Value
(Prim
,
8002 Default_Prim_Op_Position
(Prim
));
8004 else pragma Assert
(Present
(Alias
(Prim
)));
8005 Set_DT_Position_Value
(Prim
,
8006 Default_Prim_Op_Position
(Ultimate_Alias
(Prim
)));
8009 -- Overriding primitives of ancestor abstract interfaces
8011 elsif Present
(Interface_Alias
(Prim
))
8012 and then Is_Ancestor
8013 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
8014 Use_Full_View
=> True)
8016 pragma Assert
(No
(DT_Position
(Prim
)));
8017 pragma Assert
(Present
(DTC_Entity
(Interface_Alias
(Prim
))));
8019 E
:= Interface_Alias
(Prim
);
8020 Set_DT_Position_Value
(Prim
, DT_Position
(E
));
8023 (No
(DT_Position
(Alias
(Prim
)))
8024 or else DT_Position
(Alias
(Prim
)) = DT_Position
(E
));
8025 Set_DT_Position_Value
(Alias
(Prim
), DT_Position
(E
));
8026 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(Prim
)));
8028 -- Overriding primitives must use the same entry as the overridden
8029 -- primitive. Note that the Alias of the operation is set when the
8030 -- operation is declared by a renaming, in which case it is not
8031 -- overriding. If it renames another primitive it will use the
8032 -- same dispatch table slot, but if it renames an operation in a
8033 -- nested package it's a new primitive and will have its own slot.
8035 elsif No
(Interface_Alias
(Prim
))
8036 and then Present
(Alias
(Prim
))
8037 and then Chars
(Prim
) = Chars
(Alias
(Prim
))
8038 and then Nkind
(Unit_Declaration_Node
(Prim
)) /=
8039 N_Subprogram_Renaming_Declaration
8042 Par_Type
: constant Entity_Id
:=
8043 Find_Dispatching_Type
(Alias
(Prim
));
8046 if Present
(Par_Type
)
8047 and then Par_Type
/= Typ
8048 and then Is_Ancestor
(Par_Type
, Typ
, Use_Full_View
=> True)
8049 and then Present
(DTC_Entity
(Alias
(Prim
)))
8052 Set_DT_Position_Value
(Prim
, DT_Position
(E
));
8054 if not Is_Predefined_Dispatching_Alias
(E
) then
8055 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(E
)));
8061 Next_Elmt
(Prim_Elmt
);
8064 -- Third stage: Fix the position of all the new primitives. Entries
8065 -- associated with primitives covering interfaces are handled in a
8068 Prim_Elmt
:= First_Prim
;
8069 while Present
(Prim_Elmt
) loop
8070 Prim
:= Node
(Prim_Elmt
);
8072 -- Skip primitives previously set entries
8074 if Present
(DT_Position
(Prim
)) then
8077 -- Primitives covering interface primitives are handled later
8079 elsif Present
(Interface_Alias
(Prim
)) then
8083 -- Take the next available position in the DT
8086 Nb_Prim
:= Nb_Prim
+ 1;
8087 pragma Assert
(Nb_Prim
<= Count_Prim
);
8088 exit when not Fixed_Prim
(Nb_Prim
);
8091 Set_DT_Position_Value
(Prim
, UI_From_Int
(Nb_Prim
));
8092 Set_Fixed_Prim
(Nb_Prim
);
8095 Next_Elmt
(Prim_Elmt
);
8099 -- Fourth stage: Complete the decoration of primitives covering
8100 -- interfaces (that is, propagate the DT_Position attribute from
8101 -- the aliased primitive)
8103 Prim_Elmt
:= First_Prim
;
8104 while Present
(Prim_Elmt
) loop
8105 Prim
:= Node
(Prim_Elmt
);
8107 if No
(DT_Position
(Prim
))
8108 and then Present
(Interface_Alias
(Prim
))
8110 pragma Assert
(Present
(Alias
(Prim
))
8111 and then Find_Dispatching_Type
(Alias
(Prim
)) = Typ
);
8113 -- Check if this entry will be placed in the primary DT
8116 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
8117 Use_Full_View
=> True)
8119 pragma Assert
(Present
(DT_Position
(Alias
(Prim
))));
8120 Set_DT_Position_Value
(Prim
, DT_Position
(Alias
(Prim
)));
8122 -- Otherwise it will be placed in the secondary DT
8126 (Present
(DT_Position
(Interface_Alias
(Prim
))));
8127 Set_DT_Position_Value
(Prim
,
8128 DT_Position
(Interface_Alias
(Prim
)));
8132 Next_Elmt
(Prim_Elmt
);
8135 -- Generate listing showing the contents of the dispatch tables. This
8136 -- action is done before some further static checks because in case of
8137 -- critical errors caused by a wrong dispatch table we need to see the
8138 -- contents of such table.
8140 if Debug_Flag_ZZ
then
8144 -- Final stage: Ensure that the table is correct plus some further
8145 -- verifications concerning the primitives.
8147 Prim_Elmt
:= First_Prim
;
8149 while Present
(Prim_Elmt
) loop
8150 Prim
:= Node
(Prim_Elmt
);
8152 -- At this point all the primitives MUST have a position in the
8155 if No
(DT_Position
(Prim
)) then
8156 raise Program_Error
;
8159 -- Calculate real size of the dispatch table
8161 if not In_Predef_Prims_DT
(Prim
)
8162 and then UI_To_Int
(DT_Position
(Prim
)) > DT_Length
8164 DT_Length
:= UI_To_Int
(DT_Position
(Prim
));
8167 -- Ensure that the assigned position to non-predefined dispatching
8168 -- operations in the dispatch table is correct.
8170 if not Is_Predefined_Dispatching_Operation
(Prim
)
8171 and then not Is_Predefined_Dispatching_Alias
(Prim
)
8173 Validate_Position
(Prim
);
8176 if Chars
(Prim
) = Name_Finalize
then
8180 if Chars
(Prim
) = Name_Adjust
then
8184 -- An abstract operation cannot be declared in the private part for a
8185 -- visible abstract type, because it can't be overridden outside this
8186 -- package hierarchy. For explicit declarations this is checked at
8187 -- the point of declaration, but for inherited operations it must be
8188 -- done when building the dispatch table.
8190 -- Ada 2005 (AI-251): Primitives associated with interfaces are
8191 -- excluded from this check because interfaces must be visible in
8192 -- the public and private part (RM 7.3 (7.3/2))
8194 -- We disable this check in Relaxed_RM_Semantics mode, to accommodate
8197 if not Relaxed_RM_Semantics
8198 and then Is_Abstract_Type
(Typ
)
8199 and then Is_Abstract_Subprogram
(Prim
)
8200 and then Present
(Alias
(Prim
))
8201 and then not Is_Interface
8202 (Find_Dispatching_Type
(Ultimate_Alias
(Prim
)))
8203 and then No
(Interface_Alias
(Prim
))
8204 and then Is_Derived_Type
(Typ
)
8205 and then In_Private_Part
(Current_Scope
)
8207 List_Containing
(Parent
(Prim
)) =
8208 Private_Declarations
(Package_Specification
(Current_Scope
))
8209 and then Original_View_In_Visible_Part
(Typ
)
8211 -- We exclude Input and Output stream operations because
8212 -- Limited_Controlled inherits useless Input and Output stream
8213 -- operations from Root_Controlled, which can never be overridden.
8214 -- Move this check to sem???
8216 if not Is_TSS
(Prim
, TSS_Stream_Input
)
8218 not Is_TSS
(Prim
, TSS_Stream_Output
)
8221 ("abstract inherited private operation&" &
8222 " must be overridden (RM 3.9.3(10))",
8223 Parent
(Typ
), Prim
);
8227 Next_Elmt
(Prim_Elmt
);
8232 if Is_Controlled
(Typ
) then
8233 if not Finalized
then
8235 ("controlled type has no explicit Finalize method??", Typ
);
8237 elsif not Adjusted
then
8239 ("controlled type has no explicit Adjust method??", Typ
);
8243 -- Set the final size of the Dispatch Table
8245 Set_DT_Entry_Count
(The_Tag
, UI_From_Int
(DT_Length
));
8247 -- The derived type must have at least as many components as its parent
8248 -- (for root types Etype points to itself and the test cannot fail).
8250 if DT_Entry_Count
(The_Tag
) <
8251 DT_Entry_Count
(First_Tag_Component
(Parent_Typ
))
8253 raise Program_Error
;
8255 end Set_All_DT_Position
;
8257 --------------------------
8258 -- Set_CPP_Constructors --
8259 --------------------------
8261 procedure Set_CPP_Constructors
(Typ
: Entity_Id
) is
8263 function Gen_Parameters_Profile
(E
: Entity_Id
) return List_Id
;
8264 -- Duplicate the parameters profile of the imported C++ constructor
8265 -- adding the "this" pointer to the object as the additional first
8266 -- parameter under the usual form _Init : in out Typ.
8268 ----------------------------
8269 -- Gen_Parameters_Profile --
8270 ----------------------------
8272 function Gen_Parameters_Profile
(E
: Entity_Id
) return List_Id
is
8273 Loc
: constant Source_Ptr
:= Sloc
(E
);
8280 Make_Parameter_Specification
(Loc
,
8281 Defining_Identifier
=>
8282 Make_Defining_Identifier
(Loc
, Name_uInit
),
8284 Out_Present
=> True,
8285 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
8287 P
:= First
(Parameter_Specifications
(Parent
(E
)));
8288 while Present
(P
) loop
8290 Make_Parameter_Specification
(Loc
,
8291 Defining_Identifier
=>
8292 Make_Defining_Identifier
(Loc
,
8293 Chars
=> Chars
(Defining_Identifier
(P
))),
8294 Parameter_Type
=> New_Copy_Tree
(Parameter_Type
(P
)),
8295 Expression
=> New_Copy_Tree
(Expression
(P
))));
8300 end Gen_Parameters_Profile
;
8306 Found
: Boolean := False;
8312 Covers_Default_Constructor
: Entity_Id
:= Empty
;
8314 -- Start of processing for Set_CPP_Constructor
8317 pragma Assert
(Is_CPP_Class
(Typ
));
8319 -- Look for the constructor entities
8321 E
:= Next_Entity
(Typ
);
8322 while Present
(E
) loop
8323 if Ekind
(E
) = E_Function
8324 and then Is_Constructor
(E
)
8328 Parms
:= Gen_Parameters_Profile
(E
);
8329 IP
:= Make_Defining_Identifier
(Loc
, Make_Init_Proc_Name
(Typ
));
8331 -- Case 1: Constructor of untagged type
8333 -- If the C++ class has no virtual methods then the matching Ada
8334 -- type is an untagged record type. In such case there is no need
8335 -- to generate a wrapper of the C++ constructor because the _tag
8336 -- component is not available.
8338 if not Is_Tagged_Type
(Typ
) then
8340 (Make_Subprogram_Declaration
(Loc
,
8342 Make_Procedure_Specification
(Loc
,
8343 Defining_Unit_Name
=> IP
,
8344 Parameter_Specifications
=> Parms
)));
8346 Set_Init_Proc
(Typ
, IP
);
8347 Set_Is_Imported
(IP
);
8348 Set_Is_Constructor
(IP
);
8349 Set_Interface_Name
(IP
, Interface_Name
(E
));
8350 Set_Convention
(IP
, Convention_CPP
);
8352 Set_Has_Completion
(IP
);
8354 -- Case 2: Constructor of a tagged type
8356 -- In this case we generate the IP routine as a wrapper of the
8357 -- C++ constructor because IP must also save a copy of the _tag
8358 -- generated in the C++ side. The copy of the _tag is used by
8359 -- Build_CPP_Init_Procedure to elaborate derivations of C++ types.
8362 -- procedure IP (_init : in out Typ; ...) is
8363 -- procedure ConstructorP (_init : in out Typ; ...);
8364 -- pragma Import (ConstructorP);
8366 -- ConstructorP (_init, ...);
8367 -- if Typ._tag = null then
8368 -- Typ._tag := _init._tag;
8374 Body_Stmts
: constant List_Id
:= New_List
;
8375 Constructor_Id
: Entity_Id
;
8376 Constructor_Decl_Node
: Node_Id
;
8377 Init_Tags_List
: List_Id
;
8380 Constructor_Id
:= Make_Temporary
(Loc
, 'P');
8382 Constructor_Decl_Node
:=
8383 Make_Subprogram_Declaration
(Loc
,
8384 Make_Procedure_Specification
(Loc
,
8385 Defining_Unit_Name
=> Constructor_Id
,
8386 Parameter_Specifications
=> Parms
));
8388 Set_Is_Imported
(Constructor_Id
);
8389 Set_Is_Constructor
(Constructor_Id
);
8390 Set_Interface_Name
(Constructor_Id
, Interface_Name
(E
));
8391 Set_Convention
(Constructor_Id
, Convention_CPP
);
8392 Set_Is_Public
(Constructor_Id
);
8393 Set_Has_Completion
(Constructor_Id
);
8395 -- Build the init procedure as a wrapper of this constructor
8397 Parms
:= Gen_Parameters_Profile
(E
);
8399 -- Invoke the C++ constructor
8402 Actuals
: constant List_Id
:= New_List
;
8406 while Present
(P
) loop
8408 New_Occurrence_Of
(Defining_Identifier
(P
), Loc
));
8412 Append_To
(Body_Stmts
,
8413 Make_Procedure_Call_Statement
(Loc
,
8414 Name
=> New_Occurrence_Of
(Constructor_Id
, Loc
),
8415 Parameter_Associations
=> Actuals
));
8418 -- Initialize copies of C++ primary and secondary tags
8420 Init_Tags_List
:= New_List
;
8427 Tag_Elmt
:= First_Elmt
(Access_Disp_Table
(Typ
));
8428 Tag_Comp
:= First_Tag_Component
(Typ
);
8430 while Present
(Tag_Elmt
)
8431 and then Is_Tag
(Node
(Tag_Elmt
))
8433 -- Skip the following assertion with primary tags
8434 -- because Related_Type is not set on primary tag
8438 (Tag_Comp
= First_Tag_Component
(Typ
)
8439 or else Related_Type
(Node
(Tag_Elmt
))
8440 = Related_Type
(Tag_Comp
));
8442 Append_To
(Init_Tags_List
,
8443 Make_Assignment_Statement
(Loc
,
8445 New_Occurrence_Of
(Node
(Tag_Elmt
), Loc
),
8447 Make_Selected_Component
(Loc
,
8449 Make_Identifier
(Loc
, Name_uInit
),
8451 New_Occurrence_Of
(Tag_Comp
, Loc
))));
8453 Tag_Comp
:= Next_Tag_Component
(Tag_Comp
);
8454 Next_Elmt
(Tag_Elmt
);
8458 Append_To
(Body_Stmts
,
8459 Make_If_Statement
(Loc
,
8464 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))),
8467 Unchecked_Convert_To
(RTE
(RE_Tag
),
8468 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))),
8469 Then_Statements
=> Init_Tags_List
));
8472 Make_Subprogram_Body
(Loc
,
8474 Make_Procedure_Specification
(Loc
,
8475 Defining_Unit_Name
=> IP
,
8476 Parameter_Specifications
=> Parms
),
8477 Declarations
=> New_List
(Constructor_Decl_Node
),
8478 Handled_Statement_Sequence
=>
8479 Make_Handled_Sequence_Of_Statements
(Loc
,
8480 Statements
=> Body_Stmts
,
8481 Exception_Handlers
=> No_List
));
8483 Discard_Node
(IP_Body
);
8484 Set_Init_Proc
(Typ
, IP
);
8488 -- If this constructor has parameters and all its parameters have
8489 -- defaults then it covers the default constructor. The semantic
8490 -- analyzer ensures that only one constructor with defaults covers
8491 -- the default constructor.
8493 if Present
(Parameter_Specifications
(Parent
(E
)))
8494 and then Needs_No_Actuals
(E
)
8496 Covers_Default_Constructor
:= IP
;
8503 -- If there are no constructors, mark the type as abstract since we
8504 -- won't be able to declare objects of that type.
8507 Set_Is_Abstract_Type
(Typ
);
8510 -- Handle constructor that has all its parameters with defaults and
8511 -- hence it covers the default constructor. We generate a wrapper IP
8512 -- which calls the covering constructor.
8514 if Present
(Covers_Default_Constructor
) then
8516 Body_Stmts
: List_Id
;
8519 Loc
:= Sloc
(Covers_Default_Constructor
);
8521 Body_Stmts
:= New_List
(
8522 Make_Procedure_Call_Statement
(Loc
,
8524 New_Occurrence_Of
(Covers_Default_Constructor
, Loc
),
8525 Parameter_Associations
=> New_List
(
8526 Make_Identifier
(Loc
, Name_uInit
))));
8528 IP
:= Make_Defining_Identifier
(Loc
, Make_Init_Proc_Name
(Typ
));
8531 Make_Subprogram_Body
(Loc
,
8533 Make_Procedure_Specification
(Loc
,
8534 Defining_Unit_Name
=> IP
,
8535 Parameter_Specifications
=> New_List
(
8536 Make_Parameter_Specification
(Loc
,
8537 Defining_Identifier
=>
8538 Make_Defining_Identifier
(Loc
, Name_uInit
),
8539 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)))),
8541 Declarations
=> No_List
,
8543 Handled_Statement_Sequence
=>
8544 Make_Handled_Sequence_Of_Statements
(Loc
,
8545 Statements
=> Body_Stmts
,
8546 Exception_Handlers
=> No_List
));
8548 Discard_Node
(IP_Body
);
8549 Set_Init_Proc
(Typ
, IP
);
8553 -- If the CPP type has constructors then it must import also the default
8554 -- C++ constructor. It is required for default initialization of objects
8555 -- of the type. It is also required to elaborate objects of Ada types
8556 -- that are defined as derivations of this CPP type.
8558 if Has_CPP_Constructors
(Typ
)
8559 and then No
(Init_Proc
(Typ
))
8561 Error_Msg_N
("??default constructor must be imported from C++", Typ
);
8563 end Set_CPP_Constructors
;
8565 ---------------------------
8566 -- Set_DT_Position_Value --
8567 ---------------------------
8569 procedure Set_DT_Position_Value
(Prim
: Entity_Id
; Value
: Uint
) is
8571 Set_DT_Position
(Prim
, Value
);
8573 -- Propagate the value to the wrapped subprogram (if one is present)
8575 if Ekind
(Prim
) in E_Function | E_Procedure
8576 and then Is_Primitive_Wrapper
(Prim
)
8577 and then Present
(Wrapped_Entity
(Prim
))
8578 and then Is_Dispatching_Operation
(Wrapped_Entity
(Prim
))
8580 Set_DT_Position
(Wrapped_Entity
(Prim
), Value
);
8582 end Set_DT_Position_Value
;
8584 --------------------------
8585 -- Set_DTC_Entity_Value --
8586 --------------------------
8588 procedure Set_DTC_Entity_Value
8589 (Tagged_Type
: Entity_Id
;
8593 if Present
(Interface_Alias
(Prim
))
8594 and then Is_Interface
8595 (Find_Dispatching_Type
(Interface_Alias
(Prim
)))
8597 Set_DTC_Entity
(Prim
,
8600 Iface
=> Find_Dispatching_Type
(Interface_Alias
(Prim
))));
8602 Set_DTC_Entity
(Prim
,
8603 First_Tag_Component
(Tagged_Type
));
8606 -- Propagate the value to the wrapped subprogram (if one is present)
8608 if Ekind
(Prim
) in E_Function | E_Procedure
8609 and then Is_Primitive_Wrapper
(Prim
)
8610 and then Present
(Wrapped_Entity
(Prim
))
8611 and then Is_Dispatching_Operation
(Wrapped_Entity
(Prim
))
8613 Set_DTC_Entity
(Wrapped_Entity
(Prim
), DTC_Entity
(Prim
));
8615 end Set_DTC_Entity_Value
;
8621 function Tagged_Kind
(T
: Entity_Id
) return Node_Id
is
8622 Conc_Typ
: Entity_Id
;
8623 Loc
: constant Source_Ptr
:= Sloc
(T
);
8627 (Is_Tagged_Type
(T
) and then RTE_Available
(RE_Tagged_Kind
));
8631 if Is_Abstract_Type
(T
) then
8632 if Is_Limited_Record
(T
) then
8633 return New_Occurrence_Of
8634 (RTE
(RE_TK_Abstract_Limited_Tagged
), Loc
);
8636 return New_Occurrence_Of
8637 (RTE
(RE_TK_Abstract_Tagged
), Loc
);
8642 elsif Is_Concurrent_Record_Type
(T
) then
8643 Conc_Typ
:= Corresponding_Concurrent_Type
(T
);
8645 if Present
(Full_View
(Conc_Typ
)) then
8646 Conc_Typ
:= Full_View
(Conc_Typ
);
8649 if Ekind
(Conc_Typ
) = E_Protected_Type
then
8650 return New_Occurrence_Of
(RTE
(RE_TK_Protected
), Loc
);
8652 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
8653 return New_Occurrence_Of
(RTE
(RE_TK_Task
), Loc
);
8656 -- Regular tagged kinds
8659 if Is_Limited_Record
(T
) then
8660 return New_Occurrence_Of
(RTE
(RE_TK_Limited_Tagged
), Loc
);
8662 return New_Occurrence_Of
(RTE
(RE_TK_Tagged
), Loc
);
8671 procedure Write_DT
(Typ
: Entity_Id
) is
8676 -- Protect this procedure against wrong usage. Required because it will
8677 -- be used directly from GDB
8679 if not (Typ
<= Last_Node_Id
)
8680 or else not Is_Tagged_Type
(Typ
)
8682 Write_Str
("wrong usage: Write_DT must be used with tagged types");
8687 Write_Int
(Int
(Typ
));
8689 Write_Name
(Chars
(Typ
));
8691 if Is_Interface
(Typ
) then
8692 Write_Str
(" is interface");
8697 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
8698 while Present
(Elmt
) loop
8699 Prim
:= Node
(Elmt
);
8702 -- Indicate if this primitive will be allocated in the primary
8703 -- dispatch table or in a secondary dispatch table associated
8704 -- with an abstract interface type
8706 if Present
(DTC_Entity
(Prim
)) then
8707 if Is_RTE
(Etype
(DTC_Entity
(Prim
)), RE_Tag
) then
8714 -- Output the node of this primitive operation and its name
8716 Write_Int
(Int
(Prim
));
8719 if Is_Predefined_Dispatching_Operation
(Prim
) then
8720 Write_Str
("(predefined) ");
8723 -- Prefix the name of the primitive with its corresponding tagged
8724 -- type to facilitate seeing inherited primitives.
8726 if Present
(Alias
(Prim
)) then
8728 (Chars
(Find_Dispatching_Type
(Ultimate_Alias
(Prim
))));
8730 Write_Name
(Chars
(Typ
));
8734 Write_Name
(Chars
(Prim
));
8736 -- Indicate if this primitive has an aliased primitive
8738 if Present
(Alias
(Prim
)) then
8739 Write_Str
(" (alias = ");
8740 Write_Int
(Int
(Alias
(Prim
)));
8742 -- If the DTC_Entity attribute is already set we can also output
8743 -- the name of the interface covered by this primitive (if any).
8745 if Ekind
(Alias
(Prim
)) in E_Function | E_Procedure
8746 and then Present
(DTC_Entity
(Alias
(Prim
)))
8747 and then Is_Interface
(Scope
(DTC_Entity
(Alias
(Prim
))))
8749 Write_Str
(" from interface ");
8750 Write_Name
(Chars
(Scope
(DTC_Entity
(Alias
(Prim
)))));
8753 if Present
(Interface_Alias
(Prim
)) then
8754 Write_Str
(", AI_Alias of ");
8756 if Is_Null_Interface_Primitive
(Interface_Alias
(Prim
)) then
8757 Write_Str
("null primitive ");
8761 (Chars
(Find_Dispatching_Type
(Interface_Alias
(Prim
))));
8763 Write_Int
(Int
(Interface_Alias
(Prim
)));
8769 -- Display the final position of this primitive in its associated
8770 -- (primary or secondary) dispatch table.
8772 if Present
(DTC_Entity
(Prim
))
8773 and then Present
(DT_Position
(Prim
))
8775 Write_Str
(" at #");
8776 Write_Int
(UI_To_Int
(DT_Position
(Prim
)));
8779 if Is_Abstract_Subprogram
(Prim
) then
8780 Write_Str
(" is abstract;");
8782 -- Check if this is a null primitive
8784 elsif Comes_From_Source
(Prim
)
8785 and then Ekind
(Prim
) = E_Procedure
8786 and then Null_Present
(Parent
(Prim
))
8788 Write_Str
(" is null;");
8791 if Is_Eliminated
(Ultimate_Alias
(Prim
)) then
8792 Write_Str
(" (eliminated)");
8795 if Is_Imported
(Prim
)
8796 and then Convention
(Prim
) = Convention_CPP
8798 Write_Str
(" (C++)");