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 for which the dispatch table is being build may be
4481 -- subject to pragma Ghost with policy Ignore. Set the mode now to
4482 -- ensure that any nodes generated during freezing are properly flagged
4483 -- as ignored Ghost.
4485 Set_Ghost_Mode_For_Freeze
(Typ
, Typ
);
4487 -- Handle cases in which there is no need to build the dispatch table
4489 if Has_Dispatch_Table
(Typ
)
4490 or else No
(Access_Disp_Table
(Typ
))
4491 or else Is_CPP_Class
(Typ
)
4492 or else Convention
(Typ
) = Convention_CIL
4493 or else Convention
(Typ
) = Convention_Java
4498 elsif No_Run_Time_Mode
then
4499 Error_Msg_CRT
("tagged types", Typ
);
4503 elsif not RTE_Available
(RE_Tag
) then
4505 Make_Object_Declaration
(Loc
,
4506 Defining_Identifier
=> Node
(First_Elmt
4507 (Access_Disp_Table
(Typ
))),
4508 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
4509 Constant_Present
=> True,
4511 Unchecked_Convert_To
(RTE
(RE_Tag
),
4512 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
4514 Analyze_List
(Result
, Suppress
=> All_Checks
);
4515 Error_Msg_CRT
("tagged types", Typ
);
4520 -- Ensure that the value of Max_Predef_Prims defined in a-tags is
4521 -- correct. Valid values are 9 under configurable runtime or 15
4522 -- with full runtime.
4524 if RTE_Available
(RE_Interface_Data
) then
4525 if Max_Predef_Prims
/= 15 then
4526 Error_Msg_N
("run-time library configuration error", Typ
);
4531 if Max_Predef_Prims
/= 9 then
4532 Error_Msg_N
("run-time library configuration error", Typ
);
4533 Error_Msg_CRT
("tagged types", Typ
);
4539 -- Initialize Parent_Typ handling private types
4541 Parent_Typ
:= Etype
(Typ
);
4543 if Present
(Full_View
(Parent_Typ
)) then
4544 Parent_Typ
:= Full_View
(Parent_Typ
);
4547 -- Ensure that all the primitives are frozen. This is only required when
4548 -- building static dispatch tables --- the primitives must be frozen to
4549 -- be referenced (otherwise we have problems with the backend). It is
4550 -- not a requirement with nonstatic dispatch tables because in this case
4551 -- we generate now an empty dispatch table; the extra code required to
4552 -- register the primitives in the slots will be generated later --- when
4553 -- each primitive is frozen (see Freeze_Subprogram).
4555 if Building_Static_DT
(Typ
) then
4557 Save
: constant Boolean := Freezing_Library_Level_Tagged_Type
;
4559 Prim_Elmt
: Elmt_Id
;
4563 Freezing_Library_Level_Tagged_Type
:= True;
4565 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4566 while Present
(Prim_Elmt
) loop
4567 Prim
:= Node
(Prim_Elmt
);
4568 Frnodes
:= Freeze_Entity
(Prim
, Typ
);
4574 F
:= First_Formal
(Prim
);
4575 while Present
(F
) loop
4576 Check_Premature_Freezing
(Prim
, Typ
, Etype
(F
));
4580 Check_Premature_Freezing
(Prim
, Typ
, Etype
(Prim
));
4583 if Present
(Frnodes
) then
4584 Append_List_To
(Result
, Frnodes
);
4587 Next_Elmt
(Prim_Elmt
);
4590 Freezing_Library_Level_Tagged_Type
:= Save
;
4594 -- Ada 2005 (AI-251): Build the secondary dispatch tables
4596 if Has_Interfaces
(Typ
) then
4597 Collect_Interface_Components
(Typ
, Typ_Comps
);
4599 -- Each secondary dispatch table is assigned an unique positive
4600 -- suffix index; such value also corresponds with the location of
4601 -- its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
4603 -- Note: This value must be kept sync with the Suffix_Index values
4604 -- generated by Make_Tags
4608 Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
4610 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
4611 while Present
(AI_Tag_Comp
) loop
4612 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'P'));
4614 -- Build the secondary table containing pointers to thunks
4619 (Related_Type
(Node
(AI_Tag_Comp
))),
4620 Suffix_Index
=> Suffix_Index
,
4621 Num_Iface_Prims
=> UI_To_Int
4622 (DT_Entry_Count
(Node
(AI_Tag_Comp
))),
4623 Iface_DT_Ptr
=> Node
(AI_Tag_Elmt
),
4624 Predef_Prims_Ptr
=> Node
(Next_Elmt
(AI_Tag_Elmt
)),
4625 Build_Thunks
=> True,
4628 -- Skip secondary dispatch table referencing thunks to predefined
4631 Next_Elmt
(AI_Tag_Elmt
);
4632 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'Y'));
4634 -- Secondary dispatch table referencing user-defined primitives
4635 -- covered by this interface.
4637 Next_Elmt
(AI_Tag_Elmt
);
4638 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'D'));
4640 -- Build the secondary table containing pointers to primitives
4641 -- (used to give support to Generic Dispatching Constructors).
4646 (Related_Type
(Node
(AI_Tag_Comp
))),
4648 Num_Iface_Prims
=> UI_To_Int
4649 (DT_Entry_Count
(Node
(AI_Tag_Comp
))),
4650 Iface_DT_Ptr
=> Node
(AI_Tag_Elmt
),
4651 Predef_Prims_Ptr
=> Node
(Next_Elmt
(AI_Tag_Elmt
)),
4652 Build_Thunks
=> False,
4655 -- Skip secondary dispatch table referencing predefined primitives
4657 Next_Elmt
(AI_Tag_Elmt
);
4658 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'Z'));
4660 Suffix_Index
:= Suffix_Index
+ 1;
4661 Next_Elmt
(AI_Tag_Elmt
);
4662 Next_Elmt
(AI_Tag_Comp
);
4666 -- Get the _tag entity and number of primitives of its dispatch table
4668 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
4669 Nb_Prim
:= UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Typ
)));
4671 Set_Is_Statically_Allocated
(DT
, Is_Library_Level_Tagged_Type
(Typ
));
4672 Set_Is_Statically_Allocated
(SSD
, Is_Library_Level_Tagged_Type
(Typ
));
4673 Set_Is_Statically_Allocated
(TSD
, Is_Library_Level_Tagged_Type
(Typ
));
4674 Set_Is_Statically_Allocated
(Predef_Prims
,
4675 Is_Library_Level_Tagged_Type
(Typ
));
4677 -- In case of locally defined tagged type we declare the object
4678 -- containing the dispatch table by means of a variable. Its
4679 -- initialization is done later by means of an assignment. This is
4680 -- required to generate its External_Tag.
4682 if not Building_Static_DT
(Typ
) then
4685 -- DT : No_Dispatch_Table_Wrapper;
4686 -- for DT'Alignment use Address'Alignment;
4687 -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
4689 if not Has_DT
(Typ
) then
4691 Make_Object_Declaration
(Loc
,
4692 Defining_Identifier
=> DT
,
4693 Aliased_Present
=> True,
4694 Constant_Present
=> False,
4695 Object_Definition
=>
4697 (RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
)));
4700 Make_Attribute_Definition_Clause
(Loc
,
4701 Name
=> New_Occurrence_Of
(DT
, Loc
),
4702 Chars
=> Name_Alignment
,
4704 Make_Attribute_Reference
(Loc
,
4706 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4707 Attribute_Name
=> Name_Alignment
)));
4710 Make_Object_Declaration
(Loc
,
4711 Defining_Identifier
=> DT_Ptr
,
4712 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
4713 Constant_Present
=> True,
4715 Unchecked_Convert_To
(RTE
(RE_Tag
),
4716 Make_Attribute_Reference
(Loc
,
4718 Make_Selected_Component
(Loc
,
4719 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
4722 (RTE_Record_Component
(RE_NDT_Prims_Ptr
), Loc
)),
4723 Attribute_Name
=> Name_Address
))));
4725 Set_Is_Statically_Allocated
(DT_Ptr
,
4726 Is_Library_Level_Tagged_Type
(Typ
));
4728 -- Generate the SCIL node for the previous object declaration
4729 -- because it has a tag initialization.
4731 if Generate_SCIL
then
4733 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
4734 Set_SCIL_Entity
(New_Node
, Typ
);
4735 Set_SCIL_Node
(Last
(Result
), New_Node
);
4739 -- DT : Dispatch_Table_Wrapper (Nb_Prim);
4740 -- for DT'Alignment use Address'Alignment;
4741 -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
4744 -- If the tagged type has no primitives we add a dummy slot
4745 -- whose address will be the tag of this type.
4749 New_List
(Make_Integer_Literal
(Loc
, 1));
4752 New_List
(Make_Integer_Literal
(Loc
, Nb_Prim
));
4756 Make_Object_Declaration
(Loc
,
4757 Defining_Identifier
=> DT
,
4758 Aliased_Present
=> True,
4759 Constant_Present
=> False,
4760 Object_Definition
=>
4761 Make_Subtype_Indication
(Loc
,
4763 New_Occurrence_Of
(RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
4765 Make_Index_Or_Discriminant_Constraint
(Loc
,
4766 Constraints
=> DT_Constr_List
))));
4769 Make_Attribute_Definition_Clause
(Loc
,
4770 Name
=> New_Occurrence_Of
(DT
, Loc
),
4771 Chars
=> Name_Alignment
,
4773 Make_Attribute_Reference
(Loc
,
4775 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4776 Attribute_Name
=> Name_Alignment
)));
4779 Make_Object_Declaration
(Loc
,
4780 Defining_Identifier
=> DT_Ptr
,
4781 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
4782 Constant_Present
=> True,
4784 Unchecked_Convert_To
(RTE
(RE_Tag
),
4785 Make_Attribute_Reference
(Loc
,
4787 Make_Selected_Component
(Loc
,
4788 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
4791 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
4792 Attribute_Name
=> Name_Address
))));
4794 Set_Is_Statically_Allocated
(DT_Ptr
,
4795 Is_Library_Level_Tagged_Type
(Typ
));
4797 -- Generate the SCIL node for the previous object declaration
4798 -- because it has a tag initialization.
4800 if Generate_SCIL
then
4802 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
4803 Set_SCIL_Entity
(New_Node
, Typ
);
4804 Set_SCIL_Node
(Last
(Result
), New_Node
);
4808 Make_Object_Declaration
(Loc
,
4809 Defining_Identifier
=>
4810 Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
)))),
4811 Constant_Present
=> True,
4812 Object_Definition
=>
4813 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
4815 Make_Attribute_Reference
(Loc
,
4817 Make_Selected_Component
(Loc
,
4818 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
4821 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
4822 Attribute_Name
=> Name_Address
)));
4826 -- Generate: Exname : constant String := full_qualified_name (typ);
4827 -- The type itself may be an anonymous parent type, so use the first
4828 -- subtype to have a user-recognizable name.
4831 Make_Object_Declaration
(Loc
,
4832 Defining_Identifier
=> Exname
,
4833 Constant_Present
=> True,
4834 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
4836 Make_String_Literal
(Loc
,
4837 Strval
=> Fully_Qualified_Name_String
(First_Subtype
(Typ
)))));
4838 Set_Is_Statically_Allocated
(Exname
);
4839 Set_Is_True_Constant
(Exname
);
4841 -- Declare the object used by Ada.Tags.Register_Tag
4843 if RTE_Available
(RE_Register_Tag
) then
4845 Make_Object_Declaration
(Loc
,
4846 Defining_Identifier
=> HT_Link
,
4847 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
)));
4850 -- Generate code to create the storage for the type specific data object
4851 -- with enough space to store the tags of the ancestors plus the tags
4852 -- of all the implemented interfaces (as described in a-tags.adb).
4854 -- TSD : Type_Specific_Data (I_Depth) :=
4855 -- (Idepth => I_Depth,
4856 -- Access_Level => Type_Access_Level (Typ),
4857 -- Alignment => Typ'Alignment,
4858 -- Expanded_Name => Cstring_Ptr!(Exname'Address))
4859 -- External_Tag => Cstring_Ptr!(Exname'Address))
4860 -- HT_Link => HT_Link'Address,
4861 -- Transportable => <<boolean-value>>,
4862 -- Type_Is_Abstract => <<boolean-value>>,
4863 -- Needs_Finalization => <<boolean-value>>,
4864 -- [ Size_Func => Size_Prim'Access, ]
4865 -- [ Interfaces_Table => <<access-value>>, ]
4866 -- [ SSD => SSD_Table'Address ]
4867 -- Tags_Table => (0 => null,
4870 -- for TSD'Alignment use Address'Alignment
4872 TSD_Aggr_List
:= New_List
;
4874 -- Idepth: Count ancestors to compute the inheritance depth. For private
4875 -- extensions, always go to the full view in order to compute the real
4876 -- inheritance depth.
4879 Current_Typ
: Entity_Id
;
4880 Parent_Typ
: Entity_Id
;
4886 Parent_Typ
:= Etype
(Current_Typ
);
4888 if Is_Private_Type
(Parent_Typ
) then
4889 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
4892 exit when Parent_Typ
= Current_Typ
;
4894 I_Depth
:= I_Depth
+ 1;
4895 Current_Typ
:= Parent_Typ
;
4899 Append_To
(TSD_Aggr_List
,
4900 Make_Integer_Literal
(Loc
, I_Depth
));
4904 Append_To
(TSD_Aggr_List
,
4905 Make_Integer_Literal
(Loc
, Type_Access_Level
(Typ
)));
4909 -- For CPP types we cannot rely on the value of 'Alignment provided
4910 -- by the backend to initialize this TSD field.
4912 if Convention
(Typ
) = Convention_CPP
4913 or else Is_CPP_Class
(Root_Type
(Typ
))
4915 Append_To
(TSD_Aggr_List
,
4916 Make_Integer_Literal
(Loc
, 0));
4918 Append_To
(TSD_Aggr_List
,
4919 Make_Attribute_Reference
(Loc
,
4920 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
4921 Attribute_Name
=> Name_Alignment
));
4926 Append_To
(TSD_Aggr_List
,
4927 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
4928 Make_Attribute_Reference
(Loc
,
4929 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
4930 Attribute_Name
=> Name_Address
)));
4932 -- External_Tag of a local tagged type
4934 -- <typ>A : constant String :=
4935 -- "Internal tag at 16#tag-addr#: <full-name-of-typ>";
4937 -- The reason we generate this strange name is that we do not want to
4938 -- enter local tagged types in the global hash table used to compute
4939 -- the Internal_Tag attribute for two reasons:
4941 -- 1. It is hard to avoid a tasking race condition for entering the
4942 -- entry into the hash table.
4944 -- 2. It would cause a storage leak, unless we rig up considerable
4945 -- mechanism to remove the entry from the hash table on exit.
4947 -- So what we do is to generate the above external tag name, where the
4948 -- hex address is the address of the local dispatch table (i.e. exactly
4949 -- the value we want if Internal_Tag is computed from this string).
4951 -- Of course this value will only be valid if the tagged type is still
4952 -- in scope, but it clearly must be erroneous to compute the internal
4953 -- tag of a tagged type that is out of scope.
4955 -- We don't do this processing if an explicit external tag has been
4956 -- specified. That's an odd case for which we have already issued a
4957 -- warning, where we will not be able to compute the internal tag.
4959 if not Is_Library_Level_Entity
(Typ
)
4960 and then not Has_External_Tag_Rep_Clause
(Typ
)
4963 Exname
: constant Entity_Id
:=
4964 Make_Defining_Identifier
(Loc
,
4965 Chars
=> New_External_Name
(Tname
, 'A'));
4966 Full_Name
: constant String_Id
:=
4967 Fully_Qualified_Name_String
(First_Subtype
(Typ
));
4968 Str1_Id
: String_Id
;
4969 Str2_Id
: String_Id
;
4973 -- Str1 = "Internal tag at 16#";
4976 Store_String_Chars
("Internal tag at 16#");
4977 Str1_Id
:= End_String
;
4980 -- Str2 = "#: <type-full-name>";
4983 Store_String_Chars
("#: ");
4984 Store_String_Chars
(Full_Name
);
4985 Str2_Id
:= End_String
;
4988 -- Exname : constant String :=
4989 -- Str1 & Address_Image (Tag) & Str2;
4991 if RTE_Available
(RE_Address_Image
) then
4993 Make_Object_Declaration
(Loc
,
4994 Defining_Identifier
=> Exname
,
4995 Constant_Present
=> True,
4996 Object_Definition
=> New_Occurrence_Of
4997 (Standard_String
, Loc
),
4999 Make_Op_Concat
(Loc
,
5000 Left_Opnd
=> Make_String_Literal
(Loc
, Str1_Id
),
5002 Make_Op_Concat
(Loc
,
5004 Make_Function_Call
(Loc
,
5007 (RTE
(RE_Address_Image
), Loc
),
5008 Parameter_Associations
=> New_List
(
5009 Unchecked_Convert_To
(RTE
(RE_Address
),
5010 New_Occurrence_Of
(DT_Ptr
, Loc
)))),
5012 Make_String_Literal
(Loc
, Str2_Id
)))));
5016 Make_Object_Declaration
(Loc
,
5017 Defining_Identifier
=> Exname
,
5018 Constant_Present
=> True,
5019 Object_Definition
=>
5020 New_Occurrence_Of
(Standard_String
, Loc
),
5022 Make_Op_Concat
(Loc
,
5023 Left_Opnd
=> Make_String_Literal
(Loc
, Str1_Id
),
5024 Right_Opnd
=> Make_String_Literal
(Loc
, Str2_Id
))));
5028 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5029 Make_Attribute_Reference
(Loc
,
5030 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5031 Attribute_Name
=> Name_Address
));
5034 -- External tag of a library-level tagged type: Check for a definition
5035 -- of External_Tag. The clause is considered only if it applies to this
5036 -- specific tagged type, as opposed to one of its ancestors.
5037 -- If the type is an unconstrained type extension, we are building the
5038 -- dispatch table of its anonymous base type, so the external tag, if
5039 -- any was specified, must be retrieved from the first subtype. Go to
5040 -- the full view in case the clause is in the private part.
5044 Def
: constant Node_Id
:= Get_Attribute_Definition_Clause
5045 (Underlying_Type
(First_Subtype
(Typ
)),
5046 Attribute_External_Tag
);
5048 Old_Val
: String_Id
;
5049 New_Val
: String_Id
;
5053 if not Present
(Def
)
5054 or else Entity
(Name
(Def
)) /= First_Subtype
(Typ
)
5057 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5058 Make_Attribute_Reference
(Loc
,
5059 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5060 Attribute_Name
=> Name_Address
));
5062 Old_Val
:= Strval
(Expr_Value_S
(Expression
(Def
)));
5064 -- For the rep clause "for <typ>'external_tag use y" generate:
5066 -- <typ>A : constant string := y;
5068 -- <typ>A'Address is used to set the External_Tag component
5071 -- Create a new nul terminated string if it is not already
5073 if String_Length
(Old_Val
) > 0
5075 Get_String_Char
(Old_Val
, String_Length
(Old_Val
)) = 0
5079 Start_String
(Old_Val
);
5080 Store_String_Char
(Get_Char_Code
(ASCII
.NUL
));
5081 New_Val
:= End_String
;
5084 E
:= Make_Defining_Identifier
(Loc
,
5085 New_External_Name
(Chars
(Typ
), 'A'));
5088 Make_Object_Declaration
(Loc
,
5089 Defining_Identifier
=> E
,
5090 Constant_Present
=> True,
5091 Object_Definition
=>
5092 New_Occurrence_Of
(Standard_String
, Loc
),
5094 Make_String_Literal
(Loc
, New_Val
)));
5097 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5098 Make_Attribute_Reference
(Loc
,
5099 Prefix
=> New_Occurrence_Of
(E
, Loc
),
5100 Attribute_Name
=> Name_Address
));
5105 Append_To
(TSD_Aggr_List
, New_Node
);
5109 if RTE_Available
(RE_Register_Tag
) then
5110 Append_To
(TSD_Aggr_List
,
5111 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
5112 Make_Attribute_Reference
(Loc
,
5113 Prefix
=> New_Occurrence_Of
(HT_Link
, Loc
),
5114 Attribute_Name
=> Name_Address
)));
5116 Append_To
(TSD_Aggr_List
,
5117 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
5118 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5121 -- Transportable: Set for types that can be used in remote calls
5122 -- with respect to E.4(18) legality rules.
5125 Transportable
: Entity_Id
;
5131 or else Is_Shared_Passive
(Typ
)
5133 ((Is_Remote_Types
(Typ
)
5134 or else Is_Remote_Call_Interface
(Typ
))
5135 and then Original_View_In_Visible_Part
(Typ
))
5136 or else not Comes_From_Source
(Typ
));
5138 Append_To
(TSD_Aggr_List
,
5139 New_Occurrence_Of
(Transportable
, Loc
));
5142 -- Type_Is_Abstract (Ada 2012: AI05-0173). This functionality is
5143 -- not available in the HIE runtime.
5145 if RTE_Record_Component_Available
(RE_Type_Is_Abstract
) then
5147 Type_Is_Abstract
: Entity_Id
;
5149 Type_Is_Abstract
:= Boolean_Literals
(Is_Abstract_Type
(Typ
));
5150 Append_To
(TSD_Aggr_List
,
5151 New_Occurrence_Of
(Type_Is_Abstract
, Loc
));
5155 -- Needs_Finalization: Set if the type is controlled or has controlled
5159 Needs_Fin
: Entity_Id
;
5161 Needs_Fin
:= Boolean_Literals
(Needs_Finalization
(Typ
));
5162 Append_To
(TSD_Aggr_List
, New_Occurrence_Of
(Needs_Fin
, Loc
));
5167 if RTE_Record_Component_Available
(RE_Size_Func
) then
5169 -- Initialize this field to Null_Address if we are not building
5170 -- static dispatch tables static or if the size function is not
5171 -- available. In the former case we cannot initialize this field
5172 -- until the function is frozen and registered in the dispatch
5173 -- table (see Register_Primitive).
5175 if not Building_Static_DT
(Typ
) or else not Has_DT
(Typ
) then
5176 Append_To
(TSD_Aggr_List
,
5177 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5178 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5182 Prim_Elmt
: Elmt_Id
;
5184 Size_Comp
: Node_Id
;
5187 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5188 while Present
(Prim_Elmt
) loop
5189 Prim
:= Node
(Prim_Elmt
);
5191 if Chars
(Prim
) = Name_uSize
then
5192 Prim
:= Ultimate_Alias
(Prim
);
5194 if Is_Abstract_Subprogram
(Prim
) then
5196 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5197 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
5200 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5201 Make_Attribute_Reference
(Loc
,
5202 Prefix
=> New_Occurrence_Of
(Prim
, Loc
),
5203 Attribute_Name
=> Name_Unrestricted_Access
));
5209 Next_Elmt
(Prim_Elmt
);
5212 pragma Assert
(Present
(Size_Comp
));
5213 Append_To
(TSD_Aggr_List
, Size_Comp
);
5218 -- Interfaces_Table (required for AI-405)
5220 if RTE_Record_Component_Available
(RE_Interfaces_Table
) then
5222 -- Count the number of interface types implemented by Typ
5224 Collect_Interfaces
(Typ
, Typ_Ifaces
);
5226 AI
:= First_Elmt
(Typ_Ifaces
);
5227 while Present
(AI
) loop
5228 Num_Ifaces
:= Num_Ifaces
+ 1;
5232 if Num_Ifaces
= 0 then
5233 Iface_Table_Node
:= Make_Null
(Loc
);
5235 -- Generate the Interface_Table object
5239 TSD_Ifaces_List
: constant List_Id
:= New_List
;
5241 Sec_DT_Tag
: Node_Id
;
5244 AI
:= First_Elmt
(Typ_Ifaces
);
5245 while Present
(AI
) loop
5246 if Is_Ancestor
(Node
(AI
), Typ
, Use_Full_View
=> True) then
5248 New_Occurrence_Of
(DT_Ptr
, Loc
);
5252 (Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
5253 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5255 while Is_Tag
(Node
(Elmt
))
5257 Is_Ancestor
(Node
(AI
), Related_Type
(Node
(Elmt
)),
5258 Use_Full_View
=> True)
5260 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5262 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5264 pragma Assert
(not Has_Thunks
(Node
(Elmt
)));
5266 pragma Assert
(not Has_Thunks
(Node
(Elmt
)));
5270 pragma Assert
(Ekind
(Node
(Elmt
)) = E_Constant
5272 Has_Thunks
(Node
(Next_Elmt
(Next_Elmt
(Elmt
)))));
5274 New_Occurrence_Of
(Node
(Next_Elmt
(Next_Elmt
(Elmt
))),
5278 Append_To
(TSD_Ifaces_List
,
5279 Make_Aggregate
(Loc
,
5280 Expressions
=> New_List
(
5284 Unchecked_Convert_To
(RTE
(RE_Tag
),
5286 (Node
(First_Elmt
(Access_Disp_Table
(Node
(AI
)))),
5289 -- Static_Offset_To_Top
5291 New_Occurrence_Of
(Standard_True
, Loc
),
5293 -- Offset_To_Top_Value
5295 Make_Integer_Literal
(Loc
, 0),
5297 -- Offset_To_Top_Func
5303 Unchecked_Convert_To
(RTE
(RE_Tag
), Sec_DT_Tag
)
5310 Name_ITable
:= New_External_Name
(Tname
, 'I');
5311 ITable
:= Make_Defining_Identifier
(Loc
, Name_ITable
);
5312 Set_Is_Statically_Allocated
(ITable
,
5313 Is_Library_Level_Tagged_Type
(Typ
));
5315 -- The table of interfaces is not constant; its slots are
5316 -- filled at run time by the IP routine using attribute
5317 -- 'Position to know the location of the tag components
5318 -- (and this attribute cannot be safely used before the
5319 -- object is initialized).
5322 Make_Object_Declaration
(Loc
,
5323 Defining_Identifier
=> ITable
,
5324 Aliased_Present
=> True,
5325 Constant_Present
=> False,
5326 Object_Definition
=>
5327 Make_Subtype_Indication
(Loc
,
5329 New_Occurrence_Of
(RTE
(RE_Interface_Data
), Loc
),
5331 Make_Index_Or_Discriminant_Constraint
(Loc
,
5332 Constraints
=> New_List
(
5333 Make_Integer_Literal
(Loc
, Num_Ifaces
)))),
5335 Expression
=> Make_Aggregate
(Loc
,
5336 Expressions
=> New_List
(
5337 Make_Integer_Literal
(Loc
, Num_Ifaces
),
5338 Make_Aggregate
(Loc
, TSD_Ifaces_List
)))));
5341 Make_Attribute_Definition_Clause
(Loc
,
5342 Name
=> New_Occurrence_Of
(ITable
, Loc
),
5343 Chars
=> Name_Alignment
,
5345 Make_Attribute_Reference
(Loc
,
5347 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5348 Attribute_Name
=> Name_Alignment
)));
5351 Make_Attribute_Reference
(Loc
,
5352 Prefix
=> New_Occurrence_Of
(ITable
, Loc
),
5353 Attribute_Name
=> Name_Unchecked_Access
);
5357 Append_To
(TSD_Aggr_List
, Iface_Table_Node
);
5360 -- Generate the Select Specific Data table for synchronized types that
5361 -- implement synchronized interfaces. The size of the table is
5362 -- constrained by the number of non-predefined primitive operations.
5364 if RTE_Record_Component_Available
(RE_SSD
) then
5365 if Ada_Version
>= Ada_2005
5366 and then Has_DT
(Typ
)
5367 and then Is_Concurrent_Record_Type
(Typ
)
5368 and then Has_Interfaces
(Typ
)
5369 and then Nb_Prim
> 0
5370 and then not Is_Abstract_Type
(Typ
)
5371 and then not Is_Controlled
(Typ
)
5372 and then not Restriction_Active
(No_Dispatching_Calls
)
5373 and then not Restriction_Active
(No_Select_Statements
)
5376 Make_Object_Declaration
(Loc
,
5377 Defining_Identifier
=> SSD
,
5378 Aliased_Present
=> True,
5379 Object_Definition
=>
5380 Make_Subtype_Indication
(Loc
,
5381 Subtype_Mark
=> New_Occurrence_Of
(
5382 RTE
(RE_Select_Specific_Data
), Loc
),
5384 Make_Index_Or_Discriminant_Constraint
(Loc
,
5385 Constraints
=> New_List
(
5386 Make_Integer_Literal
(Loc
, Nb_Prim
))))));
5389 Make_Attribute_Definition_Clause
(Loc
,
5390 Name
=> New_Occurrence_Of
(SSD
, Loc
),
5391 Chars
=> Name_Alignment
,
5393 Make_Attribute_Reference
(Loc
,
5395 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5396 Attribute_Name
=> Name_Alignment
)));
5398 -- This table is initialized by Make_Select_Specific_Data_Table,
5399 -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
5401 Append_To
(TSD_Aggr_List
,
5402 Make_Attribute_Reference
(Loc
,
5403 Prefix
=> New_Occurrence_Of
(SSD
, Loc
),
5404 Attribute_Name
=> Name_Unchecked_Access
));
5406 Append_To
(TSD_Aggr_List
, Make_Null
(Loc
));
5410 -- Initialize the table of ancestor tags. In case of interface types
5411 -- this table is not needed.
5413 TSD_Tags_List
:= New_List
;
5415 -- If we are not statically allocating the dispatch table then we must
5416 -- fill position 0 with null because we still have not generated the
5419 if not Building_Static_DT
(Typ
)
5420 or else Is_Interface
(Typ
)
5422 Append_To
(TSD_Tags_List
,
5423 Unchecked_Convert_To
(RTE
(RE_Tag
),
5424 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5426 -- Otherwise we can safely reference the tag
5429 Append_To
(TSD_Tags_List
,
5430 New_Occurrence_Of
(DT_Ptr
, Loc
));
5433 -- Fill the rest of the table with the tags of the ancestors
5436 Current_Typ
: Entity_Id
;
5437 Parent_Typ
: Entity_Id
;
5445 Parent_Typ
:= Etype
(Current_Typ
);
5447 if Is_Private_Type
(Parent_Typ
) then
5448 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
5451 exit when Parent_Typ
= Current_Typ
;
5453 if Is_CPP_Class
(Parent_Typ
) then
5455 -- The tags defined in the C++ side will be inherited when
5456 -- the object is constructed (Exp_Ch3.Build_Init_Procedure)
5458 Append_To
(TSD_Tags_List
,
5459 Unchecked_Convert_To
(RTE
(RE_Tag
),
5460 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5462 Append_To
(TSD_Tags_List
,
5464 (Node
(First_Elmt
(Access_Disp_Table
(Parent_Typ
))),
5469 Current_Typ
:= Parent_Typ
;
5472 pragma Assert
(Pos
= I_Depth
+ 1);
5475 Append_To
(TSD_Aggr_List
,
5476 Make_Aggregate
(Loc
,
5477 Expressions
=> TSD_Tags_List
));
5479 -- Build the TSD object
5482 Make_Object_Declaration
(Loc
,
5483 Defining_Identifier
=> TSD
,
5484 Aliased_Present
=> True,
5485 Constant_Present
=> Building_Static_DT
(Typ
),
5486 Object_Definition
=>
5487 Make_Subtype_Indication
(Loc
,
5488 Subtype_Mark
=> New_Occurrence_Of
(
5489 RTE
(RE_Type_Specific_Data
), Loc
),
5491 Make_Index_Or_Discriminant_Constraint
(Loc
,
5492 Constraints
=> New_List
(
5493 Make_Integer_Literal
(Loc
, I_Depth
)))),
5495 Expression
=> Make_Aggregate
(Loc
,
5496 Expressions
=> TSD_Aggr_List
)));
5498 Set_Is_True_Constant
(TSD
, Building_Static_DT
(Typ
));
5501 Make_Attribute_Definition_Clause
(Loc
,
5502 Name
=> New_Occurrence_Of
(TSD
, Loc
),
5503 Chars
=> Name_Alignment
,
5505 Make_Attribute_Reference
(Loc
,
5507 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5508 Attribute_Name
=> Name_Alignment
)));
5510 -- Initialize or declare the dispatch table object
5512 if not Has_DT
(Typ
) then
5513 DT_Constr_List
:= New_List
;
5514 DT_Aggr_List
:= New_List
;
5519 Make_Attribute_Reference
(Loc
,
5520 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
5521 Attribute_Name
=> Name_Address
);
5523 Append_To
(DT_Constr_List
, New_Node
);
5524 Append_To
(DT_Aggr_List
, New_Copy
(New_Node
));
5525 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
5527 -- In case of locally defined tagged types we have already declared
5528 -- and uninitialized object for the dispatch table, which is now
5529 -- initialized by means of the following assignment:
5531 -- DT := (TSD'Address, 0);
5533 if not Building_Static_DT
(Typ
) then
5535 Make_Assignment_Statement
(Loc
,
5536 Name
=> New_Occurrence_Of
(DT
, Loc
),
5537 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5539 -- In case of library level tagged types we declare and export now
5540 -- the constant object containing the dummy dispatch table. There
5541 -- is no need to declare the tag here because it has been previously
5542 -- declared by Make_Tags
5544 -- DT : aliased constant No_Dispatch_Table :=
5545 -- (NDT_TSD => TSD'Address;
5546 -- NDT_Prims_Ptr => 0);
5547 -- for DT'Alignment use Address'Alignment;
5551 Make_Object_Declaration
(Loc
,
5552 Defining_Identifier
=> DT
,
5553 Aliased_Present
=> True,
5554 Constant_Present
=> True,
5555 Object_Definition
=>
5556 New_Occurrence_Of
(RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
),
5557 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5560 Make_Attribute_Definition_Clause
(Loc
,
5561 Name
=> New_Occurrence_Of
(DT
, Loc
),
5562 Chars
=> Name_Alignment
,
5564 Make_Attribute_Reference
(Loc
,
5566 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5567 Attribute_Name
=> Name_Alignment
)));
5569 Export_DT
(Typ
, DT
);
5572 -- Common case: Typ has a dispatch table
5576 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
5577 -- (predef-prim-op-1'address,
5578 -- predef-prim-op-2'address,
5580 -- predef-prim-op-n'address);
5581 -- for Predef_Prims'Alignment use Address'Alignment
5583 -- DT : Dispatch_Table (Nb_Prims) :=
5584 -- (Signature => <sig-value>,
5585 -- Tag_Kind => <tag_kind-value>,
5586 -- Predef_Prims => Predef_Prims'First'Address,
5587 -- Offset_To_Top => 0,
5588 -- TSD => TSD'Address;
5589 -- Prims_Ptr => (prim-op-1'address,
5590 -- prim-op-2'address,
5592 -- prim-op-n'address));
5593 -- for DT'Alignment use Address'Alignment
5600 if not Building_Static_DT
(Typ
) then
5601 Nb_Predef_Prims
:= Max_Predef_Prims
;
5604 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5605 while Present
(Prim_Elmt
) loop
5606 Prim
:= Node
(Prim_Elmt
);
5608 if Is_Predefined_Dispatching_Operation
(Prim
)
5609 and then not Is_Abstract_Subprogram
(Prim
)
5611 Pos
:= UI_To_Int
(DT_Position
(Prim
));
5613 if Pos
> Nb_Predef_Prims
then
5614 Nb_Predef_Prims
:= Pos
;
5618 Next_Elmt
(Prim_Elmt
);
5624 (Nat
range 1 .. Nb_Predef_Prims
) of Entity_Id
;
5629 Prim_Ops_Aggr_List
:= New_List
;
5631 Prim_Table
:= (others => Empty
);
5633 if Building_Static_DT
(Typ
) then
5634 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5635 while Present
(Prim_Elmt
) loop
5636 Prim
:= Node
(Prim_Elmt
);
5638 if Is_Predefined_Dispatching_Operation
(Prim
)
5639 and then not Is_Abstract_Subprogram
(Prim
)
5640 and then not Is_Eliminated
(Prim
)
5641 and then not Present
(Prim_Table
5642 (UI_To_Int
(DT_Position
(Prim
))))
5644 E
:= Ultimate_Alias
(Prim
);
5645 pragma Assert
(not Is_Abstract_Subprogram
(E
));
5646 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) := E
;
5649 Next_Elmt
(Prim_Elmt
);
5653 for J
in Prim_Table
'Range loop
5654 if Present
(Prim_Table
(J
)) then
5656 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
5657 Make_Attribute_Reference
(Loc
,
5659 New_Occurrence_Of
(Prim_Table
(J
), Loc
),
5660 Attribute_Name
=> Name_Unrestricted_Access
));
5662 New_Node
:= Make_Null
(Loc
);
5665 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
5669 Make_Aggregate
(Loc
,
5670 Expressions
=> Prim_Ops_Aggr_List
);
5673 Make_Subtype_Declaration
(Loc
,
5674 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
5675 Subtype_Indication
=>
5676 New_Occurrence_Of
(RTE
(RE_Address_Array
), Loc
));
5678 Append_To
(Result
, Decl
);
5681 Make_Object_Declaration
(Loc
,
5682 Defining_Identifier
=> Predef_Prims
,
5683 Aliased_Present
=> True,
5684 Constant_Present
=> Building_Static_DT
(Typ
),
5685 Object_Definition
=>
5686 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
),
5687 Expression
=> New_Node
));
5689 -- Remember aggregates initializing dispatch tables
5691 Append_Elmt
(New_Node
, DT_Aggr
);
5694 Make_Attribute_Definition_Clause
(Loc
,
5695 Name
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
5696 Chars
=> Name_Alignment
,
5698 Make_Attribute_Reference
(Loc
,
5700 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5701 Attribute_Name
=> Name_Alignment
)));
5705 -- Stage 1: Initialize the discriminant and the record components
5707 DT_Constr_List
:= New_List
;
5708 DT_Aggr_List
:= New_List
;
5710 -- Num_Prims. If the tagged type has no primitives we add a dummy
5711 -- slot whose address will be the tag of this type.
5714 New_Node
:= Make_Integer_Literal
(Loc
, 1);
5716 New_Node
:= Make_Integer_Literal
(Loc
, Nb_Prim
);
5719 Append_To
(DT_Constr_List
, New_Node
);
5720 Append_To
(DT_Aggr_List
, New_Copy
(New_Node
));
5724 if RTE_Record_Component_Available
(RE_Signature
) then
5725 Append_To
(DT_Aggr_List
,
5726 New_Occurrence_Of
(RTE
(RE_Primary_DT
), Loc
));
5731 if RTE_Record_Component_Available
(RE_Tag_Kind
) then
5732 Append_To
(DT_Aggr_List
, Tagged_Kind
(Typ
));
5737 Append_To
(DT_Aggr_List
,
5738 Make_Attribute_Reference
(Loc
,
5739 Prefix
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
5740 Attribute_Name
=> Name_Address
));
5744 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
5748 Append_To
(DT_Aggr_List
,
5749 Make_Attribute_Reference
(Loc
,
5750 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
5751 Attribute_Name
=> Name_Address
));
5753 -- Stage 2: Initialize the table of user-defined primitive operations
5755 Prim_Ops_Aggr_List
:= New_List
;
5758 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
5760 elsif not Building_Static_DT
(Typ
) then
5761 for J
in 1 .. Nb_Prim
loop
5762 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
5767 CPP_Nb_Prims
: constant Nat
:= CPP_Num_Prims
(Typ
);
5770 Prim_Elmt
: Elmt_Id
;
5772 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
5775 Prim_Table
:= (others => Empty
);
5777 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5778 while Present
(Prim_Elmt
) loop
5779 Prim
:= Node
(Prim_Elmt
);
5781 -- Retrieve the ultimate alias of the primitive for proper
5782 -- handling of renamings and eliminated primitives.
5784 E
:= Ultimate_Alias
(Prim
);
5785 Prim_Pos
:= UI_To_Int
(DT_Position
(E
));
5787 -- Do not reference predefined primitives because they are
5788 -- located in a separate dispatch table; skip entities with
5789 -- attribute Interface_Alias because they are only required
5790 -- to build secondary dispatch tables; skip abstract and
5791 -- eliminated primitives; for derivations of CPP types skip
5792 -- primitives located in the C++ part of the dispatch table
5793 -- because their slot is initialized by the IC routine.
5795 if not Is_Predefined_Dispatching_Operation
(Prim
)
5796 and then not Is_Predefined_Dispatching_Operation
(E
)
5797 and then not Present
(Interface_Alias
(Prim
))
5798 and then not Is_Abstract_Subprogram
(E
)
5799 and then not Is_Eliminated
(E
)
5800 and then (not Is_CPP_Class
(Root_Type
(Typ
))
5801 or else Prim_Pos
> CPP_Nb_Prims
)
5804 (UI_To_Int
(DT_Position
(Prim
)) <= Nb_Prim
);
5806 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) := E
;
5809 Next_Elmt
(Prim_Elmt
);
5812 for J
in Prim_Table
'Range loop
5813 if Present
(Prim_Table
(J
)) then
5815 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
5816 Make_Attribute_Reference
(Loc
,
5818 New_Occurrence_Of
(Prim_Table
(J
), Loc
),
5819 Attribute_Name
=> Name_Unrestricted_Access
));
5821 New_Node
:= Make_Null
(Loc
);
5824 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
5830 Make_Aggregate
(Loc
,
5831 Expressions
=> Prim_Ops_Aggr_List
);
5833 Append_To
(DT_Aggr_List
, New_Node
);
5835 -- Remember aggregates initializing dispatch tables
5837 Append_Elmt
(New_Node
, DT_Aggr
);
5839 -- In case of locally defined tagged types we have already declared
5840 -- and uninitialized object for the dispatch table, which is now
5841 -- initialized by means of an assignment.
5843 if not Building_Static_DT
(Typ
) then
5845 Make_Assignment_Statement
(Loc
,
5846 Name
=> New_Occurrence_Of
(DT
, Loc
),
5847 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5849 -- In case of library level tagged types we declare now and export
5850 -- the constant object containing the dispatch table.
5854 Make_Object_Declaration
(Loc
,
5855 Defining_Identifier
=> DT
,
5856 Aliased_Present
=> True,
5857 Constant_Present
=> True,
5858 Object_Definition
=>
5859 Make_Subtype_Indication
(Loc
,
5860 Subtype_Mark
=> New_Occurrence_Of
5861 (RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
5862 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
5863 Constraints
=> DT_Constr_List
)),
5864 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5867 Make_Attribute_Definition_Clause
(Loc
,
5868 Name
=> New_Occurrence_Of
(DT
, Loc
),
5869 Chars
=> Name_Alignment
,
5871 Make_Attribute_Reference
(Loc
,
5873 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5874 Attribute_Name
=> Name_Alignment
)));
5876 Export_DT
(Typ
, DT
);
5880 -- Initialize the table of ancestor tags if not building static
5883 if not Building_Static_DT
(Typ
)
5884 and then not Is_Interface
(Typ
)
5885 and then not Is_CPP_Class
(Typ
)
5888 Make_Assignment_Statement
(Loc
,
5890 Make_Indexed_Component
(Loc
,
5892 Make_Selected_Component
(Loc
,
5893 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
5896 (RTE_Record_Component
(RE_Tags_Table
), Loc
)),
5898 New_List
(Make_Integer_Literal
(Loc
, 0))),
5902 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
)));
5905 -- Inherit the dispatch tables of the parent. There is no need to
5906 -- inherit anything from the parent when building static dispatch tables
5907 -- because the whole dispatch table (including inherited primitives) has
5908 -- been already built.
5910 if Building_Static_DT
(Typ
) then
5913 -- If the ancestor is a CPP_Class type we inherit the dispatch tables
5914 -- in the init proc, and we don't need to fill them in here.
5916 elsif Is_CPP_Class
(Parent_Typ
) then
5919 -- Otherwise we fill in the dispatch tables here
5922 if Typ
/= Parent_Typ
5923 and then not Is_Interface
(Typ
)
5924 and then not Restriction_Active
(No_Dispatching_Calls
)
5926 -- Inherit the dispatch table
5928 if not Is_Interface
(Typ
)
5929 and then not Is_Interface
(Parent_Typ
)
5930 and then not Is_CPP_Class
(Parent_Typ
)
5933 Nb_Prims
: constant Int
:=
5934 UI_To_Int
(DT_Entry_Count
5935 (First_Tag_Component
(Parent_Typ
)));
5938 Append_To
(Elab_Code
,
5939 Build_Inherit_Predefined_Prims
(Loc
,
5945 (Access_Disp_Table
(Parent_Typ
)))), Loc
),
5951 (Access_Disp_Table
(Typ
)))), Loc
)));
5953 if Nb_Prims
/= 0 then
5954 Append_To
(Elab_Code
,
5955 Build_Inherit_Prims
(Loc
,
5961 (Access_Disp_Table
(Parent_Typ
))), Loc
),
5962 New_Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
5963 Num_Prims
=> Nb_Prims
));
5968 -- Inherit the secondary dispatch tables of the ancestor
5970 if not Is_CPP_Class
(Parent_Typ
) then
5972 Sec_DT_Ancestor
: Elmt_Id
:=
5978 Sec_DT_Typ
: Elmt_Id
:=
5982 (Access_Disp_Table
(Typ
))));
5984 procedure Copy_Secondary_DTs
(Typ
: Entity_Id
);
5985 -- Local procedure required to climb through the ancestors
5986 -- and copy the contents of all their secondary dispatch
5989 ------------------------
5990 -- Copy_Secondary_DTs --
5991 ------------------------
5993 procedure Copy_Secondary_DTs
(Typ
: Entity_Id
) is
5998 -- Climb to the ancestor (if any) handling private types
6000 if Present
(Full_View
(Etype
(Typ
))) then
6001 if Full_View
(Etype
(Typ
)) /= Typ
then
6002 Copy_Secondary_DTs
(Full_View
(Etype
(Typ
)));
6005 elsif Etype
(Typ
) /= Typ
then
6006 Copy_Secondary_DTs
(Etype
(Typ
));
6009 if Present
(Interfaces
(Typ
))
6010 and then not Is_Empty_Elmt_List
(Interfaces
(Typ
))
6012 Iface
:= First_Elmt
(Interfaces
(Typ
));
6013 E
:= First_Entity
(Typ
);
6015 and then Present
(Node
(Sec_DT_Ancestor
))
6016 and then Ekind
(Node
(Sec_DT_Ancestor
)) = E_Constant
6018 if Is_Tag
(E
) and then Chars
(E
) /= Name_uTag
then
6020 Num_Prims
: constant Int
:=
6021 UI_To_Int
(DT_Entry_Count
(E
));
6024 if not Is_Interface
(Etype
(Typ
)) then
6026 -- Inherit first secondary dispatch table
6028 Append_To
(Elab_Code
,
6029 Build_Inherit_Predefined_Prims
(Loc
,
6031 Unchecked_Convert_To
(RTE
(RE_Tag
),
6034 (Next_Elmt
(Sec_DT_Ancestor
)),
6037 Unchecked_Convert_To
(RTE
(RE_Tag
),
6039 (Node
(Next_Elmt
(Sec_DT_Typ
)),
6042 if Num_Prims
/= 0 then
6043 Append_To
(Elab_Code
,
6044 Build_Inherit_Prims
(Loc
,
6045 Typ
=> Node
(Iface
),
6047 Unchecked_Convert_To
6050 (Node
(Sec_DT_Ancestor
),
6053 Unchecked_Convert_To
6056 (Node
(Sec_DT_Typ
), Loc
)),
6057 Num_Prims
=> Num_Prims
));
6061 Next_Elmt
(Sec_DT_Ancestor
);
6062 Next_Elmt
(Sec_DT_Typ
);
6064 -- Skip the secondary dispatch table of
6065 -- predefined primitives
6067 Next_Elmt
(Sec_DT_Ancestor
);
6068 Next_Elmt
(Sec_DT_Typ
);
6070 if not Is_Interface
(Etype
(Typ
)) then
6072 -- Inherit second secondary dispatch table
6074 Append_To
(Elab_Code
,
6075 Build_Inherit_Predefined_Prims
(Loc
,
6077 Unchecked_Convert_To
(RTE
(RE_Tag
),
6080 (Next_Elmt
(Sec_DT_Ancestor
)),
6083 Unchecked_Convert_To
(RTE
(RE_Tag
),
6085 (Node
(Next_Elmt
(Sec_DT_Typ
)),
6088 if Num_Prims
/= 0 then
6089 Append_To
(Elab_Code
,
6090 Build_Inherit_Prims
(Loc
,
6091 Typ
=> Node
(Iface
),
6093 Unchecked_Convert_To
6096 (Node
(Sec_DT_Ancestor
),
6099 Unchecked_Convert_To
6102 (Node
(Sec_DT_Typ
), Loc
)),
6103 Num_Prims
=> Num_Prims
));
6108 Next_Elmt
(Sec_DT_Ancestor
);
6109 Next_Elmt
(Sec_DT_Typ
);
6111 -- Skip the secondary dispatch table of
6112 -- predefined primitives
6114 Next_Elmt
(Sec_DT_Ancestor
);
6115 Next_Elmt
(Sec_DT_Typ
);
6123 end Copy_Secondary_DTs
;
6126 if Present
(Node
(Sec_DT_Ancestor
))
6127 and then Ekind
(Node
(Sec_DT_Ancestor
)) = E_Constant
6129 -- Handle private types
6131 if Present
(Full_View
(Typ
)) then
6132 Copy_Secondary_DTs
(Full_View
(Typ
));
6134 Copy_Secondary_DTs
(Typ
);
6142 -- Generate code to check if the external tag of this type is the same
6143 -- as the external tag of some other declaration.
6145 -- Check_TSD (TSD'Unrestricted_Access);
6147 -- This check is a consequence of AI05-0113-1/06, so it officially
6148 -- applies to Ada 2005 (and Ada 2012). It might be argued that it is
6149 -- a desirable check to add in Ada 95 mode, but we hesitate to make
6150 -- this change, as it would be incompatible, and could conceivably
6151 -- cause a problem in existing Aa 95 code.
6153 -- We check for No_Run_Time_Mode here, because we do not want to pick
6154 -- up the RE_Check_TSD entity and call it in No_Run_Time mode.
6156 if not No_Run_Time_Mode
6157 and then Ada_Version
>= Ada_2005
6158 and then RTE_Available
(RE_Check_TSD
)
6159 and then not Duplicated_Tag_Checks_Suppressed
(Typ
)
6161 Append_To
(Elab_Code
,
6162 Make_Procedure_Call_Statement
(Loc
,
6164 New_Occurrence_Of
(RTE
(RE_Check_TSD
), Loc
),
6165 Parameter_Associations
=> New_List
(
6166 Make_Attribute_Reference
(Loc
,
6167 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6168 Attribute_Name
=> Name_Unchecked_Access
))));
6171 -- Generate code to register the Tag in the External_Tag hash table for
6172 -- the pure Ada type only.
6174 -- Register_Tag (Dt_Ptr);
6176 -- Skip this action in the following cases:
6177 -- 1) if Register_Tag is not available.
6178 -- 2) in No_Run_Time mode.
6179 -- 3) if Typ is not defined at the library level (this is required
6180 -- to avoid adding concurrency control to the hash table used
6181 -- by the run-time to register the tags).
6183 if not No_Run_Time_Mode
6184 and then Is_Library_Level_Entity
(Typ
)
6185 and then RTE_Available
(RE_Register_Tag
)
6187 Append_To
(Elab_Code
,
6188 Make_Procedure_Call_Statement
(Loc
,
6190 New_Occurrence_Of
(RTE
(RE_Register_Tag
), Loc
),
6191 Parameter_Associations
=>
6192 New_List
(New_Occurrence_Of
(DT_Ptr
, Loc
))));
6195 if not Is_Empty_List
(Elab_Code
) then
6196 Append_List_To
(Result
, Elab_Code
);
6199 -- Populate the two auxiliary tables used for dispatching asynchronous,
6200 -- conditional and timed selects for synchronized types that implement
6201 -- a limited interface. Skip this step in Ravenscar profile or when
6202 -- general dispatching is forbidden.
6204 if Ada_Version
>= Ada_2005
6205 and then Is_Concurrent_Record_Type
(Typ
)
6206 and then Has_Interfaces
(Typ
)
6207 and then not Restriction_Active
(No_Dispatching_Calls
)
6208 and then not Restriction_Active
(No_Select_Statements
)
6210 Append_List_To
(Result
,
6211 Make_Select_Specific_Data_Table
(Typ
));
6214 -- Remember entities containing dispatch tables
6216 Append_Elmt
(Predef_Prims
, DT_Decl
);
6217 Append_Elmt
(DT
, DT_Decl
);
6219 Analyze_List
(Result
, Suppress
=> All_Checks
);
6220 Set_Has_Dispatch_Table
(Typ
);
6222 -- Mark entities containing dispatch tables. Required by the backend to
6223 -- handle them properly.
6225 if Has_DT
(Typ
) then
6230 -- Object declarations
6232 Elmt
:= First_Elmt
(DT_Decl
);
6233 while Present
(Elmt
) loop
6234 Set_Is_Dispatch_Table_Entity
(Node
(Elmt
));
6235 pragma Assert
(Ekind
(Etype
(Node
(Elmt
))) = E_Array_Subtype
6236 or else Ekind
(Etype
(Node
(Elmt
))) = E_Record_Subtype
);
6237 Set_Is_Dispatch_Table_Entity
(Etype
(Node
(Elmt
)));
6241 -- Aggregates initializing dispatch tables
6243 Elmt
:= First_Elmt
(DT_Aggr
);
6244 while Present
(Elmt
) loop
6245 Set_Is_Dispatch_Table_Entity
(Etype
(Node
(Elmt
)));
6251 -- Register the tagged type in the call graph nodes table
6253 Register_CG_Node
(Typ
);
6263 function Make_VM_TSD
(Typ
: Entity_Id
) return List_Id
is
6264 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6265 Result
: constant List_Id
:= New_List
;
6267 function Count_Primitives
(Typ
: Entity_Id
) return Nat
;
6268 -- Count the non-predefined primitive operations of Typ
6270 ----------------------
6271 -- Count_Primitives --
6272 ----------------------
6274 function Count_Primitives
(Typ
: Entity_Id
) return Nat
is
6276 Prim_Elmt
: Elmt_Id
;
6282 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6283 while Present
(Prim_Elmt
) loop
6284 Prim
:= Node
(Prim_Elmt
);
6286 if Is_Predefined_Dispatching_Operation
(Prim
)
6287 or else Is_Predefined_Dispatching_Alias
(Prim
)
6291 elsif Present
(Interface_Alias
(Prim
)) then
6295 Nb_Prim
:= Nb_Prim
+ 1;
6298 Next_Elmt
(Prim_Elmt
);
6302 end Count_Primitives
;
6308 function Make_OSD
(Iface
: Entity_Id
) return Node_Id
;
6309 -- Generate the Object Specific Data table required to dispatch calls
6310 -- through synchronized interfaces. Returns a node that references the
6311 -- generated OSD object.
6313 function Make_OSD
(Iface
: Entity_Id
) return Node_Id
is
6314 Nb_Prim
: constant Nat
:= Count_Primitives
(Iface
);
6316 OSD_Aggr_List
: List_Id
;
6320 -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
6321 -- (OSD_Table => (1 => <value>,
6326 or else Is_Abstract_Type
(Typ
)
6327 or else Is_Controlled
(Typ
)
6328 or else Restriction_Active
(No_Dispatching_Calls
)
6329 or else not Is_Limited_Type
(Typ
)
6330 or else not Has_Interfaces
(Typ
)
6331 or else not RTE_Record_Component_Available
(RE_OSD_Table
)
6333 -- No OSD table required
6335 return Make_Null
(Loc
);
6338 OSD_Aggr_List
:= New_List
;
6341 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
6343 Prim_Alias
: Entity_Id
;
6344 Prim_Elmt
: Elmt_Id
;
6350 Prim_Table
:= (others => Empty
);
6351 Prim_Alias
:= Empty
;
6353 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6354 while Present
(Prim_Elmt
) loop
6355 Prim
:= Node
(Prim_Elmt
);
6357 if Present
(Interface_Alias
(Prim
))
6358 and then Find_Dispatching_Type
6359 (Interface_Alias
(Prim
)) = Iface
6361 Prim_Alias
:= Interface_Alias
(Prim
);
6362 E
:= Ultimate_Alias
(Prim
);
6363 Pos
:= UI_To_Int
(DT_Position
(Prim_Alias
));
6365 if Present
(Prim_Table
(Pos
)) then
6366 pragma Assert
(Prim_Table
(Pos
) = E
);
6370 Prim_Table
(Pos
) := E
;
6372 Append_To
(OSD_Aggr_List
,
6373 Make_Component_Association
(Loc
,
6374 Choices
=> New_List
(
6375 Make_Integer_Literal
(Loc
,
6376 DT_Position
(Prim_Alias
))),
6378 Make_Integer_Literal
(Loc
,
6379 DT_Position
(Alias
(Prim
)))));
6385 Next_Elmt
(Prim_Elmt
);
6388 pragma Assert
(Count
= Nb_Prim
);
6391 OSD
:= Make_Temporary
(Loc
, 'I');
6394 Make_Object_Declaration
(Loc
,
6395 Defining_Identifier
=> OSD
,
6396 Aliased_Present
=> True,
6397 Constant_Present
=> True,
6398 Object_Definition
=>
6399 Make_Subtype_Indication
(Loc
,
6401 New_Occurrence_Of
(RTE
(RE_Object_Specific_Data
), Loc
),
6403 Make_Index_Or_Discriminant_Constraint
(Loc
,
6404 Constraints
=> New_List
(
6405 Make_Integer_Literal
(Loc
, Nb_Prim
)))),
6408 Make_Aggregate
(Loc
,
6409 Component_Associations
=> New_List
(
6410 Make_Component_Association
(Loc
,
6411 Choices
=> New_List
(
6413 (RTE_Record_Component
(RE_OSD_Num_Prims
), Loc
)),
6415 Make_Integer_Literal
(Loc
, Nb_Prim
)),
6417 Make_Component_Association
(Loc
,
6418 Choices
=> New_List
(
6420 (RTE_Record_Component
(RE_OSD_Table
), Loc
)),
6421 Expression
=> Make_Aggregate
(Loc
,
6422 Component_Associations
=> OSD_Aggr_List
))))));
6425 Make_Attribute_Reference
(Loc
,
6426 Prefix
=> New_Occurrence_Of
(OSD
, Loc
),
6427 Attribute_Name
=> Name_Unchecked_Access
);
6433 Nb_Prim
: constant Nat
:= Count_Primitives
(Typ
);
6436 Iface_Table_Node
: Node_Id
;
6438 TSD_Aggr_List
: List_Id
;
6439 Typ_Ifaces
: Elist_Id
;
6440 TSD_Tags_List
: List_Id
;
6442 Tname
: constant Name_Id
:= Chars
(Typ
);
6443 Name_SSD
: constant Name_Id
:=
6444 New_External_Name
(Tname
, 'S', Suffix_Index
=> -1);
6445 Name_TSD
: constant Name_Id
:=
6446 New_External_Name
(Tname
, 'B', Suffix_Index
=> -1);
6447 SSD
: constant Entity_Id
:=
6448 Make_Defining_Identifier
(Loc
, Name_SSD
);
6449 TSD
: constant Entity_Id
:=
6450 Make_Defining_Identifier
(Loc
, Name_TSD
);
6452 -- Generate code to create the storage for the type specific data object
6453 -- with enough space to store the tags of the ancestors plus the tags
6454 -- of all the implemented interfaces (as described in a-tags.ads).
6456 -- TSD : Type_Specific_Data (I_Depth) :=
6457 -- (Idepth => I_Depth,
6458 -- Tag_Kind => <tag_kind-value>,
6459 -- Access_Level => Type_Access_Level (Typ),
6460 -- Alignment => Typ'Alignment,
6462 -- Type_Is_Abstract => <<boolean-value>>,
6463 -- Type_Is_Library_Level => <<boolean-value>>,
6464 -- Interfaces_Table => <<access-value>>
6465 -- SSD => SSD_Table'Address
6466 -- Tags_Table => (0 => Typ'Tag,
6470 TSD_Aggr_List
:= New_List
;
6472 -- Idepth: Count ancestors to compute the inheritance depth. For private
6473 -- extensions, always go to the full view in order to compute the real
6474 -- inheritance depth.
6477 Current_Typ
: Entity_Id
;
6478 Parent_Typ
: Entity_Id
;
6484 Parent_Typ
:= Etype
(Current_Typ
);
6486 if Is_Private_Type
(Parent_Typ
) then
6487 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
6490 exit when Parent_Typ
= Current_Typ
;
6492 I_Depth
:= I_Depth
+ 1;
6493 Current_Typ
:= Parent_Typ
;
6499 Append_To
(TSD_Aggr_List
,
6500 Make_Integer_Literal
(Loc
, I_Depth
));
6504 Append_To
(TSD_Aggr_List
, Tagged_Kind
(Typ
));
6508 Append_To
(TSD_Aggr_List
,
6509 Make_Integer_Literal
(Loc
, Type_Access_Level
(Typ
)));
6513 -- For CPP types we cannot rely on the value of 'Alignment provided
6514 -- by the backend to initialize this TSD field. Why not???
6516 if Convention
(Typ
) = Convention_CPP
6517 or else Is_CPP_Class
(Root_Type
(Typ
))
6519 Append_To
(TSD_Aggr_List
,
6520 Make_Integer_Literal
(Loc
, 0));
6522 Append_To
(TSD_Aggr_List
,
6523 Make_Attribute_Reference
(Loc
,
6524 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6525 Attribute_Name
=> Name_Alignment
));
6530 Append_To
(TSD_Aggr_List
,
6533 -- Type_Is_Abstract (Ada 2012: AI05-0173)
6536 Type_Is_Abstract
: Entity_Id
;
6540 Boolean_Literals
(Is_Abstract_Type
(Typ
));
6542 Append_To
(TSD_Aggr_List
,
6543 New_Occurrence_Of
(Type_Is_Abstract
, Loc
));
6546 -- Type_Is_Library_Level
6549 Type_Is_Library_Level
: Entity_Id
;
6551 Type_Is_Library_Level
:=
6552 Boolean_Literals
(Is_Library_Level_Entity
(Typ
));
6553 Append_To
(TSD_Aggr_List
,
6554 New_Occurrence_Of
(Type_Is_Library_Level
, Loc
));
6557 -- Interfaces_Table (required for AI-405)
6559 if RTE_Record_Component_Available
(RE_Interfaces_Table
) then
6561 -- Count the number of interface types implemented by Typ
6563 Collect_Interfaces
(Typ
, Typ_Ifaces
);
6566 AI
:= First_Elmt
(Typ_Ifaces
);
6567 while Present
(AI
) loop
6568 Num_Ifaces
:= Num_Ifaces
+ 1;
6572 if Num_Ifaces
= 0 then
6573 Iface_Table_Node
:= Make_Null
(Loc
);
6575 -- Generate the Interface_Table object
6579 TSD_Ifaces_List
: constant List_Id
:= New_List
;
6584 AI
:= First_Elmt
(Typ_Ifaces
);
6585 while Present
(AI
) loop
6588 Append_To
(TSD_Ifaces_List
,
6589 Make_Aggregate
(Loc
,
6590 Expressions
=> New_List
(
6594 Make_Attribute_Reference
(Loc
,
6595 Prefix
=> New_Occurrence_Of
(Iface
, Loc
),
6596 Attribute_Name
=> Name_Tag
),
6600 Make_OSD
(Iface
))));
6605 ITable
:= Make_Temporary
(Loc
, 'I');
6608 Make_Object_Declaration
(Loc
,
6609 Defining_Identifier
=> ITable
,
6610 Aliased_Present
=> True,
6611 Constant_Present
=> True,
6612 Object_Definition
=>
6613 Make_Subtype_Indication
(Loc
,
6615 New_Occurrence_Of
(RTE
(RE_Interface_Data
), Loc
),
6616 Constraint
=> Make_Index_Or_Discriminant_Constraint
6618 Constraints
=> New_List
(
6619 Make_Integer_Literal
(Loc
, Num_Ifaces
)))),
6621 Expression
=> Make_Aggregate
(Loc
,
6622 Expressions
=> New_List
(
6623 Make_Integer_Literal
(Loc
, Num_Ifaces
),
6624 Make_Aggregate
(Loc
,
6625 Expressions
=> TSD_Ifaces_List
)))));
6628 Make_Attribute_Reference
(Loc
,
6629 Prefix
=> New_Occurrence_Of
(ITable
, Loc
),
6630 Attribute_Name
=> Name_Unchecked_Access
);
6634 Append_To
(TSD_Aggr_List
, Iface_Table_Node
);
6637 -- Generate the Select Specific Data table for synchronized types that
6638 -- implement synchronized interfaces. The size of the table is
6639 -- constrained by the number of non-predefined primitive operations.
6641 if RTE_Record_Component_Available
(RE_SSD
) then
6642 if Ada_Version
>= Ada_2005
6643 and then Has_DT
(Typ
)
6644 and then Is_Concurrent_Record_Type
(Typ
)
6645 and then Has_Interfaces
(Typ
)
6646 and then Nb_Prim
> 0
6647 and then not Is_Abstract_Type
(Typ
)
6648 and then not Is_Controlled
(Typ
)
6649 and then not Restriction_Active
(No_Dispatching_Calls
)
6650 and then not Restriction_Active
(No_Select_Statements
)
6653 Make_Object_Declaration
(Loc
,
6654 Defining_Identifier
=> SSD
,
6655 Aliased_Present
=> True,
6656 Object_Definition
=>
6657 Make_Subtype_Indication
(Loc
,
6658 Subtype_Mark
=> New_Occurrence_Of
(
6659 RTE
(RE_Select_Specific_Data
), Loc
),
6661 Make_Index_Or_Discriminant_Constraint
(Loc
,
6662 Constraints
=> New_List
(
6663 Make_Integer_Literal
(Loc
, Nb_Prim
))))));
6665 -- This table is initialized by Make_Select_Specific_Data_Table,
6666 -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
6668 Append_To
(TSD_Aggr_List
,
6669 Make_Attribute_Reference
(Loc
,
6670 Prefix
=> New_Occurrence_Of
(SSD
, Loc
),
6671 Attribute_Name
=> Name_Unchecked_Access
));
6673 Append_To
(TSD_Aggr_List
, Make_Null
(Loc
));
6677 -- Initialize the table of ancestor tags. In case of interface types
6678 -- this table is not needed.
6680 TSD_Tags_List
:= New_List
;
6682 -- Fill position 0 with Typ'Tag
6684 Append_To
(TSD_Tags_List
,
6685 Make_Attribute_Reference
(Loc
,
6686 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6687 Attribute_Name
=> Name_Tag
));
6689 -- Fill the rest of the table with the tags of the ancestors
6692 Current_Typ
: Entity_Id
;
6693 Parent_Typ
: Entity_Id
;
6701 Parent_Typ
:= Etype
(Current_Typ
);
6703 if Is_Private_Type
(Parent_Typ
) then
6704 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
6707 exit when Parent_Typ
= Current_Typ
;
6709 Append_To
(TSD_Tags_List
,
6710 Make_Attribute_Reference
(Loc
,
6711 Prefix
=> New_Occurrence_Of
(Parent_Typ
, Loc
),
6712 Attribute_Name
=> Name_Tag
));
6715 Current_Typ
:= Parent_Typ
;
6718 pragma Assert
(Pos
= I_Depth
+ 1);
6721 Append_To
(TSD_Aggr_List
,
6722 Make_Aggregate
(Loc
,
6723 Expressions
=> TSD_Tags_List
));
6725 -- Build the TSD object
6728 Make_Object_Declaration
(Loc
,
6729 Defining_Identifier
=> TSD
,
6730 Aliased_Present
=> True,
6731 Constant_Present
=> True,
6732 Object_Definition
=>
6733 Make_Subtype_Indication
(Loc
,
6734 Subtype_Mark
=> New_Occurrence_Of
(
6735 RTE
(RE_Type_Specific_Data
), Loc
),
6737 Make_Index_Or_Discriminant_Constraint
(Loc
,
6738 Constraints
=> New_List
(
6739 Make_Integer_Literal
(Loc
, I_Depth
)))),
6741 Expression
=> Make_Aggregate
(Loc
,
6742 Expressions
=> TSD_Aggr_List
)));
6745 -- Check_TSD (TSD => TSD'Unrestricted_Access);
6747 if Ada_Version
>= Ada_2005
6748 and then Is_Library_Level_Entity
(Typ
)
6749 and then RTE_Available
(RE_Check_TSD
)
6750 and then not Duplicated_Tag_Checks_Suppressed
(Typ
)
6753 Make_Procedure_Call_Statement
(Loc
,
6754 Name
=> New_Occurrence_Of
(RTE
(RE_Check_TSD
), Loc
),
6755 Parameter_Associations
=> New_List
(
6756 Make_Attribute_Reference
(Loc
,
6757 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6758 Attribute_Name
=> Name_Unrestricted_Access
))));
6762 -- Register_TSD (TSD'Unrestricted_Access);
6765 Make_Procedure_Call_Statement
(Loc
,
6766 Name
=> New_Occurrence_Of
(RTE
(RE_Register_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
))));
6772 -- Populate the two auxiliary tables used for dispatching asynchronous,
6773 -- conditional and timed selects for synchronized types that implement
6774 -- a limited interface. Skip this step in Ravenscar profile or when
6775 -- general dispatching is forbidden.
6777 if Ada_Version
>= Ada_2005
6778 and then Is_Concurrent_Record_Type
(Typ
)
6779 and then Has_Interfaces
(Typ
)
6780 and then not Restriction_Active
(No_Dispatching_Calls
)
6781 and then not Restriction_Active
(No_Select_Statements
)
6783 Append_List_To
(Result
,
6784 Make_Select_Specific_Data_Table
(Typ
));
6790 -------------------------------------
6791 -- Make_Select_Specific_Data_Table --
6792 -------------------------------------
6794 function Make_Select_Specific_Data_Table
6795 (Typ
: Entity_Id
) return List_Id
6797 Assignments
: constant List_Id
:= New_List
;
6798 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6800 Conc_Typ
: Entity_Id
;
6803 Prim_Als
: Entity_Id
;
6804 Prim_Elmt
: Elmt_Id
;
6808 type Examined_Array
is array (Int
range <>) of Boolean;
6810 function Find_Entry_Index
(E
: Entity_Id
) return Uint
;
6811 -- Given an entry, find its index in the visible declarations of the
6812 -- corresponding concurrent type of Typ.
6814 ----------------------
6815 -- Find_Entry_Index --
6816 ----------------------
6818 function Find_Entry_Index
(E
: Entity_Id
) return Uint
is
6819 Index
: Uint
:= Uint_1
;
6820 Subp_Decl
: Entity_Id
;
6824 and then not Is_Empty_List
(Decls
)
6826 Subp_Decl
:= First
(Decls
);
6827 while Present
(Subp_Decl
) loop
6828 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
6829 if Defining_Identifier
(Subp_Decl
) = E
then
6841 end Find_Entry_Index
;
6847 -- Start of processing for Make_Select_Specific_Data_Table
6850 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
6852 if Present
(Corresponding_Concurrent_Type
(Typ
)) then
6853 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
6855 if Present
(Full_View
(Conc_Typ
)) then
6856 Conc_Typ
:= Full_View
(Conc_Typ
);
6859 if Ekind
(Conc_Typ
) = E_Protected_Type
then
6860 Decls
:= Visible_Declarations
(Protected_Definition
(
6861 Parent
(Conc_Typ
)));
6863 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
6864 Decls
:= Visible_Declarations
(Task_Definition
(
6865 Parent
(Conc_Typ
)));
6869 -- Count the non-predefined primitive operations
6871 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6872 while Present
(Prim_Elmt
) loop
6873 Prim
:= Node
(Prim_Elmt
);
6875 if not (Is_Predefined_Dispatching_Operation
(Prim
)
6876 or else Is_Predefined_Dispatching_Alias
(Prim
))
6878 Nb_Prim
:= Nb_Prim
+ 1;
6881 Next_Elmt
(Prim_Elmt
);
6885 Examined
: Examined_Array
(1 .. Nb_Prim
) := (others => False);
6888 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6889 while Present
(Prim_Elmt
) loop
6890 Prim
:= Node
(Prim_Elmt
);
6892 -- Look for primitive overriding an abstract interface subprogram
6894 if Present
(Interface_Alias
(Prim
))
6897 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
6898 Use_Full_View
=> True)
6899 and then not Examined
(UI_To_Int
(DT_Position
(Alias
(Prim
))))
6901 Prim_Pos
:= DT_Position
(Alias
(Prim
));
6902 pragma Assert
(UI_To_Int
(Prim_Pos
) <= Nb_Prim
);
6903 Examined
(UI_To_Int
(Prim_Pos
)) := True;
6905 -- Set the primitive operation kind regardless of subprogram
6907 -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
6909 if Tagged_Type_Expansion
then
6912 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
);
6916 Make_Attribute_Reference
(Loc
,
6917 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6918 Attribute_Name
=> Name_Tag
);
6921 Append_To
(Assignments
,
6922 Make_Procedure_Call_Statement
(Loc
,
6923 Name
=> New_Occurrence_Of
(RTE
(RE_Set_Prim_Op_Kind
), Loc
),
6924 Parameter_Associations
=> New_List
(
6926 Make_Integer_Literal
(Loc
, Prim_Pos
),
6927 Prim_Op_Kind
(Alias
(Prim
), Typ
))));
6929 -- Retrieve the root of the alias chain
6931 Prim_Als
:= Ultimate_Alias
(Prim
);
6933 -- In the case of an entry wrapper, set the entry index
6935 if Ekind
(Prim
) = E_Procedure
6936 and then Is_Primitive_Wrapper
(Prim_Als
)
6937 and then Ekind
(Wrapped_Entity
(Prim_Als
)) = E_Entry
6940 -- Ada.Tags.Set_Entry_Index
6941 -- (DT_Ptr, <position>, <index>);
6943 if Tagged_Type_Expansion
then
6946 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
);
6949 Make_Attribute_Reference
(Loc
,
6950 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6951 Attribute_Name
=> Name_Tag
);
6954 Append_To
(Assignments
,
6955 Make_Procedure_Call_Statement
(Loc
,
6957 New_Occurrence_Of
(RTE
(RE_Set_Entry_Index
), Loc
),
6958 Parameter_Associations
=> New_List
(
6960 Make_Integer_Literal
(Loc
, Prim_Pos
),
6961 Make_Integer_Literal
(Loc
,
6962 Find_Entry_Index
(Wrapped_Entity
(Prim_Als
))))));
6966 Next_Elmt
(Prim_Elmt
);
6971 end Make_Select_Specific_Data_Table
;
6977 function Make_Tags
(Typ
: Entity_Id
) return List_Id
is
6978 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6979 Result
: constant List_Id
:= New_List
;
6982 (Tag_Typ
: Entity_Id
;
6984 Is_Secondary_DT
: Boolean);
6985 -- Import the dispatch table DT of tagged type Tag_Typ. Required to
6986 -- generate forward references and statically allocate the table. For
6987 -- primary dispatch tables that require no dispatch table generate:
6989 -- DT : static aliased constant Non_Dispatch_Table_Wrapper;
6990 -- pragma Import (Ada, DT);
6992 -- Otherwise generate:
6994 -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
6995 -- pragma Import (Ada, DT);
7002 (Tag_Typ
: Entity_Id
;
7004 Is_Secondary_DT
: Boolean)
7006 DT_Constr_List
: List_Id
;
7010 Set_Is_Imported
(DT
);
7011 Set_Ekind
(DT
, E_Constant
);
7012 Set_Related_Type
(DT
, Typ
);
7014 -- The scope must be set now to call Get_External_Name
7016 Set_Scope
(DT
, Current_Scope
);
7018 Get_External_Name
(DT
);
7019 Set_Interface_Name
(DT
,
7020 Make_String_Literal
(Loc
, Strval
=> String_From_Name_Buffer
));
7022 -- Ensure proper Sprint output of this implicit importation
7024 Set_Is_Internal
(DT
);
7026 -- Save this entity to allow Make_DT to generate its exportation
7028 Append_Elmt
(DT
, Dispatch_Table_Wrappers
(Typ
));
7030 -- No dispatch table required
7032 if not Is_Secondary_DT
and then not Has_DT
(Tag_Typ
) then
7034 Make_Object_Declaration
(Loc
,
7035 Defining_Identifier
=> DT
,
7036 Aliased_Present
=> True,
7037 Constant_Present
=> True,
7038 Object_Definition
=>
7040 (RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
)));
7043 -- Calculate the number of primitives of the dispatch table and
7044 -- the size of the Type_Specific_Data record.
7047 UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Tag_Typ
)));
7049 -- If the tagged type has no primitives we add a dummy slot whose
7050 -- address will be the tag of this type.
7054 New_List
(Make_Integer_Literal
(Loc
, 1));
7057 New_List
(Make_Integer_Literal
(Loc
, Nb_Prim
));
7061 Make_Object_Declaration
(Loc
,
7062 Defining_Identifier
=> DT
,
7063 Aliased_Present
=> True,
7064 Constant_Present
=> True,
7065 Object_Definition
=>
7066 Make_Subtype_Indication
(Loc
,
7068 New_Occurrence_Of
(RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
7069 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
7070 Constraints
=> DT_Constr_List
))));
7076 Tname
: constant Name_Id
:= Chars
(Typ
);
7077 AI_Tag_Comp
: Elmt_Id
;
7078 DT
: Node_Id
:= Empty
;
7080 Predef_Prims_Ptr
: Node_Id
;
7081 Iface_DT
: Node_Id
:= Empty
;
7082 Iface_DT_Ptr
: Node_Id
;
7086 Typ_Comps
: Elist_Id
;
7088 -- Start of processing for Make_Tags
7091 pragma Assert
(No
(Access_Disp_Table
(Typ
)));
7092 Set_Access_Disp_Table
(Typ
, New_Elmt_List
);
7094 -- 1) Generate the primary tag entities
7096 -- Primary dispatch table containing user-defined primitives
7098 DT_Ptr
:= Make_Defining_Identifier
(Loc
, New_External_Name
(Tname
, 'P'));
7099 Set_Etype
(DT_Ptr
, RTE
(RE_Tag
));
7100 Append_Elmt
(DT_Ptr
, Access_Disp_Table
(Typ
));
7102 -- Minimum decoration
7104 Set_Ekind
(DT_Ptr
, E_Variable
);
7105 Set_Related_Type
(DT_Ptr
, Typ
);
7107 -- Notify back end that the types are associated with a dispatch table
7109 Set_Is_Dispatch_Table_Entity
(RTE
(RE_Prim_Ptr
));
7110 Set_Is_Dispatch_Table_Entity
(RTE
(RE_Predef_Prims_Table_Ptr
));
7112 -- For CPP types there is no need to build the dispatch tables since
7113 -- they are imported from the C++ side. If the CPP type has an IP then
7114 -- we declare now the variable that will store the copy of the C++ tag.
7115 -- If the CPP type is an interface, we need the variable as well because
7116 -- it becomes the pointer to the corresponding secondary table.
7118 if Is_CPP_Class
(Typ
) then
7119 if Has_CPP_Constructors
(Typ
) or else Is_Interface
(Typ
) then
7121 Make_Object_Declaration
(Loc
,
7122 Defining_Identifier
=> DT_Ptr
,
7123 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
7125 Unchecked_Convert_To
(RTE
(RE_Tag
),
7126 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
7128 Set_Is_Statically_Allocated
(DT_Ptr
,
7129 Is_Library_Level_Tagged_Type
(Typ
));
7135 -- Primary dispatch table containing predefined primitives
7138 Make_Defining_Identifier
(Loc
,
7139 Chars
=> New_External_Name
(Tname
, 'Y'));
7140 Set_Etype
(Predef_Prims_Ptr
, RTE
(RE_Address
));
7141 Append_Elmt
(Predef_Prims_Ptr
, Access_Disp_Table
(Typ
));
7143 -- Import the forward declaration of the Dispatch Table wrapper
7144 -- record (Make_DT will take care of exporting it).
7146 if Building_Static_DT
(Typ
) then
7147 Set_Dispatch_Table_Wrappers
(Typ
, New_Elmt_List
);
7150 Make_Defining_Identifier
(Loc
,
7151 Chars
=> New_External_Name
(Tname
, 'T'));
7153 Import_DT
(Typ
, DT
, Is_Secondary_DT
=> False);
7155 if Has_DT
(Typ
) then
7157 Make_Object_Declaration
(Loc
,
7158 Defining_Identifier
=> DT_Ptr
,
7159 Constant_Present
=> True,
7160 Object_Definition
=>
7161 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
7163 Unchecked_Convert_To
(RTE
(RE_Tag
),
7164 Make_Attribute_Reference
(Loc
,
7166 Make_Selected_Component
(Loc
,
7167 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
7170 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
7171 Attribute_Name
=> Name_Address
))));
7173 -- Generate the SCIL node for the previous object declaration
7174 -- because it has a tag initialization.
7176 if Generate_SCIL
then
7178 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
7179 Set_SCIL_Entity
(New_Node
, Typ
);
7180 Set_SCIL_Node
(Last
(Result
), New_Node
);
7184 Make_Object_Declaration
(Loc
,
7185 Defining_Identifier
=> Predef_Prims_Ptr
,
7186 Constant_Present
=> True,
7187 Object_Definition
=>
7188 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
7190 Make_Attribute_Reference
(Loc
,
7192 Make_Selected_Component
(Loc
,
7193 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
7196 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
7197 Attribute_Name
=> Name_Address
)));
7199 -- No dispatch table required
7203 Make_Object_Declaration
(Loc
,
7204 Defining_Identifier
=> DT_Ptr
,
7205 Constant_Present
=> True,
7206 Object_Definition
=>
7207 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
7209 Unchecked_Convert_To
(RTE
(RE_Tag
),
7210 Make_Attribute_Reference
(Loc
,
7212 Make_Selected_Component
(Loc
,
7213 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
7216 (RTE_Record_Component
(RE_NDT_Prims_Ptr
),
7218 Attribute_Name
=> Name_Address
))));
7221 Set_Is_True_Constant
(DT_Ptr
);
7222 Set_Is_Statically_Allocated
(DT_Ptr
);
7226 -- 2) Generate the secondary tag entities
7228 -- Collect the components associated with secondary dispatch tables
7230 if Has_Interfaces
(Typ
) then
7231 Collect_Interface_Components
(Typ
, Typ_Comps
);
7233 -- For each interface type we build a unique external name associated
7234 -- with its secondary dispatch table. This name is used to declare an
7235 -- object that references this secondary dispatch table, whose value
7236 -- will be used for the elaboration of Typ objects, and also for the
7237 -- elaboration of objects of types derived from Typ that do not
7238 -- override the primitives of this interface type.
7242 -- Note: The value of Suffix_Index must be in sync with the values of
7243 -- Suffix_Index in secondary dispatch tables generated by Make_DT.
7245 if Is_CPP_Class
(Typ
) then
7246 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
7247 while Present
(AI_Tag_Comp
) loop
7248 Get_Secondary_DT_External_Name
7249 (Typ
, Related_Type
(Node
(AI_Tag_Comp
)), Suffix_Index
);
7250 Typ_Name
:= Name_Find
;
7252 -- Declare variables to store copy of the C++ secondary tags
7255 Make_Defining_Identifier
(Loc
,
7256 Chars
=> New_External_Name
(Typ_Name
, 'P'));
7257 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7258 Set_Ekind
(Iface_DT_Ptr
, E_Variable
);
7259 Set_Is_Tag
(Iface_DT_Ptr
);
7261 Set_Has_Thunks
(Iface_DT_Ptr
);
7263 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7264 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7267 Make_Object_Declaration
(Loc
,
7268 Defining_Identifier
=> Iface_DT_Ptr
,
7269 Object_Definition
=> New_Occurrence_Of
7270 (RTE
(RE_Interface_Tag
), Loc
),
7272 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
7273 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
7275 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7276 Is_Library_Level_Tagged_Type
(Typ
));
7278 Next_Elmt
(AI_Tag_Comp
);
7281 -- This is not a CPP_Class type
7284 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
7285 while Present
(AI_Tag_Comp
) loop
7286 Get_Secondary_DT_External_Name
7287 (Typ
, Related_Type
(Node
(AI_Tag_Comp
)), Suffix_Index
);
7288 Typ_Name
:= Name_Find
;
7290 if Building_Static_DT
(Typ
) then
7292 Make_Defining_Identifier
(Loc
,
7293 Chars
=> New_External_Name
7294 (Typ_Name
, 'T', Suffix_Index
=> -1));
7296 (Tag_Typ
=> Related_Type
(Node
(AI_Tag_Comp
)),
7298 Is_Secondary_DT
=> True);
7301 -- Secondary dispatch table referencing thunks to user-defined
7302 -- primitives covered by this interface.
7305 Make_Defining_Identifier
(Loc
,
7306 Chars
=> New_External_Name
(Typ_Name
, 'P'));
7307 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7308 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
7309 Set_Is_Tag
(Iface_DT_Ptr
);
7310 Set_Has_Thunks
(Iface_DT_Ptr
);
7311 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7312 Is_Library_Level_Tagged_Type
(Typ
));
7313 Set_Is_True_Constant
(Iface_DT_Ptr
);
7315 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7316 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7318 if Building_Static_DT
(Typ
) then
7320 Make_Object_Declaration
(Loc
,
7321 Defining_Identifier
=> Iface_DT_Ptr
,
7322 Constant_Present
=> True,
7323 Object_Definition
=> New_Occurrence_Of
7324 (RTE
(RE_Interface_Tag
), Loc
),
7326 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
7327 Make_Attribute_Reference
(Loc
,
7329 Make_Selected_Component
(Loc
,
7331 New_Occurrence_Of
(Iface_DT
, Loc
),
7334 (RTE_Record_Component
(RE_Prims_Ptr
),
7336 Attribute_Name
=> Name_Address
))));
7339 -- Secondary dispatch table referencing thunks to predefined
7343 Make_Defining_Identifier
(Loc
,
7344 Chars
=> New_External_Name
(Typ_Name
, 'Y'));
7345 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Address
));
7346 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
7347 Set_Is_Tag
(Iface_DT_Ptr
);
7348 Set_Has_Thunks
(Iface_DT_Ptr
);
7349 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7350 Is_Library_Level_Tagged_Type
(Typ
));
7351 Set_Is_True_Constant
(Iface_DT_Ptr
);
7353 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7354 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7356 -- Secondary dispatch table referencing user-defined primitives
7357 -- covered by this interface.
7360 Make_Defining_Identifier
(Loc
,
7361 Chars
=> New_External_Name
(Typ_Name
, 'D'));
7362 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7363 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
7364 Set_Is_Tag
(Iface_DT_Ptr
);
7365 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7366 Is_Library_Level_Tagged_Type
(Typ
));
7367 Set_Is_True_Constant
(Iface_DT_Ptr
);
7369 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7370 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7372 -- Secondary dispatch table referencing predefined primitives
7375 Make_Defining_Identifier
(Loc
,
7376 Chars
=> New_External_Name
(Typ_Name
, 'Z'));
7377 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Address
));
7378 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
7379 Set_Is_Tag
(Iface_DT_Ptr
);
7380 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7381 Is_Library_Level_Tagged_Type
(Typ
));
7382 Set_Is_True_Constant
(Iface_DT_Ptr
);
7384 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7385 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7387 Next_Elmt
(AI_Tag_Comp
);
7392 -- 3) At the end of Access_Disp_Table, if the type has user-defined
7393 -- primitives, we add the entity of an access type declaration that
7394 -- is used by Build_Get_Prim_Op_Address to expand dispatching calls
7395 -- through the primary dispatch table.
7397 if UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Typ
))) = 0 then
7398 Analyze_List
(Result
);
7401 -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
7402 -- type Typ_DT_Acc is access Typ_DT;
7406 Name_DT_Prims
: constant Name_Id
:=
7407 New_External_Name
(Tname
, 'G');
7408 Name_DT_Prims_Acc
: constant Name_Id
:=
7409 New_External_Name
(Tname
, 'H');
7410 DT_Prims
: constant Entity_Id
:=
7411 Make_Defining_Identifier
(Loc
,
7413 DT_Prims_Acc
: constant Entity_Id
:=
7414 Make_Defining_Identifier
(Loc
,
7418 Make_Full_Type_Declaration
(Loc
,
7419 Defining_Identifier
=> DT_Prims
,
7421 Make_Constrained_Array_Definition
(Loc
,
7422 Discrete_Subtype_Definitions
=> New_List
(
7424 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
7425 High_Bound
=> Make_Integer_Literal
(Loc
,
7427 (First_Tag_Component
(Typ
))))),
7428 Component_Definition
=>
7429 Make_Component_Definition
(Loc
,
7430 Subtype_Indication
=>
7431 New_Occurrence_Of
(RTE
(RE_Prim_Ptr
), Loc
)))));
7434 Make_Full_Type_Declaration
(Loc
,
7435 Defining_Identifier
=> DT_Prims_Acc
,
7437 Make_Access_To_Object_Definition
(Loc
,
7438 Subtype_Indication
=>
7439 New_Occurrence_Of
(DT_Prims
, Loc
))));
7441 Append_Elmt
(DT_Prims_Acc
, Access_Disp_Table
(Typ
));
7443 -- Analyze the resulting list and suppress the generation of the
7444 -- Init_Proc associated with the above array declaration because
7445 -- this type is never used in object declarations. It is only used
7446 -- to simplify the expansion associated with dispatching calls.
7448 Analyze_List
(Result
);
7449 Set_Suppress_Initialization
(Base_Type
(DT_Prims
));
7451 -- Disable backend optimizations based on assumptions about the
7452 -- aliasing status of objects designated by the access to the
7453 -- dispatch table. Required to handle dispatch tables imported
7456 Set_No_Strict_Aliasing
(Base_Type
(DT_Prims_Acc
));
7458 -- Add the freezing nodes of these declarations; required to avoid
7459 -- generating these freezing nodes in wrong scopes (for example in
7460 -- the IC routine of a derivation of Typ).
7462 -- What is an "IC routine"? Is "init_proc" meant here???
7464 Append_List_To
(Result
, Freeze_Entity
(DT_Prims
, Typ
));
7465 Append_List_To
(Result
, Freeze_Entity
(DT_Prims_Acc
, Typ
));
7467 -- Mark entity of dispatch table. Required by the back end to
7468 -- handle them properly.
7470 Set_Is_Dispatch_Table_Entity
(DT_Prims
);
7474 -- Mark entities of dispatch table. Required by the back end to handle
7477 if Present
(DT
) then
7478 Set_Is_Dispatch_Table_Entity
(DT
);
7479 Set_Is_Dispatch_Table_Entity
(Etype
(DT
));
7482 if Present
(Iface_DT
) then
7483 Set_Is_Dispatch_Table_Entity
(Iface_DT
);
7484 Set_Is_Dispatch_Table_Entity
(Etype
(Iface_DT
));
7487 if Is_CPP_Class
(Root_Type
(Typ
)) then
7488 Set_Ekind
(DT_Ptr
, E_Variable
);
7490 Set_Ekind
(DT_Ptr
, E_Constant
);
7493 Set_Is_Tag
(DT_Ptr
);
7494 Set_Related_Type
(DT_Ptr
, Typ
);
7503 function New_Value
(From
: Node_Id
) return Node_Id
is
7504 Res
: constant Node_Id
:= Duplicate_Subexpr
(From
);
7506 if Is_Access_Type
(Etype
(From
)) then
7507 return Make_Explicit_Dereference
(Sloc
(From
), Prefix
=> Res
);
7513 -----------------------------------
7514 -- Original_View_In_Visible_Part --
7515 -----------------------------------
7517 function Original_View_In_Visible_Part
(Typ
: Entity_Id
) return Boolean is
7518 Scop
: constant Entity_Id
:= Scope
(Typ
);
7521 -- The scope must be a package
7523 if not Is_Package_Or_Generic_Package
(Scop
) then
7527 -- A type with a private declaration has a private view declared in
7528 -- the visible part.
7530 if Has_Private_Declaration
(Typ
) then
7534 return List_Containing
(Parent
(Typ
)) =
7535 Visible_Declarations
(Package_Specification
(Scop
));
7536 end Original_View_In_Visible_Part
;
7542 function Prim_Op_Kind
7544 Typ
: Entity_Id
) return Node_Id
7546 Full_Typ
: Entity_Id
:= Typ
;
7547 Loc
: constant Source_Ptr
:= Sloc
(Prim
);
7548 Prim_Op
: Entity_Id
;
7551 -- Retrieve the original primitive operation
7553 Prim_Op
:= Ultimate_Alias
(Prim
);
7555 if Ekind
(Typ
) = E_Record_Type
7556 and then Present
(Corresponding_Concurrent_Type
(Typ
))
7558 Full_Typ
:= Corresponding_Concurrent_Type
(Typ
);
7561 -- When a private tagged type is completed by a concurrent type,
7562 -- retrieve the full view.
7564 if Is_Private_Type
(Full_Typ
) then
7565 Full_Typ
:= Full_View
(Full_Typ
);
7568 if Ekind
(Prim_Op
) = E_Function
then
7570 -- Protected function
7572 if Ekind
(Full_Typ
) = E_Protected_Type
then
7573 return New_Occurrence_Of
(RTE
(RE_POK_Protected_Function
), Loc
);
7577 elsif Ekind
(Full_Typ
) = E_Task_Type
then
7578 return New_Occurrence_Of
(RTE
(RE_POK_Task_Function
), Loc
);
7583 return New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
);
7587 pragma Assert
(Ekind
(Prim_Op
) = E_Procedure
);
7589 if Ekind
(Full_Typ
) = E_Protected_Type
then
7593 if Is_Primitive_Wrapper
(Prim_Op
)
7594 and then Ekind
(Wrapped_Entity
(Prim_Op
)) = E_Entry
7596 return New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
);
7598 -- Protected procedure
7602 New_Occurrence_Of
(RTE
(RE_POK_Protected_Procedure
), Loc
);
7605 elsif Ekind
(Full_Typ
) = E_Task_Type
then
7609 if Is_Primitive_Wrapper
(Prim_Op
)
7610 and then Ekind
(Wrapped_Entity
(Prim_Op
)) = E_Entry
7612 return New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
);
7614 -- Task "procedure". These are the internally Expander-generated
7615 -- procedures (task body for instance).
7618 return New_Occurrence_Of
(RTE
(RE_POK_Task_Procedure
), Loc
);
7621 -- Regular procedure
7624 return New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
);
7629 ------------------------
7630 -- Register_Primitive --
7631 ------------------------
7633 function Register_Primitive
7635 Prim
: Entity_Id
) return List_Id
7638 Iface_Prim
: Entity_Id
;
7639 Iface_Typ
: Entity_Id
;
7640 Iface_DT_Ptr
: Entity_Id
;
7641 Iface_DT_Elmt
: Elmt_Id
;
7642 L
: constant List_Id
:= New_List
;
7645 Tag_Typ
: Entity_Id
;
7646 Thunk_Id
: Entity_Id
;
7647 Thunk_Code
: Node_Id
;
7650 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
7651 pragma Assert
(VM_Target
= No_VM
);
7653 -- Do not register in the dispatch table eliminated primitives
7655 if not RTE_Available
(RE_Tag
)
7656 or else Is_Eliminated
(Ultimate_Alias
(Prim
))
7661 if not Present
(Interface_Alias
(Prim
)) then
7662 Tag_Typ
:= Scope
(DTC_Entity
(Prim
));
7663 Pos
:= DT_Position
(Prim
);
7664 Tag
:= First_Tag_Component
(Tag_Typ
);
7666 if Is_Predefined_Dispatching_Operation
(Prim
)
7667 or else Is_Predefined_Dispatching_Alias
(Prim
)
7670 Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Tag_Typ
))));
7673 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7674 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7677 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7678 Make_Attribute_Reference
(Loc
,
7679 Prefix
=> New_Occurrence_Of
(Prim
, Loc
),
7680 Attribute_Name
=> Name_Unrestricted_Access
))));
7682 -- Register copy of the pointer to the 'size primitive in the TSD
7684 if Chars
(Prim
) = Name_uSize
7685 and then RTE_Record_Component_Available
(RE_Size_Func
)
7687 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Tag_Typ
)));
7689 Build_Set_Size_Function
(Loc
,
7690 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7691 Size_Func
=> Prim
));
7695 pragma Assert
(Pos
/= Uint_0
and then Pos
<= DT_Entry_Count
(Tag
));
7697 -- Skip registration of primitives located in the C++ part of the
7698 -- dispatch table. Their slot is set by the IC routine.
7700 if not Is_CPP_Class
(Root_Type
(Tag_Typ
))
7701 or else Pos
> CPP_Num_Prims
(Tag_Typ
)
7703 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Tag_Typ
)));
7705 Build_Set_Prim_Op_Address
(Loc
,
7707 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7710 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7711 Make_Attribute_Reference
(Loc
,
7712 Prefix
=> New_Occurrence_Of
(Prim
, Loc
),
7713 Attribute_Name
=> Name_Unrestricted_Access
))));
7717 -- Ada 2005 (AI-251): Primitive associated with an interface type
7719 -- Generate the code of the thunk only if the interface type is not an
7720 -- immediate ancestor of Typ; otherwise the dispatch table associated
7721 -- with the interface is the primary dispatch table and we have nothing
7725 Tag_Typ
:= Find_Dispatching_Type
(Alias
(Prim
));
7726 Iface_Typ
:= Find_Dispatching_Type
(Interface_Alias
(Prim
));
7728 pragma Assert
(Is_Interface
(Iface_Typ
));
7730 -- No action needed for interfaces that are ancestors of Typ because
7731 -- their primitives are located in the primary dispatch table.
7733 if Is_Ancestor
(Iface_Typ
, Tag_Typ
, Use_Full_View
=> True) then
7736 -- No action needed for primitives located in the C++ part of the
7737 -- dispatch table. Their slot is set by the IC routine.
7739 elsif Is_CPP_Class
(Root_Type
(Tag_Typ
))
7740 and then DT_Position
(Alias
(Prim
)) <= CPP_Num_Prims
(Tag_Typ
)
7741 and then not Is_Predefined_Dispatching_Operation
(Prim
)
7742 and then not Is_Predefined_Dispatching_Alias
(Prim
)
7747 Expand_Interface_Thunk
(Prim
, Thunk_Id
, Thunk_Code
);
7749 if not Is_Ancestor
(Iface_Typ
, Tag_Typ
, Use_Full_View
=> True)
7750 and then Present
(Thunk_Code
)
7752 -- Generate the code necessary to fill the appropriate entry of
7753 -- the secondary dispatch table of Prim's controlling type with
7754 -- Thunk_Id's address.
7756 Iface_DT_Elmt
:= Find_Interface_ADT
(Tag_Typ
, Iface_Typ
);
7757 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7758 pragma Assert
(Has_Thunks
(Iface_DT_Ptr
));
7760 Iface_Prim
:= Interface_Alias
(Prim
);
7761 Pos
:= DT_Position
(Iface_Prim
);
7762 Tag
:= First_Tag_Component
(Iface_Typ
);
7764 Prepend_To
(L
, Thunk_Code
);
7766 if Is_Predefined_Dispatching_Operation
(Prim
)
7767 or else Is_Predefined_Dispatching_Alias
(Prim
)
7770 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7772 New_Occurrence_Of
(Node
(Next_Elmt
(Iface_DT_Elmt
)), Loc
),
7775 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7776 Make_Attribute_Reference
(Loc
,
7777 Prefix
=> New_Occurrence_Of
(Thunk_Id
, Loc
),
7778 Attribute_Name
=> Name_Unrestricted_Access
))));
7780 Next_Elmt
(Iface_DT_Elmt
);
7781 Next_Elmt
(Iface_DT_Elmt
);
7782 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7783 pragma Assert
(not Has_Thunks
(Iface_DT_Ptr
));
7786 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7788 New_Occurrence_Of
(Node
(Next_Elmt
(Iface_DT_Elmt
)), Loc
),
7791 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7792 Make_Attribute_Reference
(Loc
,
7794 New_Occurrence_Of
(Alias
(Prim
), Loc
),
7795 Attribute_Name
=> Name_Unrestricted_Access
))));
7798 pragma Assert
(Pos
/= Uint_0
7799 and then Pos
<= DT_Entry_Count
(Tag
));
7802 Build_Set_Prim_Op_Address
(Loc
,
7804 Tag_Node
=> New_Occurrence_Of
(Iface_DT_Ptr
, Loc
),
7807 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7808 Make_Attribute_Reference
(Loc
,
7809 Prefix
=> New_Occurrence_Of
(Thunk_Id
, Loc
),
7810 Attribute_Name
=> Name_Unrestricted_Access
))));
7812 Next_Elmt
(Iface_DT_Elmt
);
7813 Next_Elmt
(Iface_DT_Elmt
);
7814 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7815 pragma Assert
(not Has_Thunks
(Iface_DT_Ptr
));
7818 Build_Set_Prim_Op_Address
(Loc
,
7820 Tag_Node
=> New_Occurrence_Of
(Iface_DT_Ptr
, Loc
),
7823 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7824 Make_Attribute_Reference
(Loc
,
7826 New_Occurrence_Of
(Alias
(Prim
), Loc
),
7827 Attribute_Name
=> Name_Unrestricted_Access
))));
7834 end Register_Primitive
;
7836 -------------------------
7837 -- Set_All_DT_Position --
7838 -------------------------
7840 procedure Set_All_DT_Position
(Typ
: Entity_Id
) is
7842 function In_Predef_Prims_DT
(Prim
: Entity_Id
) return Boolean;
7843 -- Returns True if Prim is located in the dispatch table of
7844 -- predefined primitives
7846 procedure Validate_Position
(Prim
: Entity_Id
);
7847 -- Check that position assigned to Prim is completely safe (it has not
7848 -- been assigned to a previously defined primitive operation of Typ).
7850 ------------------------
7851 -- In_Predef_Prims_DT --
7852 ------------------------
7854 function In_Predef_Prims_DT
(Prim
: Entity_Id
) return Boolean is
7858 -- Predefined primitives
7860 if Is_Predefined_Dispatching_Operation
(Prim
) then
7863 -- Renamings of predefined primitives
7865 elsif Present
(Alias
(Prim
))
7866 and then Is_Predefined_Dispatching_Operation
(Ultimate_Alias
(Prim
))
7868 if Chars
(Ultimate_Alias
(Prim
)) /= Name_Op_Eq
then
7871 -- User-defined renamings of predefined equality have their own
7872 -- slot in the primary dispatch table
7876 while Present
(Alias
(E
)) loop
7877 if Comes_From_Source
(E
) then
7884 return not Comes_From_Source
(E
);
7887 -- User-defined primitives
7892 end In_Predef_Prims_DT
;
7894 -----------------------
7895 -- Validate_Position --
7896 -----------------------
7898 procedure Validate_Position
(Prim
: Entity_Id
) is
7903 -- Aliased primitives are safe
7905 if Present
(Alias
(Prim
)) then
7909 Op_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
7910 while Present
(Op_Elmt
) loop
7911 Op
:= Node
(Op_Elmt
);
7913 -- No need to check against itself
7918 -- Primitive operations covering abstract interfaces are
7921 elsif Present
(Interface_Alias
(Op
)) then
7924 -- Predefined dispatching operations are completely safe. They
7925 -- are allocated at fixed positions in a separate table.
7927 elsif Is_Predefined_Dispatching_Operation
(Op
)
7928 or else Is_Predefined_Dispatching_Alias
(Op
)
7932 -- Aliased subprograms are safe
7934 elsif Present
(Alias
(Op
)) then
7937 elsif DT_Position
(Op
) = DT_Position
(Prim
)
7938 and then not Is_Predefined_Dispatching_Operation
(Op
)
7939 and then not Is_Predefined_Dispatching_Operation
(Prim
)
7940 and then not Is_Predefined_Dispatching_Alias
(Op
)
7941 and then not Is_Predefined_Dispatching_Alias
(Prim
)
7943 -- Handle aliased subprograms
7952 if Present
(Overridden_Operation
(Op_1
)) then
7953 Op_1
:= Overridden_Operation
(Op_1
);
7954 elsif Present
(Alias
(Op_1
)) then
7955 Op_1
:= Alias
(Op_1
);
7963 if Present
(Overridden_Operation
(Op_2
)) then
7964 Op_2
:= Overridden_Operation
(Op_2
);
7965 elsif Present
(Alias
(Op_2
)) then
7966 Op_2
:= Alias
(Op_2
);
7972 if Op_1
/= Op_2
then
7973 raise Program_Error
;
7978 Next_Elmt
(Op_Elmt
);
7980 end Validate_Position
;
7984 Parent_Typ
: constant Entity_Id
:= Etype
(Typ
);
7985 First_Prim
: constant Elmt_Id
:= First_Elmt
(Primitive_Operations
(Typ
));
7986 The_Tag
: constant Entity_Id
:= First_Tag_Component
(Typ
);
7988 Adjusted
: Boolean := False;
7989 Finalized
: Boolean := False;
7995 Prim_Elmt
: Elmt_Id
;
7997 -- Start of processing for Set_All_DT_Position
8000 pragma Assert
(Present
(First_Tag_Component
(Typ
)));
8002 -- Set the DT_Position for each primitive operation. Perform some sanity
8003 -- checks to avoid building inconsistent dispatch tables.
8005 -- First stage: Set DTC entity of all the primitive operations. This is
8006 -- required to properly read the DT_Position attribute in latter stages.
8008 Prim_Elmt
:= First_Prim
;
8010 while Present
(Prim_Elmt
) loop
8011 Prim
:= Node
(Prim_Elmt
);
8013 -- Predefined primitives have a separate dispatch table
8015 if not In_Predef_Prims_DT
(Prim
) then
8016 Count_Prim
:= Count_Prim
+ 1;
8019 Set_DTC_Entity_Value
(Typ
, Prim
);
8021 -- Clear any previous value of the DT_Position attribute. In this
8022 -- way we ensure that the final position of all the primitives is
8023 -- established by the following stages of this algorithm.
8025 Set_DT_Position_Value
(Prim
, No_Uint
);
8027 Next_Elmt
(Prim_Elmt
);
8031 Fixed_Prim
: array (Int
range 0 .. Count_Prim
) of Boolean :=
8036 procedure Handle_Inherited_Private_Subprograms
(Typ
: Entity_Id
);
8037 -- Called if Typ is declared in a nested package or a public child
8038 -- package to handle inherited primitives that were inherited by Typ
8039 -- in the visible part, but whose declaration was deferred because
8040 -- the parent operation was private and not visible at that point.
8042 procedure Set_Fixed_Prim
(Pos
: Nat
);
8043 -- Sets to true an element of the Fixed_Prim table to indicate
8044 -- that this entry of the dispatch table of Typ is occupied.
8046 ------------------------------------------
8047 -- Handle_Inherited_Private_Subprograms --
8048 ------------------------------------------
8050 procedure Handle_Inherited_Private_Subprograms
(Typ
: Entity_Id
) is
8053 Op_Elmt_2
: Elmt_Id
;
8054 Prim_Op
: Entity_Id
;
8055 Parent_Subp
: Entity_Id
;
8058 Op_List
:= Primitive_Operations
(Typ
);
8060 Op_Elmt
:= First_Elmt
(Op_List
);
8061 while Present
(Op_Elmt
) loop
8062 Prim_Op
:= Node
(Op_Elmt
);
8064 -- Search primitives that are implicit operations with an
8065 -- internal name whose parent operation has a normal name.
8067 if Present
(Alias
(Prim_Op
))
8068 and then Find_Dispatching_Type
(Alias
(Prim_Op
)) /= Typ
8069 and then not Comes_From_Source
(Prim_Op
)
8070 and then Is_Internal_Name
(Chars
(Prim_Op
))
8071 and then not Is_Internal_Name
(Chars
(Alias
(Prim_Op
)))
8073 Parent_Subp
:= Alias
(Prim_Op
);
8075 -- Check if the type has an explicit overriding for this
8078 Op_Elmt_2
:= Next_Elmt
(Op_Elmt
);
8079 while Present
(Op_Elmt_2
) loop
8080 if Chars
(Node
(Op_Elmt_2
)) = Chars
(Parent_Subp
)
8081 and then Type_Conformant
(Prim_Op
, Node
(Op_Elmt_2
))
8083 Set_DT_Position_Value
(Prim_Op
,
8084 DT_Position
(Parent_Subp
));
8085 Set_DT_Position_Value
(Node
(Op_Elmt_2
),
8086 DT_Position
(Parent_Subp
));
8087 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(Prim_Op
)));
8089 goto Next_Primitive
;
8092 Next_Elmt
(Op_Elmt_2
);
8097 Next_Elmt
(Op_Elmt
);
8099 end Handle_Inherited_Private_Subprograms
;
8101 --------------------
8102 -- Set_Fixed_Prim --
8103 --------------------
8105 procedure Set_Fixed_Prim
(Pos
: Nat
) is
8107 pragma Assert
(Pos
<= Count_Prim
);
8108 Fixed_Prim
(Pos
) := True;
8110 when Constraint_Error
=>
8111 raise Program_Error
;
8115 -- In case of nested packages and public child package it may be
8116 -- necessary a special management on inherited subprograms so that
8117 -- the dispatch table is properly filled.
8119 if Ekind
(Scope
(Scope
(Typ
))) = E_Package
8120 and then Scope
(Scope
(Typ
)) /= Standard_Standard
8121 and then ((Is_Derived_Type
(Typ
) and then not Is_Private_Type
(Typ
))
8123 (Nkind
(Parent
(Typ
)) = N_Private_Extension_Declaration
8124 and then Is_Generic_Type
(Typ
)))
8125 and then In_Open_Scopes
(Scope
(Etype
(Typ
)))
8126 and then Is_Base_Type
(Typ
)
8128 Handle_Inherited_Private_Subprograms
(Typ
);
8131 -- Second stage: Register fixed entries
8134 Prim_Elmt
:= First_Prim
;
8135 while Present
(Prim_Elmt
) loop
8136 Prim
:= Node
(Prim_Elmt
);
8138 -- Predefined primitives have a separate table and all its
8139 -- entries are at predefined fixed positions.
8141 if In_Predef_Prims_DT
(Prim
) then
8142 if Is_Predefined_Dispatching_Operation
(Prim
) then
8143 Set_DT_Position_Value
(Prim
,
8144 Default_Prim_Op_Position
(Prim
));
8146 else pragma Assert
(Present
(Alias
(Prim
)));
8147 Set_DT_Position_Value
(Prim
,
8148 Default_Prim_Op_Position
(Ultimate_Alias
(Prim
)));
8151 -- Overriding primitives of ancestor abstract interfaces
8153 elsif Present
(Interface_Alias
(Prim
))
8154 and then Is_Ancestor
8155 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
8156 Use_Full_View
=> True)
8158 pragma Assert
(DT_Position
(Prim
) = No_Uint
8159 and then Present
(DTC_Entity
(Interface_Alias
(Prim
))));
8161 E
:= Interface_Alias
(Prim
);
8162 Set_DT_Position_Value
(Prim
, DT_Position
(E
));
8165 (DT_Position
(Alias
(Prim
)) = No_Uint
8166 or else DT_Position
(Alias
(Prim
)) = DT_Position
(E
));
8167 Set_DT_Position_Value
(Alias
(Prim
), DT_Position
(E
));
8168 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(Prim
)));
8170 -- Overriding primitives must use the same entry as the
8171 -- overridden primitive.
8173 elsif not Present
(Interface_Alias
(Prim
))
8174 and then Present
(Alias
(Prim
))
8175 and then Chars
(Prim
) = Chars
(Alias
(Prim
))
8176 and then Find_Dispatching_Type
(Alias
(Prim
)) /= Typ
8177 and then Is_Ancestor
8178 (Find_Dispatching_Type
(Alias
(Prim
)), Typ
,
8179 Use_Full_View
=> True)
8180 and then Present
(DTC_Entity
(Alias
(Prim
)))
8183 Set_DT_Position_Value
(Prim
, DT_Position
(E
));
8185 if not Is_Predefined_Dispatching_Alias
(E
) then
8186 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(E
)));
8190 Next_Elmt
(Prim_Elmt
);
8193 -- Third stage: Fix the position of all the new primitives. Entries
8194 -- associated with primitives covering interfaces are handled in a
8197 Prim_Elmt
:= First_Prim
;
8198 while Present
(Prim_Elmt
) loop
8199 Prim
:= Node
(Prim_Elmt
);
8201 -- Skip primitives previously set entries
8203 if DT_Position
(Prim
) /= No_Uint
then
8206 -- Primitives covering interface primitives are handled later
8208 elsif Present
(Interface_Alias
(Prim
)) then
8212 -- Take the next available position in the DT
8215 Nb_Prim
:= Nb_Prim
+ 1;
8216 pragma Assert
(Nb_Prim
<= Count_Prim
);
8217 exit when not Fixed_Prim
(Nb_Prim
);
8220 Set_DT_Position_Value
(Prim
, UI_From_Int
(Nb_Prim
));
8221 Set_Fixed_Prim
(Nb_Prim
);
8224 Next_Elmt
(Prim_Elmt
);
8228 -- Fourth stage: Complete the decoration of primitives covering
8229 -- interfaces (that is, propagate the DT_Position attribute from
8230 -- the aliased primitive)
8232 Prim_Elmt
:= First_Prim
;
8233 while Present
(Prim_Elmt
) loop
8234 Prim
:= Node
(Prim_Elmt
);
8236 if DT_Position
(Prim
) = No_Uint
8237 and then Present
(Interface_Alias
(Prim
))
8239 pragma Assert
(Present
(Alias
(Prim
))
8240 and then Find_Dispatching_Type
(Alias
(Prim
)) = Typ
);
8242 -- Check if this entry will be placed in the primary DT
8245 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
8246 Use_Full_View
=> True)
8248 pragma Assert
(DT_Position
(Alias
(Prim
)) /= No_Uint
);
8249 Set_DT_Position_Value
(Prim
, DT_Position
(Alias
(Prim
)));
8251 -- Otherwise it will be placed in the secondary DT
8255 (DT_Position
(Interface_Alias
(Prim
)) /= No_Uint
);
8256 Set_DT_Position_Value
(Prim
,
8257 DT_Position
(Interface_Alias
(Prim
)));
8261 Next_Elmt
(Prim_Elmt
);
8264 -- Generate listing showing the contents of the dispatch tables. This
8265 -- action is done before some further static checks because in case of
8266 -- critical errors caused by a wrong dispatch table we need to see the
8267 -- contents of such table.
8269 if Debug_Flag_ZZ
then
8273 -- Final stage: Ensure that the table is correct plus some further
8274 -- verifications concerning the primitives.
8276 Prim_Elmt
:= First_Prim
;
8278 while Present
(Prim_Elmt
) loop
8279 Prim
:= Node
(Prim_Elmt
);
8281 -- At this point all the primitives MUST have a position in the
8284 if DT_Position
(Prim
) = No_Uint
then
8285 raise Program_Error
;
8288 -- Calculate real size of the dispatch table
8290 if not In_Predef_Prims_DT
(Prim
)
8291 and then UI_To_Int
(DT_Position
(Prim
)) > DT_Length
8293 DT_Length
:= UI_To_Int
(DT_Position
(Prim
));
8296 -- Ensure that the assigned position to non-predefined dispatching
8297 -- operations in the dispatch table is correct.
8299 if not Is_Predefined_Dispatching_Operation
(Prim
)
8300 and then not Is_Predefined_Dispatching_Alias
(Prim
)
8302 Validate_Position
(Prim
);
8305 if Chars
(Prim
) = Name_Finalize
then
8309 if Chars
(Prim
) = Name_Adjust
then
8313 -- An abstract operation cannot be declared in the private part for a
8314 -- visible abstract type, because it can't be overridden outside this
8315 -- package hierarchy. For explicit declarations this is checked at
8316 -- the point of declaration, but for inherited operations it must be
8317 -- done when building the dispatch table.
8319 -- Ada 2005 (AI-251): Primitives associated with interfaces are
8320 -- excluded from this check because interfaces must be visible in
8321 -- the public and private part (RM 7.3 (7.3/2))
8323 -- We disable this check in Relaxed_RM_Semantics mode, to accommodate
8326 if not Relaxed_RM_Semantics
8327 and then Is_Abstract_Type
(Typ
)
8328 and then Is_Abstract_Subprogram
(Prim
)
8329 and then Present
(Alias
(Prim
))
8330 and then not Is_Interface
8331 (Find_Dispatching_Type
(Ultimate_Alias
(Prim
)))
8332 and then not Present
(Interface_Alias
(Prim
))
8333 and then Is_Derived_Type
(Typ
)
8334 and then In_Private_Part
(Current_Scope
)
8336 List_Containing
(Parent
(Prim
)) =
8337 Private_Declarations
(Package_Specification
(Current_Scope
))
8338 and then Original_View_In_Visible_Part
(Typ
)
8340 -- We exclude Input and Output stream operations because
8341 -- Limited_Controlled inherits useless Input and Output stream
8342 -- operations from Root_Controlled, which can never be overridden.
8344 if not Is_TSS
(Prim
, TSS_Stream_Input
)
8346 not Is_TSS
(Prim
, TSS_Stream_Output
)
8349 ("abstract inherited private operation&" &
8350 " must be overridden (RM 3.9.3(10))",
8351 Parent
(Typ
), Prim
);
8355 Next_Elmt
(Prim_Elmt
);
8360 if Is_Controlled
(Typ
) then
8361 if not Finalized
then
8363 ("controlled type has no explicit Finalize method??", Typ
);
8365 elsif not Adjusted
then
8367 ("controlled type has no explicit Adjust method??", Typ
);
8371 -- Set the final size of the Dispatch Table
8373 Set_DT_Entry_Count
(The_Tag
, UI_From_Int
(DT_Length
));
8375 -- The derived type must have at least as many components as its parent
8376 -- (for root types Etype points to itself and the test cannot fail).
8378 if DT_Entry_Count
(The_Tag
) <
8379 DT_Entry_Count
(First_Tag_Component
(Parent_Typ
))
8381 raise Program_Error
;
8383 end Set_All_DT_Position
;
8385 --------------------------
8386 -- Set_CPP_Constructors --
8387 --------------------------
8389 procedure Set_CPP_Constructors
(Typ
: Entity_Id
) is
8391 function Gen_Parameters_Profile
(E
: Entity_Id
) return List_Id
;
8392 -- Duplicate the parameters profile of the imported C++ constructor
8393 -- adding an access to the object as an additional parameter.
8395 ----------------------------
8396 -- Gen_Parameters_Profile --
8397 ----------------------------
8399 function Gen_Parameters_Profile
(E
: Entity_Id
) return List_Id
is
8400 Loc
: constant Source_Ptr
:= Sloc
(E
);
8407 Make_Parameter_Specification
(Loc
,
8408 Defining_Identifier
=>
8409 Make_Defining_Identifier
(Loc
, Name_uInit
),
8410 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
8412 if Present
(Parameter_Specifications
(Parent
(E
))) then
8413 P
:= First
(Parameter_Specifications
(Parent
(E
)));
8414 while Present
(P
) loop
8416 Make_Parameter_Specification
(Loc
,
8417 Defining_Identifier
=>
8418 Make_Defining_Identifier
(Loc
,
8419 Chars
=> Chars
(Defining_Identifier
(P
))),
8420 Parameter_Type
=> New_Copy_Tree
(Parameter_Type
(P
)),
8421 Expression
=> New_Copy_Tree
(Expression
(P
))));
8427 end Gen_Parameters_Profile
;
8433 Found
: Boolean := False;
8439 Covers_Default_Constructor
: Entity_Id
:= Empty
;
8441 -- Start of processing for Set_CPP_Constructor
8444 pragma Assert
(Is_CPP_Class
(Typ
));
8446 -- Look for the constructor entities
8448 E
:= Next_Entity
(Typ
);
8449 while Present
(E
) loop
8450 if Ekind
(E
) = E_Function
8451 and then Is_Constructor
(E
)
8455 Parms
:= Gen_Parameters_Profile
(E
);
8457 Make_Defining_Identifier
(Loc
,
8458 Chars
=> Make_Init_Proc_Name
(Typ
));
8460 -- Case 1: Constructor of untagged type
8462 -- If the C++ class has no virtual methods then the matching Ada
8463 -- type is an untagged record type. In such case there is no need
8464 -- to generate a wrapper of the C++ constructor because the _tag
8465 -- component is not available.
8467 if not Is_Tagged_Type
(Typ
) then
8469 (Make_Subprogram_Declaration
(Loc
,
8471 Make_Procedure_Specification
(Loc
,
8472 Defining_Unit_Name
=> IP
,
8473 Parameter_Specifications
=> Parms
)));
8475 Set_Init_Proc
(Typ
, IP
);
8476 Set_Is_Imported
(IP
);
8477 Set_Is_Constructor
(IP
);
8478 Set_Interface_Name
(IP
, Interface_Name
(E
));
8479 Set_Convention
(IP
, Convention_CPP
);
8481 Set_Has_Completion
(IP
);
8483 -- Case 2: Constructor of a tagged type
8485 -- In this case we generate the IP as a wrapper of the the
8486 -- C++ constructor because IP must also save copy of the _tag
8487 -- generated in the C++ side. The copy of the _tag is used by
8488 -- Build_CPP_Init_Procedure to elaborate derivations of C++ types.
8491 -- procedure IP (_init : Typ; ...) is
8492 -- procedure ConstructorP (_init : Typ; ...);
8493 -- pragma Import (ConstructorP);
8495 -- ConstructorP (_init, ...);
8496 -- if Typ._tag = null then
8497 -- Typ._tag := _init._tag;
8503 Body_Stmts
: constant List_Id
:= New_List
;
8504 Constructor_Id
: Entity_Id
;
8505 Constructor_Decl_Node
: Node_Id
;
8506 Init_Tags_List
: List_Id
;
8509 Constructor_Id
:= Make_Temporary
(Loc
, 'P');
8511 Constructor_Decl_Node
:=
8512 Make_Subprogram_Declaration
(Loc
,
8513 Make_Procedure_Specification
(Loc
,
8514 Defining_Unit_Name
=> Constructor_Id
,
8515 Parameter_Specifications
=> Parms
));
8517 Set_Is_Imported
(Constructor_Id
);
8518 Set_Is_Constructor
(Constructor_Id
);
8519 Set_Interface_Name
(Constructor_Id
, Interface_Name
(E
));
8520 Set_Convention
(Constructor_Id
, Convention_CPP
);
8521 Set_Is_Public
(Constructor_Id
);
8522 Set_Has_Completion
(Constructor_Id
);
8524 -- Build the init procedure as a wrapper of this constructor
8526 Parms
:= Gen_Parameters_Profile
(E
);
8528 -- Invoke the C++ constructor
8531 Actuals
: constant List_Id
:= New_List
;
8535 while Present
(P
) loop
8537 New_Occurrence_Of
(Defining_Identifier
(P
), Loc
));
8541 Append_To
(Body_Stmts
,
8542 Make_Procedure_Call_Statement
(Loc
,
8543 Name
=> New_Occurrence_Of
(Constructor_Id
, Loc
),
8544 Parameter_Associations
=> Actuals
));
8547 -- Initialize copies of C++ primary and secondary tags
8549 Init_Tags_List
:= New_List
;
8556 Tag_Elmt
:= First_Elmt
(Access_Disp_Table
(Typ
));
8557 Tag_Comp
:= First_Tag_Component
(Typ
);
8559 while Present
(Tag_Elmt
)
8560 and then Is_Tag
(Node
(Tag_Elmt
))
8562 -- Skip the following assertion with primary tags
8563 -- because Related_Type is not set on primary tag
8567 (Tag_Comp
= First_Tag_Component
(Typ
)
8568 or else Related_Type
(Node
(Tag_Elmt
))
8569 = Related_Type
(Tag_Comp
));
8571 Append_To
(Init_Tags_List
,
8572 Make_Assignment_Statement
(Loc
,
8574 New_Occurrence_Of
(Node
(Tag_Elmt
), Loc
),
8576 Make_Selected_Component
(Loc
,
8578 Make_Identifier
(Loc
, Name_uInit
),
8580 New_Occurrence_Of
(Tag_Comp
, Loc
))));
8582 Tag_Comp
:= Next_Tag_Component
(Tag_Comp
);
8583 Next_Elmt
(Tag_Elmt
);
8587 Append_To
(Body_Stmts
,
8588 Make_If_Statement
(Loc
,
8593 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))),
8596 Unchecked_Convert_To
(RTE
(RE_Tag
),
8597 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))),
8598 Then_Statements
=> Init_Tags_List
));
8601 Make_Subprogram_Body
(Loc
,
8603 Make_Procedure_Specification
(Loc
,
8604 Defining_Unit_Name
=> IP
,
8605 Parameter_Specifications
=> Parms
),
8606 Declarations
=> New_List
(Constructor_Decl_Node
),
8607 Handled_Statement_Sequence
=>
8608 Make_Handled_Sequence_Of_Statements
(Loc
,
8609 Statements
=> Body_Stmts
,
8610 Exception_Handlers
=> No_List
));
8612 Discard_Node
(IP_Body
);
8613 Set_Init_Proc
(Typ
, IP
);
8617 -- If this constructor has parameters and all its parameters have
8618 -- defaults then it covers the default constructor. The semantic
8619 -- analyzer ensures that only one constructor with defaults covers
8620 -- the default constructor.
8622 if Present
(Parameter_Specifications
(Parent
(E
)))
8623 and then Needs_No_Actuals
(E
)
8625 Covers_Default_Constructor
:= IP
;
8632 -- If there are no constructors, mark the type as abstract since we
8633 -- won't be able to declare objects of that type.
8636 Set_Is_Abstract_Type
(Typ
);
8639 -- Handle constructor that has all its parameters with defaults and
8640 -- hence it covers the default constructor. We generate a wrapper IP
8641 -- which calls the covering constructor.
8643 if Present
(Covers_Default_Constructor
) then
8645 Body_Stmts
: List_Id
;
8648 Loc
:= Sloc
(Covers_Default_Constructor
);
8650 Body_Stmts
:= New_List
(
8651 Make_Procedure_Call_Statement
(Loc
,
8653 New_Occurrence_Of
(Covers_Default_Constructor
, Loc
),
8654 Parameter_Associations
=> New_List
(
8655 Make_Identifier
(Loc
, Name_uInit
))));
8657 IP
:= Make_Defining_Identifier
(Loc
, Make_Init_Proc_Name
(Typ
));
8660 Make_Subprogram_Body
(Loc
,
8662 Make_Procedure_Specification
(Loc
,
8663 Defining_Unit_Name
=> IP
,
8664 Parameter_Specifications
=> New_List
(
8665 Make_Parameter_Specification
(Loc
,
8666 Defining_Identifier
=>
8667 Make_Defining_Identifier
(Loc
, Name_uInit
),
8668 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)))),
8670 Declarations
=> No_List
,
8672 Handled_Statement_Sequence
=>
8673 Make_Handled_Sequence_Of_Statements
(Loc
,
8674 Statements
=> Body_Stmts
,
8675 Exception_Handlers
=> No_List
));
8677 Discard_Node
(IP_Body
);
8678 Set_Init_Proc
(Typ
, IP
);
8682 -- If the CPP type has constructors then it must import also the default
8683 -- C++ constructor. It is required for default initialization of objects
8684 -- of the type. It is also required to elaborate objects of Ada types
8685 -- that are defined as derivations of this CPP type.
8687 if Has_CPP_Constructors
(Typ
)
8688 and then No
(Init_Proc
(Typ
))
8690 Error_Msg_N
("??default constructor must be imported from C++", Typ
);
8692 end Set_CPP_Constructors
;
8694 ---------------------------
8695 -- Set_DT_Position_Value --
8696 ---------------------------
8698 procedure Set_DT_Position_Value
(Prim
: Entity_Id
; Value
: Uint
) is
8700 Set_DT_Position
(Prim
, Value
);
8702 -- Propagate the value to the wrapped subprogram (if one is present)
8704 if Ekind_In
(Prim
, E_Function
, E_Procedure
)
8705 and then Is_Primitive_Wrapper
(Prim
)
8706 and then Present
(Wrapped_Entity
(Prim
))
8707 and then Is_Dispatching_Operation
(Wrapped_Entity
(Prim
))
8709 Set_DT_Position
(Wrapped_Entity
(Prim
), Value
);
8711 end Set_DT_Position_Value
;
8713 --------------------------
8714 -- Set_DTC_Entity_Value --
8715 --------------------------
8717 procedure Set_DTC_Entity_Value
8718 (Tagged_Type
: Entity_Id
;
8722 if Present
(Interface_Alias
(Prim
))
8723 and then Is_Interface
8724 (Find_Dispatching_Type
(Interface_Alias
(Prim
)))
8726 Set_DTC_Entity
(Prim
,
8729 Iface
=> Find_Dispatching_Type
(Interface_Alias
(Prim
))));
8731 Set_DTC_Entity
(Prim
,
8732 First_Tag_Component
(Tagged_Type
));
8735 -- Propagate the value to the wrapped subprogram (if one is present)
8737 if Ekind_In
(Prim
, E_Function
, E_Procedure
)
8738 and then Is_Primitive_Wrapper
(Prim
)
8739 and then Present
(Wrapped_Entity
(Prim
))
8740 and then Is_Dispatching_Operation
(Wrapped_Entity
(Prim
))
8742 Set_DTC_Entity
(Wrapped_Entity
(Prim
), DTC_Entity
(Prim
));
8744 end Set_DTC_Entity_Value
;
8750 function Tagged_Kind
(T
: Entity_Id
) return Node_Id
is
8751 Conc_Typ
: Entity_Id
;
8752 Loc
: constant Source_Ptr
:= Sloc
(T
);
8756 (Is_Tagged_Type
(T
) and then RTE_Available
(RE_Tagged_Kind
));
8760 if Is_Abstract_Type
(T
) then
8761 if Is_Limited_Record
(T
) then
8762 return New_Occurrence_Of
8763 (RTE
(RE_TK_Abstract_Limited_Tagged
), Loc
);
8765 return New_Occurrence_Of
8766 (RTE
(RE_TK_Abstract_Tagged
), Loc
);
8771 elsif Is_Concurrent_Record_Type
(T
) then
8772 Conc_Typ
:= Corresponding_Concurrent_Type
(T
);
8774 if Present
(Full_View
(Conc_Typ
)) then
8775 Conc_Typ
:= Full_View
(Conc_Typ
);
8778 if Ekind
(Conc_Typ
) = E_Protected_Type
then
8779 return New_Occurrence_Of
(RTE
(RE_TK_Protected
), Loc
);
8781 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
8782 return New_Occurrence_Of
(RTE
(RE_TK_Task
), Loc
);
8785 -- Regular tagged kinds
8788 if Is_Limited_Record
(T
) then
8789 return New_Occurrence_Of
(RTE
(RE_TK_Limited_Tagged
), Loc
);
8791 return New_Occurrence_Of
(RTE
(RE_TK_Tagged
), Loc
);
8800 procedure Write_DT
(Typ
: Entity_Id
) is
8805 -- Protect this procedure against wrong usage. Required because it will
8806 -- be used directly from GDB
8808 if not (Typ
<= Last_Node_Id
)
8809 or else not Is_Tagged_Type
(Typ
)
8811 Write_Str
("wrong usage: Write_DT must be used with tagged types");
8816 Write_Int
(Int
(Typ
));
8818 Write_Name
(Chars
(Typ
));
8820 if Is_Interface
(Typ
) then
8821 Write_Str
(" is interface");
8826 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
8827 while Present
(Elmt
) loop
8828 Prim
:= Node
(Elmt
);
8831 -- Indicate if this primitive will be allocated in the primary
8832 -- dispatch table or in a secondary dispatch table associated
8833 -- with an abstract interface type
8835 if Present
(DTC_Entity
(Prim
)) then
8836 if Etype
(DTC_Entity
(Prim
)) = RTE
(RE_Tag
) then
8843 -- Output the node of this primitive operation and its name
8845 Write_Int
(Int
(Prim
));
8848 if Is_Predefined_Dispatching_Operation
(Prim
) then
8849 Write_Str
("(predefined) ");
8852 -- Prefix the name of the primitive with its corresponding tagged
8853 -- type to facilitate seeing inherited primitives.
8855 if Present
(Alias
(Prim
)) then
8857 (Chars
(Find_Dispatching_Type
(Ultimate_Alias
(Prim
))));
8859 Write_Name
(Chars
(Typ
));
8863 Write_Name
(Chars
(Prim
));
8865 -- Indicate if this primitive has an aliased primitive
8867 if Present
(Alias
(Prim
)) then
8868 Write_Str
(" (alias = ");
8869 Write_Int
(Int
(Alias
(Prim
)));
8871 -- If the DTC_Entity attribute is already set we can also output
8872 -- the name of the interface covered by this primitive (if any).
8874 if Ekind_In
(Alias
(Prim
), E_Function
, E_Procedure
)
8875 and then Present
(DTC_Entity
(Alias
(Prim
)))
8876 and then Is_Interface
(Scope
(DTC_Entity
(Alias
(Prim
))))
8878 Write_Str
(" from interface ");
8879 Write_Name
(Chars
(Scope
(DTC_Entity
(Alias
(Prim
)))));
8882 if Present
(Interface_Alias
(Prim
)) then
8883 Write_Str
(", AI_Alias of ");
8885 if Is_Null_Interface_Primitive
(Interface_Alias
(Prim
)) then
8886 Write_Str
("null primitive ");
8890 (Chars
(Find_Dispatching_Type
(Interface_Alias
(Prim
))));
8892 Write_Int
(Int
(Interface_Alias
(Prim
)));
8898 -- Display the final position of this primitive in its associated
8899 -- (primary or secondary) dispatch table.
8901 if Present
(DTC_Entity
(Prim
))
8902 and then DT_Position
(Prim
) /= No_Uint
8904 Write_Str
(" at #");
8905 Write_Int
(UI_To_Int
(DT_Position
(Prim
)));
8908 if Is_Abstract_Subprogram
(Prim
) then
8909 Write_Str
(" is abstract;");
8911 -- Check if this is a null primitive
8913 elsif Comes_From_Source
(Prim
)
8914 and then Ekind
(Prim
) = E_Procedure
8915 and then Null_Present
(Parent
(Prim
))
8917 Write_Str
(" is null;");
8920 if Is_Eliminated
(Ultimate_Alias
(Prim
)) then
8921 Write_Str
(" (eliminated)");
8924 if Is_Imported
(Prim
)
8925 and then Convention
(Prim
) = Convention_CPP
8927 Write_Str
(" (C++)");