1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Exp_Atag
; use Exp_Atag
;
33 with Exp_Ch6
; use Exp_Ch6
;
34 with Exp_CG
; use Exp_CG
;
35 with Exp_Dbug
; use Exp_Dbug
;
36 with Exp_Tss
; use Exp_Tss
;
37 with Exp_Util
; use Exp_Util
;
38 with Freeze
; use Freeze
;
39 with Ghost
; use Ghost
;
40 with Itypes
; use Itypes
;
41 with Layout
; use Layout
;
42 with Nlists
; use Nlists
;
43 with Nmake
; use Nmake
;
44 with Namet
; use Namet
;
46 with Output
; use Output
;
47 with Restrict
; use Restrict
;
48 with Rident
; use Rident
;
49 with Rtsfind
; use Rtsfind
;
51 with Sem_Aux
; use Sem_Aux
;
52 with Sem_Ch6
; use Sem_Ch6
;
53 with Sem_Ch7
; use Sem_Ch7
;
54 with Sem_Ch8
; use Sem_Ch8
;
55 with Sem_Disp
; use Sem_Disp
;
56 with Sem_Eval
; use Sem_Eval
;
57 with Sem_Res
; use Sem_Res
;
58 with Sem_Type
; use Sem_Type
;
59 with Sem_Util
; use Sem_Util
;
60 with Sinfo
; use Sinfo
;
61 with Snames
; use Snames
;
62 with Stand
; use Stand
;
63 with Stringt
; use Stringt
;
64 with SCIL_LL
; use SCIL_LL
;
65 with Targparm
; use Targparm
;
66 with Tbuild
; use Tbuild
;
68 package body Exp_Disp
is
70 -----------------------
71 -- Local Subprograms --
72 -----------------------
74 function Default_Prim_Op_Position
(E
: Entity_Id
) return Uint
;
75 -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
76 -- of the default primitive operations.
78 function Has_DT
(Typ
: Entity_Id
) return Boolean;
79 pragma Inline
(Has_DT
);
80 -- Returns true if we generate a dispatch table for tagged type Typ
82 function Is_Predefined_Dispatching_Alias
(Prim
: Entity_Id
) return Boolean;
83 -- Returns true if Prim is not a predefined dispatching primitive but it is
84 -- an alias of a predefined dispatching primitive (i.e. through a renaming)
86 function New_Value
(From
: Node_Id
) return Node_Id
;
87 -- From is the original Expression. New_Value is equivalent to a call to
88 -- Duplicate_Subexpr with an explicit dereference when From is an access
91 function Original_View_In_Visible_Part
(Typ
: Entity_Id
) return Boolean;
92 -- Check if the type has a private view or if the public view appears in
93 -- the visible part of a package spec.
97 Typ
: Entity_Id
) return Node_Id
;
98 -- Ada 2005 (AI-345): Determine the primitive operation kind of Prim
99 -- according to its type Typ. Return a reference to an RE_Prim_Op_Kind
100 -- enumeration value.
102 function Tagged_Kind
(T
: Entity_Id
) return Node_Id
;
103 -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
104 -- to an RE_Tagged_Kind enumeration value.
106 ----------------------
107 -- Apply_Tag_Checks --
108 ----------------------
110 procedure Apply_Tag_Checks
(Call_Node
: Node_Id
) is
111 Loc
: constant Source_Ptr
:= Sloc
(Call_Node
);
112 Ctrl_Arg
: constant Node_Id
:= Controlling_Argument
(Call_Node
);
113 Ctrl_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Ctrl_Arg
));
114 Param_List
: constant List_Id
:= Parameter_Associations
(Call_Node
);
120 Eq_Prim_Op
: Entity_Id
:= Empty
;
123 if No_Run_Time_Mode
then
124 Error_Msg_CRT
("tagged types", Call_Node
);
128 -- Apply_Tag_Checks is called directly from the semantics, so we
129 -- need a check to see whether expansion is active before proceeding.
130 -- In addition, there is no need to expand the call when compiling
131 -- under restriction No_Dispatching_Calls; the semantic analyzer has
132 -- previously notified the violation of this restriction.
134 if not Expander_Active
135 or else Restriction_Active
(No_Dispatching_Calls
)
140 -- Set subprogram. If this is an inherited operation that was
141 -- overridden, the body that is being called is its alias.
143 Subp
:= Entity
(Name
(Call_Node
));
145 if Present
(Alias
(Subp
))
146 and then Is_Inherited_Operation
(Subp
)
147 and then No
(DTC_Entity
(Subp
))
149 Subp
:= Alias
(Subp
);
152 -- Definition of the class-wide type and the tagged type
154 -- If the controlling argument is itself a tag rather than a tagged
155 -- object, then use the class-wide type associated with the subprogram's
156 -- controlling type. This case can occur when a call to an inherited
157 -- primitive has an actual that originated from a default parameter
158 -- given by a tag-indeterminate call and when there is no other
159 -- controlling argument providing the tag (AI-239 requires dispatching).
160 -- This capability of dispatching directly by tag is also needed by the
161 -- implementation of AI-260 (for the generic dispatching constructors).
163 if Ctrl_Typ
= RTE
(RE_Tag
)
164 or else (RTE_Available
(RE_Interface_Tag
)
165 and then Ctrl_Typ
= RTE
(RE_Interface_Tag
))
167 CW_Typ
:= Class_Wide_Type
(Find_Dispatching_Type
(Subp
));
169 -- Class_Wide_Type is applied to the expressions used to initialize
170 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
171 -- there are cases where the controlling type is resolved to a specific
172 -- type (such as for designated types of arguments such as CW'Access).
174 elsif Is_Access_Type
(Ctrl_Typ
) then
175 CW_Typ
:= Class_Wide_Type
(Designated_Type
(Ctrl_Typ
));
178 CW_Typ
:= Class_Wide_Type
(Ctrl_Typ
);
181 Typ
:= Find_Specific_Type
(CW_Typ
);
183 if not Is_Limited_Type
(Typ
) then
184 Eq_Prim_Op
:= Find_Prim_Op
(Typ
, Name_Op_Eq
);
187 -- Dispatching call to C++ primitive
189 if Is_CPP_Class
(Typ
) then
192 -- Dispatching call to Ada primitive
194 elsif Present
(Param_List
) then
196 -- Generate the Tag checks when appropriate
198 Param
:= First_Actual
(Call_Node
);
199 while Present
(Param
) loop
201 -- No tag check with itself
203 if Param
= Ctrl_Arg
then
206 -- No tag check for parameter whose type is neither tagged nor
207 -- access to tagged (for access parameters)
209 elsif No
(Find_Controlling_Arg
(Param
)) then
212 -- No tag check for function dispatching on result if the
213 -- Tag given by the context is this one
215 elsif Find_Controlling_Arg
(Param
) = Ctrl_Arg
then
218 -- "=" is the only dispatching operation allowed to get operands
219 -- with incompatible tags (it just returns false). We use
220 -- Duplicate_Subexpr_Move_Checks instead of calling Relocate_Node
221 -- because the value will be duplicated to check the tags.
223 elsif Subp
= Eq_Prim_Op
then
226 -- No check in presence of suppress flags
228 elsif Tag_Checks_Suppressed
(Etype
(Param
))
229 or else (Is_Access_Type
(Etype
(Param
))
230 and then Tag_Checks_Suppressed
231 (Designated_Type
(Etype
(Param
))))
235 -- Optimization: no tag checks if the parameters are identical
237 elsif Is_Entity_Name
(Param
)
238 and then Is_Entity_Name
(Ctrl_Arg
)
239 and then Entity
(Param
) = Entity
(Ctrl_Arg
)
243 -- Now we need to generate the Tag check
246 -- Generate code for tag equality check
248 -- Perhaps should have Checks.Apply_Tag_Equality_Check???
250 Insert_Action
(Ctrl_Arg
,
251 Make_Implicit_If_Statement
(Call_Node
,
255 Make_Selected_Component
(Loc
,
256 Prefix
=> New_Value
(Ctrl_Arg
),
259 (First_Tag_Component
(Typ
), Loc
)),
262 Make_Selected_Component
(Loc
,
264 Unchecked_Convert_To
(Typ
, New_Value
(Param
)),
267 (First_Tag_Component
(Typ
), Loc
))),
270 New_List
(New_Constraint_Error
(Loc
))));
276 end Apply_Tag_Checks
;
278 ------------------------
279 -- Building_Static_DT --
280 ------------------------
282 function Building_Static_DT
(Typ
: Entity_Id
) return Boolean is
283 Root_Typ
: Entity_Id
:= Root_Type
(Typ
);
286 -- Handle private types
288 if Present
(Full_View
(Root_Typ
)) then
289 Root_Typ
:= Full_View
(Root_Typ
);
292 return Static_Dispatch_Tables
293 and then Is_Library_Level_Tagged_Type
(Typ
)
294 and then VM_Target
= No_VM
296 -- If the type is derived from a CPP class we cannot statically
297 -- build the dispatch tables because we must inherit primitives
298 -- from the CPP side.
300 and then not Is_CPP_Class
(Root_Typ
);
301 end Building_Static_DT
;
303 ----------------------------------
304 -- Build_Static_Dispatch_Tables --
305 ----------------------------------
307 procedure Build_Static_Dispatch_Tables
(N
: Entity_Id
) is
308 Target_List
: List_Id
;
310 procedure Build_Dispatch_Tables
(List
: List_Id
);
311 -- Build the static dispatch table of tagged types found in the list of
312 -- declarations. The generated nodes are added at the end of Target_List
314 procedure Build_Package_Dispatch_Tables
(N
: Node_Id
);
315 -- Build static dispatch tables associated with package declaration N
317 ---------------------------
318 -- Build_Dispatch_Tables --
319 ---------------------------
321 procedure Build_Dispatch_Tables
(List
: List_Id
) is
326 while Present
(D
) loop
328 -- Handle nested packages and package bodies recursively. The
329 -- generated code is placed on the Target_List established for
330 -- the enclosing compilation unit.
332 if Nkind
(D
) = N_Package_Declaration
then
333 Build_Package_Dispatch_Tables
(D
);
335 elsif Nkind
(D
) = N_Package_Body
then
336 Build_Dispatch_Tables
(Declarations
(D
));
338 elsif Nkind
(D
) = N_Package_Body_Stub
339 and then Present
(Library_Unit
(D
))
341 Build_Dispatch_Tables
342 (Declarations
(Proper_Body
(Unit
(Library_Unit
(D
)))));
344 -- Handle full type declarations and derivations of library level
347 elsif Nkind_In
(D
, N_Full_Type_Declaration
,
348 N_Derived_Type_Definition
)
349 and then Is_Library_Level_Tagged_Type
(Defining_Entity
(D
))
350 and then Ekind
(Defining_Entity
(D
)) /= E_Record_Subtype
351 and then not Is_Private_Type
(Defining_Entity
(D
))
353 -- We do not generate dispatch tables for the internal types
354 -- created for a type extension with unknown discriminants
355 -- The needed information is shared with the source type,
356 -- See Expand_N_Record_Extension.
358 if Is_Underlying_Record_View
(Defining_Entity
(D
))
360 (not Comes_From_Source
(Defining_Entity
(D
))
362 Has_Unknown_Discriminants
(Etype
(Defining_Entity
(D
)))
364 not Comes_From_Source
365 (First_Subtype
(Defining_Entity
(D
))))
369 Insert_List_After_And_Analyze
(Last
(Target_List
),
370 Make_DT
(Defining_Entity
(D
)));
373 -- Handle private types of library level tagged types. We must
374 -- exchange the private and full-view to ensure the correct
375 -- expansion. If the full view is a synchronized type ignore
376 -- the type because the table will be built for the corresponding
377 -- record type, that has its own declaration.
379 elsif (Nkind
(D
) = N_Private_Type_Declaration
380 or else Nkind
(D
) = N_Private_Extension_Declaration
)
381 and then Present
(Full_View
(Defining_Entity
(D
)))
384 E1
: constant Entity_Id
:= Defining_Entity
(D
);
385 E2
: constant Entity_Id
:= Full_View
(E1
);
388 if Is_Library_Level_Tagged_Type
(E2
)
389 and then Ekind
(E2
) /= E_Record_Subtype
390 and then not Is_Concurrent_Type
(E2
)
392 Exchange_Declarations
(E1
);
393 Insert_List_After_And_Analyze
(Last
(Target_List
),
395 Exchange_Declarations
(E2
);
402 end Build_Dispatch_Tables
;
404 -----------------------------------
405 -- Build_Package_Dispatch_Tables --
406 -----------------------------------
408 procedure Build_Package_Dispatch_Tables
(N
: Node_Id
) is
409 Spec
: constant Node_Id
:= Specification
(N
);
410 Id
: constant Entity_Id
:= Defining_Entity
(N
);
411 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
412 Priv_Decls
: constant List_Id
:= Private_Declarations
(Spec
);
417 if Present
(Priv_Decls
) then
418 Build_Dispatch_Tables
(Vis_Decls
);
419 Build_Dispatch_Tables
(Priv_Decls
);
421 elsif Present
(Vis_Decls
) then
422 Build_Dispatch_Tables
(Vis_Decls
);
426 end Build_Package_Dispatch_Tables
;
428 -- Start of processing for Build_Static_Dispatch_Tables
431 if not Expander_Active
432 or else not Tagged_Type_Expansion
437 if Nkind
(N
) = N_Package_Declaration
then
439 Spec
: constant Node_Id
:= Specification
(N
);
440 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
441 Priv_Decls
: constant List_Id
:= Private_Declarations
(Spec
);
444 if Present
(Priv_Decls
)
445 and then Is_Non_Empty_List
(Priv_Decls
)
447 Target_List
:= Priv_Decls
;
449 elsif not Present
(Vis_Decls
) then
450 Target_List
:= New_List
;
451 Set_Private_Declarations
(Spec
, Target_List
);
453 Target_List
:= Vis_Decls
;
456 Build_Package_Dispatch_Tables
(N
);
459 else pragma Assert
(Nkind
(N
) = N_Package_Body
);
460 Target_List
:= Declarations
(N
);
461 Build_Dispatch_Tables
(Target_List
);
463 end Build_Static_Dispatch_Tables
;
465 ------------------------------
466 -- Convert_Tag_To_Interface --
467 ------------------------------
469 function Convert_Tag_To_Interface
471 Expr
: Node_Id
) return Node_Id
473 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
474 Anon_Type
: Entity_Id
;
478 pragma Assert
(Is_Class_Wide_Type
(Typ
)
479 and then Is_Interface
(Typ
)
481 ((Nkind
(Expr
) = N_Selected_Component
482 and then Is_Tag
(Entity
(Selector_Name
(Expr
))))
484 (Nkind
(Expr
) = N_Function_Call
485 and then RTE_Available
(RE_Displace
)
486 and then Entity
(Name
(Expr
)) = RTE
(RE_Displace
))));
488 Anon_Type
:= Create_Itype
(E_Anonymous_Access_Type
, Expr
);
489 Set_Directly_Designated_Type
(Anon_Type
, Typ
);
490 Set_Etype
(Anon_Type
, Anon_Type
);
491 Set_Can_Never_Be_Null
(Anon_Type
);
493 -- Decorate the size and alignment attributes of the anonymous access
494 -- type, as required by the back end.
496 Layout_Type
(Anon_Type
);
498 if Nkind
(Expr
) = N_Selected_Component
499 and then Is_Tag
(Entity
(Selector_Name
(Expr
)))
502 Make_Explicit_Dereference
(Loc
,
503 Unchecked_Convert_To
(Anon_Type
,
504 Make_Attribute_Reference
(Loc
,
506 Attribute_Name
=> Name_Address
)));
509 Make_Explicit_Dereference
(Loc
,
510 Unchecked_Convert_To
(Anon_Type
, Expr
));
514 end Convert_Tag_To_Interface
;
520 function CPP_Num_Prims
(Typ
: Entity_Id
) return Nat
is
522 Tag_Comp
: Entity_Id
;
525 if not Is_Tagged_Type
(Typ
)
526 or else not Is_CPP_Class
(Root_Type
(Typ
))
531 CPP_Typ
:= Enclosing_CPP_Parent
(Typ
);
532 Tag_Comp
:= First_Tag_Component
(CPP_Typ
);
534 -- If number of primitives already set in the tag component, use it
536 if Present
(Tag_Comp
)
537 and then DT_Entry_Count
(Tag_Comp
) /= No_Uint
539 return UI_To_Int
(DT_Entry_Count
(Tag_Comp
));
541 -- Otherwise, count the primitives of the enclosing CPP type
549 Elmt
:= First_Elmt
(Primitive_Operations
(CPP_Typ
));
550 while Present
(Elmt
) loop
561 ------------------------------
562 -- Default_Prim_Op_Position --
563 ------------------------------
565 function Default_Prim_Op_Position
(E
: Entity_Id
) return Uint
is
566 TSS_Name
: TSS_Name_Type
;
569 Get_Name_String
(Chars
(E
));
572 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
574 if Chars
(E
) = Name_uSize
then
577 elsif TSS_Name
= TSS_Stream_Read
then
580 elsif TSS_Name
= TSS_Stream_Write
then
583 elsif TSS_Name
= TSS_Stream_Input
then
586 elsif TSS_Name
= TSS_Stream_Output
then
589 elsif Chars
(E
) = Name_Op_Eq
then
592 elsif Chars
(E
) = Name_uAssign
then
595 elsif TSS_Name
= TSS_Deep_Adjust
then
598 elsif TSS_Name
= TSS_Deep_Finalize
then
601 -- In VM targets unconditionally allow obtaining the position associated
602 -- with predefined interface primitives since in these platforms any
603 -- tagged type has these primitives.
605 elsif Ada_Version
>= Ada_2005
or else not Tagged_Type_Expansion
then
606 if Chars
(E
) = Name_uDisp_Asynchronous_Select
then
609 elsif Chars
(E
) = Name_uDisp_Conditional_Select
then
612 elsif Chars
(E
) = Name_uDisp_Get_Prim_Op_Kind
then
615 elsif Chars
(E
) = Name_uDisp_Get_Task_Id
then
618 elsif Chars
(E
) = Name_uDisp_Requeue
then
621 elsif Chars
(E
) = Name_uDisp_Timed_Select
then
627 end Default_Prim_Op_Position
;
629 -----------------------------
630 -- Expand_Dispatching_Call --
631 -----------------------------
633 procedure Expand_Dispatching_Call
(Call_Node
: Node_Id
) is
634 Loc
: constant Source_Ptr
:= Sloc
(Call_Node
);
635 Call_Typ
: constant Entity_Id
:= Etype
(Call_Node
);
637 Ctrl_Arg
: constant Node_Id
:= Controlling_Argument
(Call_Node
);
638 Ctrl_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Ctrl_Arg
));
639 Param_List
: constant List_Id
:= Parameter_Associations
(Call_Node
);
644 New_Call_Name
: Node_Id
;
645 New_Params
: List_Id
:= No_List
;
648 Subp_Ptr_Typ
: Entity_Id
;
649 Subp_Typ
: Entity_Id
;
651 Eq_Prim_Op
: Entity_Id
:= Empty
;
652 Controlling_Tag
: Node_Id
;
654 function New_Value
(From
: Node_Id
) return Node_Id
;
655 -- From is the original Expression. New_Value is equivalent to a call
656 -- to Duplicate_Subexpr with an explicit dereference when From is an
663 function New_Value
(From
: Node_Id
) return Node_Id
is
664 Res
: constant Node_Id
:= Duplicate_Subexpr
(From
);
666 if Is_Access_Type
(Etype
(From
)) then
668 Make_Explicit_Dereference
(Sloc
(From
),
679 SCIL_Related_Node
: Node_Id
:= Call_Node
;
681 -- Start of processing for Expand_Dispatching_Call
684 if No_Run_Time_Mode
then
685 Error_Msg_CRT
("tagged types", Call_Node
);
689 -- Expand_Dispatching_Call is called directly from the semantics, so we
690 -- only proceed if the expander is active.
692 if not Expander_Active
694 -- And there is no need to expand the call if we are compiling under
695 -- restriction No_Dispatching_Calls; the semantic analyzer has
696 -- previously notified the violation of this restriction.
698 or else Restriction_Active
(No_Dispatching_Calls
)
700 -- No action needed if the dispatching call has been already expanded
702 or else Is_Expanded_Dispatching_Call
(Name
(Call_Node
))
707 -- Set subprogram. If this is an inherited operation that was
708 -- overridden, the body that is being called is its alias.
710 Subp
:= Entity
(Name
(Call_Node
));
712 if Present
(Alias
(Subp
))
713 and then Is_Inherited_Operation
(Subp
)
714 and then No
(DTC_Entity
(Subp
))
716 Subp
:= Alias
(Subp
);
719 -- Definition of the class-wide type and the tagged type
721 -- If the controlling argument is itself a tag rather than a tagged
722 -- object, then use the class-wide type associated with the subprogram's
723 -- controlling type. This case can occur when a call to an inherited
724 -- primitive has an actual that originated from a default parameter
725 -- given by a tag-indeterminate call and when there is no other
726 -- controlling argument providing the tag (AI-239 requires dispatching).
727 -- This capability of dispatching directly by tag is also needed by the
728 -- implementation of AI-260 (for the generic dispatching constructors).
730 if Ctrl_Typ
= RTE
(RE_Tag
)
731 or else (RTE_Available
(RE_Interface_Tag
)
732 and then Ctrl_Typ
= RTE
(RE_Interface_Tag
))
734 CW_Typ
:= Class_Wide_Type
(Find_Dispatching_Type
(Subp
));
736 -- Class_Wide_Type is applied to the expressions used to initialize
737 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
738 -- there are cases where the controlling type is resolved to a specific
739 -- type (such as for designated types of arguments such as CW'Access).
741 elsif Is_Access_Type
(Ctrl_Typ
) then
742 CW_Typ
:= Class_Wide_Type
(Designated_Type
(Ctrl_Typ
));
745 CW_Typ
:= Class_Wide_Type
(Ctrl_Typ
);
748 Typ
:= Find_Specific_Type
(CW_Typ
);
750 if not Is_Limited_Type
(Typ
) then
751 Eq_Prim_Op
:= Find_Prim_Op
(Typ
, Name_Op_Eq
);
754 -- Dispatching call to C++ primitive. Create a new parameter list
755 -- with no tag checks.
757 New_Params
:= New_List
;
759 if Is_CPP_Class
(Typ
) then
760 Param
:= First_Actual
(Call_Node
);
761 while Present
(Param
) loop
762 Append_To
(New_Params
, Relocate_Node
(Param
));
766 -- Dispatching call to Ada primitive
768 elsif Present
(Param_List
) then
769 Apply_Tag_Checks
(Call_Node
);
771 Param
:= First_Actual
(Call_Node
);
772 while Present
(Param
) loop
774 -- Cases in which we may have generated run-time checks. Note that
775 -- we strip any qualification from Param before comparing with the
776 -- already-stripped controlling argument.
778 if Unqualify
(Param
) = Ctrl_Arg
or else Subp
= Eq_Prim_Op
then
779 Append_To
(New_Params
,
780 Duplicate_Subexpr_Move_Checks
(Param
));
782 elsif Nkind
(Parent
(Param
)) /= N_Parameter_Association
783 or else not Is_Accessibility_Actual
(Parent
(Param
))
785 Append_To
(New_Params
, Relocate_Node
(Param
));
792 -- Generate the appropriate subprogram pointer type
794 if Etype
(Subp
) = Typ
then
797 Res_Typ
:= Etype
(Subp
);
800 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, Call_Node
);
801 Subp_Ptr_Typ
:= Create_Itype
(E_Access_Subprogram_Type
, Call_Node
);
802 Set_Etype
(Subp_Typ
, Res_Typ
);
803 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
804 Set_Convention
(Subp_Typ
, Convention
(Subp
));
806 -- Notify gigi that the designated type is a dispatching primitive
808 Set_Is_Dispatch_Table_Entity
(Subp_Typ
);
810 -- Create a new list of parameters which is a copy of the old formal
811 -- list including the creation of a new set of matching entities.
814 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
815 New_Formal
: Entity_Id
;
816 Extra
: Entity_Id
:= Empty
;
819 if Present
(Old_Formal
) then
820 New_Formal
:= New_Copy
(Old_Formal
);
821 Set_First_Entity
(Subp_Typ
, New_Formal
);
822 Param
:= First_Actual
(Call_Node
);
825 Set_Scope
(New_Formal
, Subp_Typ
);
827 -- Change all the controlling argument types to be class-wide
828 -- to avoid a recursion in dispatching.
830 if Is_Controlling_Formal
(New_Formal
) then
831 Set_Etype
(New_Formal
, Etype
(Param
));
834 -- If the type of the formal is an itype, there was code here
835 -- introduced in 1998 in revision 1.46, to create a new itype
836 -- by copy. This seems useless, and in fact leads to semantic
837 -- errors when the itype is the completion of a type derived
838 -- from a private type.
841 Next_Formal
(Old_Formal
);
842 exit when No
(Old_Formal
);
844 Set_Next_Entity
(New_Formal
, New_Copy
(Old_Formal
));
845 Next_Entity
(New_Formal
);
849 Set_Next_Entity
(New_Formal
, Empty
);
850 Set_Last_Entity
(Subp_Typ
, Extra
);
853 -- Now that the explicit formals have been duplicated, any extra
854 -- formals needed by the subprogram must be created.
856 if Present
(Extra
) then
857 Set_Extra_Formal
(Extra
, Empty
);
860 Create_Extra_Formals
(Subp_Typ
);
863 -- Complete description of pointer type, including size information, as
864 -- must be done with itypes to prevent order-of-elaboration anomalies
867 Set_Etype
(Subp_Ptr_Typ
, Subp_Ptr_Typ
);
868 Set_Directly_Designated_Type
(Subp_Ptr_Typ
, Subp_Typ
);
869 Set_Convention
(Subp_Ptr_Typ
, Convention
(Subp_Typ
));
870 Layout_Type
(Subp_Ptr_Typ
);
872 -- If the controlling argument is a value of type Ada.Tag or an abstract
873 -- interface class-wide type then use it directly. Otherwise, the tag
874 -- must be extracted from the controlling object.
876 if Ctrl_Typ
= RTE
(RE_Tag
)
877 or else (RTE_Available
(RE_Interface_Tag
)
878 and then Ctrl_Typ
= RTE
(RE_Interface_Tag
))
880 Controlling_Tag
:= Duplicate_Subexpr
(Ctrl_Arg
);
882 -- Extract the tag from an unchecked type conversion. Done to avoid
883 -- the expansion of additional code just to obtain the value of such
884 -- tag because the current management of interface type conversions
885 -- generates in some cases this unchecked type conversion with the
886 -- tag of the object (see Expand_Interface_Conversion).
888 elsif Nkind
(Ctrl_Arg
) = N_Unchecked_Type_Conversion
890 (Etype
(Expression
(Ctrl_Arg
)) = RTE
(RE_Tag
)
892 (RTE_Available
(RE_Interface_Tag
)
894 Etype
(Expression
(Ctrl_Arg
)) = RTE
(RE_Interface_Tag
)))
896 Controlling_Tag
:= Duplicate_Subexpr
(Expression
(Ctrl_Arg
));
898 -- Ada 2005 (AI-251): Abstract interface class-wide type
900 elsif Is_Interface
(Ctrl_Typ
)
901 and then Is_Class_Wide_Type
(Ctrl_Typ
)
903 Controlling_Tag
:= Duplicate_Subexpr
(Ctrl_Arg
);
907 Make_Selected_Component
(Loc
,
908 Prefix
=> Duplicate_Subexpr_Move_Checks
(Ctrl_Arg
),
909 Selector_Name
=> New_Occurrence_Of
(DTC_Entity
(Subp
), Loc
));
912 -- Handle dispatching calls to predefined primitives
914 if Is_Predefined_Dispatching_Operation
(Subp
)
915 or else Is_Predefined_Dispatching_Alias
(Subp
)
917 Build_Get_Predefined_Prim_Op_Address
(Loc
,
918 Tag_Node
=> Controlling_Tag
,
919 Position
=> DT_Position
(Subp
),
920 New_Node
=> New_Node
);
922 -- Handle dispatching calls to user-defined primitives
925 Build_Get_Prim_Op_Address
(Loc
,
926 Typ
=> Underlying_Type
(Find_Dispatching_Type
(Subp
)),
927 Tag_Node
=> Controlling_Tag
,
928 Position
=> DT_Position
(Subp
),
929 New_Node
=> New_Node
);
933 Unchecked_Convert_To
(Subp_Ptr_Typ
, New_Node
);
935 -- Generate the SCIL node for this dispatching call. Done now because
936 -- attribute SCIL_Controlling_Tag must be set after the new call name
937 -- is built to reference the nodes that will see the SCIL backend
938 -- (because Build_Get_Prim_Op_Address generates an unchecked type
939 -- conversion which relocates the controlling tag node).
941 if Generate_SCIL
then
942 SCIL_Node
:= Make_SCIL_Dispatching_Call
(Sloc
(Call_Node
));
943 Set_SCIL_Entity
(SCIL_Node
, Typ
);
944 Set_SCIL_Target_Prim
(SCIL_Node
, Subp
);
946 -- Common case: the controlling tag is the tag of an object
947 -- (for example, obj.tag)
949 if Nkind
(Controlling_Tag
) = N_Selected_Component
then
950 Set_SCIL_Controlling_Tag
(SCIL_Node
, Controlling_Tag
);
952 -- Handle renaming of selected component
954 elsif Nkind
(Controlling_Tag
) = N_Identifier
955 and then Nkind
(Parent
(Entity
(Controlling_Tag
))) =
956 N_Object_Renaming_Declaration
957 and then Nkind
(Name
(Parent
(Entity
(Controlling_Tag
)))) =
960 Set_SCIL_Controlling_Tag
(SCIL_Node
,
961 Name
(Parent
(Entity
(Controlling_Tag
))));
963 -- If the controlling tag is an identifier, the SCIL node references
964 -- the corresponding object or parameter declaration
966 elsif Nkind
(Controlling_Tag
) = N_Identifier
967 and then Nkind_In
(Parent
(Entity
(Controlling_Tag
)),
968 N_Object_Declaration
,
969 N_Parameter_Specification
)
971 Set_SCIL_Controlling_Tag
(SCIL_Node
,
972 Parent
(Entity
(Controlling_Tag
)));
974 -- If the controlling tag is a dereference, the SCIL node references
975 -- the corresponding object or parameter declaration
977 elsif Nkind
(Controlling_Tag
) = N_Explicit_Dereference
978 and then Nkind
(Prefix
(Controlling_Tag
)) = N_Identifier
979 and then Nkind_In
(Parent
(Entity
(Prefix
(Controlling_Tag
))),
980 N_Object_Declaration
,
981 N_Parameter_Specification
)
983 Set_SCIL_Controlling_Tag
(SCIL_Node
,
984 Parent
(Entity
(Prefix
(Controlling_Tag
))));
986 -- For a direct reference of the tag of the type the SCIL node
987 -- references the internal object declaration containing the tag
990 elsif Nkind
(Controlling_Tag
) = N_Attribute_Reference
991 and then Attribute_Name
(Controlling_Tag
) = Name_Tag
993 Set_SCIL_Controlling_Tag
(SCIL_Node
,
997 (Access_Disp_Table
(Entity
(Prefix
(Controlling_Tag
)))))));
999 -- Interfaces are not supported. For now we leave the SCIL node
1000 -- decorated with the Controlling_Tag. More work needed here???
1002 elsif Is_Interface
(Etype
(Controlling_Tag
)) then
1003 Set_SCIL_Controlling_Tag
(SCIL_Node
, Controlling_Tag
);
1006 pragma Assert
(False);
1011 if Nkind
(Call_Node
) = N_Function_Call
then
1013 Make_Function_Call
(Loc
,
1014 Name
=> New_Call_Name
,
1015 Parameter_Associations
=> New_Params
);
1017 -- If this is a dispatching "=", we must first compare the tags so
1018 -- we generate: x.tag = y.tag and then x = y
1020 if Subp
= Eq_Prim_Op
then
1021 Param
:= First_Actual
(Call_Node
);
1027 Make_Selected_Component
(Loc
,
1028 Prefix
=> New_Value
(Param
),
1030 New_Occurrence_Of
(First_Tag_Component
(Typ
),
1034 Make_Selected_Component
(Loc
,
1036 Unchecked_Convert_To
(Typ
,
1037 New_Value
(Next_Actual
(Param
))),
1040 (First_Tag_Component
(Typ
), Loc
))),
1041 Right_Opnd
=> New_Call
);
1043 SCIL_Related_Node
:= Right_Opnd
(New_Call
);
1048 Make_Procedure_Call_Statement
(Loc
,
1049 Name
=> New_Call_Name
,
1050 Parameter_Associations
=> New_Params
);
1053 -- Register the dispatching call in the call graph nodes table
1055 Register_CG_Node
(Call_Node
);
1057 Rewrite
(Call_Node
, New_Call
);
1059 -- Associate the SCIL node of this dispatching call
1061 if Generate_SCIL
then
1062 Set_SCIL_Node
(SCIL_Related_Node
, SCIL_Node
);
1065 -- Suppress all checks during the analysis of the expanded code to avoid
1066 -- the generation of spurious warnings under ZFP run-time.
1068 Analyze_And_Resolve
(Call_Node
, Call_Typ
, Suppress
=> All_Checks
);
1069 end Expand_Dispatching_Call
;
1071 ---------------------------------
1072 -- Expand_Interface_Conversion --
1073 ---------------------------------
1075 procedure Expand_Interface_Conversion
(N
: Node_Id
) is
1076 function Underlying_Record_Type
(Typ
: Entity_Id
) return Entity_Id
;
1077 -- Return the underlying record type of Typ.
1079 ----------------------------
1080 -- Underlying_Record_Type --
1081 ----------------------------
1083 function Underlying_Record_Type
(Typ
: Entity_Id
) return Entity_Id
is
1084 E
: Entity_Id
:= Typ
;
1087 -- Handle access to class-wide interface types
1089 if Is_Access_Type
(E
) then
1090 E
:= Etype
(Directly_Designated_Type
(E
));
1093 -- Handle class-wide types. This conversion can appear explicitly in
1094 -- the source code. Example: I'Class (Obj)
1096 if Is_Class_Wide_Type
(E
) then
1100 -- If the target type is a tagged synchronized type, the dispatch
1101 -- table info is in the corresponding record type.
1103 if Is_Concurrent_Type
(E
) then
1104 E
:= Corresponding_Record_Type
(E
);
1107 -- Handle private types
1109 E
:= Underlying_Type
(E
);
1113 return Base_Type
(E
);
1114 end Underlying_Record_Type
;
1118 Loc
: constant Source_Ptr
:= Sloc
(N
);
1119 Etyp
: constant Entity_Id
:= Etype
(N
);
1120 Operand
: constant Node_Id
:= Expression
(N
);
1121 Operand_Typ
: Entity_Id
:= Etype
(Operand
);
1123 Iface_Typ
: constant Entity_Id
:= Underlying_Record_Type
(Etype
(N
));
1124 Iface_Tag
: Entity_Id
;
1125 Is_Static
: Boolean;
1127 -- Start of processing for Expand_Interface_Conversion
1130 -- Freeze the entity associated with the target interface to have
1131 -- available the attribute Access_Disp_Table.
1133 Freeze_Before
(N
, Iface_Typ
);
1135 -- Ada 2005 (AI-345): Handle synchronized interface type derivations
1137 if Is_Concurrent_Type
(Operand_Typ
) then
1138 Operand_Typ
:= Base_Type
(Corresponding_Record_Type
(Operand_Typ
));
1141 -- No displacement of the pointer to the object needed when the type of
1142 -- the operand is not an interface type and the interface is one of
1143 -- its parent types (since they share the primary dispatch table).
1146 Opnd
: Entity_Id
:= Operand_Typ
;
1149 if Is_Access_Type
(Opnd
) then
1150 Opnd
:= Designated_Type
(Opnd
);
1153 if not Is_Interface
(Opnd
)
1154 and then Is_Ancestor
(Iface_Typ
, Opnd
, Use_Full_View
=> True)
1160 -- Evaluate if we can statically displace the pointer to the object
1163 Opnd_Typ
: constant Node_Id
:= Underlying_Record_Type
(Operand_Typ
);
1167 not Is_Interface
(Opnd_Typ
)
1168 and then Interface_Present_In_Ancestor
1171 and then (Etype
(Opnd_Typ
) = Opnd_Typ
1173 Is_Variable_Size_Record
(Etype
(Opnd_Typ
)));
1176 if not Tagged_Type_Expansion
then
1177 if VM_Target
/= No_VM
then
1178 if Is_Access_Type
(Operand_Typ
) then
1179 Operand_Typ
:= Designated_Type
(Operand_Typ
);
1182 if Is_Class_Wide_Type
(Operand_Typ
) then
1183 Operand_Typ
:= Root_Type
(Operand_Typ
);
1186 if not Is_Static
and then Operand_Typ
/= Iface_Typ
then
1188 Make_Procedure_Call_Statement
(Loc
,
1189 Name
=> New_Occurrence_Of
1190 (RTE
(RE_Check_Interface_Conversion
), Loc
),
1191 Parameter_Associations
=> New_List
(
1192 Make_Attribute_Reference
(Loc
,
1193 Prefix
=> Duplicate_Subexpr
(Expression
(N
)),
1194 Attribute_Name
=> Name_Tag
),
1195 Make_Attribute_Reference
(Loc
,
1196 Prefix
=> New_Occurrence_Of
(Iface_Typ
, Loc
),
1197 Attribute_Name
=> Name_Tag
))));
1200 -- Just do a conversion ???
1202 Rewrite
(N
, Unchecked_Convert_To
(Etype
(N
), N
));
1208 -- A static conversion to an interface type that is not classwide is
1209 -- curious but legal if the interface operation is a null procedure.
1210 -- If the operation is abstract it will be rejected later.
1213 and then Is_Interface
(Etype
(N
))
1214 and then not Is_Class_Wide_Type
(Etype
(N
))
1215 and then Comes_From_Source
(N
)
1217 Rewrite
(N
, Unchecked_Convert_To
(Etype
(N
), N
));
1222 if not Is_Static
then
1224 -- Give error if configurable run time and Displace not available
1226 if not RTE_Available
(RE_Displace
) then
1227 Error_Msg_CRT
("dynamic interface conversion", N
);
1231 -- Handle conversion of access-to-class-wide interface types. Target
1232 -- can be an access to an object or an access to another class-wide
1233 -- interface (see -1- and -2- in the following example):
1235 -- type Iface1_Ref is access all Iface1'Class;
1236 -- type Iface2_Ref is access all Iface1'Class;
1238 -- Acc1 : Iface1_Ref := new ...
1239 -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1
1240 -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
1242 if Is_Access_Type
(Operand_Typ
) then
1244 Unchecked_Convert_To
(Etype
(N
),
1245 Make_Function_Call
(Loc
,
1246 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
1247 Parameter_Associations
=> New_List
(
1249 Unchecked_Convert_To
(RTE
(RE_Address
),
1250 Relocate_Node
(Expression
(N
))),
1253 (Node
(First_Elmt
(Access_Disp_Table
(Iface_Typ
))),
1261 Make_Function_Call
(Loc
,
1262 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
1263 Parameter_Associations
=> New_List
(
1264 Make_Attribute_Reference
(Loc
,
1265 Prefix
=> Relocate_Node
(Expression
(N
)),
1266 Attribute_Name
=> Name_Address
),
1269 (Node
(First_Elmt
(Access_Disp_Table
(Iface_Typ
))),
1274 -- If target is a class-wide interface, change the type of the data
1275 -- returned by IW_Convert to indicate this is a dispatching call.
1278 New_Itype
: Entity_Id
;
1281 New_Itype
:= Create_Itype
(E_Anonymous_Access_Type
, N
);
1282 Set_Etype
(New_Itype
, New_Itype
);
1283 Set_Directly_Designated_Type
(New_Itype
, Etyp
);
1286 Make_Explicit_Dereference
(Loc
,
1288 Unchecked_Convert_To
(New_Itype
, Relocate_Node
(N
))));
1290 Freeze_Itype
(New_Itype
, N
);
1296 Iface_Tag
:= Find_Interface_Tag
(Operand_Typ
, Iface_Typ
);
1297 pragma Assert
(Iface_Tag
/= Empty
);
1299 -- Keep separate access types to interfaces because one internal
1300 -- function is used to handle the null value (see following comments)
1302 if not Is_Access_Type
(Etype
(N
)) then
1304 -- Statically displace the pointer to the object to reference the
1305 -- component containing the secondary dispatch table.
1308 Convert_Tag_To_Interface
(Class_Wide_Type
(Iface_Typ
),
1309 Make_Selected_Component
(Loc
,
1310 Prefix
=> Relocate_Node
(Expression
(N
)),
1311 Selector_Name
=> New_Occurrence_Of
(Iface_Tag
, Loc
))));
1314 -- Build internal function to handle the case in which the actual is
1315 -- null. If the actual is null returns null because no displacement
1316 -- is required; otherwise performs a type conversion that will be
1317 -- expanded in the code that returns the value of the displaced
1320 -- function Func (O : Address) return Iface_Typ is
1321 -- type Op_Typ is access all Operand_Typ;
1322 -- Aux : Op_Typ := To_Op_Typ (O);
1324 -- if O = Null_Address then
1327 -- return Iface_Typ!(Aux.Iface_Tag'Address);
1332 Desig_Typ
: Entity_Id
;
1334 New_Typ_Decl
: Node_Id
;
1338 Desig_Typ
:= Etype
(Expression
(N
));
1340 if Is_Access_Type
(Desig_Typ
) then
1342 Available_View
(Directly_Designated_Type
(Desig_Typ
));
1345 if Is_Concurrent_Type
(Desig_Typ
) then
1346 Desig_Typ
:= Base_Type
(Corresponding_Record_Type
(Desig_Typ
));
1350 Make_Full_Type_Declaration
(Loc
,
1351 Defining_Identifier
=> Make_Temporary
(Loc
, 'T'),
1353 Make_Access_To_Object_Definition
(Loc
,
1354 All_Present
=> True,
1355 Null_Exclusion_Present
=> False,
1356 Constant_Present
=> False,
1357 Subtype_Indication
=>
1358 New_Occurrence_Of
(Desig_Typ
, Loc
)));
1361 Make_Simple_Return_Statement
(Loc
,
1362 Unchecked_Convert_To
(Etype
(N
),
1363 Make_Attribute_Reference
(Loc
,
1365 Make_Selected_Component
(Loc
,
1367 Unchecked_Convert_To
1368 (Defining_Identifier
(New_Typ_Decl
),
1369 Make_Identifier
(Loc
, Name_uO
)),
1371 New_Occurrence_Of
(Iface_Tag
, Loc
)),
1372 Attribute_Name
=> Name_Address
))));
1374 -- If the type is null-excluding, no need for the null branch.
1375 -- Otherwise we need to check for it and return null.
1377 if not Can_Never_Be_Null
(Etype
(N
)) then
1379 Make_If_Statement
(Loc
,
1382 Left_Opnd
=> Make_Identifier
(Loc
, Name_uO
),
1383 Right_Opnd
=> New_Occurrence_Of
1384 (RTE
(RE_Null_Address
), Loc
)),
1386 Then_Statements
=> New_List
(
1387 Make_Simple_Return_Statement
(Loc
, Make_Null
(Loc
))),
1388 Else_Statements
=> Stats
));
1391 Fent
:= Make_Temporary
(Loc
, 'F');
1393 Make_Subprogram_Body
(Loc
,
1395 Make_Function_Specification
(Loc
,
1396 Defining_Unit_Name
=> Fent
,
1398 Parameter_Specifications
=> New_List
(
1399 Make_Parameter_Specification
(Loc
,
1400 Defining_Identifier
=>
1401 Make_Defining_Identifier
(Loc
, Name_uO
),
1403 New_Occurrence_Of
(RTE
(RE_Address
), Loc
))),
1405 Result_Definition
=>
1406 New_Occurrence_Of
(Etype
(N
), Loc
)),
1408 Declarations
=> New_List
(New_Typ_Decl
),
1410 Handled_Statement_Sequence
=>
1411 Make_Handled_Sequence_Of_Statements
(Loc
, Stats
));
1413 -- Place function body before the expression containing the
1414 -- conversion. We suppress all checks because the body of the
1415 -- internally generated function already takes care of the case
1416 -- in which the actual is null; therefore there is no need to
1417 -- double check that the pointer is not null when the program
1418 -- executes the alternative that performs the type conversion).
1420 Insert_Action
(N
, Func
, Suppress
=> All_Checks
);
1422 if Is_Access_Type
(Etype
(Expression
(N
))) then
1424 Apply_Accessibility_Check
1425 (N
=> Expression
(N
),
1429 -- Generate: Func (Address!(Expression))
1432 Make_Function_Call
(Loc
,
1433 Name
=> New_Occurrence_Of
(Fent
, Loc
),
1434 Parameter_Associations
=> New_List
(
1435 Unchecked_Convert_To
(RTE
(RE_Address
),
1436 Relocate_Node
(Expression
(N
))))));
1439 -- Generate: Func (Operand_Typ!(Expression)'Address)
1442 Make_Function_Call
(Loc
,
1443 Name
=> New_Occurrence_Of
(Fent
, Loc
),
1444 Parameter_Associations
=> New_List
(
1445 Make_Attribute_Reference
(Loc
,
1446 Prefix
=> Unchecked_Convert_To
(Operand_Typ
,
1447 Relocate_Node
(Expression
(N
))),
1448 Attribute_Name
=> Name_Address
))));
1454 end Expand_Interface_Conversion
;
1456 ------------------------------
1457 -- Expand_Interface_Actuals --
1458 ------------------------------
1460 procedure Expand_Interface_Actuals
(Call_Node
: Node_Id
) is
1462 Actual_Dup
: Node_Id
;
1463 Actual_Typ
: Entity_Id
;
1465 Conversion
: Node_Id
;
1467 Formal_Typ
: Entity_Id
;
1469 Formal_DDT
: Entity_Id
;
1470 Actual_DDT
: Entity_Id
;
1473 -- This subprogram is called directly from the semantics, so we need a
1474 -- check to see whether expansion is active before proceeding.
1476 if not Expander_Active
then
1480 -- Call using access to subprogram with explicit dereference
1482 if Nkind
(Name
(Call_Node
)) = N_Explicit_Dereference
then
1483 Subp
:= Etype
(Name
(Call_Node
));
1485 -- Call using selected component
1487 elsif Nkind
(Name
(Call_Node
)) = N_Selected_Component
then
1488 Subp
:= Entity
(Selector_Name
(Name
(Call_Node
)));
1490 -- Call using direct name
1493 Subp
:= Entity
(Name
(Call_Node
));
1496 -- Ada 2005 (AI-251): Look for interface type formals to force "this"
1499 Formal
:= First_Formal
(Subp
);
1500 Actual
:= First_Actual
(Call_Node
);
1501 while Present
(Formal
) loop
1502 Formal_Typ
:= Etype
(Formal
);
1504 if Ekind
(Formal_Typ
) = E_Record_Type_With_Private
then
1505 Formal_Typ
:= Full_View
(Formal_Typ
);
1508 if Is_Access_Type
(Formal_Typ
) then
1509 Formal_DDT
:= Directly_Designated_Type
(Formal_Typ
);
1512 Actual_Typ
:= Etype
(Actual
);
1514 if Is_Access_Type
(Actual_Typ
) then
1515 Actual_DDT
:= Directly_Designated_Type
(Actual_Typ
);
1518 if Is_Interface
(Formal_Typ
)
1519 and then Is_Class_Wide_Type
(Formal_Typ
)
1521 -- No need to displace the pointer if the type of the actual
1522 -- coincides with the type of the formal.
1524 if Actual_Typ
= Formal_Typ
then
1527 -- No need to displace the pointer if the interface type is a
1528 -- parent of the type of the actual because in this case the
1529 -- interface primitives are located in the primary dispatch table.
1531 elsif Is_Ancestor
(Formal_Typ
, Actual_Typ
,
1532 Use_Full_View
=> True)
1536 -- Implicit conversion to the class-wide formal type to force the
1537 -- displacement of the pointer.
1540 -- Normally, expansion of actuals for calls to build-in-place
1541 -- functions happens as part of Expand_Actuals, but in this
1542 -- case the call will be wrapped in a conversion and soon after
1543 -- expanded further to handle the displacement for a class-wide
1544 -- interface conversion, so if this is a BIP call then we need
1545 -- to handle it now.
1547 if Ada_Version
>= Ada_2005
1548 and then Is_Build_In_Place_Function_Call
(Actual
)
1550 Make_Build_In_Place_Call_In_Anonymous_Context
(Actual
);
1553 Conversion
:= Convert_To
(Formal_Typ
, Relocate_Node
(Actual
));
1554 Rewrite
(Actual
, Conversion
);
1555 Analyze_And_Resolve
(Actual
, Formal_Typ
);
1558 -- Access to class-wide interface type
1560 elsif Is_Access_Type
(Formal_Typ
)
1561 and then Is_Interface
(Formal_DDT
)
1562 and then Is_Class_Wide_Type
(Formal_DDT
)
1563 and then Interface_Present_In_Ancestor
1565 Iface
=> Etype
(Formal_DDT
))
1567 -- Handle attributes 'Access and 'Unchecked_Access
1569 if Nkind
(Actual
) = N_Attribute_Reference
1571 (Attribute_Name
(Actual
) = Name_Access
1572 or else Attribute_Name
(Actual
) = Name_Unchecked_Access
)
1574 -- This case must have been handled by the analysis and
1575 -- expansion of 'Access. The only exception is when types
1576 -- match and no further expansion is required.
1578 pragma Assert
(Base_Type
(Etype
(Prefix
(Actual
)))
1579 = Base_Type
(Formal_DDT
));
1582 -- No need to displace the pointer if the type of the actual
1583 -- coincides with the type of the formal.
1585 elsif Actual_DDT
= Formal_DDT
then
1588 -- No need to displace the pointer if the interface type is
1589 -- a parent of the type of the actual because in this case the
1590 -- interface primitives are located in the primary dispatch table.
1592 elsif Is_Ancestor
(Formal_DDT
, Actual_DDT
,
1593 Use_Full_View
=> True)
1598 Actual_Dup
:= Relocate_Node
(Actual
);
1600 if From_Limited_With
(Actual_Typ
) then
1602 -- If the type of the actual parameter comes from a
1603 -- limited with-clause and the non-limited view is already
1604 -- available, we replace the anonymous access type by
1605 -- a duplicate declaration whose designated type is the
1606 -- non-limited view.
1608 if Has_Non_Limited_View
(Actual_DDT
) then
1609 Anon
:= New_Copy
(Actual_Typ
);
1611 if Is_Itype
(Anon
) then
1612 Set_Scope
(Anon
, Current_Scope
);
1615 Set_Directly_Designated_Type
1616 (Anon
, Non_Limited_View
(Actual_DDT
));
1617 Set_Etype
(Actual_Dup
, Anon
);
1621 Conversion
:= Convert_To
(Formal_Typ
, Actual_Dup
);
1622 Rewrite
(Actual
, Conversion
);
1623 Analyze_And_Resolve
(Actual
, Formal_Typ
);
1627 Next_Actual
(Actual
);
1628 Next_Formal
(Formal
);
1630 end Expand_Interface_Actuals
;
1632 ----------------------------
1633 -- Expand_Interface_Thunk --
1634 ----------------------------
1636 procedure Expand_Interface_Thunk
1638 Thunk_Id
: out Entity_Id
;
1639 Thunk_Code
: out Node_Id
)
1641 Loc
: constant Source_Ptr
:= Sloc
(Prim
);
1642 Actuals
: constant List_Id
:= New_List
;
1643 Decl
: constant List_Id
:= New_List
;
1644 Formals
: constant List_Id
:= New_List
;
1645 Target
: constant Entity_Id
:= Ultimate_Alias
(Prim
);
1652 Iface_Formal
: Node_Id
;
1654 Offset_To_Top
: Node_Id
;
1655 Target_Formal
: Entity_Id
;
1659 Thunk_Code
:= Empty
;
1661 -- No thunk needed if the primitive has been eliminated
1663 if Is_Eliminated
(Ultimate_Alias
(Prim
)) then
1666 -- In case of primitives that are functions without formals and a
1667 -- controlling result there is no need to build the thunk.
1669 elsif not Present
(First_Formal
(Target
)) then
1670 pragma Assert
(Ekind
(Target
) = E_Function
1671 and then Has_Controlling_Result
(Target
));
1675 -- Duplicate the formals of the Target primitive. In the thunk, the type
1676 -- of the controlling formal is the covered interface type (instead of
1677 -- the target tagged type). Done to avoid problems with discriminated
1678 -- tagged types because, if the controlling type has discriminants with
1679 -- default values, then the type conversions done inside the body of
1680 -- the thunk (after the displacement of the pointer to the base of the
1681 -- actual object) generate code that modify its contents.
1683 -- Note: This special management is not done for predefined primitives
1686 if not Is_Predefined_Dispatching_Operation
(Prim
) then
1687 Iface_Formal
:= First_Formal
(Interface_Alias
(Prim
));
1690 Formal
:= First_Formal
(Target
);
1691 while Present
(Formal
) loop
1692 Ftyp
:= Etype
(Formal
);
1694 -- Use the interface type as the type of the controlling formal (see
1697 if not Is_Controlling_Formal
(Formal
)
1698 or else Is_Predefined_Dispatching_Operation
(Prim
)
1700 Ftyp
:= Etype
(Formal
);
1701 Expr
:= New_Copy_Tree
(Expression
(Parent
(Formal
)));
1703 Ftyp
:= Etype
(Iface_Formal
);
1708 Make_Parameter_Specification
(Loc
,
1709 Defining_Identifier
=>
1710 Make_Defining_Identifier
(Sloc
(Formal
),
1711 Chars
=> Chars
(Formal
)),
1712 In_Present
=> In_Present
(Parent
(Formal
)),
1713 Out_Present
=> Out_Present
(Parent
(Formal
)),
1714 Parameter_Type
=> New_Occurrence_Of
(Ftyp
, Loc
),
1715 Expression
=> Expr
));
1717 if not Is_Predefined_Dispatching_Operation
(Prim
) then
1718 Next_Formal
(Iface_Formal
);
1721 Next_Formal
(Formal
);
1724 Target_Formal
:= First_Formal
(Target
);
1725 Formal
:= First
(Formals
);
1726 while Present
(Formal
) loop
1728 -- If the parent is a constrained discriminated type, then the
1729 -- primitive operation will have been defined on a first subtype.
1730 -- For proper matching with controlling type, use base type.
1732 if Ekind
(Target_Formal
) = E_In_Parameter
1733 and then Ekind
(Etype
(Target_Formal
)) = E_Anonymous_Access_Type
1736 Base_Type
(Directly_Designated_Type
(Etype
(Target_Formal
)));
1738 Ftyp
:= Base_Type
(Etype
(Target_Formal
));
1741 -- For concurrent types, the relevant information is found in the
1742 -- Corresponding_Record_Type, rather than the type entity itself.
1744 if Is_Concurrent_Type
(Ftyp
) then
1745 Ftyp
:= Corresponding_Record_Type
(Ftyp
);
1748 if Ekind
(Target_Formal
) = E_In_Parameter
1749 and then Ekind
(Etype
(Target_Formal
)) = E_Anonymous_Access_Type
1750 and then Is_Controlling_Formal
(Target_Formal
)
1753 -- type T is access all <<type of the target formal>>
1754 -- S : Storage_Offset := Storage_Offset!(Formal)
1755 -- - Offset_To_Top (address!(Formal))
1758 Make_Full_Type_Declaration
(Loc
,
1759 Defining_Identifier
=> Make_Temporary
(Loc
, 'T'),
1761 Make_Access_To_Object_Definition
(Loc
,
1762 All_Present
=> True,
1763 Null_Exclusion_Present
=> False,
1764 Constant_Present
=> False,
1765 Subtype_Indication
=>
1766 New_Occurrence_Of
(Ftyp
, Loc
)));
1769 Unchecked_Convert_To
(RTE
(RE_Address
),
1770 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
1772 if not RTE_Available
(RE_Offset_To_Top
) then
1774 Build_Offset_To_Top
(Loc
, New_Arg
);
1777 Make_Function_Call
(Loc
,
1778 Name
=> New_Occurrence_Of
(RTE
(RE_Offset_To_Top
), Loc
),
1779 Parameter_Associations
=> New_List
(New_Arg
));
1783 Make_Object_Declaration
(Loc
,
1784 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
1785 Constant_Present
=> True,
1786 Object_Definition
=>
1787 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
1789 Make_Op_Subtract
(Loc
,
1791 Unchecked_Convert_To
1792 (RTE
(RE_Storage_Offset
),
1794 (Defining_Identifier
(Formal
), Loc
)),
1798 Append_To
(Decl
, Decl_2
);
1799 Append_To
(Decl
, Decl_1
);
1801 -- Reference the new actual. Generate:
1805 Unchecked_Convert_To
1806 (Defining_Identifier
(Decl_2
),
1807 New_Occurrence_Of
(Defining_Identifier
(Decl_1
), Loc
)));
1809 elsif Is_Controlling_Formal
(Target_Formal
) then
1812 -- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
1813 -- - Offset_To_Top (Formal'Address)
1814 -- S2 : Addr_Ptr := Addr_Ptr!(S1)
1817 Make_Attribute_Reference
(Loc
,
1819 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
),
1823 if not RTE_Available
(RE_Offset_To_Top
) then
1825 Build_Offset_To_Top
(Loc
, New_Arg
);
1828 Make_Function_Call
(Loc
,
1829 Name
=> New_Occurrence_Of
(RTE
(RE_Offset_To_Top
), Loc
),
1830 Parameter_Associations
=> New_List
(New_Arg
));
1834 Make_Object_Declaration
(Loc
,
1835 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
1836 Constant_Present
=> True,
1837 Object_Definition
=>
1838 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
1840 Make_Op_Subtract
(Loc
,
1842 Unchecked_Convert_To
1843 (RTE
(RE_Storage_Offset
),
1844 Make_Attribute_Reference
(Loc
,
1847 (Defining_Identifier
(Formal
), Loc
),
1848 Attribute_Name
=> Name_Address
)),
1853 Make_Object_Declaration
(Loc
,
1854 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
1855 Constant_Present
=> True,
1856 Object_Definition
=>
1857 New_Occurrence_Of
(RTE
(RE_Addr_Ptr
), Loc
),
1859 Unchecked_Convert_To
1861 New_Occurrence_Of
(Defining_Identifier
(Decl_1
), Loc
)));
1863 Append_To
(Decl
, Decl_1
);
1864 Append_To
(Decl
, Decl_2
);
1866 -- Reference the new actual, generate:
1867 -- Target_Formal (S2.all)
1870 Unchecked_Convert_To
(Ftyp
,
1871 Make_Explicit_Dereference
(Loc
,
1872 New_Occurrence_Of
(Defining_Identifier
(Decl_2
), Loc
))));
1874 -- Ensure proper matching of access types. Required to avoid
1875 -- reporting spurious errors.
1877 elsif Is_Access_Type
(Etype
(Target_Formal
)) then
1879 Unchecked_Convert_To
(Base_Type
(Etype
(Target_Formal
)),
1880 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
)));
1882 -- No special management required for this actual
1886 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
1889 Next_Formal
(Target_Formal
);
1893 Thunk_Id
:= Make_Temporary
(Loc
, 'T');
1894 Set_Ekind
(Thunk_Id
, Ekind
(Prim
));
1895 Set_Is_Thunk
(Thunk_Id
);
1896 Set_Convention
(Thunk_Id
, Convention
(Prim
));
1897 Set_Thunk_Entity
(Thunk_Id
, Target
);
1901 if Ekind
(Target
) = E_Procedure
then
1903 Make_Subprogram_Body
(Loc
,
1905 Make_Procedure_Specification
(Loc
,
1906 Defining_Unit_Name
=> Thunk_Id
,
1907 Parameter_Specifications
=> Formals
),
1908 Declarations
=> Decl
,
1909 Handled_Statement_Sequence
=>
1910 Make_Handled_Sequence_Of_Statements
(Loc
,
1911 Statements
=> New_List
(
1912 Make_Procedure_Call_Statement
(Loc
,
1913 Name
=> New_Occurrence_Of
(Target
, Loc
),
1914 Parameter_Associations
=> Actuals
))));
1918 else pragma Assert
(Ekind
(Target
) = E_Function
);
1920 Result_Def
: Node_Id
;
1921 Call_Node
: Node_Id
;
1925 Make_Function_Call
(Loc
,
1926 Name
=> New_Occurrence_Of
(Target
, Loc
),
1927 Parameter_Associations
=> Actuals
);
1929 if not Is_Interface
(Etype
(Prim
)) then
1930 Result_Def
:= New_Copy
(Result_Definition
(Parent
(Target
)));
1932 -- Thunk of function returning a class-wide interface object. No
1933 -- extra displacement needed since the displacement is generated
1934 -- in the return statement of Prim. Example:
1936 -- type Iface is interface ...
1937 -- function F (O : Iface) return Iface'Class;
1939 -- type T is new ... and Iface with ...
1940 -- function F (O : T) return Iface'Class;
1942 elsif Is_Class_Wide_Type
(Etype
(Prim
)) then
1943 Result_Def
:= New_Occurrence_Of
(Etype
(Prim
), Loc
);
1945 -- Thunk of function returning an interface object. Displacement
1948 -- type Iface is interface ...
1949 -- function F (O : Iface) return Iface;
1951 -- type T is new ... and Iface with ...
1952 -- function F (O : T) return T;
1956 New_Occurrence_Of
(Class_Wide_Type
(Etype
(Prim
)), Loc
);
1958 -- Adding implicit conversion to force the displacement of
1959 -- the pointer to the object to reference the corresponding
1960 -- secondary dispatch table.
1963 Make_Type_Conversion
(Loc
,
1965 New_Occurrence_Of
(Class_Wide_Type
(Etype
(Prim
)), Loc
),
1966 Expression
=> Relocate_Node
(Call_Node
));
1970 Make_Subprogram_Body
(Loc
,
1972 Make_Function_Specification
(Loc
,
1973 Defining_Unit_Name
=> Thunk_Id
,
1974 Parameter_Specifications
=> Formals
,
1975 Result_Definition
=> Result_Def
),
1976 Declarations
=> Decl
,
1977 Handled_Statement_Sequence
=>
1978 Make_Handled_Sequence_Of_Statements
(Loc
,
1979 Statements
=> New_List
(
1980 Make_Simple_Return_Statement
(Loc
, Call_Node
))));
1983 end Expand_Interface_Thunk
;
1985 --------------------------
1986 -- Has_CPP_Constructors --
1987 --------------------------
1989 function Has_CPP_Constructors
(Typ
: Entity_Id
) return Boolean is
1993 -- Look for the constructor entities
1995 E
:= Next_Entity
(Typ
);
1996 while Present
(E
) loop
1997 if Ekind
(E
) = E_Function
and then Is_Constructor
(E
) then
2005 end Has_CPP_Constructors
;
2011 function Has_DT
(Typ
: Entity_Id
) return Boolean is
2013 return not Is_Interface
(Typ
)
2014 and then not Restriction_Active
(No_Dispatching_Calls
);
2017 ----------------------------------
2018 -- Is_Expanded_Dispatching_Call --
2019 ----------------------------------
2021 function Is_Expanded_Dispatching_Call
(N
: Node_Id
) return Boolean is
2023 return Nkind
(N
) in N_Subprogram_Call
2024 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
2025 and then Is_Dispatch_Table_Entity
(Etype
(Name
(N
)));
2026 end Is_Expanded_Dispatching_Call
;
2028 -----------------------------------------
2029 -- Is_Predefined_Dispatching_Operation --
2030 -----------------------------------------
2032 function Is_Predefined_Dispatching_Operation
2033 (E
: Entity_Id
) return Boolean
2035 TSS_Name
: TSS_Name_Type
;
2038 if not Is_Dispatching_Operation
(E
) then
2042 Get_Name_String
(Chars
(E
));
2044 -- Most predefined primitives have internally generated names. Equality
2045 -- must be treated differently; the predefined operation is recognized
2046 -- as a homogeneous binary operator that returns Boolean.
2048 if Name_Len
> TSS_Name_Type
'Last then
2049 TSS_Name
:= TSS_Name_Type
(Name_Buffer
(Name_Len
- TSS_Name
'Length + 1
2051 if Chars
(E
) = Name_uSize
2052 or else TSS_Name
= TSS_Stream_Read
2053 or else TSS_Name
= TSS_Stream_Write
2054 or else TSS_Name
= TSS_Stream_Input
2055 or else TSS_Name
= TSS_Stream_Output
2057 (Chars
(E
) = Name_Op_Eq
2058 and then Etype
(First_Formal
(E
)) = Etype
(Last_Formal
(E
)))
2059 or else Chars
(E
) = Name_uAssign
2060 or else TSS_Name
= TSS_Deep_Adjust
2061 or else TSS_Name
= TSS_Deep_Finalize
2062 or else Is_Predefined_Interface_Primitive
(E
)
2069 end Is_Predefined_Dispatching_Operation
;
2071 ---------------------------------------
2072 -- Is_Predefined_Internal_Operation --
2073 ---------------------------------------
2075 function Is_Predefined_Internal_Operation
2076 (E
: Entity_Id
) return Boolean
2078 TSS_Name
: TSS_Name_Type
;
2081 if not Is_Dispatching_Operation
(E
) then
2085 Get_Name_String
(Chars
(E
));
2087 -- Most predefined primitives have internally generated names. Equality
2088 -- must be treated differently; the predefined operation is recognized
2089 -- as a homogeneous binary operator that returns Boolean.
2091 if Name_Len
> TSS_Name_Type
'Last then
2094 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
2096 if Nam_In
(Chars
(E
), Name_uSize
, Name_uAssign
)
2098 (Chars
(E
) = Name_Op_Eq
2099 and then Etype
(First_Formal
(E
)) = Etype
(Last_Formal
(E
)))
2100 or else TSS_Name
= TSS_Deep_Adjust
2101 or else TSS_Name
= TSS_Deep_Finalize
2102 or else Is_Predefined_Interface_Primitive
(E
)
2109 end Is_Predefined_Internal_Operation
;
2111 -------------------------------------
2112 -- Is_Predefined_Dispatching_Alias --
2113 -------------------------------------
2115 function Is_Predefined_Dispatching_Alias
(Prim
: Entity_Id
) return Boolean
2118 return not Is_Predefined_Dispatching_Operation
(Prim
)
2119 and then Present
(Alias
(Prim
))
2120 and then Is_Predefined_Dispatching_Operation
(Ultimate_Alias
(Prim
));
2121 end Is_Predefined_Dispatching_Alias
;
2123 ---------------------------------------
2124 -- Is_Predefined_Interface_Primitive --
2125 ---------------------------------------
2127 function Is_Predefined_Interface_Primitive
(E
: Entity_Id
) return Boolean is
2129 -- In VM targets we don't restrict the functionality of this test to
2130 -- compiling in Ada 2005 mode since in VM targets any tagged type has
2131 -- these primitives.
2133 return (Ada_Version
>= Ada_2005
or else not Tagged_Type_Expansion
)
2134 and then Nam_In
(Chars
(E
), Name_uDisp_Asynchronous_Select
,
2135 Name_uDisp_Conditional_Select
,
2136 Name_uDisp_Get_Prim_Op_Kind
,
2137 Name_uDisp_Get_Task_Id
,
2139 Name_uDisp_Timed_Select
);
2140 end Is_Predefined_Interface_Primitive
;
2142 ----------------------------------------
2143 -- Make_Disp_Asynchronous_Select_Body --
2144 ----------------------------------------
2146 -- For interface types, generate:
2148 -- procedure _Disp_Asynchronous_Select
2149 -- (T : in out <Typ>;
2151 -- P : System.Address;
2152 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2157 -- C := Ada.Tags.POK_Function;
2158 -- end _Disp_Asynchronous_Select;
2160 -- For protected types, generate:
2162 -- procedure _Disp_Asynchronous_Select
2163 -- (T : in out <Typ>;
2165 -- P : System.Address;
2166 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2170 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2171 -- Bnn : System.Tasking.Protected_Objects.Operations.
2172 -- Communication_Block;
2174 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2175 -- (T._object'Access,
2176 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2178 -- System.Tasking.Asynchronous_Call,
2180 -- B := System.Storage_Elements.Dummy_Communication_Block (Bnn);
2181 -- end _Disp_Asynchronous_Select;
2183 -- For task types, generate:
2185 -- procedure _Disp_Asynchronous_Select
2186 -- (T : in out <Typ>;
2188 -- P : System.Address;
2189 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2193 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2195 -- System.Tasking.Rendezvous.Task_Entry_Call
2197 -- System.Tasking.Task_Entry_Index (I),
2199 -- System.Tasking.Asynchronous_Call,
2201 -- end _Disp_Asynchronous_Select;
2203 function Make_Disp_Asynchronous_Select_Body
2204 (Typ
: Entity_Id
) return Node_Id
2206 Com_Block
: Entity_Id
;
2207 Conc_Typ
: Entity_Id
:= Empty
;
2208 Decls
: constant List_Id
:= New_List
;
2209 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2211 Stmts
: constant List_Id
:= New_List
;
2215 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2217 -- Null body is generated for interface types
2219 if Is_Interface
(Typ
) then
2221 Make_Subprogram_Body
(Loc
,
2223 Make_Disp_Asynchronous_Select_Spec
(Typ
),
2224 Declarations
=> New_List
,
2225 Handled_Statement_Sequence
=>
2226 Make_Handled_Sequence_Of_Statements
(Loc
,
2228 Make_Assignment_Statement
(Loc
,
2229 Name
=> Make_Identifier
(Loc
, Name_uF
),
2230 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
2233 if Is_Concurrent_Record_Type
(Typ
) then
2234 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
2238 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2240 -- where I will be used to capture the entry index of the primitive
2241 -- wrapper at position S.
2243 if Tagged_Type_Expansion
then
2245 Unchecked_Convert_To
(RTE
(RE_Tag
),
2247 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
2250 Make_Attribute_Reference
(Loc
,
2251 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
2252 Attribute_Name
=> Name_Tag
);
2256 Make_Object_Declaration
(Loc
,
2257 Defining_Identifier
=>
2258 Make_Defining_Identifier
(Loc
, Name_uI
),
2259 Object_Definition
=>
2260 New_Occurrence_Of
(Standard_Integer
, Loc
),
2262 Make_Function_Call
(Loc
,
2264 New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
2265 Parameter_Associations
=>
2266 New_List
(Tag_Node
, Make_Identifier
(Loc
, Name_uS
)))));
2268 if Ekind
(Conc_Typ
) = E_Protected_Type
then
2271 -- Bnn : Communication_Block;
2273 Com_Block
:= Make_Temporary
(Loc
, 'B');
2275 Make_Object_Declaration
(Loc
,
2276 Defining_Identifier
=> Com_Block
,
2277 Object_Definition
=>
2278 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
2280 -- Build T._object'Access for calls below
2283 Make_Attribute_Reference
(Loc
,
2284 Attribute_Name
=> Name_Unchecked_Access
,
2286 Make_Selected_Component
(Loc
,
2287 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2288 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
2290 case Corresponding_Runtime_Package
(Conc_Typ
) is
2291 when System_Tasking_Protected_Objects_Entries
=>
2294 -- Protected_Entry_Call
2295 -- (T._object'Access, -- Object
2296 -- Protected_Entry_Index! (I), -- E
2297 -- P, -- Uninterpreted_Data
2298 -- Asynchronous_Call, -- Mode
2299 -- Bnn); -- Communication_Block
2301 -- where T is the protected object, I is the entry index, P
2302 -- is the wrapped parameters and B is the name of the
2303 -- communication block.
2306 Make_Procedure_Call_Statement
(Loc
,
2308 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
2309 Parameter_Associations
=>
2313 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2316 (RTE
(RE_Protected_Entry_Index
), Loc
),
2317 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2319 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2320 New_Occurrence_Of
-- Asynchronous_Call
2321 (RTE
(RE_Asynchronous_Call
), Loc
),
2322 New_Occurrence_Of
-- comm block
2323 (Com_Block
, Loc
))));
2326 raise Program_Error
;
2330 -- B := Dummy_Communication_Block (Bnn);
2333 Make_Assignment_Statement
(Loc
,
2334 Name
=> Make_Identifier
(Loc
, Name_uB
),
2336 Make_Unchecked_Type_Conversion
(Loc
,
2339 (RTE
(RE_Dummy_Communication_Block
), Loc
),
2340 Expression
=> New_Occurrence_Of
(Com_Block
, Loc
))));
2346 Make_Assignment_Statement
(Loc
,
2347 Name
=> Make_Identifier
(Loc
, Name_uF
),
2348 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
2351 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
2355 -- (T._task_id, -- Acceptor
2356 -- Task_Entry_Index! (I), -- E
2357 -- P, -- Uninterpreted_Data
2358 -- Asynchronous_Call, -- Mode
2359 -- F); -- Rendezvous_Successful
2361 -- where T is the task object, I is the entry index, P is the
2362 -- wrapped parameters and F is the status flag.
2365 Make_Procedure_Call_Statement
(Loc
,
2367 New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
2368 Parameter_Associations
=>
2370 Make_Selected_Component
(Loc
, -- T._task_id
2371 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2372 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
2374 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2376 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
2377 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2379 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2380 New_Occurrence_Of
-- Asynchronous_Call
2381 (RTE
(RE_Asynchronous_Call
), Loc
),
2382 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
2386 -- Ensure that the statements list is non-empty
2389 Make_Assignment_Statement
(Loc
,
2390 Name
=> Make_Identifier
(Loc
, Name_uF
),
2391 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
2395 Make_Subprogram_Body
(Loc
,
2397 Make_Disp_Asynchronous_Select_Spec
(Typ
),
2398 Declarations
=> Decls
,
2399 Handled_Statement_Sequence
=>
2400 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
2401 end Make_Disp_Asynchronous_Select_Body
;
2403 ----------------------------------------
2404 -- Make_Disp_Asynchronous_Select_Spec --
2405 ----------------------------------------
2407 function Make_Disp_Asynchronous_Select_Spec
2408 (Typ
: Entity_Id
) return Node_Id
2410 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2411 Def_Id
: constant Node_Id
:=
2412 Make_Defining_Identifier
(Loc
,
2413 Name_uDisp_Asynchronous_Select
);
2414 Params
: constant List_Id
:= New_List
;
2417 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2419 -- T : in out Typ; -- Object parameter
2420 -- S : Integer; -- Primitive operation slot
2421 -- P : Address; -- Wrapped parameters
2422 -- B : out Dummy_Communication_Block; -- Communication block dummy
2423 -- F : out Boolean; -- Status flag
2425 Append_List_To
(Params
, New_List
(
2427 Make_Parameter_Specification
(Loc
,
2428 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
2429 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
2431 Out_Present
=> True),
2433 Make_Parameter_Specification
(Loc
,
2434 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
2435 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
2437 Make_Parameter_Specification
(Loc
,
2438 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
2439 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2441 Make_Parameter_Specification
(Loc
,
2442 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uB
),
2444 New_Occurrence_Of
(RTE
(RE_Dummy_Communication_Block
), Loc
),
2445 Out_Present
=> True),
2447 Make_Parameter_Specification
(Loc
,
2448 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
2449 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
2450 Out_Present
=> True)));
2453 Make_Procedure_Specification
(Loc
,
2454 Defining_Unit_Name
=> Def_Id
,
2455 Parameter_Specifications
=> Params
);
2456 end Make_Disp_Asynchronous_Select_Spec
;
2458 ---------------------------------------
2459 -- Make_Disp_Conditional_Select_Body --
2460 ---------------------------------------
2462 -- For interface types, generate:
2464 -- procedure _Disp_Conditional_Select
2465 -- (T : in out <Typ>;
2467 -- P : System.Address;
2468 -- C : out Ada.Tags.Prim_Op_Kind;
2473 -- C := Ada.Tags.POK_Function;
2474 -- end _Disp_Conditional_Select;
2476 -- For protected types, generate:
2478 -- procedure _Disp_Conditional_Select
2479 -- (T : in out <Typ>;
2481 -- P : System.Address;
2482 -- C : out Ada.Tags.Prim_Op_Kind;
2486 -- Bnn : System.Tasking.Protected_Objects.Operations.
2487 -- Communication_Block;
2490 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S));
2492 -- if C = Ada.Tags.POK_Procedure
2493 -- or else C = Ada.Tags.POK_Protected_Procedure
2494 -- or else C = Ada.Tags.POK_Task_Procedure
2500 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2501 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2502 -- (T.object'Access,
2503 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2505 -- System.Tasking.Conditional_Call,
2507 -- F := not Cancelled (Bnn);
2508 -- end _Disp_Conditional_Select;
2510 -- For task types, generate:
2512 -- procedure _Disp_Conditional_Select
2513 -- (T : in out <Typ>;
2515 -- P : System.Address;
2516 -- C : out Ada.Tags.Prim_Op_Kind;
2522 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2523 -- System.Tasking.Rendezvous.Task_Entry_Call
2525 -- System.Tasking.Task_Entry_Index (I),
2527 -- System.Tasking.Conditional_Call,
2529 -- end _Disp_Conditional_Select;
2531 function Make_Disp_Conditional_Select_Body
2532 (Typ
: Entity_Id
) return Node_Id
2534 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2535 Blk_Nam
: Entity_Id
;
2536 Conc_Typ
: Entity_Id
:= Empty
;
2537 Decls
: constant List_Id
:= New_List
;
2539 Stmts
: constant List_Id
:= New_List
;
2543 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2545 -- Null body is generated for interface types
2547 if Is_Interface
(Typ
) then
2549 Make_Subprogram_Body
(Loc
,
2551 Make_Disp_Conditional_Select_Spec
(Typ
),
2552 Declarations
=> No_List
,
2553 Handled_Statement_Sequence
=>
2554 Make_Handled_Sequence_Of_Statements
(Loc
,
2555 New_List
(Make_Assignment_Statement
(Loc
,
2556 Name
=> Make_Identifier
(Loc
, Name_uF
),
2557 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
2560 if Is_Concurrent_Record_Type
(Typ
) then
2561 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
2566 -- where I will be used to capture the entry index of the primitive
2567 -- wrapper at position S.
2570 Make_Object_Declaration
(Loc
,
2571 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uI
),
2572 Object_Definition
=>
2573 New_Occurrence_Of
(Standard_Integer
, Loc
)));
2576 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S);
2578 -- if C = POK_Procedure
2579 -- or else C = POK_Protected_Procedure
2580 -- or else C = POK_Task_Procedure;
2586 Build_Common_Dispatching_Select_Statements
(Typ
, Stmts
);
2589 -- Bnn : Communication_Block;
2591 -- where Bnn is the name of the communication block used in the
2592 -- call to Protected_Entry_Call.
2594 Blk_Nam
:= Make_Temporary
(Loc
, 'B');
2596 Make_Object_Declaration
(Loc
,
2597 Defining_Identifier
=> Blk_Nam
,
2598 Object_Definition
=>
2599 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
2602 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2604 -- I is the entry index and S is the dispatch table slot
2606 if Tagged_Type_Expansion
then
2608 Unchecked_Convert_To
(RTE
(RE_Tag
),
2610 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
2614 Make_Attribute_Reference
(Loc
,
2615 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
2616 Attribute_Name
=> Name_Tag
);
2620 Make_Assignment_Statement
(Loc
,
2621 Name
=> Make_Identifier
(Loc
, Name_uI
),
2623 Make_Function_Call
(Loc
,
2625 New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
2626 Parameter_Associations
=> New_List
(
2628 Make_Identifier
(Loc
, Name_uS
)))));
2630 if Ekind
(Conc_Typ
) = E_Protected_Type
then
2632 Obj_Ref
:= -- T._object'Access
2633 Make_Attribute_Reference
(Loc
,
2634 Attribute_Name
=> Name_Unchecked_Access
,
2636 Make_Selected_Component
(Loc
,
2637 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2638 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
2640 case Corresponding_Runtime_Package
(Conc_Typ
) is
2641 when System_Tasking_Protected_Objects_Entries
=>
2644 -- Protected_Entry_Call
2645 -- (T._object'Access, -- Object
2646 -- Protected_Entry_Index! (I), -- E
2647 -- P, -- Uninterpreted_Data
2648 -- Conditional_Call, -- Mode
2651 -- where T is the protected object, I is the entry index, P
2652 -- are the wrapped parameters and Bnn is the name of the
2653 -- communication block.
2656 Make_Procedure_Call_Statement
(Loc
,
2658 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
2659 Parameter_Associations
=> New_List
(
2662 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2665 (RTE
(RE_Protected_Entry_Index
), Loc
),
2666 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2668 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2670 New_Occurrence_Of
-- Conditional_Call
2671 (RTE
(RE_Conditional_Call
), Loc
),
2672 New_Occurrence_Of
-- Bnn
2675 when System_Tasking_Protected_Objects_Single_Entry
=>
2677 -- If we are compiling for a restricted run-time, the call
2678 -- uses the simpler form.
2681 Make_Procedure_Call_Statement
(Loc
,
2684 (RTE
(RE_Protected_Single_Entry_Call
), Loc
),
2685 Parameter_Associations
=> New_List
(
2688 Make_Attribute_Reference
(Loc
,
2689 Prefix
=> Make_Identifier
(Loc
, Name_uP
),
2690 Attribute_Name
=> Name_Address
),
2693 (RTE
(RE_Conditional_Call
), Loc
))));
2695 raise Program_Error
;
2699 -- F := not Cancelled (Bnn);
2701 -- where F is the success flag. The status of Cancelled is negated
2702 -- in order to match the behaviour of the version for task types.
2705 Make_Assignment_Statement
(Loc
,
2706 Name
=> Make_Identifier
(Loc
, Name_uF
),
2710 Make_Function_Call
(Loc
,
2712 New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
2713 Parameter_Associations
=> New_List
(
2714 New_Occurrence_Of
(Blk_Nam
, Loc
))))));
2716 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
2720 -- (T._task_id, -- Acceptor
2721 -- Task_Entry_Index! (I), -- E
2722 -- P, -- Uninterpreted_Data
2723 -- Conditional_Call, -- Mode
2724 -- F); -- Rendezvous_Successful
2726 -- where T is the task object, I is the entry index, P are the
2727 -- wrapped parameters and F is the status flag.
2730 Make_Procedure_Call_Statement
(Loc
,
2732 New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
2733 Parameter_Associations
=> New_List
(
2735 Make_Selected_Component
(Loc
, -- T._task_id
2736 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2737 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
2739 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2741 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
2742 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2744 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2745 New_Occurrence_Of
-- Conditional_Call
2746 (RTE
(RE_Conditional_Call
), Loc
),
2747 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
2751 -- Initialize out parameters
2754 Make_Assignment_Statement
(Loc
,
2755 Name
=> Make_Identifier
(Loc
, Name_uF
),
2756 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
2758 Make_Assignment_Statement
(Loc
,
2759 Name
=> Make_Identifier
(Loc
, Name_uC
),
2760 Expression
=> New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
)));
2764 Make_Subprogram_Body
(Loc
,
2766 Make_Disp_Conditional_Select_Spec
(Typ
),
2767 Declarations
=> Decls
,
2768 Handled_Statement_Sequence
=>
2769 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
2770 end Make_Disp_Conditional_Select_Body
;
2772 ---------------------------------------
2773 -- Make_Disp_Conditional_Select_Spec --
2774 ---------------------------------------
2776 function Make_Disp_Conditional_Select_Spec
2777 (Typ
: Entity_Id
) return Node_Id
2779 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2780 Def_Id
: constant Node_Id
:=
2781 Make_Defining_Identifier
(Loc
,
2782 Name_uDisp_Conditional_Select
);
2783 Params
: constant List_Id
:= New_List
;
2786 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2788 -- T : in out Typ; -- Object parameter
2789 -- S : Integer; -- Primitive operation slot
2790 -- P : Address; -- Wrapped parameters
2791 -- C : out Prim_Op_Kind; -- Call kind
2792 -- F : out Boolean; -- Status flag
2794 Append_List_To
(Params
, New_List
(
2796 Make_Parameter_Specification
(Loc
,
2797 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
2798 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
2800 Out_Present
=> True),
2802 Make_Parameter_Specification
(Loc
,
2803 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
2804 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
2806 Make_Parameter_Specification
(Loc
,
2807 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
2808 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2810 Make_Parameter_Specification
(Loc
,
2811 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
2813 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
2814 Out_Present
=> True),
2816 Make_Parameter_Specification
(Loc
,
2817 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
2818 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
2819 Out_Present
=> True)));
2822 Make_Procedure_Specification
(Loc
,
2823 Defining_Unit_Name
=> Def_Id
,
2824 Parameter_Specifications
=> Params
);
2825 end Make_Disp_Conditional_Select_Spec
;
2827 -------------------------------------
2828 -- Make_Disp_Get_Prim_Op_Kind_Body --
2829 -------------------------------------
2831 function Make_Disp_Get_Prim_Op_Kind_Body
(Typ
: Entity_Id
) return Node_Id
is
2832 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2836 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2838 if Is_Interface
(Typ
) then
2840 Make_Subprogram_Body
(Loc
,
2842 Make_Disp_Get_Prim_Op_Kind_Spec
(Typ
),
2843 Declarations
=> New_List
,
2844 Handled_Statement_Sequence
=>
2845 Make_Handled_Sequence_Of_Statements
(Loc
,
2846 New_List
(Make_Null_Statement
(Loc
))));
2850 -- C := get_prim_op_kind (tag! (<type>VP), S);
2852 -- where C is the out parameter capturing the call kind and S is the
2853 -- dispatch table slot number.
2855 if Tagged_Type_Expansion
then
2857 Unchecked_Convert_To
(RTE
(RE_Tag
),
2859 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
2863 Make_Attribute_Reference
(Loc
,
2864 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
2865 Attribute_Name
=> Name_Tag
);
2869 Make_Subprogram_Body
(Loc
,
2871 Make_Disp_Get_Prim_Op_Kind_Spec
(Typ
),
2872 Declarations
=> New_List
,
2873 Handled_Statement_Sequence
=>
2874 Make_Handled_Sequence_Of_Statements
(Loc
,
2876 Make_Assignment_Statement
(Loc
,
2877 Name
=> Make_Identifier
(Loc
, Name_uC
),
2879 Make_Function_Call
(Loc
,
2881 New_Occurrence_Of
(RTE
(RE_Get_Prim_Op_Kind
), Loc
),
2882 Parameter_Associations
=> New_List
(
2884 Make_Identifier
(Loc
, Name_uS
)))))));
2885 end Make_Disp_Get_Prim_Op_Kind_Body
;
2887 -------------------------------------
2888 -- Make_Disp_Get_Prim_Op_Kind_Spec --
2889 -------------------------------------
2891 function Make_Disp_Get_Prim_Op_Kind_Spec
2892 (Typ
: Entity_Id
) return Node_Id
2894 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2895 Def_Id
: constant Node_Id
:=
2896 Make_Defining_Identifier
(Loc
, Name_uDisp_Get_Prim_Op_Kind
);
2897 Params
: constant List_Id
:= New_List
;
2900 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2902 -- T : in out Typ; -- Object parameter
2903 -- S : Integer; -- Primitive operation slot
2904 -- C : out Prim_Op_Kind; -- Call kind
2906 Append_List_To
(Params
, New_List
(
2908 Make_Parameter_Specification
(Loc
,
2909 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
2910 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
2912 Out_Present
=> True),
2914 Make_Parameter_Specification
(Loc
,
2915 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
2916 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
2918 Make_Parameter_Specification
(Loc
,
2919 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
2921 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
2922 Out_Present
=> True)));
2925 Make_Procedure_Specification
(Loc
,
2926 Defining_Unit_Name
=> Def_Id
,
2927 Parameter_Specifications
=> Params
);
2928 end Make_Disp_Get_Prim_Op_Kind_Spec
;
2930 --------------------------------
2931 -- Make_Disp_Get_Task_Id_Body --
2932 --------------------------------
2934 function Make_Disp_Get_Task_Id_Body
2935 (Typ
: Entity_Id
) return Node_Id
2937 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2941 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2943 if Is_Concurrent_Record_Type
(Typ
)
2944 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) = E_Task_Type
2947 -- return To_Address (_T._task_id);
2950 Make_Simple_Return_Statement
(Loc
,
2952 Make_Unchecked_Type_Conversion
(Loc
,
2953 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
2955 Make_Selected_Component
(Loc
,
2956 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2957 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
))));
2959 -- A null body is constructed for non-task types
2963 -- return Null_Address;
2966 Make_Simple_Return_Statement
(Loc
,
2967 Expression
=> New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
2971 Make_Subprogram_Body
(Loc
,
2972 Specification
=> Make_Disp_Get_Task_Id_Spec
(Typ
),
2973 Declarations
=> New_List
,
2974 Handled_Statement_Sequence
=>
2975 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Ret
)));
2976 end Make_Disp_Get_Task_Id_Body
;
2978 --------------------------------
2979 -- Make_Disp_Get_Task_Id_Spec --
2980 --------------------------------
2982 function Make_Disp_Get_Task_Id_Spec
2983 (Typ
: Entity_Id
) return Node_Id
2985 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2988 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2991 Make_Function_Specification
(Loc
,
2992 Defining_Unit_Name
=>
2993 Make_Defining_Identifier
(Loc
, Name_uDisp_Get_Task_Id
),
2994 Parameter_Specifications
=> New_List
(
2995 Make_Parameter_Specification
(Loc
,
2996 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
2997 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
2998 Result_Definition
=>
2999 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
3000 end Make_Disp_Get_Task_Id_Spec
;
3002 ----------------------------
3003 -- Make_Disp_Requeue_Body --
3004 ----------------------------
3006 function Make_Disp_Requeue_Body
3007 (Typ
: Entity_Id
) return Node_Id
3009 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3010 Conc_Typ
: Entity_Id
:= Empty
;
3011 Stmts
: constant List_Id
:= New_List
;
3014 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3016 -- Null body is generated for interface types and non-concurrent
3019 if Is_Interface
(Typ
)
3020 or else not Is_Concurrent_Record_Type
(Typ
)
3023 Make_Subprogram_Body
(Loc
,
3024 Specification
=> Make_Disp_Requeue_Spec
(Typ
),
3025 Declarations
=> No_List
,
3026 Handled_Statement_Sequence
=>
3027 Make_Handled_Sequence_Of_Statements
(Loc
,
3028 New_List
(Make_Null_Statement
(Loc
))));
3031 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
3033 if Ekind
(Conc_Typ
) = E_Protected_Type
then
3035 -- Generate statements:
3037 -- System.Tasking.Protected_Objects.Operations.
3038 -- Requeue_Protected_Entry
3039 -- (Protection_Entries_Access (P),
3040 -- O._object'Unchecked_Access,
3041 -- Protected_Entry_Index (I),
3044 -- System.Tasking.Protected_Objects.Operations.
3045 -- Requeue_Task_To_Protected_Entry
3046 -- (O._object'Unchecked_Access,
3047 -- Protected_Entry_Index (I),
3051 if Restriction_Active
(No_Entry_Queue
) then
3052 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
3055 Make_If_Statement
(Loc
,
3056 Condition
=> Make_Identifier
(Loc
, Name_uF
),
3061 -- Call to Requeue_Protected_Entry
3063 Make_Procedure_Call_Statement
(Loc
,
3066 (RTE
(RE_Requeue_Protected_Entry
), Loc
),
3067 Parameter_Associations
=>
3070 Make_Unchecked_Type_Conversion
(Loc
, -- PEA (P)
3073 RTE
(RE_Protection_Entries_Access
), Loc
),
3075 Make_Identifier
(Loc
, Name_uP
)),
3077 Make_Attribute_Reference
(Loc
, -- O._object'Acc
3079 Name_Unchecked_Access
,
3081 Make_Selected_Component
(Loc
,
3083 Make_Identifier
(Loc
, Name_uO
),
3085 Make_Identifier
(Loc
, Name_uObject
))),
3087 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3090 (RTE
(RE_Protected_Entry_Index
), Loc
),
3091 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3093 Make_Identifier
(Loc
, Name_uA
)))), -- abort status
3098 -- Call to Requeue_Task_To_Protected_Entry
3100 Make_Procedure_Call_Statement
(Loc
,
3103 (RTE
(RE_Requeue_Task_To_Protected_Entry
), Loc
),
3104 Parameter_Associations
=>
3107 Make_Attribute_Reference
(Loc
, -- O._object'Acc
3108 Attribute_Name
=> Name_Unchecked_Access
,
3110 Make_Selected_Component
(Loc
,
3112 Make_Identifier
(Loc
, Name_uO
),
3114 Make_Identifier
(Loc
, Name_uObject
))),
3116 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3119 (RTE
(RE_Protected_Entry_Index
), Loc
),
3120 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3122 Make_Identifier
(Loc
, Name_uA
)))))); -- abort status
3126 pragma Assert
(Is_Task_Type
(Conc_Typ
));
3130 -- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry
3131 -- (Protection_Entries_Access (P),
3133 -- Task_Entry_Index (I),
3136 -- System.Tasking.Rendezvous.Requeue_Task_Entry
3138 -- Task_Entry_Index (I),
3143 Make_If_Statement
(Loc
,
3144 Condition
=> Make_Identifier
(Loc
, Name_uF
),
3146 Then_Statements
=> New_List
(
3148 -- Call to Requeue_Protected_To_Task_Entry
3150 Make_Procedure_Call_Statement
(Loc
,
3153 (RTE
(RE_Requeue_Protected_To_Task_Entry
), Loc
),
3155 Parameter_Associations
=> New_List
(
3157 Make_Unchecked_Type_Conversion
(Loc
, -- PEA (P)
3160 (RTE
(RE_Protection_Entries_Access
), Loc
),
3161 Expression
=> Make_Identifier
(Loc
, Name_uP
)),
3163 Make_Selected_Component
(Loc
, -- O._task_id
3164 Prefix
=> Make_Identifier
(Loc
, Name_uO
),
3165 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3167 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3169 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
3170 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3172 Make_Identifier
(Loc
, Name_uA
)))), -- abort status
3174 Else_Statements
=> New_List
(
3176 -- Call to Requeue_Task_Entry
3178 Make_Procedure_Call_Statement
(Loc
,
3180 New_Occurrence_Of
(RTE
(RE_Requeue_Task_Entry
), Loc
),
3182 Parameter_Associations
=> New_List
(
3184 Make_Selected_Component
(Loc
, -- O._task_id
3185 Prefix
=> Make_Identifier
(Loc
, Name_uO
),
3186 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3188 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3190 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
3191 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3193 Make_Identifier
(Loc
, Name_uA
)))))); -- abort status
3196 -- Even though no declarations are needed in both cases, we allocate
3197 -- a list for entities added by Freeze.
3200 Make_Subprogram_Body
(Loc
,
3201 Specification
=> Make_Disp_Requeue_Spec
(Typ
),
3202 Declarations
=> New_List
,
3203 Handled_Statement_Sequence
=>
3204 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
3205 end Make_Disp_Requeue_Body
;
3207 ----------------------------
3208 -- Make_Disp_Requeue_Spec --
3209 ----------------------------
3211 function Make_Disp_Requeue_Spec
3212 (Typ
: Entity_Id
) return Node_Id
3214 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3217 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3219 -- O : in out Typ; - Object parameter
3220 -- F : Boolean; - Protected (True) / task (False) flag
3221 -- P : Address; - Protection_Entries_Access value
3222 -- I : Entry_Index - Index of entry call
3223 -- A : Boolean - Abort flag
3225 -- Note that the Protection_Entries_Access value is represented as a
3226 -- System.Address in order to avoid dragging in the tasking runtime
3227 -- when compiling sources without tasking constructs.
3230 Make_Procedure_Specification
(Loc
,
3231 Defining_Unit_Name
=>
3232 Make_Defining_Identifier
(Loc
, Name_uDisp_Requeue
),
3234 Parameter_Specifications
=> New_List
(
3236 Make_Parameter_Specification
(Loc
, -- O
3237 Defining_Identifier
=>
3238 Make_Defining_Identifier
(Loc
, Name_uO
),
3240 New_Occurrence_Of
(Typ
, Loc
),
3242 Out_Present
=> True),
3244 Make_Parameter_Specification
(Loc
, -- F
3245 Defining_Identifier
=>
3246 Make_Defining_Identifier
(Loc
, Name_uF
),
3248 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
3250 Make_Parameter_Specification
(Loc
, -- P
3251 Defining_Identifier
=>
3252 Make_Defining_Identifier
(Loc
, Name_uP
),
3254 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3256 Make_Parameter_Specification
(Loc
, -- I
3257 Defining_Identifier
=>
3258 Make_Defining_Identifier
(Loc
, Name_uI
),
3260 New_Occurrence_Of
(Standard_Integer
, Loc
)),
3262 Make_Parameter_Specification
(Loc
, -- A
3263 Defining_Identifier
=>
3264 Make_Defining_Identifier
(Loc
, Name_uA
),
3266 New_Occurrence_Of
(Standard_Boolean
, Loc
))));
3267 end Make_Disp_Requeue_Spec
;
3269 ---------------------------------
3270 -- Make_Disp_Timed_Select_Body --
3271 ---------------------------------
3273 -- For interface types, generate:
3275 -- procedure _Disp_Timed_Select
3276 -- (T : in out <Typ>;
3278 -- P : System.Address;
3281 -- C : out Ada.Tags.Prim_Op_Kind;
3286 -- C := Ada.Tags.POK_Function;
3287 -- end _Disp_Timed_Select;
3289 -- For protected types, generate:
3291 -- procedure _Disp_Timed_Select
3292 -- (T : in out <Typ>;
3294 -- P : System.Address;
3297 -- C : out Ada.Tags.Prim_Op_Kind;
3303 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S);
3305 -- if C = Ada.Tags.POK_Procedure
3306 -- or else C = Ada.Tags.POK_Protected_Procedure
3307 -- or else C = Ada.Tags.POK_Task_Procedure
3313 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3314 -- System.Tasking.Protected_Objects.Operations.
3315 -- Timed_Protected_Entry_Call
3316 -- (T._object'Access,
3317 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
3322 -- end _Disp_Timed_Select;
3324 -- For task types, generate:
3326 -- procedure _Disp_Timed_Select
3327 -- (T : in out <Typ>;
3329 -- P : System.Address;
3332 -- C : out Ada.Tags.Prim_Op_Kind;
3338 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3339 -- System.Tasking.Rendezvous.Timed_Task_Entry_Call
3341 -- System.Tasking.Task_Entry_Index (I),
3346 -- end _Disp_Time_Select;
3348 function Make_Disp_Timed_Select_Body
3349 (Typ
: Entity_Id
) return Node_Id
3351 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3352 Conc_Typ
: Entity_Id
:= Empty
;
3353 Decls
: constant List_Id
:= New_List
;
3355 Stmts
: constant List_Id
:= New_List
;
3359 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3361 -- Null body is generated for interface types
3363 if Is_Interface
(Typ
) then
3365 Make_Subprogram_Body
(Loc
,
3366 Specification
=> Make_Disp_Timed_Select_Spec
(Typ
),
3367 Declarations
=> New_List
,
3368 Handled_Statement_Sequence
=>
3369 Make_Handled_Sequence_Of_Statements
(Loc
,
3371 Make_Assignment_Statement
(Loc
,
3372 Name
=> Make_Identifier
(Loc
, Name_uF
),
3373 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
3376 if Is_Concurrent_Record_Type
(Typ
) then
3377 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
3382 -- where I will be used to capture the entry index of the primitive
3383 -- wrapper at position S.
3386 Make_Object_Declaration
(Loc
,
3387 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uI
),
3388 Object_Definition
=>
3389 New_Occurrence_Of
(Standard_Integer
, Loc
)));
3392 -- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
3394 -- if C = POK_Procedure
3395 -- or else C = POK_Protected_Procedure
3396 -- or else C = POK_Task_Procedure;
3402 Build_Common_Dispatching_Select_Statements
(Typ
, Stmts
);
3405 -- I := Get_Entry_Index (tag! (<type>VP), S);
3407 -- I is the entry index and S is the dispatch table slot
3409 if Tagged_Type_Expansion
then
3411 Unchecked_Convert_To
(RTE
(RE_Tag
),
3413 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
3417 Make_Attribute_Reference
(Loc
,
3418 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
3419 Attribute_Name
=> Name_Tag
);
3423 Make_Assignment_Statement
(Loc
,
3424 Name
=> Make_Identifier
(Loc
, Name_uI
),
3426 Make_Function_Call
(Loc
,
3427 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
3428 Parameter_Associations
=> New_List
(
3430 Make_Identifier
(Loc
, Name_uS
)))));
3434 if Ekind
(Conc_Typ
) = E_Protected_Type
then
3436 -- Build T._object'Access
3439 Make_Attribute_Reference
(Loc
,
3440 Attribute_Name
=> Name_Unchecked_Access
,
3442 Make_Selected_Component
(Loc
,
3443 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
3444 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
3446 -- Normal case, No_Entry_Queue restriction not active. In this
3447 -- case we generate:
3449 -- Timed_Protected_Entry_Call
3450 -- (T._object'access,
3451 -- Protected_Entry_Index! (I),
3454 -- where T is the protected object, I is the entry index, P are
3455 -- the wrapped parameters, D is the delay amount, M is the delay
3456 -- mode and F is the status flag.
3458 -- Historically, there was also an implementation for single
3459 -- entry protected types (in s-tposen). However, it was removed
3460 -- by also testing for no No_Select_Statements restriction in
3461 -- Exp_Utils.Corresponding_Runtime_Package. This simplified the
3462 -- implementation of s-tposen.adb and provided consistency between
3463 -- all versions of System.Tasking.Protected_Objects.Single_Entry
3466 case Corresponding_Runtime_Package
(Conc_Typ
) is
3467 when System_Tasking_Protected_Objects_Entries
=>
3469 Make_Procedure_Call_Statement
(Loc
,
3472 (RTE
(RE_Timed_Protected_Entry_Call
), Loc
),
3473 Parameter_Associations
=> New_List
(
3476 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3479 (RTE
(RE_Protected_Entry_Index
), Loc
),
3480 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3482 Make_Identifier
(Loc
, Name_uP
), -- parameter block
3483 Make_Identifier
(Loc
, Name_uD
), -- delay
3484 Make_Identifier
(Loc
, Name_uM
), -- delay mode
3485 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
3488 raise Program_Error
;
3494 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
3497 -- Timed_Task_Entry_Call (
3499 -- Task_Entry_Index! (I),
3505 -- where T is the task object, I is the entry index, P are the
3506 -- wrapped parameters, D is the delay amount, M is the delay
3507 -- mode and F is the status flag.
3510 Make_Procedure_Call_Statement
(Loc
,
3512 New_Occurrence_Of
(RTE
(RE_Timed_Task_Entry_Call
), Loc
),
3514 Parameter_Associations
=> New_List
(
3515 Make_Selected_Component
(Loc
, -- T._task_id
3516 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
3517 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3519 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3521 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
3522 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3524 Make_Identifier
(Loc
, Name_uP
), -- parameter block
3525 Make_Identifier
(Loc
, Name_uD
), -- delay
3526 Make_Identifier
(Loc
, Name_uM
), -- delay mode
3527 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
3531 -- Initialize out parameters
3534 Make_Assignment_Statement
(Loc
,
3535 Name
=> Make_Identifier
(Loc
, Name_uF
),
3536 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3538 Make_Assignment_Statement
(Loc
,
3539 Name
=> Make_Identifier
(Loc
, Name_uC
),
3540 Expression
=> New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
)));
3544 Make_Subprogram_Body
(Loc
,
3545 Specification
=> Make_Disp_Timed_Select_Spec
(Typ
),
3546 Declarations
=> Decls
,
3547 Handled_Statement_Sequence
=>
3548 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
3549 end Make_Disp_Timed_Select_Body
;
3551 ---------------------------------
3552 -- Make_Disp_Timed_Select_Spec --
3553 ---------------------------------
3555 function Make_Disp_Timed_Select_Spec
3556 (Typ
: Entity_Id
) return Node_Id
3558 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3559 Def_Id
: constant Node_Id
:=
3560 Make_Defining_Identifier
(Loc
,
3561 Name_uDisp_Timed_Select
);
3562 Params
: constant List_Id
:= New_List
;
3565 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3567 -- T : in out Typ; -- Object parameter
3568 -- S : Integer; -- Primitive operation slot
3569 -- P : Address; -- Wrapped parameters
3570 -- D : Duration; -- Delay
3571 -- M : Integer; -- Delay Mode
3572 -- C : out Prim_Op_Kind; -- Call kind
3573 -- F : out Boolean; -- Status flag
3575 Append_List_To
(Params
, New_List
(
3577 Make_Parameter_Specification
(Loc
,
3578 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
3579 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
3581 Out_Present
=> True),
3583 Make_Parameter_Specification
(Loc
,
3584 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
3585 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3587 Make_Parameter_Specification
(Loc
,
3588 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
3589 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3591 Make_Parameter_Specification
(Loc
,
3592 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uD
),
3593 Parameter_Type
=> New_Occurrence_Of
(Standard_Duration
, Loc
)),
3595 Make_Parameter_Specification
(Loc
,
3596 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uM
),
3597 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3599 Make_Parameter_Specification
(Loc
,
3600 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
3602 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
3603 Out_Present
=> True)));
3606 Make_Parameter_Specification
(Loc
,
3607 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
3608 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3609 Out_Present
=> True));
3612 Make_Procedure_Specification
(Loc
,
3613 Defining_Unit_Name
=> Def_Id
,
3614 Parameter_Specifications
=> Params
);
3615 end Make_Disp_Timed_Select_Spec
;
3621 -- The frontend supports two models for expanding dispatch tables
3622 -- associated with library-level defined tagged types: statically and
3623 -- non-statically allocated dispatch tables. In the former case the object
3624 -- containing the dispatch table is constant and it is initialized by means
3625 -- of a positional aggregate. In the latter case, the object containing
3626 -- the dispatch table is a variable which is initialized by means of
3629 -- In case of locally defined tagged types, the object containing the
3630 -- object containing the dispatch table is always a variable (instead of a
3631 -- constant). This is currently required to give support to late overriding
3632 -- of primitives. For example:
3634 -- procedure Example is
3636 -- type T1 is tagged null record;
3637 -- procedure Prim (O : T1);
3640 -- type T2 is new Pkg.T1 with null record;
3641 -- procedure Prim (X : T2) is -- late overriding
3647 function Make_DT
(Typ
: Entity_Id
; N
: Node_Id
:= Empty
) return List_Id
is
3648 GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
3649 -- Save the current Ghost mode in effect in case the tagged type sets a
3652 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3654 Max_Predef_Prims
: constant Int
:=
3658 (Parent
(RTE
(RE_Max_Predef_Prims
)))));
3660 DT_Decl
: constant Elist_Id
:= New_Elmt_List
;
3661 DT_Aggr
: constant Elist_Id
:= New_Elmt_List
;
3662 -- Entities marked with attribute Is_Dispatch_Table_Entity
3664 procedure Check_Premature_Freezing
3666 Tagged_Type
: Entity_Id
;
3668 -- Verify that all untagged types in the profile of a subprogram are
3669 -- frozen at the point the subprogram is frozen. This enforces the rule
3670 -- on RM 13.14 (14) as modified by AI05-019. At the point a subprogram
3671 -- is frozen, enough must be known about it to build the activation
3672 -- record for it, which requires at least that the size of all
3673 -- parameters be known. Controlling arguments are by-reference,
3674 -- and therefore the rule only applies to untagged types. Typical
3675 -- violation of the rule involves an object declaration that freezes a
3676 -- tagged type, when one of its primitive operations has a type in its
3677 -- profile whose full view has not been analyzed yet. More complex cases
3678 -- involve composite types that have one private unfrozen subcomponent.
3680 procedure Export_DT
(Typ
: Entity_Id
; DT
: Entity_Id
; Index
: Nat
:= 0);
3681 -- Export the dispatch table DT of tagged type Typ. Required to generate
3682 -- forward references and statically allocate the table. For primary
3683 -- dispatch tables Index is 0; for secondary dispatch tables the value
3684 -- of index must match the Suffix_Index value assigned to the table by
3685 -- Make_Tags when generating its unique external name, and it is used to
3686 -- retrieve from the Dispatch_Table_Wrappers list associated with Typ
3687 -- the external name generated by Import_DT.
3689 procedure Make_Secondary_DT
3693 Num_Iface_Prims
: Nat
;
3694 Iface_DT_Ptr
: Entity_Id
;
3695 Predef_Prims_Ptr
: Entity_Id
;
3696 Build_Thunks
: Boolean;
3698 -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch
3699 -- Table of Typ associated with Iface. Each abstract interface of Typ
3700 -- has two secondary dispatch tables: one containing pointers to thunks
3701 -- and another containing pointers to the primitives covering the
3702 -- interface primitives. The former secondary table is generated when
3703 -- Build_Thunks is True, and provides common support for dispatching
3704 -- calls through interface types; the latter secondary table is
3705 -- generated when Build_Thunks is False, and provides support for
3706 -- Generic Dispatching Constructors that dispatch calls through
3707 -- interface types. When constructing this latter table the value of
3708 -- Suffix_Index is -1 to indicate that there is no need to export such
3709 -- table when building statically allocated dispatch tables; a positive
3710 -- value of Suffix_Index must match the Suffix_Index value assigned to
3711 -- this secondary dispatch table by Make_Tags when its unique external
3712 -- name was generated.
3714 procedure Restore_Globals
;
3715 -- Restore the values of all saved global variables
3717 ------------------------------
3718 -- Check_Premature_Freezing --
3719 ------------------------------
3721 procedure Check_Premature_Freezing
3723 Tagged_Type
: Entity_Id
;
3728 function Is_Actual_For_Formal_Incomplete_Type
3729 (T
: Entity_Id
) return Boolean;
3730 -- In Ada 2012, if a nested generic has an incomplete formal type,
3731 -- the actual may be (and usually is) a private type whose completion
3732 -- appears later. It is safe to build the dispatch table in this
3733 -- case, gigi will have full views available.
3735 ------------------------------------------
3736 -- Is_Actual_For_Formal_Incomplete_Type --
3737 ------------------------------------------
3739 function Is_Actual_For_Formal_Incomplete_Type
3740 (T
: Entity_Id
) return Boolean
3742 Gen_Par
: Entity_Id
;
3746 if not Is_Generic_Instance
(Current_Scope
)
3747 or else not Used_As_Generic_Actual
(T
)
3751 Gen_Par
:= Generic_Parent
(Parent
(Current_Scope
));
3756 (Generic_Formal_Declarations
3757 (Unit_Declaration_Node
(Gen_Par
)));
3758 while Present
(F
) loop
3759 if Ekind
(Defining_Identifier
(F
)) = E_Incomplete_Type
then
3767 end Is_Actual_For_Formal_Incomplete_Type
;
3769 -- Start of processing for Check_Premature_Freezing
3772 -- Note that if the type is a (subtype of) a generic actual, the
3773 -- actual will have been frozen by the instantiation.
3776 and then Is_Private_Type
(Typ
)
3777 and then No
(Full_View
(Typ
))
3778 and then not Is_Generic_Type
(Typ
)
3779 and then not Is_Tagged_Type
(Typ
)
3780 and then not Is_Frozen
(Typ
)
3781 and then not Is_Generic_Actual_Type
(Typ
)
3783 Error_Msg_Sloc
:= Sloc
(Subp
);
3785 ("declaration must appear after completion of type &", N
, Typ
);
3787 ("\which is an untagged type in the profile of "
3788 & "primitive operation & declared#", N
, Subp
);
3791 Comp
:= Private_Component
(Typ
);
3793 if not Is_Tagged_Type
(Typ
)
3794 and then Present
(Comp
)
3795 and then not Is_Frozen
(Comp
)
3796 and then not Is_Actual_For_Formal_Incomplete_Type
(Comp
)
3798 Error_Msg_Sloc
:= Sloc
(Subp
);
3799 Error_Msg_Node_2
:= Subp
;
3800 Error_Msg_Name_1
:= Chars
(Tagged_Type
);
3802 ("declaration must appear after completion of type &",
3805 ("\which is a component of untagged type& in the profile "
3806 & "of primitive & of type % that is frozen by the "
3807 & "declaration ", N
, Typ
);
3810 end Check_Premature_Freezing
;
3816 procedure Export_DT
(Typ
: Entity_Id
; DT
: Entity_Id
; Index
: Nat
:= 0)
3822 Set_Is_Statically_Allocated
(DT
);
3823 Set_Is_True_Constant
(DT
);
3824 Set_Is_Exported
(DT
);
3827 Elmt
:= First_Elmt
(Dispatch_Table_Wrappers
(Typ
));
3828 while Count
/= Index
loop
3833 pragma Assert
(Related_Type
(Node
(Elmt
)) = Typ
);
3835 Get_External_Name
(Node
(Elmt
));
3836 Set_Interface_Name
(DT
,
3837 Make_String_Literal
(Loc
,
3838 Strval
=> String_From_Name_Buffer
));
3840 -- Ensure proper Sprint output of this implicit importation
3842 Set_Is_Internal
(DT
);
3846 -----------------------
3847 -- Make_Secondary_DT --
3848 -----------------------
3850 procedure Make_Secondary_DT
3854 Num_Iface_Prims
: Nat
;
3855 Iface_DT_Ptr
: Entity_Id
;
3856 Predef_Prims_Ptr
: Entity_Id
;
3857 Build_Thunks
: Boolean;
3860 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3861 Exporting_Table
: constant Boolean :=
3862 Building_Static_DT
(Typ
)
3863 and then Suffix_Index
> 0;
3864 Iface_DT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
3865 Predef_Prims
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
3866 DT_Constr_List
: List_Id
;
3867 DT_Aggr_List
: List_Id
;
3868 Empty_DT
: Boolean := False;
3869 Nb_Predef_Prims
: Nat
:= 0;
3873 OSD_Aggr_List
: List_Id
;
3876 Prim_Elmt
: Elmt_Id
;
3877 Prim_Ops_Aggr_List
: List_Id
;
3880 -- Handle cases in which we do not generate statically allocated
3883 if not Building_Static_DT
(Typ
) then
3884 Set_Ekind
(Predef_Prims
, E_Variable
);
3885 Set_Ekind
(Iface_DT
, E_Variable
);
3887 -- Statically allocated dispatch tables and related entities are
3891 Set_Ekind
(Predef_Prims
, E_Constant
);
3892 Set_Is_Statically_Allocated
(Predef_Prims
);
3893 Set_Is_True_Constant
(Predef_Prims
);
3895 Set_Ekind
(Iface_DT
, E_Constant
);
3896 Set_Is_Statically_Allocated
(Iface_DT
);
3897 Set_Is_True_Constant
(Iface_DT
);
3900 -- Calculate the number of slots of the dispatch table. If the number
3901 -- of primitives of Typ is 0 we reserve a dummy single entry for its
3902 -- DT because at run time the pointer to this dummy entry will be
3905 if Num_Iface_Prims
= 0 then
3909 Nb_Prim
:= Num_Iface_Prims
;
3914 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
3915 -- (predef-prim-op-thunk-1'address,
3916 -- predef-prim-op-thunk-2'address,
3918 -- predef-prim-op-thunk-n'address);
3919 -- for Predef_Prims'Alignment use Address'Alignment
3921 -- Stage 1: Calculate the number of predefined primitives
3923 if not Building_Static_DT
(Typ
) then
3924 Nb_Predef_Prims
:= Max_Predef_Prims
;
3926 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
3927 while Present
(Prim_Elmt
) loop
3928 Prim
:= Node
(Prim_Elmt
);
3930 if Is_Predefined_Dispatching_Operation
(Prim
)
3931 and then not Is_Abstract_Subprogram
(Prim
)
3933 Pos
:= UI_To_Int
(DT_Position
(Prim
));
3935 if Pos
> Nb_Predef_Prims
then
3936 Nb_Predef_Prims
:= Pos
;
3940 Next_Elmt
(Prim_Elmt
);
3944 -- Stage 2: Create the thunks associated with the predefined
3945 -- primitives and save their entity to fill the aggregate.
3948 Prim_Table
: array (Nat
range 1 .. Nb_Predef_Prims
) of Entity_Id
;
3950 Thunk_Id
: Entity_Id
;
3951 Thunk_Code
: Node_Id
;
3954 Prim_Ops_Aggr_List
:= New_List
;
3955 Prim_Table
:= (others => Empty
);
3957 if Building_Static_DT
(Typ
) then
3958 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
3959 while Present
(Prim_Elmt
) loop
3960 Prim
:= Node
(Prim_Elmt
);
3962 if Is_Predefined_Dispatching_Operation
(Prim
)
3963 and then not Is_Abstract_Subprogram
(Prim
)
3964 and then not Is_Eliminated
(Prim
)
3965 and then not Present
(Prim_Table
3966 (UI_To_Int
(DT_Position
(Prim
))))
3968 if not Build_Thunks
then
3969 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) :=
3973 Expand_Interface_Thunk
3974 (Ultimate_Alias
(Prim
), Thunk_Id
, Thunk_Code
);
3976 if Present
(Thunk_Id
) then
3977 Append_To
(Result
, Thunk_Code
);
3978 Prim_Table
(UI_To_Int
(DT_Position
(Prim
)))
3984 Next_Elmt
(Prim_Elmt
);
3988 for J
in Prim_Table
'Range loop
3989 if Present
(Prim_Table
(J
)) then
3991 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
3992 Make_Attribute_Reference
(Loc
,
3993 Prefix
=> New_Occurrence_Of
(Prim_Table
(J
), Loc
),
3994 Attribute_Name
=> Name_Unrestricted_Access
));
3996 New_Node
:= Make_Null
(Loc
);
3999 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
4003 Make_Aggregate
(Loc
, Expressions
=> Prim_Ops_Aggr_List
);
4005 -- Remember aggregates initializing dispatch tables
4007 Append_Elmt
(New_Node
, DT_Aggr
);
4010 Make_Subtype_Declaration
(Loc
,
4011 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
4012 Subtype_Indication
=>
4013 New_Occurrence_Of
(RTE
(RE_Address_Array
), Loc
));
4015 Append_To
(Result
, Decl
);
4018 Make_Object_Declaration
(Loc
,
4019 Defining_Identifier
=> Predef_Prims
,
4020 Constant_Present
=> Building_Static_DT
(Typ
),
4021 Aliased_Present
=> True,
4022 Object_Definition
=> New_Occurrence_Of
4023 (Defining_Identifier
(Decl
), Loc
),
4024 Expression
=> New_Node
));
4027 Make_Attribute_Definition_Clause
(Loc
,
4028 Name
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
4029 Chars
=> Name_Alignment
,
4031 Make_Attribute_Reference
(Loc
,
4033 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4034 Attribute_Name
=> Name_Alignment
)));
4039 -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
4040 -- (OSD_Table => (1 => <value>,
4044 -- Iface_DT : Dispatch_Table (Nb_Prims) :=
4045 -- ([ Signature => <sig-value> ],
4046 -- Tag_Kind => <tag_kind-value>,
4047 -- Predef_Prims => Predef_Prims'Address,
4048 -- Offset_To_Top => 0,
4049 -- OSD => OSD'Address,
4050 -- Prims_Ptr => (prim-op-1'address,
4051 -- prim-op-2'address,
4053 -- prim-op-n'address));
4054 -- for Iface_DT'Alignment use Address'Alignment;
4056 -- Stage 3: Initialize the discriminant and the record components
4058 DT_Constr_List
:= New_List
;
4059 DT_Aggr_List
:= New_List
;
4063 Append_To
(DT_Constr_List
, Make_Integer_Literal
(Loc
, Nb_Prim
));
4064 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, Nb_Prim
));
4068 if RTE_Record_Component_Available
(RE_Signature
) then
4069 Append_To
(DT_Aggr_List
,
4070 New_Occurrence_Of
(RTE
(RE_Secondary_DT
), Loc
));
4075 if RTE_Record_Component_Available
(RE_Tag_Kind
) then
4076 Append_To
(DT_Aggr_List
, Tagged_Kind
(Typ
));
4081 Append_To
(DT_Aggr_List
,
4082 Make_Attribute_Reference
(Loc
,
4083 Prefix
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
4084 Attribute_Name
=> Name_Address
));
4086 -- Note: The correct value of Offset_To_Top will be set by the init
4089 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
4091 -- Generate the Object Specific Data table required to dispatch calls
4092 -- through synchronized interfaces.
4095 or else Is_Abstract_Type
(Typ
)
4096 or else Is_Controlled
(Typ
)
4097 or else Restriction_Active
(No_Dispatching_Calls
)
4098 or else not Is_Limited_Type
(Typ
)
4099 or else not Has_Interfaces
(Typ
)
4100 or else not Build_Thunks
4101 or else not RTE_Record_Component_Available
(RE_OSD_Table
)
4103 -- No OSD table required
4105 Append_To
(DT_Aggr_List
,
4106 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
4109 OSD_Aggr_List
:= New_List
;
4112 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
4114 Prim_Alias
: Entity_Id
;
4115 Prim_Elmt
: Elmt_Id
;
4121 Prim_Table
:= (others => Empty
);
4122 Prim_Alias
:= Empty
;
4124 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4125 while Present
(Prim_Elmt
) loop
4126 Prim
:= Node
(Prim_Elmt
);
4128 if Present
(Interface_Alias
(Prim
))
4129 and then Find_Dispatching_Type
4130 (Interface_Alias
(Prim
)) = Iface
4132 Prim_Alias
:= Interface_Alias
(Prim
);
4133 E
:= Ultimate_Alias
(Prim
);
4134 Pos
:= UI_To_Int
(DT_Position
(Prim_Alias
));
4136 if Present
(Prim_Table
(Pos
)) then
4137 pragma Assert
(Prim_Table
(Pos
) = E
);
4141 Prim_Table
(Pos
) := E
;
4143 Append_To
(OSD_Aggr_List
,
4144 Make_Component_Association
(Loc
,
4145 Choices
=> New_List
(
4146 Make_Integer_Literal
(Loc
,
4147 DT_Position
(Prim_Alias
))),
4149 Make_Integer_Literal
(Loc
,
4150 DT_Position
(Alias
(Prim
)))));
4156 Next_Elmt
(Prim_Elmt
);
4158 pragma Assert
(Count
= Nb_Prim
);
4161 OSD
:= Make_Temporary
(Loc
, 'I');
4164 Make_Object_Declaration
(Loc
,
4165 Defining_Identifier
=> OSD
,
4166 Object_Definition
=>
4167 Make_Subtype_Indication
(Loc
,
4169 New_Occurrence_Of
(RTE
(RE_Object_Specific_Data
), Loc
),
4171 Make_Index_Or_Discriminant_Constraint
(Loc
,
4172 Constraints
=> New_List
(
4173 Make_Integer_Literal
(Loc
, Nb_Prim
)))),
4176 Make_Aggregate
(Loc
,
4177 Component_Associations
=> New_List
(
4178 Make_Component_Association
(Loc
,
4179 Choices
=> New_List
(
4181 (RTE_Record_Component
(RE_OSD_Num_Prims
), Loc
)),
4183 Make_Integer_Literal
(Loc
, Nb_Prim
)),
4185 Make_Component_Association
(Loc
,
4186 Choices
=> New_List
(
4188 (RTE_Record_Component
(RE_OSD_Table
), Loc
)),
4189 Expression
=> Make_Aggregate
(Loc
,
4190 Component_Associations
=> OSD_Aggr_List
))))));
4193 Make_Attribute_Definition_Clause
(Loc
,
4194 Name
=> New_Occurrence_Of
(OSD
, Loc
),
4195 Chars
=> Name_Alignment
,
4197 Make_Attribute_Reference
(Loc
,
4199 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4200 Attribute_Name
=> Name_Alignment
)));
4202 -- In secondary dispatch tables the Typeinfo component contains
4203 -- the address of the Object Specific Data (see a-tags.ads)
4205 Append_To
(DT_Aggr_List
,
4206 Make_Attribute_Reference
(Loc
,
4207 Prefix
=> New_Occurrence_Of
(OSD
, Loc
),
4208 Attribute_Name
=> Name_Address
));
4211 -- Initialize the table of primitive operations
4213 Prim_Ops_Aggr_List
:= New_List
;
4216 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
4218 elsif Is_Abstract_Type
(Typ
)
4219 or else not Building_Static_DT
(Typ
)
4221 for J
in 1 .. Nb_Prim
loop
4222 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
4227 CPP_Nb_Prims
: constant Nat
:= CPP_Num_Prims
(Typ
);
4230 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
4231 Thunk_Code
: Node_Id
;
4232 Thunk_Id
: Entity_Id
;
4235 Prim_Table
:= (others => Empty
);
4237 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4238 while Present
(Prim_Elmt
) loop
4239 Prim
:= Node
(Prim_Elmt
);
4240 E
:= Ultimate_Alias
(Prim
);
4241 Prim_Pos
:= UI_To_Int
(DT_Position
(E
));
4243 -- Do not reference predefined primitives because they are
4244 -- located in a separate dispatch table; skip abstract and
4245 -- eliminated primitives; skip primitives located in the C++
4246 -- part of the dispatch table because their slot is set by
4249 if not Is_Predefined_Dispatching_Operation
(Prim
)
4250 and then Present
(Interface_Alias
(Prim
))
4251 and then not Is_Abstract_Subprogram
(Alias
(Prim
))
4252 and then not Is_Eliminated
(Alias
(Prim
))
4253 and then (not Is_CPP_Class
(Root_Type
(Typ
))
4254 or else Prim_Pos
> CPP_Nb_Prims
)
4255 and then Find_Dispatching_Type
4256 (Interface_Alias
(Prim
)) = Iface
4258 -- Generate the code of the thunk only if the abstract
4259 -- interface type is not an immediate ancestor of
4260 -- Tagged_Type. Otherwise the DT associated with the
4261 -- interface is the primary DT.
4263 and then not Is_Ancestor
(Iface
, Typ
,
4264 Use_Full_View
=> True)
4266 if not Build_Thunks
then
4268 UI_To_Int
(DT_Position
(Interface_Alias
(Prim
)));
4269 Prim_Table
(Prim_Pos
) := Alias
(Prim
);
4272 Expand_Interface_Thunk
(Prim
, Thunk_Id
, Thunk_Code
);
4274 if Present
(Thunk_Id
) then
4276 UI_To_Int
(DT_Position
(Interface_Alias
(Prim
)));
4278 Prim_Table
(Prim_Pos
) := Thunk_Id
;
4279 Append_To
(Result
, Thunk_Code
);
4284 Next_Elmt
(Prim_Elmt
);
4287 for J
in Prim_Table
'Range loop
4288 if Present
(Prim_Table
(J
)) then
4290 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
4291 Make_Attribute_Reference
(Loc
,
4292 Prefix
=> New_Occurrence_Of
(Prim_Table
(J
), Loc
),
4293 Attribute_Name
=> Name_Unrestricted_Access
));
4296 New_Node
:= Make_Null
(Loc
);
4299 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
4305 Make_Aggregate
(Loc
,
4306 Expressions
=> Prim_Ops_Aggr_List
);
4308 Append_To
(DT_Aggr_List
, New_Node
);
4310 -- Remember aggregates initializing dispatch tables
4312 Append_Elmt
(New_Node
, DT_Aggr
);
4314 -- Note: Secondary dispatch tables cannot be declared constant
4315 -- because the component Offset_To_Top is currently initialized
4316 -- by the IP routine.
4319 Make_Object_Declaration
(Loc
,
4320 Defining_Identifier
=> Iface_DT
,
4321 Aliased_Present
=> True,
4322 Constant_Present
=> False,
4324 Object_Definition
=>
4325 Make_Subtype_Indication
(Loc
,
4326 Subtype_Mark
=> New_Occurrence_Of
4327 (RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
4328 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
4329 Constraints
=> DT_Constr_List
)),
4332 Make_Aggregate
(Loc
,
4333 Expressions
=> DT_Aggr_List
)));
4336 Make_Attribute_Definition_Clause
(Loc
,
4337 Name
=> New_Occurrence_Of
(Iface_DT
, Loc
),
4338 Chars
=> Name_Alignment
,
4341 Make_Attribute_Reference
(Loc
,
4343 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4344 Attribute_Name
=> Name_Alignment
)));
4346 if Exporting_Table
then
4347 Export_DT
(Typ
, Iface_DT
, Suffix_Index
);
4349 -- Generate code to create the pointer to the dispatch table
4351 -- Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address);
4353 -- Note: This declaration is not added here if the table is exported
4354 -- because in such case Make_Tags has already added this declaration.
4358 Make_Object_Declaration
(Loc
,
4359 Defining_Identifier
=> Iface_DT_Ptr
,
4360 Constant_Present
=> True,
4362 Object_Definition
=>
4363 New_Occurrence_Of
(RTE
(RE_Interface_Tag
), Loc
),
4366 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
4367 Make_Attribute_Reference
(Loc
,
4369 Make_Selected_Component
(Loc
,
4370 Prefix
=> New_Occurrence_Of
(Iface_DT
, Loc
),
4373 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
4374 Attribute_Name
=> Name_Address
))));
4378 Make_Object_Declaration
(Loc
,
4379 Defining_Identifier
=> Predef_Prims_Ptr
,
4380 Constant_Present
=> True,
4382 Object_Definition
=>
4383 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
4386 Make_Attribute_Reference
(Loc
,
4388 Make_Selected_Component
(Loc
,
4389 Prefix
=> New_Occurrence_Of
(Iface_DT
, Loc
),
4392 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
4393 Attribute_Name
=> Name_Address
)));
4395 -- Remember entities containing dispatch tables
4397 Append_Elmt
(Predef_Prims
, DT_Decl
);
4398 Append_Elmt
(Iface_DT
, DT_Decl
);
4399 end Make_Secondary_DT
;
4401 ---------------------
4402 -- Restore_Globals --
4403 ---------------------
4405 procedure Restore_Globals
is
4408 end Restore_Globals
;
4412 Elab_Code
: constant List_Id
:= New_List
;
4413 Result
: constant List_Id
:= New_List
;
4414 Tname
: constant Name_Id
:= Chars
(Typ
);
4416 AI_Tag_Elmt
: Elmt_Id
;
4417 AI_Tag_Comp
: Elmt_Id
;
4418 DT_Aggr_List
: List_Id
;
4419 DT_Constr_List
: List_Id
;
4423 Iface_Table_Node
: Node_Id
;
4424 Name_ITable
: Name_Id
;
4425 Nb_Predef_Prims
: Nat
:= 0;
4428 Num_Ifaces
: Nat
:= 0;
4429 Parent_Typ
: Entity_Id
;
4431 Prim_Elmt
: Elmt_Id
;
4432 Prim_Ops_Aggr_List
: List_Id
;
4434 Typ_Comps
: Elist_Id
;
4435 Typ_Ifaces
: Elist_Id
;
4436 TSD_Aggr_List
: List_Id
;
4437 TSD_Tags_List
: List_Id
;
4439 -- The following name entries are used by Make_DT to generate a number
4440 -- of entities related to a tagged type. These entities may be generated
4441 -- in a scope other than that of the tagged type declaration, and if
4442 -- the entities for two tagged types with the same name happen to be
4443 -- generated in the same scope, we have to take care to use different
4444 -- names. This is achieved by means of a unique serial number appended
4445 -- to each generated entity name.
4447 Name_DT
: constant Name_Id
:=
4448 New_External_Name
(Tname
, 'T', Suffix_Index
=> -1);
4449 Name_Exname
: constant Name_Id
:=
4450 New_External_Name
(Tname
, 'E', Suffix_Index
=> -1);
4451 Name_HT_Link
: constant Name_Id
:=
4452 New_External_Name
(Tname
, 'H', Suffix_Index
=> -1);
4453 Name_Predef_Prims
: constant Name_Id
:=
4454 New_External_Name
(Tname
, 'R', Suffix_Index
=> -1);
4455 Name_SSD
: constant Name_Id
:=
4456 New_External_Name
(Tname
, 'S', Suffix_Index
=> -1);
4457 Name_TSD
: constant Name_Id
:=
4458 New_External_Name
(Tname
, 'B', Suffix_Index
=> -1);
4460 -- Entities built with above names
4462 DT
: constant Entity_Id
:=
4463 Make_Defining_Identifier
(Loc
, Name_DT
);
4464 Exname
: constant Entity_Id
:=
4465 Make_Defining_Identifier
(Loc
, Name_Exname
);
4466 HT_Link
: constant Entity_Id
:=
4467 Make_Defining_Identifier
(Loc
, Name_HT_Link
);
4468 Predef_Prims
: constant Entity_Id
:=
4469 Make_Defining_Identifier
(Loc
, Name_Predef_Prims
);
4470 SSD
: constant Entity_Id
:=
4471 Make_Defining_Identifier
(Loc
, Name_SSD
);
4472 TSD
: constant Entity_Id
:=
4473 Make_Defining_Identifier
(Loc
, Name_TSD
);
4475 -- Start of processing for Make_DT
4478 pragma Assert
(Is_Frozen
(Typ
));
4480 -- The tagged type being processed may be subject to pragma Ghost with
4481 -- policy Ignore. Set the mode now to ensure that any nodes generated
4482 -- during dispatch table creation are properly flagged as ignored Ghost.
4484 Set_Ghost_Mode
(Declaration_Node
(Typ
), Typ
);
4486 -- Handle cases in which there is no need to build the dispatch table
4488 if Has_Dispatch_Table
(Typ
)
4489 or else No
(Access_Disp_Table
(Typ
))
4490 or else Is_CPP_Class
(Typ
)
4491 or else Convention
(Typ
) = Convention_CIL
4492 or else Convention
(Typ
) = Convention_Java
4497 elsif No_Run_Time_Mode
then
4498 Error_Msg_CRT
("tagged types", Typ
);
4502 elsif not RTE_Available
(RE_Tag
) then
4504 Make_Object_Declaration
(Loc
,
4505 Defining_Identifier
=> Node
(First_Elmt
4506 (Access_Disp_Table
(Typ
))),
4507 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
4508 Constant_Present
=> True,
4510 Unchecked_Convert_To
(RTE
(RE_Tag
),
4511 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
4513 Analyze_List
(Result
, Suppress
=> All_Checks
);
4514 Error_Msg_CRT
("tagged types", Typ
);
4519 -- Ensure that the value of Max_Predef_Prims defined in a-tags is
4520 -- correct. Valid values are 9 under configurable runtime or 15
4521 -- with full runtime.
4523 if RTE_Available
(RE_Interface_Data
) then
4524 if Max_Predef_Prims
/= 15 then
4525 Error_Msg_N
("run-time library configuration error", Typ
);
4530 if Max_Predef_Prims
/= 9 then
4531 Error_Msg_N
("run-time library configuration error", Typ
);
4532 Error_Msg_CRT
("tagged types", Typ
);
4538 -- Initialize Parent_Typ handling private types
4540 Parent_Typ
:= Etype
(Typ
);
4542 if Present
(Full_View
(Parent_Typ
)) then
4543 Parent_Typ
:= Full_View
(Parent_Typ
);
4546 -- Ensure that all the primitives are frozen. This is only required when
4547 -- building static dispatch tables --- the primitives must be frozen to
4548 -- be referenced (otherwise we have problems with the backend). It is
4549 -- not a requirement with nonstatic dispatch tables because in this case
4550 -- we generate now an empty dispatch table; the extra code required to
4551 -- register the primitives in the slots will be generated later --- when
4552 -- each primitive is frozen (see Freeze_Subprogram).
4554 if Building_Static_DT
(Typ
) then
4556 Save
: constant Boolean := Freezing_Library_Level_Tagged_Type
;
4558 Prim_Elmt
: Elmt_Id
;
4562 Freezing_Library_Level_Tagged_Type
:= True;
4564 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4565 while Present
(Prim_Elmt
) loop
4566 Prim
:= Node
(Prim_Elmt
);
4567 Frnodes
:= Freeze_Entity
(Prim
, Typ
);
4573 F
:= First_Formal
(Prim
);
4574 while Present
(F
) loop
4575 Check_Premature_Freezing
(Prim
, Typ
, Etype
(F
));
4579 Check_Premature_Freezing
(Prim
, Typ
, Etype
(Prim
));
4582 if Present
(Frnodes
) then
4583 Append_List_To
(Result
, Frnodes
);
4586 Next_Elmt
(Prim_Elmt
);
4589 Freezing_Library_Level_Tagged_Type
:= Save
;
4593 -- Ada 2005 (AI-251): Build the secondary dispatch tables
4595 if Has_Interfaces
(Typ
) then
4596 Collect_Interface_Components
(Typ
, Typ_Comps
);
4598 -- Each secondary dispatch table is assigned an unique positive
4599 -- suffix index; such value also corresponds with the location of
4600 -- its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
4602 -- Note: This value must be kept sync with the Suffix_Index values
4603 -- generated by Make_Tags
4607 Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
4609 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
4610 while Present
(AI_Tag_Comp
) loop
4611 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'P'));
4613 -- Build the secondary table containing pointers to thunks
4618 (Related_Type
(Node
(AI_Tag_Comp
))),
4619 Suffix_Index
=> Suffix_Index
,
4620 Num_Iface_Prims
=> UI_To_Int
4621 (DT_Entry_Count
(Node
(AI_Tag_Comp
))),
4622 Iface_DT_Ptr
=> Node
(AI_Tag_Elmt
),
4623 Predef_Prims_Ptr
=> Node
(Next_Elmt
(AI_Tag_Elmt
)),
4624 Build_Thunks
=> True,
4627 -- Skip secondary dispatch table referencing thunks to predefined
4630 Next_Elmt
(AI_Tag_Elmt
);
4631 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'Y'));
4633 -- Secondary dispatch table referencing user-defined primitives
4634 -- covered by this interface.
4636 Next_Elmt
(AI_Tag_Elmt
);
4637 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'D'));
4639 -- Build the secondary table containing pointers to primitives
4640 -- (used to give support to Generic Dispatching Constructors).
4645 (Related_Type
(Node
(AI_Tag_Comp
))),
4647 Num_Iface_Prims
=> UI_To_Int
4648 (DT_Entry_Count
(Node
(AI_Tag_Comp
))),
4649 Iface_DT_Ptr
=> Node
(AI_Tag_Elmt
),
4650 Predef_Prims_Ptr
=> Node
(Next_Elmt
(AI_Tag_Elmt
)),
4651 Build_Thunks
=> False,
4654 -- Skip secondary dispatch table referencing predefined primitives
4656 Next_Elmt
(AI_Tag_Elmt
);
4657 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'Z'));
4659 Suffix_Index
:= Suffix_Index
+ 1;
4660 Next_Elmt
(AI_Tag_Elmt
);
4661 Next_Elmt
(AI_Tag_Comp
);
4665 -- Get the _tag entity and number of primitives of its dispatch table
4667 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
4668 Nb_Prim
:= UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Typ
)));
4670 Set_Is_Statically_Allocated
(DT
, Is_Library_Level_Tagged_Type
(Typ
));
4671 Set_Is_Statically_Allocated
(SSD
, Is_Library_Level_Tagged_Type
(Typ
));
4672 Set_Is_Statically_Allocated
(TSD
, Is_Library_Level_Tagged_Type
(Typ
));
4673 Set_Is_Statically_Allocated
(Predef_Prims
,
4674 Is_Library_Level_Tagged_Type
(Typ
));
4676 -- In case of locally defined tagged type we declare the object
4677 -- containing the dispatch table by means of a variable. Its
4678 -- initialization is done later by means of an assignment. This is
4679 -- required to generate its External_Tag.
4681 if not Building_Static_DT
(Typ
) then
4684 -- DT : No_Dispatch_Table_Wrapper;
4685 -- for DT'Alignment use Address'Alignment;
4686 -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
4688 if not Has_DT
(Typ
) then
4690 Make_Object_Declaration
(Loc
,
4691 Defining_Identifier
=> DT
,
4692 Aliased_Present
=> True,
4693 Constant_Present
=> False,
4694 Object_Definition
=>
4696 (RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
)));
4699 Make_Attribute_Definition_Clause
(Loc
,
4700 Name
=> New_Occurrence_Of
(DT
, Loc
),
4701 Chars
=> Name_Alignment
,
4703 Make_Attribute_Reference
(Loc
,
4705 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4706 Attribute_Name
=> Name_Alignment
)));
4709 Make_Object_Declaration
(Loc
,
4710 Defining_Identifier
=> DT_Ptr
,
4711 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
4712 Constant_Present
=> True,
4714 Unchecked_Convert_To
(RTE
(RE_Tag
),
4715 Make_Attribute_Reference
(Loc
,
4717 Make_Selected_Component
(Loc
,
4718 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
4721 (RTE_Record_Component
(RE_NDT_Prims_Ptr
), Loc
)),
4722 Attribute_Name
=> Name_Address
))));
4724 Set_Is_Statically_Allocated
(DT_Ptr
,
4725 Is_Library_Level_Tagged_Type
(Typ
));
4727 -- Generate the SCIL node for the previous object declaration
4728 -- because it has a tag initialization.
4730 if Generate_SCIL
then
4732 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
4733 Set_SCIL_Entity
(New_Node
, Typ
);
4734 Set_SCIL_Node
(Last
(Result
), New_Node
);
4738 -- DT : Dispatch_Table_Wrapper (Nb_Prim);
4739 -- for DT'Alignment use Address'Alignment;
4740 -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
4743 -- If the tagged type has no primitives we add a dummy slot
4744 -- whose address will be the tag of this type.
4748 New_List
(Make_Integer_Literal
(Loc
, 1));
4751 New_List
(Make_Integer_Literal
(Loc
, Nb_Prim
));
4755 Make_Object_Declaration
(Loc
,
4756 Defining_Identifier
=> DT
,
4757 Aliased_Present
=> True,
4758 Constant_Present
=> False,
4759 Object_Definition
=>
4760 Make_Subtype_Indication
(Loc
,
4762 New_Occurrence_Of
(RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
4764 Make_Index_Or_Discriminant_Constraint
(Loc
,
4765 Constraints
=> DT_Constr_List
))));
4768 Make_Attribute_Definition_Clause
(Loc
,
4769 Name
=> New_Occurrence_Of
(DT
, Loc
),
4770 Chars
=> Name_Alignment
,
4772 Make_Attribute_Reference
(Loc
,
4774 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4775 Attribute_Name
=> Name_Alignment
)));
4778 Make_Object_Declaration
(Loc
,
4779 Defining_Identifier
=> DT_Ptr
,
4780 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
4781 Constant_Present
=> True,
4783 Unchecked_Convert_To
(RTE
(RE_Tag
),
4784 Make_Attribute_Reference
(Loc
,
4786 Make_Selected_Component
(Loc
,
4787 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
4790 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
4791 Attribute_Name
=> Name_Address
))));
4793 Set_Is_Statically_Allocated
(DT_Ptr
,
4794 Is_Library_Level_Tagged_Type
(Typ
));
4796 -- Generate the SCIL node for the previous object declaration
4797 -- because it has a tag initialization.
4799 if Generate_SCIL
then
4801 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
4802 Set_SCIL_Entity
(New_Node
, Typ
);
4803 Set_SCIL_Node
(Last
(Result
), New_Node
);
4807 Make_Object_Declaration
(Loc
,
4808 Defining_Identifier
=>
4809 Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
)))),
4810 Constant_Present
=> True,
4811 Object_Definition
=>
4812 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
4814 Make_Attribute_Reference
(Loc
,
4816 Make_Selected_Component
(Loc
,
4817 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
4820 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
4821 Attribute_Name
=> Name_Address
)));
4825 -- Generate: Exname : constant String := full_qualified_name (typ);
4826 -- The type itself may be an anonymous parent type, so use the first
4827 -- subtype to have a user-recognizable name.
4830 Make_Object_Declaration
(Loc
,
4831 Defining_Identifier
=> Exname
,
4832 Constant_Present
=> True,
4833 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
4835 Make_String_Literal
(Loc
,
4836 Strval
=> Fully_Qualified_Name_String
(First_Subtype
(Typ
)))));
4837 Set_Is_Statically_Allocated
(Exname
);
4838 Set_Is_True_Constant
(Exname
);
4840 -- Declare the object used by Ada.Tags.Register_Tag
4842 if RTE_Available
(RE_Register_Tag
) then
4844 Make_Object_Declaration
(Loc
,
4845 Defining_Identifier
=> HT_Link
,
4846 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
)));
4849 -- Generate code to create the storage for the type specific data object
4850 -- with enough space to store the tags of the ancestors plus the tags
4851 -- of all the implemented interfaces (as described in a-tags.adb).
4853 -- TSD : Type_Specific_Data (I_Depth) :=
4854 -- (Idepth => I_Depth,
4855 -- Access_Level => Type_Access_Level (Typ),
4856 -- Alignment => Typ'Alignment,
4857 -- Expanded_Name => Cstring_Ptr!(Exname'Address))
4858 -- External_Tag => Cstring_Ptr!(Exname'Address))
4859 -- HT_Link => HT_Link'Address,
4860 -- Transportable => <<boolean-value>>,
4861 -- Type_Is_Abstract => <<boolean-value>>,
4862 -- Needs_Finalization => <<boolean-value>>,
4863 -- [ Size_Func => Size_Prim'Access, ]
4864 -- [ Interfaces_Table => <<access-value>>, ]
4865 -- [ SSD => SSD_Table'Address ]
4866 -- Tags_Table => (0 => null,
4869 -- for TSD'Alignment use Address'Alignment
4871 TSD_Aggr_List
:= New_List
;
4873 -- Idepth: Count ancestors to compute the inheritance depth. For private
4874 -- extensions, always go to the full view in order to compute the real
4875 -- inheritance depth.
4878 Current_Typ
: Entity_Id
;
4879 Parent_Typ
: Entity_Id
;
4885 Parent_Typ
:= Etype
(Current_Typ
);
4887 if Is_Private_Type
(Parent_Typ
) then
4888 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
4891 exit when Parent_Typ
= Current_Typ
;
4893 I_Depth
:= I_Depth
+ 1;
4894 Current_Typ
:= Parent_Typ
;
4898 Append_To
(TSD_Aggr_List
,
4899 Make_Integer_Literal
(Loc
, I_Depth
));
4903 Append_To
(TSD_Aggr_List
,
4904 Make_Integer_Literal
(Loc
, Type_Access_Level
(Typ
)));
4908 -- For CPP types we cannot rely on the value of 'Alignment provided
4909 -- by the backend to initialize this TSD field.
4911 if Convention
(Typ
) = Convention_CPP
4912 or else Is_CPP_Class
(Root_Type
(Typ
))
4914 Append_To
(TSD_Aggr_List
,
4915 Make_Integer_Literal
(Loc
, 0));
4917 Append_To
(TSD_Aggr_List
,
4918 Make_Attribute_Reference
(Loc
,
4919 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
4920 Attribute_Name
=> Name_Alignment
));
4925 Append_To
(TSD_Aggr_List
,
4926 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
4927 Make_Attribute_Reference
(Loc
,
4928 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
4929 Attribute_Name
=> Name_Address
)));
4931 -- External_Tag of a local tagged type
4933 -- <typ>A : constant String :=
4934 -- "Internal tag at 16#tag-addr#: <full-name-of-typ>";
4936 -- The reason we generate this strange name is that we do not want to
4937 -- enter local tagged types in the global hash table used to compute
4938 -- the Internal_Tag attribute for two reasons:
4940 -- 1. It is hard to avoid a tasking race condition for entering the
4941 -- entry into the hash table.
4943 -- 2. It would cause a storage leak, unless we rig up considerable
4944 -- mechanism to remove the entry from the hash table on exit.
4946 -- So what we do is to generate the above external tag name, where the
4947 -- hex address is the address of the local dispatch table (i.e. exactly
4948 -- the value we want if Internal_Tag is computed from this string).
4950 -- Of course this value will only be valid if the tagged type is still
4951 -- in scope, but it clearly must be erroneous to compute the internal
4952 -- tag of a tagged type that is out of scope.
4954 -- We don't do this processing if an explicit external tag has been
4955 -- specified. That's an odd case for which we have already issued a
4956 -- warning, where we will not be able to compute the internal tag.
4958 if not Is_Library_Level_Entity
(Typ
)
4959 and then not Has_External_Tag_Rep_Clause
(Typ
)
4962 Exname
: constant Entity_Id
:=
4963 Make_Defining_Identifier
(Loc
,
4964 Chars
=> New_External_Name
(Tname
, 'A'));
4965 Full_Name
: constant String_Id
:=
4966 Fully_Qualified_Name_String
(First_Subtype
(Typ
));
4967 Str1_Id
: String_Id
;
4968 Str2_Id
: String_Id
;
4972 -- Str1 = "Internal tag at 16#";
4975 Store_String_Chars
("Internal tag at 16#");
4976 Str1_Id
:= End_String
;
4979 -- Str2 = "#: <type-full-name>";
4982 Store_String_Chars
("#: ");
4983 Store_String_Chars
(Full_Name
);
4984 Str2_Id
:= End_String
;
4987 -- Exname : constant String :=
4988 -- Str1 & Address_Image (Tag) & Str2;
4990 if RTE_Available
(RE_Address_Image
) then
4992 Make_Object_Declaration
(Loc
,
4993 Defining_Identifier
=> Exname
,
4994 Constant_Present
=> True,
4995 Object_Definition
=> New_Occurrence_Of
4996 (Standard_String
, Loc
),
4998 Make_Op_Concat
(Loc
,
4999 Left_Opnd
=> Make_String_Literal
(Loc
, Str1_Id
),
5001 Make_Op_Concat
(Loc
,
5003 Make_Function_Call
(Loc
,
5006 (RTE
(RE_Address_Image
), Loc
),
5007 Parameter_Associations
=> New_List
(
5008 Unchecked_Convert_To
(RTE
(RE_Address
),
5009 New_Occurrence_Of
(DT_Ptr
, Loc
)))),
5011 Make_String_Literal
(Loc
, Str2_Id
)))));
5015 Make_Object_Declaration
(Loc
,
5016 Defining_Identifier
=> Exname
,
5017 Constant_Present
=> True,
5018 Object_Definition
=>
5019 New_Occurrence_Of
(Standard_String
, Loc
),
5021 Make_Op_Concat
(Loc
,
5022 Left_Opnd
=> Make_String_Literal
(Loc
, Str1_Id
),
5023 Right_Opnd
=> Make_String_Literal
(Loc
, Str2_Id
))));
5027 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5028 Make_Attribute_Reference
(Loc
,
5029 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5030 Attribute_Name
=> Name_Address
));
5033 -- External tag of a library-level tagged type: Check for a definition
5034 -- of External_Tag. The clause is considered only if it applies to this
5035 -- specific tagged type, as opposed to one of its ancestors.
5036 -- If the type is an unconstrained type extension, we are building the
5037 -- dispatch table of its anonymous base type, so the external tag, if
5038 -- any was specified, must be retrieved from the first subtype. Go to
5039 -- the full view in case the clause is in the private part.
5043 Def
: constant Node_Id
:= Get_Attribute_Definition_Clause
5044 (Underlying_Type
(First_Subtype
(Typ
)),
5045 Attribute_External_Tag
);
5047 Old_Val
: String_Id
;
5048 New_Val
: String_Id
;
5052 if not Present
(Def
)
5053 or else Entity
(Name
(Def
)) /= First_Subtype
(Typ
)
5056 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5057 Make_Attribute_Reference
(Loc
,
5058 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5059 Attribute_Name
=> Name_Address
));
5061 Old_Val
:= Strval
(Expr_Value_S
(Expression
(Def
)));
5063 -- For the rep clause "for <typ>'external_tag use y" generate:
5065 -- <typ>A : constant string := y;
5067 -- <typ>A'Address is used to set the External_Tag component
5070 -- Create a new nul terminated string if it is not already
5072 if String_Length
(Old_Val
) > 0
5074 Get_String_Char
(Old_Val
, String_Length
(Old_Val
)) = 0
5078 Start_String
(Old_Val
);
5079 Store_String_Char
(Get_Char_Code
(ASCII
.NUL
));
5080 New_Val
:= End_String
;
5083 E
:= Make_Defining_Identifier
(Loc
,
5084 New_External_Name
(Chars
(Typ
), 'A'));
5087 Make_Object_Declaration
(Loc
,
5088 Defining_Identifier
=> E
,
5089 Constant_Present
=> True,
5090 Object_Definition
=>
5091 New_Occurrence_Of
(Standard_String
, Loc
),
5093 Make_String_Literal
(Loc
, New_Val
)));
5096 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5097 Make_Attribute_Reference
(Loc
,
5098 Prefix
=> New_Occurrence_Of
(E
, Loc
),
5099 Attribute_Name
=> Name_Address
));
5104 Append_To
(TSD_Aggr_List
, New_Node
);
5108 if RTE_Available
(RE_Register_Tag
) then
5109 Append_To
(TSD_Aggr_List
,
5110 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
5111 Make_Attribute_Reference
(Loc
,
5112 Prefix
=> New_Occurrence_Of
(HT_Link
, Loc
),
5113 Attribute_Name
=> Name_Address
)));
5115 Append_To
(TSD_Aggr_List
,
5116 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
5117 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5120 -- Transportable: Set for types that can be used in remote calls
5121 -- with respect to E.4(18) legality rules.
5124 Transportable
: Entity_Id
;
5130 or else Is_Shared_Passive
(Typ
)
5132 ((Is_Remote_Types
(Typ
)
5133 or else Is_Remote_Call_Interface
(Typ
))
5134 and then Original_View_In_Visible_Part
(Typ
))
5135 or else not Comes_From_Source
(Typ
));
5137 Append_To
(TSD_Aggr_List
,
5138 New_Occurrence_Of
(Transportable
, Loc
));
5141 -- Type_Is_Abstract (Ada 2012: AI05-0173). This functionality is
5142 -- not available in the HIE runtime.
5144 if RTE_Record_Component_Available
(RE_Type_Is_Abstract
) then
5146 Type_Is_Abstract
: Entity_Id
;
5148 Type_Is_Abstract
:= Boolean_Literals
(Is_Abstract_Type
(Typ
));
5149 Append_To
(TSD_Aggr_List
,
5150 New_Occurrence_Of
(Type_Is_Abstract
, Loc
));
5154 -- Needs_Finalization: Set if the type is controlled or has controlled
5158 Needs_Fin
: Entity_Id
;
5160 Needs_Fin
:= Boolean_Literals
(Needs_Finalization
(Typ
));
5161 Append_To
(TSD_Aggr_List
, New_Occurrence_Of
(Needs_Fin
, Loc
));
5166 if RTE_Record_Component_Available
(RE_Size_Func
) then
5168 -- Initialize this field to Null_Address if we are not building
5169 -- static dispatch tables static or if the size function is not
5170 -- available. In the former case we cannot initialize this field
5171 -- until the function is frozen and registered in the dispatch
5172 -- table (see Register_Primitive).
5174 if not Building_Static_DT
(Typ
) or else not Has_DT
(Typ
) then
5175 Append_To
(TSD_Aggr_List
,
5176 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5177 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5181 Prim_Elmt
: Elmt_Id
;
5183 Size_Comp
: Node_Id
;
5186 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5187 while Present
(Prim_Elmt
) loop
5188 Prim
:= Node
(Prim_Elmt
);
5190 if Chars
(Prim
) = Name_uSize
then
5191 Prim
:= Ultimate_Alias
(Prim
);
5193 if Is_Abstract_Subprogram
(Prim
) then
5195 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5196 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
5199 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5200 Make_Attribute_Reference
(Loc
,
5201 Prefix
=> New_Occurrence_Of
(Prim
, Loc
),
5202 Attribute_Name
=> Name_Unrestricted_Access
));
5208 Next_Elmt
(Prim_Elmt
);
5211 pragma Assert
(Present
(Size_Comp
));
5212 Append_To
(TSD_Aggr_List
, Size_Comp
);
5217 -- Interfaces_Table (required for AI-405)
5219 if RTE_Record_Component_Available
(RE_Interfaces_Table
) then
5221 -- Count the number of interface types implemented by Typ
5223 Collect_Interfaces
(Typ
, Typ_Ifaces
);
5225 AI
:= First_Elmt
(Typ_Ifaces
);
5226 while Present
(AI
) loop
5227 Num_Ifaces
:= Num_Ifaces
+ 1;
5231 if Num_Ifaces
= 0 then
5232 Iface_Table_Node
:= Make_Null
(Loc
);
5234 -- Generate the Interface_Table object
5238 TSD_Ifaces_List
: constant List_Id
:= New_List
;
5240 Sec_DT_Tag
: Node_Id
;
5243 AI
:= First_Elmt
(Typ_Ifaces
);
5244 while Present
(AI
) loop
5245 if Is_Ancestor
(Node
(AI
), Typ
, Use_Full_View
=> True) then
5247 New_Occurrence_Of
(DT_Ptr
, Loc
);
5251 (Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
5252 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5254 while Is_Tag
(Node
(Elmt
))
5256 Is_Ancestor
(Node
(AI
), Related_Type
(Node
(Elmt
)),
5257 Use_Full_View
=> True)
5259 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5261 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5263 pragma Assert
(not Has_Thunks
(Node
(Elmt
)));
5265 pragma Assert
(not Has_Thunks
(Node
(Elmt
)));
5269 pragma Assert
(Ekind
(Node
(Elmt
)) = E_Constant
5271 Has_Thunks
(Node
(Next_Elmt
(Next_Elmt
(Elmt
)))));
5273 New_Occurrence_Of
(Node
(Next_Elmt
(Next_Elmt
(Elmt
))),
5277 Append_To
(TSD_Ifaces_List
,
5278 Make_Aggregate
(Loc
,
5279 Expressions
=> New_List
(
5283 Unchecked_Convert_To
(RTE
(RE_Tag
),
5285 (Node
(First_Elmt
(Access_Disp_Table
(Node
(AI
)))),
5288 -- Static_Offset_To_Top
5290 New_Occurrence_Of
(Standard_True
, Loc
),
5292 -- Offset_To_Top_Value
5294 Make_Integer_Literal
(Loc
, 0),
5296 -- Offset_To_Top_Func
5302 Unchecked_Convert_To
(RTE
(RE_Tag
), Sec_DT_Tag
)
5309 Name_ITable
:= New_External_Name
(Tname
, 'I');
5310 ITable
:= Make_Defining_Identifier
(Loc
, Name_ITable
);
5311 Set_Is_Statically_Allocated
(ITable
,
5312 Is_Library_Level_Tagged_Type
(Typ
));
5314 -- The table of interfaces is not constant; its slots are
5315 -- filled at run time by the IP routine using attribute
5316 -- 'Position to know the location of the tag components
5317 -- (and this attribute cannot be safely used before the
5318 -- object is initialized).
5321 Make_Object_Declaration
(Loc
,
5322 Defining_Identifier
=> ITable
,
5323 Aliased_Present
=> True,
5324 Constant_Present
=> False,
5325 Object_Definition
=>
5326 Make_Subtype_Indication
(Loc
,
5328 New_Occurrence_Of
(RTE
(RE_Interface_Data
), Loc
),
5330 Make_Index_Or_Discriminant_Constraint
(Loc
,
5331 Constraints
=> New_List
(
5332 Make_Integer_Literal
(Loc
, Num_Ifaces
)))),
5334 Expression
=> Make_Aggregate
(Loc
,
5335 Expressions
=> New_List
(
5336 Make_Integer_Literal
(Loc
, Num_Ifaces
),
5337 Make_Aggregate
(Loc
, TSD_Ifaces_List
)))));
5340 Make_Attribute_Definition_Clause
(Loc
,
5341 Name
=> New_Occurrence_Of
(ITable
, Loc
),
5342 Chars
=> Name_Alignment
,
5344 Make_Attribute_Reference
(Loc
,
5346 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5347 Attribute_Name
=> Name_Alignment
)));
5350 Make_Attribute_Reference
(Loc
,
5351 Prefix
=> New_Occurrence_Of
(ITable
, Loc
),
5352 Attribute_Name
=> Name_Unchecked_Access
);
5356 Append_To
(TSD_Aggr_List
, Iface_Table_Node
);
5359 -- Generate the Select Specific Data table for synchronized types that
5360 -- implement synchronized interfaces. The size of the table is
5361 -- constrained by the number of non-predefined primitive operations.
5363 if RTE_Record_Component_Available
(RE_SSD
) then
5364 if Ada_Version
>= Ada_2005
5365 and then Has_DT
(Typ
)
5366 and then Is_Concurrent_Record_Type
(Typ
)
5367 and then Has_Interfaces
(Typ
)
5368 and then Nb_Prim
> 0
5369 and then not Is_Abstract_Type
(Typ
)
5370 and then not Is_Controlled
(Typ
)
5371 and then not Restriction_Active
(No_Dispatching_Calls
)
5372 and then not Restriction_Active
(No_Select_Statements
)
5375 Make_Object_Declaration
(Loc
,
5376 Defining_Identifier
=> SSD
,
5377 Aliased_Present
=> True,
5378 Object_Definition
=>
5379 Make_Subtype_Indication
(Loc
,
5380 Subtype_Mark
=> New_Occurrence_Of
(
5381 RTE
(RE_Select_Specific_Data
), Loc
),
5383 Make_Index_Or_Discriminant_Constraint
(Loc
,
5384 Constraints
=> New_List
(
5385 Make_Integer_Literal
(Loc
, Nb_Prim
))))));
5388 Make_Attribute_Definition_Clause
(Loc
,
5389 Name
=> New_Occurrence_Of
(SSD
, Loc
),
5390 Chars
=> Name_Alignment
,
5392 Make_Attribute_Reference
(Loc
,
5394 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5395 Attribute_Name
=> Name_Alignment
)));
5397 -- This table is initialized by Make_Select_Specific_Data_Table,
5398 -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
5400 Append_To
(TSD_Aggr_List
,
5401 Make_Attribute_Reference
(Loc
,
5402 Prefix
=> New_Occurrence_Of
(SSD
, Loc
),
5403 Attribute_Name
=> Name_Unchecked_Access
));
5405 Append_To
(TSD_Aggr_List
, Make_Null
(Loc
));
5409 -- Initialize the table of ancestor tags. In case of interface types
5410 -- this table is not needed.
5412 TSD_Tags_List
:= New_List
;
5414 -- If we are not statically allocating the dispatch table then we must
5415 -- fill position 0 with null because we still have not generated the
5418 if not Building_Static_DT
(Typ
)
5419 or else Is_Interface
(Typ
)
5421 Append_To
(TSD_Tags_List
,
5422 Unchecked_Convert_To
(RTE
(RE_Tag
),
5423 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5425 -- Otherwise we can safely reference the tag
5428 Append_To
(TSD_Tags_List
,
5429 New_Occurrence_Of
(DT_Ptr
, Loc
));
5432 -- Fill the rest of the table with the tags of the ancestors
5435 Current_Typ
: Entity_Id
;
5436 Parent_Typ
: Entity_Id
;
5444 Parent_Typ
:= Etype
(Current_Typ
);
5446 if Is_Private_Type
(Parent_Typ
) then
5447 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
5450 exit when Parent_Typ
= Current_Typ
;
5452 if Is_CPP_Class
(Parent_Typ
) then
5454 -- The tags defined in the C++ side will be inherited when
5455 -- the object is constructed (Exp_Ch3.Build_Init_Procedure)
5457 Append_To
(TSD_Tags_List
,
5458 Unchecked_Convert_To
(RTE
(RE_Tag
),
5459 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5461 Append_To
(TSD_Tags_List
,
5463 (Node
(First_Elmt
(Access_Disp_Table
(Parent_Typ
))),
5468 Current_Typ
:= Parent_Typ
;
5471 pragma Assert
(Pos
= I_Depth
+ 1);
5474 Append_To
(TSD_Aggr_List
,
5475 Make_Aggregate
(Loc
,
5476 Expressions
=> TSD_Tags_List
));
5478 -- Build the TSD object
5481 Make_Object_Declaration
(Loc
,
5482 Defining_Identifier
=> TSD
,
5483 Aliased_Present
=> True,
5484 Constant_Present
=> Building_Static_DT
(Typ
),
5485 Object_Definition
=>
5486 Make_Subtype_Indication
(Loc
,
5487 Subtype_Mark
=> New_Occurrence_Of
(
5488 RTE
(RE_Type_Specific_Data
), Loc
),
5490 Make_Index_Or_Discriminant_Constraint
(Loc
,
5491 Constraints
=> New_List
(
5492 Make_Integer_Literal
(Loc
, I_Depth
)))),
5494 Expression
=> Make_Aggregate
(Loc
,
5495 Expressions
=> TSD_Aggr_List
)));
5497 Set_Is_True_Constant
(TSD
, Building_Static_DT
(Typ
));
5500 Make_Attribute_Definition_Clause
(Loc
,
5501 Name
=> New_Occurrence_Of
(TSD
, Loc
),
5502 Chars
=> Name_Alignment
,
5504 Make_Attribute_Reference
(Loc
,
5506 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5507 Attribute_Name
=> Name_Alignment
)));
5509 -- Initialize or declare the dispatch table object
5511 if not Has_DT
(Typ
) then
5512 DT_Constr_List
:= New_List
;
5513 DT_Aggr_List
:= New_List
;
5518 Make_Attribute_Reference
(Loc
,
5519 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
5520 Attribute_Name
=> Name_Address
);
5522 Append_To
(DT_Constr_List
, New_Node
);
5523 Append_To
(DT_Aggr_List
, New_Copy
(New_Node
));
5524 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
5526 -- In case of locally defined tagged types we have already declared
5527 -- and uninitialized object for the dispatch table, which is now
5528 -- initialized by means of the following assignment:
5530 -- DT := (TSD'Address, 0);
5532 if not Building_Static_DT
(Typ
) then
5534 Make_Assignment_Statement
(Loc
,
5535 Name
=> New_Occurrence_Of
(DT
, Loc
),
5536 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5538 -- In case of library level tagged types we declare and export now
5539 -- the constant object containing the dummy dispatch table. There
5540 -- is no need to declare the tag here because it has been previously
5541 -- declared by Make_Tags
5543 -- DT : aliased constant No_Dispatch_Table :=
5544 -- (NDT_TSD => TSD'Address;
5545 -- NDT_Prims_Ptr => 0);
5546 -- for DT'Alignment use Address'Alignment;
5550 Make_Object_Declaration
(Loc
,
5551 Defining_Identifier
=> DT
,
5552 Aliased_Present
=> True,
5553 Constant_Present
=> True,
5554 Object_Definition
=>
5555 New_Occurrence_Of
(RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
),
5556 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5559 Make_Attribute_Definition_Clause
(Loc
,
5560 Name
=> New_Occurrence_Of
(DT
, Loc
),
5561 Chars
=> Name_Alignment
,
5563 Make_Attribute_Reference
(Loc
,
5565 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5566 Attribute_Name
=> Name_Alignment
)));
5568 Export_DT
(Typ
, DT
);
5571 -- Common case: Typ has a dispatch table
5575 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
5576 -- (predef-prim-op-1'address,
5577 -- predef-prim-op-2'address,
5579 -- predef-prim-op-n'address);
5580 -- for Predef_Prims'Alignment use Address'Alignment
5582 -- DT : Dispatch_Table (Nb_Prims) :=
5583 -- (Signature => <sig-value>,
5584 -- Tag_Kind => <tag_kind-value>,
5585 -- Predef_Prims => Predef_Prims'First'Address,
5586 -- Offset_To_Top => 0,
5587 -- TSD => TSD'Address;
5588 -- Prims_Ptr => (prim-op-1'address,
5589 -- prim-op-2'address,
5591 -- prim-op-n'address));
5592 -- for DT'Alignment use Address'Alignment
5599 if not Building_Static_DT
(Typ
) then
5600 Nb_Predef_Prims
:= Max_Predef_Prims
;
5603 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5604 while Present
(Prim_Elmt
) loop
5605 Prim
:= Node
(Prim_Elmt
);
5607 if Is_Predefined_Dispatching_Operation
(Prim
)
5608 and then not Is_Abstract_Subprogram
(Prim
)
5610 Pos
:= UI_To_Int
(DT_Position
(Prim
));
5612 if Pos
> Nb_Predef_Prims
then
5613 Nb_Predef_Prims
:= Pos
;
5617 Next_Elmt
(Prim_Elmt
);
5623 (Nat
range 1 .. Nb_Predef_Prims
) of Entity_Id
;
5628 Prim_Ops_Aggr_List
:= New_List
;
5630 Prim_Table
:= (others => Empty
);
5632 if Building_Static_DT
(Typ
) then
5633 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5634 while Present
(Prim_Elmt
) loop
5635 Prim
:= Node
(Prim_Elmt
);
5637 if Is_Predefined_Dispatching_Operation
(Prim
)
5638 and then not Is_Abstract_Subprogram
(Prim
)
5639 and then not Is_Eliminated
(Prim
)
5640 and then not Present
(Prim_Table
5641 (UI_To_Int
(DT_Position
(Prim
))))
5643 E
:= Ultimate_Alias
(Prim
);
5644 pragma Assert
(not Is_Abstract_Subprogram
(E
));
5645 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) := E
;
5648 Next_Elmt
(Prim_Elmt
);
5652 for J
in Prim_Table
'Range loop
5653 if Present
(Prim_Table
(J
)) then
5655 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
5656 Make_Attribute_Reference
(Loc
,
5658 New_Occurrence_Of
(Prim_Table
(J
), Loc
),
5659 Attribute_Name
=> Name_Unrestricted_Access
));
5661 New_Node
:= Make_Null
(Loc
);
5664 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
5668 Make_Aggregate
(Loc
,
5669 Expressions
=> Prim_Ops_Aggr_List
);
5672 Make_Subtype_Declaration
(Loc
,
5673 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
5674 Subtype_Indication
=>
5675 New_Occurrence_Of
(RTE
(RE_Address_Array
), Loc
));
5677 Append_To
(Result
, Decl
);
5680 Make_Object_Declaration
(Loc
,
5681 Defining_Identifier
=> Predef_Prims
,
5682 Aliased_Present
=> True,
5683 Constant_Present
=> Building_Static_DT
(Typ
),
5684 Object_Definition
=>
5685 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
),
5686 Expression
=> New_Node
));
5688 -- Remember aggregates initializing dispatch tables
5690 Append_Elmt
(New_Node
, DT_Aggr
);
5693 Make_Attribute_Definition_Clause
(Loc
,
5694 Name
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
5695 Chars
=> Name_Alignment
,
5697 Make_Attribute_Reference
(Loc
,
5699 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5700 Attribute_Name
=> Name_Alignment
)));
5704 -- Stage 1: Initialize the discriminant and the record components
5706 DT_Constr_List
:= New_List
;
5707 DT_Aggr_List
:= New_List
;
5709 -- Num_Prims. If the tagged type has no primitives we add a dummy
5710 -- slot whose address will be the tag of this type.
5713 New_Node
:= Make_Integer_Literal
(Loc
, 1);
5715 New_Node
:= Make_Integer_Literal
(Loc
, Nb_Prim
);
5718 Append_To
(DT_Constr_List
, New_Node
);
5719 Append_To
(DT_Aggr_List
, New_Copy
(New_Node
));
5723 if RTE_Record_Component_Available
(RE_Signature
) then
5724 Append_To
(DT_Aggr_List
,
5725 New_Occurrence_Of
(RTE
(RE_Primary_DT
), Loc
));
5730 if RTE_Record_Component_Available
(RE_Tag_Kind
) then
5731 Append_To
(DT_Aggr_List
, Tagged_Kind
(Typ
));
5736 Append_To
(DT_Aggr_List
,
5737 Make_Attribute_Reference
(Loc
,
5738 Prefix
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
5739 Attribute_Name
=> Name_Address
));
5743 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
5747 Append_To
(DT_Aggr_List
,
5748 Make_Attribute_Reference
(Loc
,
5749 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
5750 Attribute_Name
=> Name_Address
));
5752 -- Stage 2: Initialize the table of user-defined primitive operations
5754 Prim_Ops_Aggr_List
:= New_List
;
5757 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
5759 elsif not Building_Static_DT
(Typ
) then
5760 for J
in 1 .. Nb_Prim
loop
5761 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
5766 CPP_Nb_Prims
: constant Nat
:= CPP_Num_Prims
(Typ
);
5769 Prim_Elmt
: Elmt_Id
;
5771 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
5774 Prim_Table
:= (others => Empty
);
5776 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5777 while Present
(Prim_Elmt
) loop
5778 Prim
:= Node
(Prim_Elmt
);
5780 -- Retrieve the ultimate alias of the primitive for proper
5781 -- handling of renamings and eliminated primitives.
5783 E
:= Ultimate_Alias
(Prim
);
5784 Prim_Pos
:= UI_To_Int
(DT_Position
(E
));
5786 -- Skip predefined primitives because they are located in a
5787 -- separate dispatch table.
5789 if not Is_Predefined_Dispatching_Operation
(Prim
)
5790 and then not Is_Predefined_Dispatching_Operation
(E
)
5792 -- Skip entities with attribute Interface_Alias because
5793 -- those are only required to build secondary dispatch
5796 and then not Present
(Interface_Alias
(Prim
))
5798 -- Skip abstract and eliminated primitives
5800 and then not Is_Abstract_Subprogram
(E
)
5801 and then not Is_Eliminated
(E
)
5803 -- For derivations of CPP types skip primitives located in
5804 -- the C++ part of the dispatch table because their slots
5805 -- are initialized by the IC routine.
5807 and then (not Is_CPP_Class
(Root_Type
(Typ
))
5808 or else Prim_Pos
> CPP_Nb_Prims
)
5810 -- Skip ignored Ghost subprograms as those will be removed
5811 -- from the executable.
5813 and then not Is_Ignored_Ghost_Entity
(E
)
5816 (UI_To_Int
(DT_Position
(Prim
)) <= Nb_Prim
);
5818 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) := E
;
5821 Next_Elmt
(Prim_Elmt
);
5824 for J
in Prim_Table
'Range loop
5825 if Present
(Prim_Table
(J
)) then
5827 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
5828 Make_Attribute_Reference
(Loc
,
5830 New_Occurrence_Of
(Prim_Table
(J
), Loc
),
5831 Attribute_Name
=> Name_Unrestricted_Access
));
5833 New_Node
:= Make_Null
(Loc
);
5836 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
5842 Make_Aggregate
(Loc
,
5843 Expressions
=> Prim_Ops_Aggr_List
);
5845 Append_To
(DT_Aggr_List
, New_Node
);
5847 -- Remember aggregates initializing dispatch tables
5849 Append_Elmt
(New_Node
, DT_Aggr
);
5851 -- In case of locally defined tagged types we have already declared
5852 -- and uninitialized object for the dispatch table, which is now
5853 -- initialized by means of an assignment.
5855 if not Building_Static_DT
(Typ
) then
5857 Make_Assignment_Statement
(Loc
,
5858 Name
=> New_Occurrence_Of
(DT
, Loc
),
5859 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5861 -- In case of library level tagged types we declare now and export
5862 -- the constant object containing the dispatch table.
5866 Make_Object_Declaration
(Loc
,
5867 Defining_Identifier
=> DT
,
5868 Aliased_Present
=> True,
5869 Constant_Present
=> True,
5870 Object_Definition
=>
5871 Make_Subtype_Indication
(Loc
,
5872 Subtype_Mark
=> New_Occurrence_Of
5873 (RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
5874 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
5875 Constraints
=> DT_Constr_List
)),
5876 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5879 Make_Attribute_Definition_Clause
(Loc
,
5880 Name
=> New_Occurrence_Of
(DT
, Loc
),
5881 Chars
=> Name_Alignment
,
5883 Make_Attribute_Reference
(Loc
,
5885 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5886 Attribute_Name
=> Name_Alignment
)));
5888 Export_DT
(Typ
, DT
);
5892 -- Initialize the table of ancestor tags if not building static
5895 if not Building_Static_DT
(Typ
)
5896 and then not Is_Interface
(Typ
)
5897 and then not Is_CPP_Class
(Typ
)
5900 Make_Assignment_Statement
(Loc
,
5902 Make_Indexed_Component
(Loc
,
5904 Make_Selected_Component
(Loc
,
5905 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
5908 (RTE_Record_Component
(RE_Tags_Table
), Loc
)),
5910 New_List
(Make_Integer_Literal
(Loc
, 0))),
5914 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
)));
5917 -- Inherit the dispatch tables of the parent. There is no need to
5918 -- inherit anything from the parent when building static dispatch tables
5919 -- because the whole dispatch table (including inherited primitives) has
5920 -- been already built.
5922 if Building_Static_DT
(Typ
) then
5925 -- If the ancestor is a CPP_Class type we inherit the dispatch tables
5926 -- in the init proc, and we don't need to fill them in here.
5928 elsif Is_CPP_Class
(Parent_Typ
) then
5931 -- Otherwise we fill in the dispatch tables here
5934 if Typ
/= Parent_Typ
5935 and then not Is_Interface
(Typ
)
5936 and then not Restriction_Active
(No_Dispatching_Calls
)
5938 -- Inherit the dispatch table
5940 if not Is_Interface
(Typ
)
5941 and then not Is_Interface
(Parent_Typ
)
5942 and then not Is_CPP_Class
(Parent_Typ
)
5945 Nb_Prims
: constant Int
:=
5946 UI_To_Int
(DT_Entry_Count
5947 (First_Tag_Component
(Parent_Typ
)));
5950 Append_To
(Elab_Code
,
5951 Build_Inherit_Predefined_Prims
(Loc
,
5957 (Access_Disp_Table
(Parent_Typ
)))), Loc
),
5963 (Access_Disp_Table
(Typ
)))), Loc
)));
5965 if Nb_Prims
/= 0 then
5966 Append_To
(Elab_Code
,
5967 Build_Inherit_Prims
(Loc
,
5973 (Access_Disp_Table
(Parent_Typ
))), Loc
),
5974 New_Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
5975 Num_Prims
=> Nb_Prims
));
5980 -- Inherit the secondary dispatch tables of the ancestor
5982 if not Is_CPP_Class
(Parent_Typ
) then
5984 Sec_DT_Ancestor
: Elmt_Id
:=
5990 Sec_DT_Typ
: Elmt_Id
:=
5994 (Access_Disp_Table
(Typ
))));
5996 procedure Copy_Secondary_DTs
(Typ
: Entity_Id
);
5997 -- Local procedure required to climb through the ancestors
5998 -- and copy the contents of all their secondary dispatch
6001 ------------------------
6002 -- Copy_Secondary_DTs --
6003 ------------------------
6005 procedure Copy_Secondary_DTs
(Typ
: Entity_Id
) is
6010 -- Climb to the ancestor (if any) handling private types
6012 if Present
(Full_View
(Etype
(Typ
))) then
6013 if Full_View
(Etype
(Typ
)) /= Typ
then
6014 Copy_Secondary_DTs
(Full_View
(Etype
(Typ
)));
6017 elsif Etype
(Typ
) /= Typ
then
6018 Copy_Secondary_DTs
(Etype
(Typ
));
6021 if Present
(Interfaces
(Typ
))
6022 and then not Is_Empty_Elmt_List
(Interfaces
(Typ
))
6024 Iface
:= First_Elmt
(Interfaces
(Typ
));
6025 E
:= First_Entity
(Typ
);
6027 and then Present
(Node
(Sec_DT_Ancestor
))
6028 and then Ekind
(Node
(Sec_DT_Ancestor
)) = E_Constant
6030 if Is_Tag
(E
) and then Chars
(E
) /= Name_uTag
then
6032 Num_Prims
: constant Int
:=
6033 UI_To_Int
(DT_Entry_Count
(E
));
6036 if not Is_Interface
(Etype
(Typ
)) then
6038 -- Inherit first secondary dispatch table
6040 Append_To
(Elab_Code
,
6041 Build_Inherit_Predefined_Prims
(Loc
,
6043 Unchecked_Convert_To
(RTE
(RE_Tag
),
6046 (Next_Elmt
(Sec_DT_Ancestor
)),
6049 Unchecked_Convert_To
(RTE
(RE_Tag
),
6051 (Node
(Next_Elmt
(Sec_DT_Typ
)),
6054 if Num_Prims
/= 0 then
6055 Append_To
(Elab_Code
,
6056 Build_Inherit_Prims
(Loc
,
6057 Typ
=> Node
(Iface
),
6059 Unchecked_Convert_To
6062 (Node
(Sec_DT_Ancestor
),
6065 Unchecked_Convert_To
6068 (Node
(Sec_DT_Typ
), Loc
)),
6069 Num_Prims
=> Num_Prims
));
6073 Next_Elmt
(Sec_DT_Ancestor
);
6074 Next_Elmt
(Sec_DT_Typ
);
6076 -- Skip the secondary dispatch table of
6077 -- predefined primitives
6079 Next_Elmt
(Sec_DT_Ancestor
);
6080 Next_Elmt
(Sec_DT_Typ
);
6082 if not Is_Interface
(Etype
(Typ
)) then
6084 -- Inherit second secondary dispatch table
6086 Append_To
(Elab_Code
,
6087 Build_Inherit_Predefined_Prims
(Loc
,
6089 Unchecked_Convert_To
(RTE
(RE_Tag
),
6092 (Next_Elmt
(Sec_DT_Ancestor
)),
6095 Unchecked_Convert_To
(RTE
(RE_Tag
),
6097 (Node
(Next_Elmt
(Sec_DT_Typ
)),
6100 if Num_Prims
/= 0 then
6101 Append_To
(Elab_Code
,
6102 Build_Inherit_Prims
(Loc
,
6103 Typ
=> Node
(Iface
),
6105 Unchecked_Convert_To
6108 (Node
(Sec_DT_Ancestor
),
6111 Unchecked_Convert_To
6114 (Node
(Sec_DT_Typ
), Loc
)),
6115 Num_Prims
=> Num_Prims
));
6120 Next_Elmt
(Sec_DT_Ancestor
);
6121 Next_Elmt
(Sec_DT_Typ
);
6123 -- Skip the secondary dispatch table of
6124 -- predefined primitives
6126 Next_Elmt
(Sec_DT_Ancestor
);
6127 Next_Elmt
(Sec_DT_Typ
);
6135 end Copy_Secondary_DTs
;
6138 if Present
(Node
(Sec_DT_Ancestor
))
6139 and then Ekind
(Node
(Sec_DT_Ancestor
)) = E_Constant
6141 -- Handle private types
6143 if Present
(Full_View
(Typ
)) then
6144 Copy_Secondary_DTs
(Full_View
(Typ
));
6146 Copy_Secondary_DTs
(Typ
);
6154 -- Generate code to check if the external tag of this type is the same
6155 -- as the external tag of some other declaration.
6157 -- Check_TSD (TSD'Unrestricted_Access);
6159 -- This check is a consequence of AI05-0113-1/06, so it officially
6160 -- applies to Ada 2005 (and Ada 2012). It might be argued that it is
6161 -- a desirable check to add in Ada 95 mode, but we hesitate to make
6162 -- this change, as it would be incompatible, and could conceivably
6163 -- cause a problem in existing Aa 95 code.
6165 -- We check for No_Run_Time_Mode here, because we do not want to pick
6166 -- up the RE_Check_TSD entity and call it in No_Run_Time mode.
6168 if not No_Run_Time_Mode
6169 and then Ada_Version
>= Ada_2005
6170 and then RTE_Available
(RE_Check_TSD
)
6171 and then not Duplicated_Tag_Checks_Suppressed
(Typ
)
6173 Append_To
(Elab_Code
,
6174 Make_Procedure_Call_Statement
(Loc
,
6176 New_Occurrence_Of
(RTE
(RE_Check_TSD
), Loc
),
6177 Parameter_Associations
=> New_List
(
6178 Make_Attribute_Reference
(Loc
,
6179 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6180 Attribute_Name
=> Name_Unchecked_Access
))));
6183 -- Generate code to register the Tag in the External_Tag hash table for
6184 -- the pure Ada type only.
6186 -- Register_Tag (Dt_Ptr);
6188 -- Skip this action in the following cases:
6189 -- 1) if Register_Tag is not available.
6190 -- 2) in No_Run_Time mode.
6191 -- 3) if Typ is not defined at the library level (this is required
6192 -- to avoid adding concurrency control to the hash table used
6193 -- by the run-time to register the tags).
6195 if not No_Run_Time_Mode
6196 and then Is_Library_Level_Entity
(Typ
)
6197 and then RTE_Available
(RE_Register_Tag
)
6199 Append_To
(Elab_Code
,
6200 Make_Procedure_Call_Statement
(Loc
,
6202 New_Occurrence_Of
(RTE
(RE_Register_Tag
), Loc
),
6203 Parameter_Associations
=>
6204 New_List
(New_Occurrence_Of
(DT_Ptr
, Loc
))));
6207 if not Is_Empty_List
(Elab_Code
) then
6208 Append_List_To
(Result
, Elab_Code
);
6211 -- Populate the two auxiliary tables used for dispatching asynchronous,
6212 -- conditional and timed selects for synchronized types that implement
6213 -- a limited interface. Skip this step in Ravenscar profile or when
6214 -- general dispatching is forbidden.
6216 if Ada_Version
>= Ada_2005
6217 and then Is_Concurrent_Record_Type
(Typ
)
6218 and then Has_Interfaces
(Typ
)
6219 and then not Restriction_Active
(No_Dispatching_Calls
)
6220 and then not Restriction_Active
(No_Select_Statements
)
6222 Append_List_To
(Result
,
6223 Make_Select_Specific_Data_Table
(Typ
));
6226 -- Remember entities containing dispatch tables
6228 Append_Elmt
(Predef_Prims
, DT_Decl
);
6229 Append_Elmt
(DT
, DT_Decl
);
6231 Analyze_List
(Result
, Suppress
=> All_Checks
);
6232 Set_Has_Dispatch_Table
(Typ
);
6234 -- Mark entities containing dispatch tables. Required by the backend to
6235 -- handle them properly.
6237 if Has_DT
(Typ
) then
6242 -- Object declarations
6244 Elmt
:= First_Elmt
(DT_Decl
);
6245 while Present
(Elmt
) loop
6246 Set_Is_Dispatch_Table_Entity
(Node
(Elmt
));
6247 pragma Assert
(Ekind
(Etype
(Node
(Elmt
))) = E_Array_Subtype
6248 or else Ekind
(Etype
(Node
(Elmt
))) = E_Record_Subtype
);
6249 Set_Is_Dispatch_Table_Entity
(Etype
(Node
(Elmt
)));
6253 -- Aggregates initializing dispatch tables
6255 Elmt
:= First_Elmt
(DT_Aggr
);
6256 while Present
(Elmt
) loop
6257 Set_Is_Dispatch_Table_Entity
(Etype
(Node
(Elmt
)));
6263 -- Register the tagged type in the call graph nodes table
6265 Register_CG_Node
(Typ
);
6275 function Make_VM_TSD
(Typ
: Entity_Id
) return List_Id
is
6276 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6277 Result
: constant List_Id
:= New_List
;
6279 function Count_Primitives
(Typ
: Entity_Id
) return Nat
;
6280 -- Count the non-predefined primitive operations of Typ
6282 ----------------------
6283 -- Count_Primitives --
6284 ----------------------
6286 function Count_Primitives
(Typ
: Entity_Id
) return Nat
is
6288 Prim_Elmt
: Elmt_Id
;
6294 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6295 while Present
(Prim_Elmt
) loop
6296 Prim
:= Node
(Prim_Elmt
);
6298 if Is_Predefined_Dispatching_Operation
(Prim
)
6299 or else Is_Predefined_Dispatching_Alias
(Prim
)
6303 elsif Present
(Interface_Alias
(Prim
)) then
6307 Nb_Prim
:= Nb_Prim
+ 1;
6310 Next_Elmt
(Prim_Elmt
);
6314 end Count_Primitives
;
6320 function Make_OSD
(Iface
: Entity_Id
) return Node_Id
;
6321 -- Generate the Object Specific Data table required to dispatch calls
6322 -- through synchronized interfaces. Returns a node that references the
6323 -- generated OSD object.
6325 function Make_OSD
(Iface
: Entity_Id
) return Node_Id
is
6326 Nb_Prim
: constant Nat
:= Count_Primitives
(Iface
);
6328 OSD_Aggr_List
: List_Id
;
6332 -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
6333 -- (OSD_Table => (1 => <value>,
6338 or else Is_Abstract_Type
(Typ
)
6339 or else Is_Controlled
(Typ
)
6340 or else Restriction_Active
(No_Dispatching_Calls
)
6341 or else not Is_Limited_Type
(Typ
)
6342 or else not Has_Interfaces
(Typ
)
6343 or else not RTE_Record_Component_Available
(RE_OSD_Table
)
6345 -- No OSD table required
6347 return Make_Null
(Loc
);
6350 OSD_Aggr_List
:= New_List
;
6353 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
6355 Prim_Alias
: Entity_Id
;
6356 Prim_Elmt
: Elmt_Id
;
6362 Prim_Table
:= (others => Empty
);
6363 Prim_Alias
:= Empty
;
6365 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6366 while Present
(Prim_Elmt
) loop
6367 Prim
:= Node
(Prim_Elmt
);
6369 if Present
(Interface_Alias
(Prim
))
6370 and then Find_Dispatching_Type
6371 (Interface_Alias
(Prim
)) = Iface
6373 Prim_Alias
:= Interface_Alias
(Prim
);
6374 E
:= Ultimate_Alias
(Prim
);
6375 Pos
:= UI_To_Int
(DT_Position
(Prim_Alias
));
6377 if Present
(Prim_Table
(Pos
)) then
6378 pragma Assert
(Prim_Table
(Pos
) = E
);
6382 Prim_Table
(Pos
) := E
;
6384 Append_To
(OSD_Aggr_List
,
6385 Make_Component_Association
(Loc
,
6386 Choices
=> New_List
(
6387 Make_Integer_Literal
(Loc
,
6388 DT_Position
(Prim_Alias
))),
6390 Make_Integer_Literal
(Loc
,
6391 DT_Position
(Alias
(Prim
)))));
6397 Next_Elmt
(Prim_Elmt
);
6400 pragma Assert
(Count
= Nb_Prim
);
6403 OSD
:= Make_Temporary
(Loc
, 'I');
6406 Make_Object_Declaration
(Loc
,
6407 Defining_Identifier
=> OSD
,
6408 Aliased_Present
=> True,
6409 Constant_Present
=> True,
6410 Object_Definition
=>
6411 Make_Subtype_Indication
(Loc
,
6413 New_Occurrence_Of
(RTE
(RE_Object_Specific_Data
), Loc
),
6415 Make_Index_Or_Discriminant_Constraint
(Loc
,
6416 Constraints
=> New_List
(
6417 Make_Integer_Literal
(Loc
, Nb_Prim
)))),
6420 Make_Aggregate
(Loc
,
6421 Component_Associations
=> New_List
(
6422 Make_Component_Association
(Loc
,
6423 Choices
=> New_List
(
6425 (RTE_Record_Component
(RE_OSD_Num_Prims
), Loc
)),
6427 Make_Integer_Literal
(Loc
, Nb_Prim
)),
6429 Make_Component_Association
(Loc
,
6430 Choices
=> New_List
(
6432 (RTE_Record_Component
(RE_OSD_Table
), Loc
)),
6433 Expression
=> Make_Aggregate
(Loc
,
6434 Component_Associations
=> OSD_Aggr_List
))))));
6437 Make_Attribute_Reference
(Loc
,
6438 Prefix
=> New_Occurrence_Of
(OSD
, Loc
),
6439 Attribute_Name
=> Name_Unchecked_Access
);
6445 Nb_Prim
: constant Nat
:= Count_Primitives
(Typ
);
6448 Iface_Table_Node
: Node_Id
;
6450 TSD_Aggr_List
: List_Id
;
6451 Typ_Ifaces
: Elist_Id
;
6452 TSD_Tags_List
: List_Id
;
6454 Tname
: constant Name_Id
:= Chars
(Typ
);
6455 Name_SSD
: constant Name_Id
:=
6456 New_External_Name
(Tname
, 'S', Suffix_Index
=> -1);
6457 Name_TSD
: constant Name_Id
:=
6458 New_External_Name
(Tname
, 'B', Suffix_Index
=> -1);
6459 SSD
: constant Entity_Id
:=
6460 Make_Defining_Identifier
(Loc
, Name_SSD
);
6461 TSD
: constant Entity_Id
:=
6462 Make_Defining_Identifier
(Loc
, Name_TSD
);
6464 -- Generate code to create the storage for the type specific data object
6465 -- with enough space to store the tags of the ancestors plus the tags
6466 -- of all the implemented interfaces (as described in a-tags.ads).
6468 -- TSD : Type_Specific_Data (I_Depth) :=
6469 -- (Idepth => I_Depth,
6470 -- Tag_Kind => <tag_kind-value>,
6471 -- Access_Level => Type_Access_Level (Typ),
6472 -- Alignment => Typ'Alignment,
6474 -- Type_Is_Abstract => <<boolean-value>>,
6475 -- Type_Is_Library_Level => <<boolean-value>>,
6476 -- Interfaces_Table => <<access-value>>
6477 -- SSD => SSD_Table'Address
6478 -- Tags_Table => (0 => Typ'Tag,
6482 TSD_Aggr_List
:= New_List
;
6484 -- Idepth: Count ancestors to compute the inheritance depth. For private
6485 -- extensions, always go to the full view in order to compute the real
6486 -- inheritance depth.
6489 Current_Typ
: Entity_Id
;
6490 Parent_Typ
: Entity_Id
;
6496 Parent_Typ
:= Etype
(Current_Typ
);
6498 if Is_Private_Type
(Parent_Typ
) then
6499 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
6502 exit when Parent_Typ
= Current_Typ
;
6504 I_Depth
:= I_Depth
+ 1;
6505 Current_Typ
:= Parent_Typ
;
6511 Append_To
(TSD_Aggr_List
,
6512 Make_Integer_Literal
(Loc
, I_Depth
));
6516 Append_To
(TSD_Aggr_List
, Tagged_Kind
(Typ
));
6520 Append_To
(TSD_Aggr_List
,
6521 Make_Integer_Literal
(Loc
, Type_Access_Level
(Typ
)));
6525 -- For CPP types we cannot rely on the value of 'Alignment provided
6526 -- by the backend to initialize this TSD field. Why not???
6528 if Convention
(Typ
) = Convention_CPP
6529 or else Is_CPP_Class
(Root_Type
(Typ
))
6531 Append_To
(TSD_Aggr_List
,
6532 Make_Integer_Literal
(Loc
, 0));
6534 Append_To
(TSD_Aggr_List
,
6535 Make_Attribute_Reference
(Loc
,
6536 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6537 Attribute_Name
=> Name_Alignment
));
6542 Append_To
(TSD_Aggr_List
,
6545 -- Type_Is_Abstract (Ada 2012: AI05-0173)
6548 Type_Is_Abstract
: Entity_Id
;
6552 Boolean_Literals
(Is_Abstract_Type
(Typ
));
6554 Append_To
(TSD_Aggr_List
,
6555 New_Occurrence_Of
(Type_Is_Abstract
, Loc
));
6558 -- Type_Is_Library_Level
6561 Type_Is_Library_Level
: Entity_Id
;
6563 Type_Is_Library_Level
:=
6564 Boolean_Literals
(Is_Library_Level_Entity
(Typ
));
6565 Append_To
(TSD_Aggr_List
,
6566 New_Occurrence_Of
(Type_Is_Library_Level
, Loc
));
6569 -- Interfaces_Table (required for AI-405)
6571 if RTE_Record_Component_Available
(RE_Interfaces_Table
) then
6573 -- Count the number of interface types implemented by Typ
6575 Collect_Interfaces
(Typ
, Typ_Ifaces
);
6578 AI
:= First_Elmt
(Typ_Ifaces
);
6579 while Present
(AI
) loop
6580 Num_Ifaces
:= Num_Ifaces
+ 1;
6584 if Num_Ifaces
= 0 then
6585 Iface_Table_Node
:= Make_Null
(Loc
);
6587 -- Generate the Interface_Table object
6591 TSD_Ifaces_List
: constant List_Id
:= New_List
;
6596 AI
:= First_Elmt
(Typ_Ifaces
);
6597 while Present
(AI
) loop
6600 Append_To
(TSD_Ifaces_List
,
6601 Make_Aggregate
(Loc
,
6602 Expressions
=> New_List
(
6606 Make_Attribute_Reference
(Loc
,
6607 Prefix
=> New_Occurrence_Of
(Iface
, Loc
),
6608 Attribute_Name
=> Name_Tag
),
6612 Make_OSD
(Iface
))));
6617 ITable
:= Make_Temporary
(Loc
, 'I');
6620 Make_Object_Declaration
(Loc
,
6621 Defining_Identifier
=> ITable
,
6622 Aliased_Present
=> True,
6623 Constant_Present
=> True,
6624 Object_Definition
=>
6625 Make_Subtype_Indication
(Loc
,
6627 New_Occurrence_Of
(RTE
(RE_Interface_Data
), Loc
),
6628 Constraint
=> Make_Index_Or_Discriminant_Constraint
6630 Constraints
=> New_List
(
6631 Make_Integer_Literal
(Loc
, Num_Ifaces
)))),
6633 Expression
=> Make_Aggregate
(Loc
,
6634 Expressions
=> New_List
(
6635 Make_Integer_Literal
(Loc
, Num_Ifaces
),
6636 Make_Aggregate
(Loc
,
6637 Expressions
=> TSD_Ifaces_List
)))));
6640 Make_Attribute_Reference
(Loc
,
6641 Prefix
=> New_Occurrence_Of
(ITable
, Loc
),
6642 Attribute_Name
=> Name_Unchecked_Access
);
6646 Append_To
(TSD_Aggr_List
, Iface_Table_Node
);
6649 -- Generate the Select Specific Data table for synchronized types that
6650 -- implement synchronized interfaces. The size of the table is
6651 -- constrained by the number of non-predefined primitive operations.
6653 if RTE_Record_Component_Available
(RE_SSD
) then
6654 if Ada_Version
>= Ada_2005
6655 and then Has_DT
(Typ
)
6656 and then Is_Concurrent_Record_Type
(Typ
)
6657 and then Has_Interfaces
(Typ
)
6658 and then Nb_Prim
> 0
6659 and then not Is_Abstract_Type
(Typ
)
6660 and then not Is_Controlled
(Typ
)
6661 and then not Restriction_Active
(No_Dispatching_Calls
)
6662 and then not Restriction_Active
(No_Select_Statements
)
6665 Make_Object_Declaration
(Loc
,
6666 Defining_Identifier
=> SSD
,
6667 Aliased_Present
=> True,
6668 Object_Definition
=>
6669 Make_Subtype_Indication
(Loc
,
6670 Subtype_Mark
=> New_Occurrence_Of
(
6671 RTE
(RE_Select_Specific_Data
), Loc
),
6673 Make_Index_Or_Discriminant_Constraint
(Loc
,
6674 Constraints
=> New_List
(
6675 Make_Integer_Literal
(Loc
, Nb_Prim
))))));
6677 -- This table is initialized by Make_Select_Specific_Data_Table,
6678 -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
6680 Append_To
(TSD_Aggr_List
,
6681 Make_Attribute_Reference
(Loc
,
6682 Prefix
=> New_Occurrence_Of
(SSD
, Loc
),
6683 Attribute_Name
=> Name_Unchecked_Access
));
6685 Append_To
(TSD_Aggr_List
, Make_Null
(Loc
));
6689 -- Initialize the table of ancestor tags. In case of interface types
6690 -- this table is not needed.
6692 TSD_Tags_List
:= New_List
;
6694 -- Fill position 0 with Typ'Tag
6696 Append_To
(TSD_Tags_List
,
6697 Make_Attribute_Reference
(Loc
,
6698 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6699 Attribute_Name
=> Name_Tag
));
6701 -- Fill the rest of the table with the tags of the ancestors
6704 Current_Typ
: Entity_Id
;
6705 Parent_Typ
: Entity_Id
;
6713 Parent_Typ
:= Etype
(Current_Typ
);
6715 if Is_Private_Type
(Parent_Typ
) then
6716 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
6719 exit when Parent_Typ
= Current_Typ
;
6721 Append_To
(TSD_Tags_List
,
6722 Make_Attribute_Reference
(Loc
,
6723 Prefix
=> New_Occurrence_Of
(Parent_Typ
, Loc
),
6724 Attribute_Name
=> Name_Tag
));
6727 Current_Typ
:= Parent_Typ
;
6730 pragma Assert
(Pos
= I_Depth
+ 1);
6733 Append_To
(TSD_Aggr_List
,
6734 Make_Aggregate
(Loc
,
6735 Expressions
=> TSD_Tags_List
));
6737 -- Build the TSD object
6740 Make_Object_Declaration
(Loc
,
6741 Defining_Identifier
=> TSD
,
6742 Aliased_Present
=> True,
6743 Constant_Present
=> True,
6744 Object_Definition
=>
6745 Make_Subtype_Indication
(Loc
,
6746 Subtype_Mark
=> New_Occurrence_Of
(
6747 RTE
(RE_Type_Specific_Data
), Loc
),
6749 Make_Index_Or_Discriminant_Constraint
(Loc
,
6750 Constraints
=> New_List
(
6751 Make_Integer_Literal
(Loc
, I_Depth
)))),
6753 Expression
=> Make_Aggregate
(Loc
,
6754 Expressions
=> TSD_Aggr_List
)));
6757 -- Check_TSD (TSD => TSD'Unrestricted_Access);
6759 if Ada_Version
>= Ada_2005
6760 and then Is_Library_Level_Entity
(Typ
)
6761 and then RTE_Available
(RE_Check_TSD
)
6762 and then not Duplicated_Tag_Checks_Suppressed
(Typ
)
6765 Make_Procedure_Call_Statement
(Loc
,
6766 Name
=> New_Occurrence_Of
(RTE
(RE_Check_TSD
), Loc
),
6767 Parameter_Associations
=> New_List
(
6768 Make_Attribute_Reference
(Loc
,
6769 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6770 Attribute_Name
=> Name_Unrestricted_Access
))));
6774 -- Register_TSD (TSD'Unrestricted_Access);
6777 Make_Procedure_Call_Statement
(Loc
,
6778 Name
=> New_Occurrence_Of
(RTE
(RE_Register_TSD
), Loc
),
6779 Parameter_Associations
=> New_List
(
6780 Make_Attribute_Reference
(Loc
,
6781 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6782 Attribute_Name
=> Name_Unrestricted_Access
))));
6784 -- Populate the two auxiliary tables used for dispatching asynchronous,
6785 -- conditional and timed selects for synchronized types that implement
6786 -- a limited interface. Skip this step in Ravenscar profile or when
6787 -- general dispatching is forbidden.
6789 if Ada_Version
>= Ada_2005
6790 and then Is_Concurrent_Record_Type
(Typ
)
6791 and then Has_Interfaces
(Typ
)
6792 and then not Restriction_Active
(No_Dispatching_Calls
)
6793 and then not Restriction_Active
(No_Select_Statements
)
6795 Append_List_To
(Result
,
6796 Make_Select_Specific_Data_Table
(Typ
));
6802 -------------------------------------
6803 -- Make_Select_Specific_Data_Table --
6804 -------------------------------------
6806 function Make_Select_Specific_Data_Table
6807 (Typ
: Entity_Id
) return List_Id
6809 Assignments
: constant List_Id
:= New_List
;
6810 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6812 Conc_Typ
: Entity_Id
;
6815 Prim_Als
: Entity_Id
;
6816 Prim_Elmt
: Elmt_Id
;
6820 type Examined_Array
is array (Int
range <>) of Boolean;
6822 function Find_Entry_Index
(E
: Entity_Id
) return Uint
;
6823 -- Given an entry, find its index in the visible declarations of the
6824 -- corresponding concurrent type of Typ.
6826 ----------------------
6827 -- Find_Entry_Index --
6828 ----------------------
6830 function Find_Entry_Index
(E
: Entity_Id
) return Uint
is
6831 Index
: Uint
:= Uint_1
;
6832 Subp_Decl
: Entity_Id
;
6836 and then not Is_Empty_List
(Decls
)
6838 Subp_Decl
:= First
(Decls
);
6839 while Present
(Subp_Decl
) loop
6840 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
6841 if Defining_Identifier
(Subp_Decl
) = E
then
6853 end Find_Entry_Index
;
6859 -- Start of processing for Make_Select_Specific_Data_Table
6862 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
6864 if Present
(Corresponding_Concurrent_Type
(Typ
)) then
6865 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
6867 if Present
(Full_View
(Conc_Typ
)) then
6868 Conc_Typ
:= Full_View
(Conc_Typ
);
6871 if Ekind
(Conc_Typ
) = E_Protected_Type
then
6872 Decls
:= Visible_Declarations
(Protected_Definition
(
6873 Parent
(Conc_Typ
)));
6875 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
6876 Decls
:= Visible_Declarations
(Task_Definition
(
6877 Parent
(Conc_Typ
)));
6881 -- Count the non-predefined primitive operations
6883 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6884 while Present
(Prim_Elmt
) loop
6885 Prim
:= Node
(Prim_Elmt
);
6887 if not (Is_Predefined_Dispatching_Operation
(Prim
)
6888 or else Is_Predefined_Dispatching_Alias
(Prim
))
6890 Nb_Prim
:= Nb_Prim
+ 1;
6893 Next_Elmt
(Prim_Elmt
);
6897 Examined
: Examined_Array
(1 .. Nb_Prim
) := (others => False);
6900 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6901 while Present
(Prim_Elmt
) loop
6902 Prim
:= Node
(Prim_Elmt
);
6904 -- Look for primitive overriding an abstract interface subprogram
6906 if Present
(Interface_Alias
(Prim
))
6909 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
6910 Use_Full_View
=> True)
6911 and then not Examined
(UI_To_Int
(DT_Position
(Alias
(Prim
))))
6913 Prim_Pos
:= DT_Position
(Alias
(Prim
));
6914 pragma Assert
(UI_To_Int
(Prim_Pos
) <= Nb_Prim
);
6915 Examined
(UI_To_Int
(Prim_Pos
)) := True;
6917 -- Set the primitive operation kind regardless of subprogram
6919 -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
6921 if Tagged_Type_Expansion
then
6924 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
);
6928 Make_Attribute_Reference
(Loc
,
6929 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6930 Attribute_Name
=> Name_Tag
);
6933 Append_To
(Assignments
,
6934 Make_Procedure_Call_Statement
(Loc
,
6935 Name
=> New_Occurrence_Of
(RTE
(RE_Set_Prim_Op_Kind
), Loc
),
6936 Parameter_Associations
=> New_List
(
6938 Make_Integer_Literal
(Loc
, Prim_Pos
),
6939 Prim_Op_Kind
(Alias
(Prim
), Typ
))));
6941 -- Retrieve the root of the alias chain
6943 Prim_Als
:= Ultimate_Alias
(Prim
);
6945 -- In the case of an entry wrapper, set the entry index
6947 if Ekind
(Prim
) = E_Procedure
6948 and then Is_Primitive_Wrapper
(Prim_Als
)
6949 and then Ekind
(Wrapped_Entity
(Prim_Als
)) = E_Entry
6952 -- Ada.Tags.Set_Entry_Index
6953 -- (DT_Ptr, <position>, <index>);
6955 if Tagged_Type_Expansion
then
6958 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
);
6961 Make_Attribute_Reference
(Loc
,
6962 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6963 Attribute_Name
=> Name_Tag
);
6966 Append_To
(Assignments
,
6967 Make_Procedure_Call_Statement
(Loc
,
6969 New_Occurrence_Of
(RTE
(RE_Set_Entry_Index
), Loc
),
6970 Parameter_Associations
=> New_List
(
6972 Make_Integer_Literal
(Loc
, Prim_Pos
),
6973 Make_Integer_Literal
(Loc
,
6974 Find_Entry_Index
(Wrapped_Entity
(Prim_Als
))))));
6978 Next_Elmt
(Prim_Elmt
);
6983 end Make_Select_Specific_Data_Table
;
6989 function Make_Tags
(Typ
: Entity_Id
) return List_Id
is
6990 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6991 Result
: constant List_Id
:= New_List
;
6994 (Tag_Typ
: Entity_Id
;
6996 Is_Secondary_DT
: Boolean);
6997 -- Import the dispatch table DT of tagged type Tag_Typ. Required to
6998 -- generate forward references and statically allocate the table. For
6999 -- primary dispatch tables that require no dispatch table generate:
7001 -- DT : static aliased constant Non_Dispatch_Table_Wrapper;
7002 -- pragma Import (Ada, DT);
7004 -- Otherwise generate:
7006 -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
7007 -- pragma Import (Ada, DT);
7014 (Tag_Typ
: Entity_Id
;
7016 Is_Secondary_DT
: Boolean)
7018 DT_Constr_List
: List_Id
;
7022 Set_Is_Imported
(DT
);
7023 Set_Ekind
(DT
, E_Constant
);
7024 Set_Related_Type
(DT
, Typ
);
7026 -- The scope must be set now to call Get_External_Name
7028 Set_Scope
(DT
, Current_Scope
);
7030 Get_External_Name
(DT
);
7031 Set_Interface_Name
(DT
,
7032 Make_String_Literal
(Loc
, Strval
=> String_From_Name_Buffer
));
7034 -- Ensure proper Sprint output of this implicit importation
7036 Set_Is_Internal
(DT
);
7038 -- Save this entity to allow Make_DT to generate its exportation
7040 Append_Elmt
(DT
, Dispatch_Table_Wrappers
(Typ
));
7042 -- No dispatch table required
7044 if not Is_Secondary_DT
and then not Has_DT
(Tag_Typ
) then
7046 Make_Object_Declaration
(Loc
,
7047 Defining_Identifier
=> DT
,
7048 Aliased_Present
=> True,
7049 Constant_Present
=> True,
7050 Object_Definition
=>
7052 (RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
)));
7055 -- Calculate the number of primitives of the dispatch table and
7056 -- the size of the Type_Specific_Data record.
7059 UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Tag_Typ
)));
7061 -- If the tagged type has no primitives we add a dummy slot whose
7062 -- address will be the tag of this type.
7066 New_List
(Make_Integer_Literal
(Loc
, 1));
7069 New_List
(Make_Integer_Literal
(Loc
, Nb_Prim
));
7073 Make_Object_Declaration
(Loc
,
7074 Defining_Identifier
=> DT
,
7075 Aliased_Present
=> True,
7076 Constant_Present
=> True,
7077 Object_Definition
=>
7078 Make_Subtype_Indication
(Loc
,
7080 New_Occurrence_Of
(RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
7081 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
7082 Constraints
=> DT_Constr_List
))));
7088 Tname
: constant Name_Id
:= Chars
(Typ
);
7089 AI_Tag_Comp
: Elmt_Id
;
7090 DT
: Node_Id
:= Empty
;
7092 Predef_Prims_Ptr
: Node_Id
;
7093 Iface_DT
: Node_Id
:= Empty
;
7094 Iface_DT_Ptr
: Node_Id
;
7098 Typ_Comps
: Elist_Id
;
7100 -- Start of processing for Make_Tags
7103 pragma Assert
(No
(Access_Disp_Table
(Typ
)));
7104 Set_Access_Disp_Table
(Typ
, New_Elmt_List
);
7106 -- 1) Generate the primary tag entities
7108 -- Primary dispatch table containing user-defined primitives
7110 DT_Ptr
:= Make_Defining_Identifier
(Loc
, New_External_Name
(Tname
, 'P'));
7111 Set_Etype
(DT_Ptr
, RTE
(RE_Tag
));
7112 Append_Elmt
(DT_Ptr
, Access_Disp_Table
(Typ
));
7114 -- Minimum decoration
7116 Set_Ekind
(DT_Ptr
, E_Variable
);
7117 Set_Related_Type
(DT_Ptr
, Typ
);
7119 -- Notify back end that the types are associated with a dispatch table
7121 Set_Is_Dispatch_Table_Entity
(RTE
(RE_Prim_Ptr
));
7122 Set_Is_Dispatch_Table_Entity
(RTE
(RE_Predef_Prims_Table_Ptr
));
7124 -- For CPP types there is no need to build the dispatch tables since
7125 -- they are imported from the C++ side. If the CPP type has an IP then
7126 -- we declare now the variable that will store the copy of the C++ tag.
7127 -- If the CPP type is an interface, we need the variable as well because
7128 -- it becomes the pointer to the corresponding secondary table.
7130 if Is_CPP_Class
(Typ
) then
7131 if Has_CPP_Constructors
(Typ
) or else Is_Interface
(Typ
) then
7133 Make_Object_Declaration
(Loc
,
7134 Defining_Identifier
=> DT_Ptr
,
7135 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
7137 Unchecked_Convert_To
(RTE
(RE_Tag
),
7138 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
7140 Set_Is_Statically_Allocated
(DT_Ptr
,
7141 Is_Library_Level_Tagged_Type
(Typ
));
7147 -- Primary dispatch table containing predefined primitives
7150 Make_Defining_Identifier
(Loc
,
7151 Chars
=> New_External_Name
(Tname
, 'Y'));
7152 Set_Etype
(Predef_Prims_Ptr
, RTE
(RE_Address
));
7153 Append_Elmt
(Predef_Prims_Ptr
, Access_Disp_Table
(Typ
));
7155 -- Import the forward declaration of the Dispatch Table wrapper
7156 -- record (Make_DT will take care of exporting it).
7158 if Building_Static_DT
(Typ
) then
7159 Set_Dispatch_Table_Wrappers
(Typ
, New_Elmt_List
);
7162 Make_Defining_Identifier
(Loc
,
7163 Chars
=> New_External_Name
(Tname
, 'T'));
7165 Import_DT
(Typ
, DT
, Is_Secondary_DT
=> False);
7167 if Has_DT
(Typ
) then
7169 Make_Object_Declaration
(Loc
,
7170 Defining_Identifier
=> DT_Ptr
,
7171 Constant_Present
=> True,
7172 Object_Definition
=>
7173 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
7175 Unchecked_Convert_To
(RTE
(RE_Tag
),
7176 Make_Attribute_Reference
(Loc
,
7178 Make_Selected_Component
(Loc
,
7179 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
7182 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
7183 Attribute_Name
=> Name_Address
))));
7185 -- Generate the SCIL node for the previous object declaration
7186 -- because it has a tag initialization.
7188 if Generate_SCIL
then
7190 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
7191 Set_SCIL_Entity
(New_Node
, Typ
);
7192 Set_SCIL_Node
(Last
(Result
), New_Node
);
7196 Make_Object_Declaration
(Loc
,
7197 Defining_Identifier
=> Predef_Prims_Ptr
,
7198 Constant_Present
=> True,
7199 Object_Definition
=>
7200 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
7202 Make_Attribute_Reference
(Loc
,
7204 Make_Selected_Component
(Loc
,
7205 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
7208 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
7209 Attribute_Name
=> Name_Address
)));
7211 -- No dispatch table required
7215 Make_Object_Declaration
(Loc
,
7216 Defining_Identifier
=> DT_Ptr
,
7217 Constant_Present
=> True,
7218 Object_Definition
=>
7219 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
7221 Unchecked_Convert_To
(RTE
(RE_Tag
),
7222 Make_Attribute_Reference
(Loc
,
7224 Make_Selected_Component
(Loc
,
7225 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
7228 (RTE_Record_Component
(RE_NDT_Prims_Ptr
),
7230 Attribute_Name
=> Name_Address
))));
7233 Set_Is_True_Constant
(DT_Ptr
);
7234 Set_Is_Statically_Allocated
(DT_Ptr
);
7238 -- 2) Generate the secondary tag entities
7240 -- Collect the components associated with secondary dispatch tables
7242 if Has_Interfaces
(Typ
) then
7243 Collect_Interface_Components
(Typ
, Typ_Comps
);
7245 -- For each interface type we build a unique external name associated
7246 -- with its secondary dispatch table. This name is used to declare an
7247 -- object that references this secondary dispatch table, whose value
7248 -- will be used for the elaboration of Typ objects, and also for the
7249 -- elaboration of objects of types derived from Typ that do not
7250 -- override the primitives of this interface type.
7254 -- Note: The value of Suffix_Index must be in sync with the values of
7255 -- Suffix_Index in secondary dispatch tables generated by Make_DT.
7257 if Is_CPP_Class
(Typ
) then
7258 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
7259 while Present
(AI_Tag_Comp
) loop
7260 Get_Secondary_DT_External_Name
7261 (Typ
, Related_Type
(Node
(AI_Tag_Comp
)), Suffix_Index
);
7262 Typ_Name
:= Name_Find
;
7264 -- Declare variables to store copy of the C++ secondary tags
7267 Make_Defining_Identifier
(Loc
,
7268 Chars
=> New_External_Name
(Typ_Name
, 'P'));
7269 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7270 Set_Ekind
(Iface_DT_Ptr
, E_Variable
);
7271 Set_Is_Tag
(Iface_DT_Ptr
);
7273 Set_Has_Thunks
(Iface_DT_Ptr
);
7275 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7276 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7279 Make_Object_Declaration
(Loc
,
7280 Defining_Identifier
=> Iface_DT_Ptr
,
7281 Object_Definition
=> New_Occurrence_Of
7282 (RTE
(RE_Interface_Tag
), Loc
),
7284 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
7285 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
7287 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7288 Is_Library_Level_Tagged_Type
(Typ
));
7290 Next_Elmt
(AI_Tag_Comp
);
7293 -- This is not a CPP_Class type
7296 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
7297 while Present
(AI_Tag_Comp
) loop
7298 Get_Secondary_DT_External_Name
7299 (Typ
, Related_Type
(Node
(AI_Tag_Comp
)), Suffix_Index
);
7300 Typ_Name
:= Name_Find
;
7302 if Building_Static_DT
(Typ
) then
7304 Make_Defining_Identifier
(Loc
,
7305 Chars
=> New_External_Name
7306 (Typ_Name
, 'T', Suffix_Index
=> -1));
7308 (Tag_Typ
=> Related_Type
(Node
(AI_Tag_Comp
)),
7310 Is_Secondary_DT
=> True);
7313 -- Secondary dispatch table referencing thunks to user-defined
7314 -- primitives covered by this interface.
7317 Make_Defining_Identifier
(Loc
,
7318 Chars
=> New_External_Name
(Typ_Name
, 'P'));
7319 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7320 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
7321 Set_Is_Tag
(Iface_DT_Ptr
);
7322 Set_Has_Thunks
(Iface_DT_Ptr
);
7323 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7324 Is_Library_Level_Tagged_Type
(Typ
));
7325 Set_Is_True_Constant
(Iface_DT_Ptr
);
7327 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7328 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7330 if Building_Static_DT
(Typ
) then
7332 Make_Object_Declaration
(Loc
,
7333 Defining_Identifier
=> Iface_DT_Ptr
,
7334 Constant_Present
=> True,
7335 Object_Definition
=> New_Occurrence_Of
7336 (RTE
(RE_Interface_Tag
), Loc
),
7338 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
7339 Make_Attribute_Reference
(Loc
,
7341 Make_Selected_Component
(Loc
,
7343 New_Occurrence_Of
(Iface_DT
, Loc
),
7346 (RTE_Record_Component
(RE_Prims_Ptr
),
7348 Attribute_Name
=> Name_Address
))));
7351 -- Secondary dispatch table referencing thunks to predefined
7355 Make_Defining_Identifier
(Loc
,
7356 Chars
=> New_External_Name
(Typ_Name
, 'Y'));
7357 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Address
));
7358 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
7359 Set_Is_Tag
(Iface_DT_Ptr
);
7360 Set_Has_Thunks
(Iface_DT_Ptr
);
7361 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7362 Is_Library_Level_Tagged_Type
(Typ
));
7363 Set_Is_True_Constant
(Iface_DT_Ptr
);
7365 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7366 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7368 -- Secondary dispatch table referencing user-defined primitives
7369 -- covered by this interface.
7372 Make_Defining_Identifier
(Loc
,
7373 Chars
=> New_External_Name
(Typ_Name
, 'D'));
7374 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7375 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
7376 Set_Is_Tag
(Iface_DT_Ptr
);
7377 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7378 Is_Library_Level_Tagged_Type
(Typ
));
7379 Set_Is_True_Constant
(Iface_DT_Ptr
);
7381 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7382 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7384 -- Secondary dispatch table referencing predefined primitives
7387 Make_Defining_Identifier
(Loc
,
7388 Chars
=> New_External_Name
(Typ_Name
, 'Z'));
7389 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Address
));
7390 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
7391 Set_Is_Tag
(Iface_DT_Ptr
);
7392 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7393 Is_Library_Level_Tagged_Type
(Typ
));
7394 Set_Is_True_Constant
(Iface_DT_Ptr
);
7396 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7397 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7399 Next_Elmt
(AI_Tag_Comp
);
7404 -- 3) At the end of Access_Disp_Table, if the type has user-defined
7405 -- primitives, we add the entity of an access type declaration that
7406 -- is used by Build_Get_Prim_Op_Address to expand dispatching calls
7407 -- through the primary dispatch table.
7409 if UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Typ
))) = 0 then
7410 Analyze_List
(Result
);
7413 -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
7414 -- type Typ_DT_Acc is access Typ_DT;
7418 Name_DT_Prims
: constant Name_Id
:=
7419 New_External_Name
(Tname
, 'G');
7420 Name_DT_Prims_Acc
: constant Name_Id
:=
7421 New_External_Name
(Tname
, 'H');
7422 DT_Prims
: constant Entity_Id
:=
7423 Make_Defining_Identifier
(Loc
,
7425 DT_Prims_Acc
: constant Entity_Id
:=
7426 Make_Defining_Identifier
(Loc
,
7430 Make_Full_Type_Declaration
(Loc
,
7431 Defining_Identifier
=> DT_Prims
,
7433 Make_Constrained_Array_Definition
(Loc
,
7434 Discrete_Subtype_Definitions
=> New_List
(
7436 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
7437 High_Bound
=> Make_Integer_Literal
(Loc
,
7439 (First_Tag_Component
(Typ
))))),
7440 Component_Definition
=>
7441 Make_Component_Definition
(Loc
,
7442 Subtype_Indication
=>
7443 New_Occurrence_Of
(RTE
(RE_Prim_Ptr
), Loc
)))));
7446 Make_Full_Type_Declaration
(Loc
,
7447 Defining_Identifier
=> DT_Prims_Acc
,
7449 Make_Access_To_Object_Definition
(Loc
,
7450 Subtype_Indication
=>
7451 New_Occurrence_Of
(DT_Prims
, Loc
))));
7453 Append_Elmt
(DT_Prims_Acc
, Access_Disp_Table
(Typ
));
7455 -- Analyze the resulting list and suppress the generation of the
7456 -- Init_Proc associated with the above array declaration because
7457 -- this type is never used in object declarations. It is only used
7458 -- to simplify the expansion associated with dispatching calls.
7460 Analyze_List
(Result
);
7461 Set_Suppress_Initialization
(Base_Type
(DT_Prims
));
7463 -- Disable backend optimizations based on assumptions about the
7464 -- aliasing status of objects designated by the access to the
7465 -- dispatch table. Required to handle dispatch tables imported
7468 Set_No_Strict_Aliasing
(Base_Type
(DT_Prims_Acc
));
7470 -- Add the freezing nodes of these declarations; required to avoid
7471 -- generating these freezing nodes in wrong scopes (for example in
7472 -- the IC routine of a derivation of Typ).
7474 -- What is an "IC routine"? Is "init_proc" meant here???
7476 Append_List_To
(Result
, Freeze_Entity
(DT_Prims
, Typ
));
7477 Append_List_To
(Result
, Freeze_Entity
(DT_Prims_Acc
, Typ
));
7479 -- Mark entity of dispatch table. Required by the back end to
7480 -- handle them properly.
7482 Set_Is_Dispatch_Table_Entity
(DT_Prims
);
7486 -- Mark entities of dispatch table. Required by the back end to handle
7489 if Present
(DT
) then
7490 Set_Is_Dispatch_Table_Entity
(DT
);
7491 Set_Is_Dispatch_Table_Entity
(Etype
(DT
));
7494 if Present
(Iface_DT
) then
7495 Set_Is_Dispatch_Table_Entity
(Iface_DT
);
7496 Set_Is_Dispatch_Table_Entity
(Etype
(Iface_DT
));
7499 if Is_CPP_Class
(Root_Type
(Typ
)) then
7500 Set_Ekind
(DT_Ptr
, E_Variable
);
7502 Set_Ekind
(DT_Ptr
, E_Constant
);
7505 Set_Is_Tag
(DT_Ptr
);
7506 Set_Related_Type
(DT_Ptr
, Typ
);
7515 function New_Value
(From
: Node_Id
) return Node_Id
is
7516 Res
: constant Node_Id
:= Duplicate_Subexpr
(From
);
7518 if Is_Access_Type
(Etype
(From
)) then
7519 return Make_Explicit_Dereference
(Sloc
(From
), Prefix
=> Res
);
7525 -----------------------------------
7526 -- Original_View_In_Visible_Part --
7527 -----------------------------------
7529 function Original_View_In_Visible_Part
(Typ
: Entity_Id
) return Boolean is
7530 Scop
: constant Entity_Id
:= Scope
(Typ
);
7533 -- The scope must be a package
7535 if not Is_Package_Or_Generic_Package
(Scop
) then
7539 -- A type with a private declaration has a private view declared in
7540 -- the visible part.
7542 if Has_Private_Declaration
(Typ
) then
7546 return List_Containing
(Parent
(Typ
)) =
7547 Visible_Declarations
(Package_Specification
(Scop
));
7548 end Original_View_In_Visible_Part
;
7554 function Prim_Op_Kind
7556 Typ
: Entity_Id
) return Node_Id
7558 Full_Typ
: Entity_Id
:= Typ
;
7559 Loc
: constant Source_Ptr
:= Sloc
(Prim
);
7560 Prim_Op
: Entity_Id
;
7563 -- Retrieve the original primitive operation
7565 Prim_Op
:= Ultimate_Alias
(Prim
);
7567 if Ekind
(Typ
) = E_Record_Type
7568 and then Present
(Corresponding_Concurrent_Type
(Typ
))
7570 Full_Typ
:= Corresponding_Concurrent_Type
(Typ
);
7573 -- When a private tagged type is completed by a concurrent type,
7574 -- retrieve the full view.
7576 if Is_Private_Type
(Full_Typ
) then
7577 Full_Typ
:= Full_View
(Full_Typ
);
7580 if Ekind
(Prim_Op
) = E_Function
then
7582 -- Protected function
7584 if Ekind
(Full_Typ
) = E_Protected_Type
then
7585 return New_Occurrence_Of
(RTE
(RE_POK_Protected_Function
), Loc
);
7589 elsif Ekind
(Full_Typ
) = E_Task_Type
then
7590 return New_Occurrence_Of
(RTE
(RE_POK_Task_Function
), Loc
);
7595 return New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
);
7599 pragma Assert
(Ekind
(Prim_Op
) = E_Procedure
);
7601 if Ekind
(Full_Typ
) = E_Protected_Type
then
7605 if Is_Primitive_Wrapper
(Prim_Op
)
7606 and then Ekind
(Wrapped_Entity
(Prim_Op
)) = E_Entry
7608 return New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
);
7610 -- Protected procedure
7614 New_Occurrence_Of
(RTE
(RE_POK_Protected_Procedure
), Loc
);
7617 elsif Ekind
(Full_Typ
) = E_Task_Type
then
7621 if Is_Primitive_Wrapper
(Prim_Op
)
7622 and then Ekind
(Wrapped_Entity
(Prim_Op
)) = E_Entry
7624 return New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
);
7626 -- Task "procedure". These are the internally Expander-generated
7627 -- procedures (task body for instance).
7630 return New_Occurrence_Of
(RTE
(RE_POK_Task_Procedure
), Loc
);
7633 -- Regular procedure
7636 return New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
);
7641 ------------------------
7642 -- Register_Primitive --
7643 ------------------------
7645 function Register_Primitive
7647 Prim
: Entity_Id
) return List_Id
7650 Iface_Prim
: Entity_Id
;
7651 Iface_Typ
: Entity_Id
;
7652 Iface_DT_Ptr
: Entity_Id
;
7653 Iface_DT_Elmt
: Elmt_Id
;
7654 L
: constant List_Id
:= New_List
;
7657 Tag_Typ
: Entity_Id
;
7658 Thunk_Id
: Entity_Id
;
7659 Thunk_Code
: Node_Id
;
7662 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
7663 pragma Assert
(VM_Target
= No_VM
);
7665 -- Do not register in the dispatch table eliminated primitives
7667 if not RTE_Available
(RE_Tag
)
7668 or else Is_Eliminated
(Ultimate_Alias
(Prim
))
7673 if not Present
(Interface_Alias
(Prim
)) then
7674 Tag_Typ
:= Scope
(DTC_Entity
(Prim
));
7675 Pos
:= DT_Position
(Prim
);
7676 Tag
:= First_Tag_Component
(Tag_Typ
);
7678 if Is_Predefined_Dispatching_Operation
(Prim
)
7679 or else Is_Predefined_Dispatching_Alias
(Prim
)
7682 Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Tag_Typ
))));
7685 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7686 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7689 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7690 Make_Attribute_Reference
(Loc
,
7691 Prefix
=> New_Occurrence_Of
(Prim
, Loc
),
7692 Attribute_Name
=> Name_Unrestricted_Access
))));
7694 -- Register copy of the pointer to the 'size primitive in the TSD
7696 if Chars
(Prim
) = Name_uSize
7697 and then RTE_Record_Component_Available
(RE_Size_Func
)
7699 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Tag_Typ
)));
7701 Build_Set_Size_Function
(Loc
,
7702 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7703 Size_Func
=> Prim
));
7707 pragma Assert
(Pos
/= Uint_0
and then Pos
<= DT_Entry_Count
(Tag
));
7709 -- Skip registration of primitives located in the C++ part of the
7710 -- dispatch table. Their slot is set by the IC routine.
7712 if not Is_CPP_Class
(Root_Type
(Tag_Typ
))
7713 or else Pos
> CPP_Num_Prims
(Tag_Typ
)
7715 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Tag_Typ
)));
7717 Build_Set_Prim_Op_Address
(Loc
,
7719 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7722 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7723 Make_Attribute_Reference
(Loc
,
7724 Prefix
=> New_Occurrence_Of
(Prim
, Loc
),
7725 Attribute_Name
=> Name_Unrestricted_Access
))));
7729 -- Ada 2005 (AI-251): Primitive associated with an interface type
7731 -- Generate the code of the thunk only if the interface type is not an
7732 -- immediate ancestor of Typ; otherwise the dispatch table associated
7733 -- with the interface is the primary dispatch table and we have nothing
7737 Tag_Typ
:= Find_Dispatching_Type
(Alias
(Prim
));
7738 Iface_Typ
:= Find_Dispatching_Type
(Interface_Alias
(Prim
));
7740 pragma Assert
(Is_Interface
(Iface_Typ
));
7742 -- No action needed for interfaces that are ancestors of Typ because
7743 -- their primitives are located in the primary dispatch table.
7745 if Is_Ancestor
(Iface_Typ
, Tag_Typ
, Use_Full_View
=> True) then
7748 -- No action needed for primitives located in the C++ part of the
7749 -- dispatch table. Their slot is set by the IC routine.
7751 elsif Is_CPP_Class
(Root_Type
(Tag_Typ
))
7752 and then DT_Position
(Alias
(Prim
)) <= CPP_Num_Prims
(Tag_Typ
)
7753 and then not Is_Predefined_Dispatching_Operation
(Prim
)
7754 and then not Is_Predefined_Dispatching_Alias
(Prim
)
7759 Expand_Interface_Thunk
(Prim
, Thunk_Id
, Thunk_Code
);
7761 if not Is_Ancestor
(Iface_Typ
, Tag_Typ
, Use_Full_View
=> True)
7762 and then Present
(Thunk_Code
)
7764 -- Generate the code necessary to fill the appropriate entry of
7765 -- the secondary dispatch table of Prim's controlling type with
7766 -- Thunk_Id's address.
7768 Iface_DT_Elmt
:= Find_Interface_ADT
(Tag_Typ
, Iface_Typ
);
7769 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7770 pragma Assert
(Has_Thunks
(Iface_DT_Ptr
));
7772 Iface_Prim
:= Interface_Alias
(Prim
);
7773 Pos
:= DT_Position
(Iface_Prim
);
7774 Tag
:= First_Tag_Component
(Iface_Typ
);
7776 Prepend_To
(L
, Thunk_Code
);
7778 if Is_Predefined_Dispatching_Operation
(Prim
)
7779 or else Is_Predefined_Dispatching_Alias
(Prim
)
7782 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7784 New_Occurrence_Of
(Node
(Next_Elmt
(Iface_DT_Elmt
)), Loc
),
7787 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7788 Make_Attribute_Reference
(Loc
,
7789 Prefix
=> New_Occurrence_Of
(Thunk_Id
, Loc
),
7790 Attribute_Name
=> Name_Unrestricted_Access
))));
7792 Next_Elmt
(Iface_DT_Elmt
);
7793 Next_Elmt
(Iface_DT_Elmt
);
7794 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7795 pragma Assert
(not Has_Thunks
(Iface_DT_Ptr
));
7798 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7800 New_Occurrence_Of
(Node
(Next_Elmt
(Iface_DT_Elmt
)), Loc
),
7803 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7804 Make_Attribute_Reference
(Loc
,
7806 New_Occurrence_Of
(Alias
(Prim
), Loc
),
7807 Attribute_Name
=> Name_Unrestricted_Access
))));
7810 pragma Assert
(Pos
/= Uint_0
7811 and then Pos
<= DT_Entry_Count
(Tag
));
7814 Build_Set_Prim_Op_Address
(Loc
,
7816 Tag_Node
=> New_Occurrence_Of
(Iface_DT_Ptr
, Loc
),
7819 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7820 Make_Attribute_Reference
(Loc
,
7821 Prefix
=> New_Occurrence_Of
(Thunk_Id
, Loc
),
7822 Attribute_Name
=> Name_Unrestricted_Access
))));
7824 Next_Elmt
(Iface_DT_Elmt
);
7825 Next_Elmt
(Iface_DT_Elmt
);
7826 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7827 pragma Assert
(not Has_Thunks
(Iface_DT_Ptr
));
7830 Build_Set_Prim_Op_Address
(Loc
,
7832 Tag_Node
=> New_Occurrence_Of
(Iface_DT_Ptr
, Loc
),
7835 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7836 Make_Attribute_Reference
(Loc
,
7838 New_Occurrence_Of
(Alias
(Prim
), Loc
),
7839 Attribute_Name
=> Name_Unrestricted_Access
))));
7846 end Register_Primitive
;
7848 -------------------------
7849 -- Set_All_DT_Position --
7850 -------------------------
7852 procedure Set_All_DT_Position
(Typ
: Entity_Id
) is
7854 function In_Predef_Prims_DT
(Prim
: Entity_Id
) return Boolean;
7855 -- Returns True if Prim is located in the dispatch table of
7856 -- predefined primitives
7858 procedure Validate_Position
(Prim
: Entity_Id
);
7859 -- Check that position assigned to Prim is completely safe (it has not
7860 -- been assigned to a previously defined primitive operation of Typ).
7862 ------------------------
7863 -- In_Predef_Prims_DT --
7864 ------------------------
7866 function In_Predef_Prims_DT
(Prim
: Entity_Id
) return Boolean is
7870 -- Predefined primitives
7872 if Is_Predefined_Dispatching_Operation
(Prim
) then
7875 -- Renamings of predefined primitives
7877 elsif Present
(Alias
(Prim
))
7878 and then Is_Predefined_Dispatching_Operation
(Ultimate_Alias
(Prim
))
7880 if Chars
(Ultimate_Alias
(Prim
)) /= Name_Op_Eq
then
7883 -- User-defined renamings of predefined equality have their own
7884 -- slot in the primary dispatch table
7888 while Present
(Alias
(E
)) loop
7889 if Comes_From_Source
(E
) then
7896 return not Comes_From_Source
(E
);
7899 -- User-defined primitives
7904 end In_Predef_Prims_DT
;
7906 -----------------------
7907 -- Validate_Position --
7908 -----------------------
7910 procedure Validate_Position
(Prim
: Entity_Id
) is
7915 -- Aliased primitives are safe
7917 if Present
(Alias
(Prim
)) then
7921 Op_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
7922 while Present
(Op_Elmt
) loop
7923 Op
:= Node
(Op_Elmt
);
7925 -- No need to check against itself
7930 -- Primitive operations covering abstract interfaces are
7933 elsif Present
(Interface_Alias
(Op
)) then
7936 -- Predefined dispatching operations are completely safe. They
7937 -- are allocated at fixed positions in a separate table.
7939 elsif Is_Predefined_Dispatching_Operation
(Op
)
7940 or else Is_Predefined_Dispatching_Alias
(Op
)
7944 -- Aliased subprograms are safe
7946 elsif Present
(Alias
(Op
)) then
7949 elsif DT_Position
(Op
) = DT_Position
(Prim
)
7950 and then not Is_Predefined_Dispatching_Operation
(Op
)
7951 and then not Is_Predefined_Dispatching_Operation
(Prim
)
7952 and then not Is_Predefined_Dispatching_Alias
(Op
)
7953 and then not Is_Predefined_Dispatching_Alias
(Prim
)
7955 -- Handle aliased subprograms
7964 if Present
(Overridden_Operation
(Op_1
)) then
7965 Op_1
:= Overridden_Operation
(Op_1
);
7966 elsif Present
(Alias
(Op_1
)) then
7967 Op_1
:= Alias
(Op_1
);
7975 if Present
(Overridden_Operation
(Op_2
)) then
7976 Op_2
:= Overridden_Operation
(Op_2
);
7977 elsif Present
(Alias
(Op_2
)) then
7978 Op_2
:= Alias
(Op_2
);
7984 if Op_1
/= Op_2
then
7985 raise Program_Error
;
7990 Next_Elmt
(Op_Elmt
);
7992 end Validate_Position
;
7996 Parent_Typ
: constant Entity_Id
:= Etype
(Typ
);
7997 First_Prim
: constant Elmt_Id
:= First_Elmt
(Primitive_Operations
(Typ
));
7998 The_Tag
: constant Entity_Id
:= First_Tag_Component
(Typ
);
8000 Adjusted
: Boolean := False;
8001 Finalized
: Boolean := False;
8007 Prim_Elmt
: Elmt_Id
;
8009 -- Start of processing for Set_All_DT_Position
8012 pragma Assert
(Present
(First_Tag_Component
(Typ
)));
8014 -- Set the DT_Position for each primitive operation. Perform some sanity
8015 -- checks to avoid building inconsistent dispatch tables.
8017 -- First stage: Set DTC entity of all the primitive operations. This is
8018 -- required to properly read the DT_Position attribute in latter stages.
8020 Prim_Elmt
:= First_Prim
;
8022 while Present
(Prim_Elmt
) loop
8023 Prim
:= Node
(Prim_Elmt
);
8025 -- Predefined primitives have a separate dispatch table
8027 if not In_Predef_Prims_DT
(Prim
) then
8028 Count_Prim
:= Count_Prim
+ 1;
8031 Set_DTC_Entity_Value
(Typ
, Prim
);
8033 -- Clear any previous value of the DT_Position attribute. In this
8034 -- way we ensure that the final position of all the primitives is
8035 -- established by the following stages of this algorithm.
8037 Set_DT_Position_Value
(Prim
, No_Uint
);
8039 Next_Elmt
(Prim_Elmt
);
8043 Fixed_Prim
: array (Int
range 0 .. Count_Prim
) of Boolean :=
8048 procedure Handle_Inherited_Private_Subprograms
(Typ
: Entity_Id
);
8049 -- Called if Typ is declared in a nested package or a public child
8050 -- package to handle inherited primitives that were inherited by Typ
8051 -- in the visible part, but whose declaration was deferred because
8052 -- the parent operation was private and not visible at that point.
8054 procedure Set_Fixed_Prim
(Pos
: Nat
);
8055 -- Sets to true an element of the Fixed_Prim table to indicate
8056 -- that this entry of the dispatch table of Typ is occupied.
8058 ------------------------------------------
8059 -- Handle_Inherited_Private_Subprograms --
8060 ------------------------------------------
8062 procedure Handle_Inherited_Private_Subprograms
(Typ
: Entity_Id
) is
8065 Op_Elmt_2
: Elmt_Id
;
8066 Prim_Op
: Entity_Id
;
8067 Parent_Subp
: Entity_Id
;
8070 Op_List
:= Primitive_Operations
(Typ
);
8072 Op_Elmt
:= First_Elmt
(Op_List
);
8073 while Present
(Op_Elmt
) loop
8074 Prim_Op
:= Node
(Op_Elmt
);
8076 -- Search primitives that are implicit operations with an
8077 -- internal name whose parent operation has a normal name.
8079 if Present
(Alias
(Prim_Op
))
8080 and then Find_Dispatching_Type
(Alias
(Prim_Op
)) /= Typ
8081 and then not Comes_From_Source
(Prim_Op
)
8082 and then Is_Internal_Name
(Chars
(Prim_Op
))
8083 and then not Is_Internal_Name
(Chars
(Alias
(Prim_Op
)))
8085 Parent_Subp
:= Alias
(Prim_Op
);
8087 -- Check if the type has an explicit overriding for this
8090 Op_Elmt_2
:= Next_Elmt
(Op_Elmt
);
8091 while Present
(Op_Elmt_2
) loop
8092 if Chars
(Node
(Op_Elmt_2
)) = Chars
(Parent_Subp
)
8093 and then Type_Conformant
(Prim_Op
, Node
(Op_Elmt_2
))
8095 Set_DT_Position_Value
(Prim_Op
,
8096 DT_Position
(Parent_Subp
));
8097 Set_DT_Position_Value
(Node
(Op_Elmt_2
),
8098 DT_Position
(Parent_Subp
));
8099 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(Prim_Op
)));
8101 goto Next_Primitive
;
8104 Next_Elmt
(Op_Elmt_2
);
8109 Next_Elmt
(Op_Elmt
);
8111 end Handle_Inherited_Private_Subprograms
;
8113 --------------------
8114 -- Set_Fixed_Prim --
8115 --------------------
8117 procedure Set_Fixed_Prim
(Pos
: Nat
) is
8119 pragma Assert
(Pos
<= Count_Prim
);
8120 Fixed_Prim
(Pos
) := True;
8122 when Constraint_Error
=>
8123 raise Program_Error
;
8127 -- In case of nested packages and public child package it may be
8128 -- necessary a special management on inherited subprograms so that
8129 -- the dispatch table is properly filled.
8131 if Ekind
(Scope
(Scope
(Typ
))) = E_Package
8132 and then Scope
(Scope
(Typ
)) /= Standard_Standard
8133 and then ((Is_Derived_Type
(Typ
) and then not Is_Private_Type
(Typ
))
8135 (Nkind
(Parent
(Typ
)) = N_Private_Extension_Declaration
8136 and then Is_Generic_Type
(Typ
)))
8137 and then In_Open_Scopes
(Scope
(Etype
(Typ
)))
8138 and then Is_Base_Type
(Typ
)
8140 Handle_Inherited_Private_Subprograms
(Typ
);
8143 -- Second stage: Register fixed entries
8146 Prim_Elmt
:= First_Prim
;
8147 while Present
(Prim_Elmt
) loop
8148 Prim
:= Node
(Prim_Elmt
);
8150 -- Predefined primitives have a separate table and all its
8151 -- entries are at predefined fixed positions.
8153 if In_Predef_Prims_DT
(Prim
) then
8154 if Is_Predefined_Dispatching_Operation
(Prim
) then
8155 Set_DT_Position_Value
(Prim
,
8156 Default_Prim_Op_Position
(Prim
));
8158 else pragma Assert
(Present
(Alias
(Prim
)));
8159 Set_DT_Position_Value
(Prim
,
8160 Default_Prim_Op_Position
(Ultimate_Alias
(Prim
)));
8163 -- Overriding primitives of ancestor abstract interfaces
8165 elsif Present
(Interface_Alias
(Prim
))
8166 and then Is_Ancestor
8167 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
8168 Use_Full_View
=> True)
8170 pragma Assert
(DT_Position
(Prim
) = No_Uint
8171 and then Present
(DTC_Entity
(Interface_Alias
(Prim
))));
8173 E
:= Interface_Alias
(Prim
);
8174 Set_DT_Position_Value
(Prim
, DT_Position
(E
));
8177 (DT_Position
(Alias
(Prim
)) = No_Uint
8178 or else DT_Position
(Alias
(Prim
)) = DT_Position
(E
));
8179 Set_DT_Position_Value
(Alias
(Prim
), DT_Position
(E
));
8180 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(Prim
)));
8182 -- Overriding primitives must use the same entry as the
8183 -- overridden primitive.
8185 elsif not Present
(Interface_Alias
(Prim
))
8186 and then Present
(Alias
(Prim
))
8187 and then Chars
(Prim
) = Chars
(Alias
(Prim
))
8188 and then Find_Dispatching_Type
(Alias
(Prim
)) /= Typ
8189 and then Is_Ancestor
8190 (Find_Dispatching_Type
(Alias
(Prim
)), Typ
,
8191 Use_Full_View
=> True)
8192 and then Present
(DTC_Entity
(Alias
(Prim
)))
8195 Set_DT_Position_Value
(Prim
, DT_Position
(E
));
8197 if not Is_Predefined_Dispatching_Alias
(E
) then
8198 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(E
)));
8202 Next_Elmt
(Prim_Elmt
);
8205 -- Third stage: Fix the position of all the new primitives. Entries
8206 -- associated with primitives covering interfaces are handled in a
8209 Prim_Elmt
:= First_Prim
;
8210 while Present
(Prim_Elmt
) loop
8211 Prim
:= Node
(Prim_Elmt
);
8213 -- Skip primitives previously set entries
8215 if DT_Position
(Prim
) /= No_Uint
then
8218 -- Primitives covering interface primitives are handled later
8220 elsif Present
(Interface_Alias
(Prim
)) then
8224 -- Take the next available position in the DT
8227 Nb_Prim
:= Nb_Prim
+ 1;
8228 pragma Assert
(Nb_Prim
<= Count_Prim
);
8229 exit when not Fixed_Prim
(Nb_Prim
);
8232 Set_DT_Position_Value
(Prim
, UI_From_Int
(Nb_Prim
));
8233 Set_Fixed_Prim
(Nb_Prim
);
8236 Next_Elmt
(Prim_Elmt
);
8240 -- Fourth stage: Complete the decoration of primitives covering
8241 -- interfaces (that is, propagate the DT_Position attribute from
8242 -- the aliased primitive)
8244 Prim_Elmt
:= First_Prim
;
8245 while Present
(Prim_Elmt
) loop
8246 Prim
:= Node
(Prim_Elmt
);
8248 if DT_Position
(Prim
) = No_Uint
8249 and then Present
(Interface_Alias
(Prim
))
8251 pragma Assert
(Present
(Alias
(Prim
))
8252 and then Find_Dispatching_Type
(Alias
(Prim
)) = Typ
);
8254 -- Check if this entry will be placed in the primary DT
8257 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
8258 Use_Full_View
=> True)
8260 pragma Assert
(DT_Position
(Alias
(Prim
)) /= No_Uint
);
8261 Set_DT_Position_Value
(Prim
, DT_Position
(Alias
(Prim
)));
8263 -- Otherwise it will be placed in the secondary DT
8267 (DT_Position
(Interface_Alias
(Prim
)) /= No_Uint
);
8268 Set_DT_Position_Value
(Prim
,
8269 DT_Position
(Interface_Alias
(Prim
)));
8273 Next_Elmt
(Prim_Elmt
);
8276 -- Generate listing showing the contents of the dispatch tables. This
8277 -- action is done before some further static checks because in case of
8278 -- critical errors caused by a wrong dispatch table we need to see the
8279 -- contents of such table.
8281 if Debug_Flag_ZZ
then
8285 -- Final stage: Ensure that the table is correct plus some further
8286 -- verifications concerning the primitives.
8288 Prim_Elmt
:= First_Prim
;
8290 while Present
(Prim_Elmt
) loop
8291 Prim
:= Node
(Prim_Elmt
);
8293 -- At this point all the primitives MUST have a position in the
8296 if DT_Position
(Prim
) = No_Uint
then
8297 raise Program_Error
;
8300 -- Calculate real size of the dispatch table
8302 if not In_Predef_Prims_DT
(Prim
)
8303 and then UI_To_Int
(DT_Position
(Prim
)) > DT_Length
8305 DT_Length
:= UI_To_Int
(DT_Position
(Prim
));
8308 -- Ensure that the assigned position to non-predefined dispatching
8309 -- operations in the dispatch table is correct.
8311 if not Is_Predefined_Dispatching_Operation
(Prim
)
8312 and then not Is_Predefined_Dispatching_Alias
(Prim
)
8314 Validate_Position
(Prim
);
8317 if Chars
(Prim
) = Name_Finalize
then
8321 if Chars
(Prim
) = Name_Adjust
then
8325 -- An abstract operation cannot be declared in the private part for a
8326 -- visible abstract type, because it can't be overridden outside this
8327 -- package hierarchy. For explicit declarations this is checked at
8328 -- the point of declaration, but for inherited operations it must be
8329 -- done when building the dispatch table.
8331 -- Ada 2005 (AI-251): Primitives associated with interfaces are
8332 -- excluded from this check because interfaces must be visible in
8333 -- the public and private part (RM 7.3 (7.3/2))
8335 -- We disable this check in Relaxed_RM_Semantics mode, to accommodate
8338 if not Relaxed_RM_Semantics
8339 and then Is_Abstract_Type
(Typ
)
8340 and then Is_Abstract_Subprogram
(Prim
)
8341 and then Present
(Alias
(Prim
))
8342 and then not Is_Interface
8343 (Find_Dispatching_Type
(Ultimate_Alias
(Prim
)))
8344 and then not Present
(Interface_Alias
(Prim
))
8345 and then Is_Derived_Type
(Typ
)
8346 and then In_Private_Part
(Current_Scope
)
8348 List_Containing
(Parent
(Prim
)) =
8349 Private_Declarations
(Package_Specification
(Current_Scope
))
8350 and then Original_View_In_Visible_Part
(Typ
)
8352 -- We exclude Input and Output stream operations because
8353 -- Limited_Controlled inherits useless Input and Output stream
8354 -- operations from Root_Controlled, which can never be overridden.
8356 if not Is_TSS
(Prim
, TSS_Stream_Input
)
8358 not Is_TSS
(Prim
, TSS_Stream_Output
)
8361 ("abstract inherited private operation&" &
8362 " must be overridden (RM 3.9.3(10))",
8363 Parent
(Typ
), Prim
);
8367 Next_Elmt
(Prim_Elmt
);
8372 if Is_Controlled
(Typ
) then
8373 if not Finalized
then
8375 ("controlled type has no explicit Finalize method??", Typ
);
8377 elsif not Adjusted
then
8379 ("controlled type has no explicit Adjust method??", Typ
);
8383 -- Set the final size of the Dispatch Table
8385 Set_DT_Entry_Count
(The_Tag
, UI_From_Int
(DT_Length
));
8387 -- The derived type must have at least as many components as its parent
8388 -- (for root types Etype points to itself and the test cannot fail).
8390 if DT_Entry_Count
(The_Tag
) <
8391 DT_Entry_Count
(First_Tag_Component
(Parent_Typ
))
8393 raise Program_Error
;
8395 end Set_All_DT_Position
;
8397 --------------------------
8398 -- Set_CPP_Constructors --
8399 --------------------------
8401 procedure Set_CPP_Constructors
(Typ
: Entity_Id
) is
8403 function Gen_Parameters_Profile
(E
: Entity_Id
) return List_Id
;
8404 -- Duplicate the parameters profile of the imported C++ constructor
8405 -- adding an access to the object as an additional parameter.
8407 ----------------------------
8408 -- Gen_Parameters_Profile --
8409 ----------------------------
8411 function Gen_Parameters_Profile
(E
: Entity_Id
) return List_Id
is
8412 Loc
: constant Source_Ptr
:= Sloc
(E
);
8419 Make_Parameter_Specification
(Loc
,
8420 Defining_Identifier
=>
8421 Make_Defining_Identifier
(Loc
, Name_uInit
),
8422 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
8424 if Present
(Parameter_Specifications
(Parent
(E
))) then
8425 P
:= First
(Parameter_Specifications
(Parent
(E
)));
8426 while Present
(P
) loop
8428 Make_Parameter_Specification
(Loc
,
8429 Defining_Identifier
=>
8430 Make_Defining_Identifier
(Loc
,
8431 Chars
=> Chars
(Defining_Identifier
(P
))),
8432 Parameter_Type
=> New_Copy_Tree
(Parameter_Type
(P
)),
8433 Expression
=> New_Copy_Tree
(Expression
(P
))));
8439 end Gen_Parameters_Profile
;
8445 Found
: Boolean := False;
8451 Covers_Default_Constructor
: Entity_Id
:= Empty
;
8453 -- Start of processing for Set_CPP_Constructor
8456 pragma Assert
(Is_CPP_Class
(Typ
));
8458 -- Look for the constructor entities
8460 E
:= Next_Entity
(Typ
);
8461 while Present
(E
) loop
8462 if Ekind
(E
) = E_Function
8463 and then Is_Constructor
(E
)
8467 Parms
:= Gen_Parameters_Profile
(E
);
8469 Make_Defining_Identifier
(Loc
,
8470 Chars
=> Make_Init_Proc_Name
(Typ
));
8472 -- Case 1: Constructor of untagged type
8474 -- If the C++ class has no virtual methods then the matching Ada
8475 -- type is an untagged record type. In such case there is no need
8476 -- to generate a wrapper of the C++ constructor because the _tag
8477 -- component is not available.
8479 if not Is_Tagged_Type
(Typ
) then
8481 (Make_Subprogram_Declaration
(Loc
,
8483 Make_Procedure_Specification
(Loc
,
8484 Defining_Unit_Name
=> IP
,
8485 Parameter_Specifications
=> Parms
)));
8487 Set_Init_Proc
(Typ
, IP
);
8488 Set_Is_Imported
(IP
);
8489 Set_Is_Constructor
(IP
);
8490 Set_Interface_Name
(IP
, Interface_Name
(E
));
8491 Set_Convention
(IP
, Convention_CPP
);
8493 Set_Has_Completion
(IP
);
8495 -- Case 2: Constructor of a tagged type
8497 -- In this case we generate the IP as a wrapper of the the
8498 -- C++ constructor because IP must also save copy of the _tag
8499 -- generated in the C++ side. The copy of the _tag is used by
8500 -- Build_CPP_Init_Procedure to elaborate derivations of C++ types.
8503 -- procedure IP (_init : Typ; ...) is
8504 -- procedure ConstructorP (_init : Typ; ...);
8505 -- pragma Import (ConstructorP);
8507 -- ConstructorP (_init, ...);
8508 -- if Typ._tag = null then
8509 -- Typ._tag := _init._tag;
8515 Body_Stmts
: constant List_Id
:= New_List
;
8516 Constructor_Id
: Entity_Id
;
8517 Constructor_Decl_Node
: Node_Id
;
8518 Init_Tags_List
: List_Id
;
8521 Constructor_Id
:= Make_Temporary
(Loc
, 'P');
8523 Constructor_Decl_Node
:=
8524 Make_Subprogram_Declaration
(Loc
,
8525 Make_Procedure_Specification
(Loc
,
8526 Defining_Unit_Name
=> Constructor_Id
,
8527 Parameter_Specifications
=> Parms
));
8529 Set_Is_Imported
(Constructor_Id
);
8530 Set_Is_Constructor
(Constructor_Id
);
8531 Set_Interface_Name
(Constructor_Id
, Interface_Name
(E
));
8532 Set_Convention
(Constructor_Id
, Convention_CPP
);
8533 Set_Is_Public
(Constructor_Id
);
8534 Set_Has_Completion
(Constructor_Id
);
8536 -- Build the init procedure as a wrapper of this constructor
8538 Parms
:= Gen_Parameters_Profile
(E
);
8540 -- Invoke the C++ constructor
8543 Actuals
: constant List_Id
:= New_List
;
8547 while Present
(P
) loop
8549 New_Occurrence_Of
(Defining_Identifier
(P
), Loc
));
8553 Append_To
(Body_Stmts
,
8554 Make_Procedure_Call_Statement
(Loc
,
8555 Name
=> New_Occurrence_Of
(Constructor_Id
, Loc
),
8556 Parameter_Associations
=> Actuals
));
8559 -- Initialize copies of C++ primary and secondary tags
8561 Init_Tags_List
:= New_List
;
8568 Tag_Elmt
:= First_Elmt
(Access_Disp_Table
(Typ
));
8569 Tag_Comp
:= First_Tag_Component
(Typ
);
8571 while Present
(Tag_Elmt
)
8572 and then Is_Tag
(Node
(Tag_Elmt
))
8574 -- Skip the following assertion with primary tags
8575 -- because Related_Type is not set on primary tag
8579 (Tag_Comp
= First_Tag_Component
(Typ
)
8580 or else Related_Type
(Node
(Tag_Elmt
))
8581 = Related_Type
(Tag_Comp
));
8583 Append_To
(Init_Tags_List
,
8584 Make_Assignment_Statement
(Loc
,
8586 New_Occurrence_Of
(Node
(Tag_Elmt
), Loc
),
8588 Make_Selected_Component
(Loc
,
8590 Make_Identifier
(Loc
, Name_uInit
),
8592 New_Occurrence_Of
(Tag_Comp
, Loc
))));
8594 Tag_Comp
:= Next_Tag_Component
(Tag_Comp
);
8595 Next_Elmt
(Tag_Elmt
);
8599 Append_To
(Body_Stmts
,
8600 Make_If_Statement
(Loc
,
8605 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))),
8608 Unchecked_Convert_To
(RTE
(RE_Tag
),
8609 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))),
8610 Then_Statements
=> Init_Tags_List
));
8613 Make_Subprogram_Body
(Loc
,
8615 Make_Procedure_Specification
(Loc
,
8616 Defining_Unit_Name
=> IP
,
8617 Parameter_Specifications
=> Parms
),
8618 Declarations
=> New_List
(Constructor_Decl_Node
),
8619 Handled_Statement_Sequence
=>
8620 Make_Handled_Sequence_Of_Statements
(Loc
,
8621 Statements
=> Body_Stmts
,
8622 Exception_Handlers
=> No_List
));
8624 Discard_Node
(IP_Body
);
8625 Set_Init_Proc
(Typ
, IP
);
8629 -- If this constructor has parameters and all its parameters have
8630 -- defaults then it covers the default constructor. The semantic
8631 -- analyzer ensures that only one constructor with defaults covers
8632 -- the default constructor.
8634 if Present
(Parameter_Specifications
(Parent
(E
)))
8635 and then Needs_No_Actuals
(E
)
8637 Covers_Default_Constructor
:= IP
;
8644 -- If there are no constructors, mark the type as abstract since we
8645 -- won't be able to declare objects of that type.
8648 Set_Is_Abstract_Type
(Typ
);
8651 -- Handle constructor that has all its parameters with defaults and
8652 -- hence it covers the default constructor. We generate a wrapper IP
8653 -- which calls the covering constructor.
8655 if Present
(Covers_Default_Constructor
) then
8657 Body_Stmts
: List_Id
;
8660 Loc
:= Sloc
(Covers_Default_Constructor
);
8662 Body_Stmts
:= New_List
(
8663 Make_Procedure_Call_Statement
(Loc
,
8665 New_Occurrence_Of
(Covers_Default_Constructor
, Loc
),
8666 Parameter_Associations
=> New_List
(
8667 Make_Identifier
(Loc
, Name_uInit
))));
8669 IP
:= Make_Defining_Identifier
(Loc
, Make_Init_Proc_Name
(Typ
));
8672 Make_Subprogram_Body
(Loc
,
8674 Make_Procedure_Specification
(Loc
,
8675 Defining_Unit_Name
=> IP
,
8676 Parameter_Specifications
=> New_List
(
8677 Make_Parameter_Specification
(Loc
,
8678 Defining_Identifier
=>
8679 Make_Defining_Identifier
(Loc
, Name_uInit
),
8680 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)))),
8682 Declarations
=> No_List
,
8684 Handled_Statement_Sequence
=>
8685 Make_Handled_Sequence_Of_Statements
(Loc
,
8686 Statements
=> Body_Stmts
,
8687 Exception_Handlers
=> No_List
));
8689 Discard_Node
(IP_Body
);
8690 Set_Init_Proc
(Typ
, IP
);
8694 -- If the CPP type has constructors then it must import also the default
8695 -- C++ constructor. It is required for default initialization of objects
8696 -- of the type. It is also required to elaborate objects of Ada types
8697 -- that are defined as derivations of this CPP type.
8699 if Has_CPP_Constructors
(Typ
)
8700 and then No
(Init_Proc
(Typ
))
8702 Error_Msg_N
("??default constructor must be imported from C++", Typ
);
8704 end Set_CPP_Constructors
;
8706 ---------------------------
8707 -- Set_DT_Position_Value --
8708 ---------------------------
8710 procedure Set_DT_Position_Value
(Prim
: Entity_Id
; Value
: Uint
) is
8712 Set_DT_Position
(Prim
, Value
);
8714 -- Propagate the value to the wrapped subprogram (if one is present)
8716 if Ekind_In
(Prim
, E_Function
, E_Procedure
)
8717 and then Is_Primitive_Wrapper
(Prim
)
8718 and then Present
(Wrapped_Entity
(Prim
))
8719 and then Is_Dispatching_Operation
(Wrapped_Entity
(Prim
))
8721 Set_DT_Position
(Wrapped_Entity
(Prim
), Value
);
8723 end Set_DT_Position_Value
;
8725 --------------------------
8726 -- Set_DTC_Entity_Value --
8727 --------------------------
8729 procedure Set_DTC_Entity_Value
8730 (Tagged_Type
: Entity_Id
;
8734 if Present
(Interface_Alias
(Prim
))
8735 and then Is_Interface
8736 (Find_Dispatching_Type
(Interface_Alias
(Prim
)))
8738 Set_DTC_Entity
(Prim
,
8741 Iface
=> Find_Dispatching_Type
(Interface_Alias
(Prim
))));
8743 Set_DTC_Entity
(Prim
,
8744 First_Tag_Component
(Tagged_Type
));
8747 -- Propagate the value to the wrapped subprogram (if one is present)
8749 if Ekind_In
(Prim
, E_Function
, E_Procedure
)
8750 and then Is_Primitive_Wrapper
(Prim
)
8751 and then Present
(Wrapped_Entity
(Prim
))
8752 and then Is_Dispatching_Operation
(Wrapped_Entity
(Prim
))
8754 Set_DTC_Entity
(Wrapped_Entity
(Prim
), DTC_Entity
(Prim
));
8756 end Set_DTC_Entity_Value
;
8762 function Tagged_Kind
(T
: Entity_Id
) return Node_Id
is
8763 Conc_Typ
: Entity_Id
;
8764 Loc
: constant Source_Ptr
:= Sloc
(T
);
8768 (Is_Tagged_Type
(T
) and then RTE_Available
(RE_Tagged_Kind
));
8772 if Is_Abstract_Type
(T
) then
8773 if Is_Limited_Record
(T
) then
8774 return New_Occurrence_Of
8775 (RTE
(RE_TK_Abstract_Limited_Tagged
), Loc
);
8777 return New_Occurrence_Of
8778 (RTE
(RE_TK_Abstract_Tagged
), Loc
);
8783 elsif Is_Concurrent_Record_Type
(T
) then
8784 Conc_Typ
:= Corresponding_Concurrent_Type
(T
);
8786 if Present
(Full_View
(Conc_Typ
)) then
8787 Conc_Typ
:= Full_View
(Conc_Typ
);
8790 if Ekind
(Conc_Typ
) = E_Protected_Type
then
8791 return New_Occurrence_Of
(RTE
(RE_TK_Protected
), Loc
);
8793 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
8794 return New_Occurrence_Of
(RTE
(RE_TK_Task
), Loc
);
8797 -- Regular tagged kinds
8800 if Is_Limited_Record
(T
) then
8801 return New_Occurrence_Of
(RTE
(RE_TK_Limited_Tagged
), Loc
);
8803 return New_Occurrence_Of
(RTE
(RE_TK_Tagged
), Loc
);
8812 procedure Write_DT
(Typ
: Entity_Id
) is
8817 -- Protect this procedure against wrong usage. Required because it will
8818 -- be used directly from GDB
8820 if not (Typ
<= Last_Node_Id
)
8821 or else not Is_Tagged_Type
(Typ
)
8823 Write_Str
("wrong usage: Write_DT must be used with tagged types");
8828 Write_Int
(Int
(Typ
));
8830 Write_Name
(Chars
(Typ
));
8832 if Is_Interface
(Typ
) then
8833 Write_Str
(" is interface");
8838 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
8839 while Present
(Elmt
) loop
8840 Prim
:= Node
(Elmt
);
8843 -- Indicate if this primitive will be allocated in the primary
8844 -- dispatch table or in a secondary dispatch table associated
8845 -- with an abstract interface type
8847 if Present
(DTC_Entity
(Prim
)) then
8848 if Etype
(DTC_Entity
(Prim
)) = RTE
(RE_Tag
) then
8855 -- Output the node of this primitive operation and its name
8857 Write_Int
(Int
(Prim
));
8860 if Is_Predefined_Dispatching_Operation
(Prim
) then
8861 Write_Str
("(predefined) ");
8864 -- Prefix the name of the primitive with its corresponding tagged
8865 -- type to facilitate seeing inherited primitives.
8867 if Present
(Alias
(Prim
)) then
8869 (Chars
(Find_Dispatching_Type
(Ultimate_Alias
(Prim
))));
8871 Write_Name
(Chars
(Typ
));
8875 Write_Name
(Chars
(Prim
));
8877 -- Indicate if this primitive has an aliased primitive
8879 if Present
(Alias
(Prim
)) then
8880 Write_Str
(" (alias = ");
8881 Write_Int
(Int
(Alias
(Prim
)));
8883 -- If the DTC_Entity attribute is already set we can also output
8884 -- the name of the interface covered by this primitive (if any).
8886 if Ekind_In
(Alias
(Prim
), E_Function
, E_Procedure
)
8887 and then Present
(DTC_Entity
(Alias
(Prim
)))
8888 and then Is_Interface
(Scope
(DTC_Entity
(Alias
(Prim
))))
8890 Write_Str
(" from interface ");
8891 Write_Name
(Chars
(Scope
(DTC_Entity
(Alias
(Prim
)))));
8894 if Present
(Interface_Alias
(Prim
)) then
8895 Write_Str
(", AI_Alias of ");
8897 if Is_Null_Interface_Primitive
(Interface_Alias
(Prim
)) then
8898 Write_Str
("null primitive ");
8902 (Chars
(Find_Dispatching_Type
(Interface_Alias
(Prim
))));
8904 Write_Int
(Int
(Interface_Alias
(Prim
)));
8910 -- Display the final position of this primitive in its associated
8911 -- (primary or secondary) dispatch table.
8913 if Present
(DTC_Entity
(Prim
))
8914 and then DT_Position
(Prim
) /= No_Uint
8916 Write_Str
(" at #");
8917 Write_Int
(UI_To_Int
(DT_Position
(Prim
)));
8920 if Is_Abstract_Subprogram
(Prim
) then
8921 Write_Str
(" is abstract;");
8923 -- Check if this is a null primitive
8925 elsif Comes_From_Source
(Prim
)
8926 and then Ekind
(Prim
) = E_Procedure
8927 and then Null_Present
(Parent
(Prim
))
8929 Write_Str
(" is null;");
8932 if Is_Eliminated
(Ultimate_Alias
(Prim
)) then
8933 Write_Str
(" (eliminated)");
8936 if Is_Imported
(Prim
)
8937 and then Convention
(Prim
) = Convention_CPP
8939 Write_Str
(" (C++)");