1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, 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 Sinput
; use Sinput
;
62 with Snames
; use Snames
;
63 with Stand
; use Stand
;
64 with Stringt
; use Stringt
;
65 with SCIL_LL
; use SCIL_LL
;
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
)
295 -- If the type is derived from a CPP class we cannot statically
296 -- build the dispatch tables because we must inherit primitives
297 -- from the CPP side.
299 and then not Is_CPP_Class
(Root_Typ
);
300 end Building_Static_DT
;
302 ----------------------------------
303 -- Build_Static_Dispatch_Tables --
304 ----------------------------------
306 procedure Build_Static_Dispatch_Tables
(N
: Entity_Id
) is
307 Target_List
: List_Id
;
309 procedure Build_Dispatch_Tables
(List
: List_Id
);
310 -- Build the static dispatch table of tagged types found in the list of
311 -- declarations. The generated nodes are added at the end of Target_List
313 procedure Build_Package_Dispatch_Tables
(N
: Node_Id
);
314 -- Build static dispatch tables associated with package declaration N
316 ---------------------------
317 -- Build_Dispatch_Tables --
318 ---------------------------
320 procedure Build_Dispatch_Tables
(List
: List_Id
) is
325 while Present
(D
) loop
327 -- Handle nested packages and package bodies recursively. The
328 -- generated code is placed on the Target_List established for
329 -- the enclosing compilation unit.
331 if Nkind
(D
) = N_Package_Declaration
then
332 Build_Package_Dispatch_Tables
(D
);
334 elsif Nkind
(D
) = N_Package_Body
then
335 Build_Dispatch_Tables
(Declarations
(D
));
337 elsif Nkind
(D
) = N_Package_Body_Stub
338 and then Present
(Library_Unit
(D
))
340 Build_Dispatch_Tables
341 (Declarations
(Proper_Body
(Unit
(Library_Unit
(D
)))));
343 -- Handle full type declarations and derivations of library level
346 elsif Nkind_In
(D
, N_Full_Type_Declaration
,
347 N_Derived_Type_Definition
)
348 and then Is_Library_Level_Tagged_Type
(Defining_Entity
(D
))
349 and then Ekind
(Defining_Entity
(D
)) /= E_Record_Subtype
350 and then not Is_Private_Type
(Defining_Entity
(D
))
352 -- We do not generate dispatch tables for the internal types
353 -- created for a type extension with unknown discriminants
354 -- The needed information is shared with the source type,
355 -- See Expand_N_Record_Extension.
357 if Is_Underlying_Record_View
(Defining_Entity
(D
))
359 (not Comes_From_Source
(Defining_Entity
(D
))
361 Has_Unknown_Discriminants
(Etype
(Defining_Entity
(D
)))
363 not Comes_From_Source
364 (First_Subtype
(Defining_Entity
(D
))))
368 Insert_List_After_And_Analyze
(Last
(Target_List
),
369 Make_DT
(Defining_Entity
(D
)));
372 -- Handle private types of library level tagged types. We must
373 -- exchange the private and full-view to ensure the correct
374 -- expansion. If the full view is a synchronized type ignore
375 -- the type because the table will be built for the corresponding
376 -- record type, that has its own declaration.
378 elsif (Nkind
(D
) = N_Private_Type_Declaration
379 or else Nkind
(D
) = N_Private_Extension_Declaration
)
380 and then Present
(Full_View
(Defining_Entity
(D
)))
383 E1
: constant Entity_Id
:= Defining_Entity
(D
);
384 E2
: constant Entity_Id
:= Full_View
(E1
);
387 if Is_Library_Level_Tagged_Type
(E2
)
388 and then Ekind
(E2
) /= E_Record_Subtype
389 and then not Is_Concurrent_Type
(E2
)
391 Exchange_Declarations
(E1
);
392 Insert_List_After_And_Analyze
(Last
(Target_List
),
394 Exchange_Declarations
(E2
);
401 end Build_Dispatch_Tables
;
403 -----------------------------------
404 -- Build_Package_Dispatch_Tables --
405 -----------------------------------
407 procedure Build_Package_Dispatch_Tables
(N
: Node_Id
) is
408 Spec
: constant Node_Id
:= Specification
(N
);
409 Id
: constant Entity_Id
:= Defining_Entity
(N
);
410 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
411 Priv_Decls
: constant List_Id
:= Private_Declarations
(Spec
);
416 if Present
(Priv_Decls
) then
417 Build_Dispatch_Tables
(Vis_Decls
);
418 Build_Dispatch_Tables
(Priv_Decls
);
420 elsif Present
(Vis_Decls
) then
421 Build_Dispatch_Tables
(Vis_Decls
);
425 end Build_Package_Dispatch_Tables
;
427 -- Start of processing for Build_Static_Dispatch_Tables
430 if not Expander_Active
431 or else not Tagged_Type_Expansion
436 if Nkind
(N
) = N_Package_Declaration
then
438 Spec
: constant Node_Id
:= Specification
(N
);
439 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
440 Priv_Decls
: constant List_Id
:= Private_Declarations
(Spec
);
443 if Present
(Priv_Decls
)
444 and then Is_Non_Empty_List
(Priv_Decls
)
446 Target_List
:= Priv_Decls
;
448 elsif not Present
(Vis_Decls
) then
449 Target_List
:= New_List
;
450 Set_Private_Declarations
(Spec
, Target_List
);
452 Target_List
:= Vis_Decls
;
455 Build_Package_Dispatch_Tables
(N
);
458 else pragma Assert
(Nkind
(N
) = N_Package_Body
);
459 Target_List
:= Declarations
(N
);
460 Build_Dispatch_Tables
(Target_List
);
462 end Build_Static_Dispatch_Tables
;
464 ------------------------------
465 -- Convert_Tag_To_Interface --
466 ------------------------------
468 function Convert_Tag_To_Interface
470 Expr
: Node_Id
) return Node_Id
472 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
473 Anon_Type
: Entity_Id
;
477 pragma Assert
(Is_Class_Wide_Type
(Typ
)
478 and then Is_Interface
(Typ
)
480 ((Nkind
(Expr
) = N_Selected_Component
481 and then Is_Tag
(Entity
(Selector_Name
(Expr
))))
483 (Nkind
(Expr
) = N_Function_Call
484 and then RTE_Available
(RE_Displace
)
485 and then Entity
(Name
(Expr
)) = RTE
(RE_Displace
))));
487 Anon_Type
:= Create_Itype
(E_Anonymous_Access_Type
, Expr
);
488 Set_Directly_Designated_Type
(Anon_Type
, Typ
);
489 Set_Etype
(Anon_Type
, Anon_Type
);
490 Set_Can_Never_Be_Null
(Anon_Type
);
492 -- Decorate the size and alignment attributes of the anonymous access
493 -- type, as required by the back end.
495 Layout_Type
(Anon_Type
);
497 if Nkind
(Expr
) = N_Selected_Component
498 and then Is_Tag
(Entity
(Selector_Name
(Expr
)))
501 Make_Explicit_Dereference
(Loc
,
502 Unchecked_Convert_To
(Anon_Type
,
503 Make_Attribute_Reference
(Loc
,
505 Attribute_Name
=> Name_Address
)));
508 Make_Explicit_Dereference
(Loc
,
509 Unchecked_Convert_To
(Anon_Type
, Expr
));
513 end Convert_Tag_To_Interface
;
519 function CPP_Num_Prims
(Typ
: Entity_Id
) return Nat
is
521 Tag_Comp
: Entity_Id
;
524 if not Is_Tagged_Type
(Typ
)
525 or else not Is_CPP_Class
(Root_Type
(Typ
))
530 CPP_Typ
:= Enclosing_CPP_Parent
(Typ
);
531 Tag_Comp
:= First_Tag_Component
(CPP_Typ
);
533 -- If number of primitives already set in the tag component, use it
535 if Present
(Tag_Comp
)
536 and then DT_Entry_Count
(Tag_Comp
) /= No_Uint
538 return UI_To_Int
(DT_Entry_Count
(Tag_Comp
));
540 -- Otherwise, count the primitives of the enclosing CPP type
548 Elmt
:= First_Elmt
(Primitive_Operations
(CPP_Typ
));
549 while Present
(Elmt
) loop
560 ------------------------------
561 -- Default_Prim_Op_Position --
562 ------------------------------
564 function Default_Prim_Op_Position
(E
: Entity_Id
) return Uint
is
565 TSS_Name
: TSS_Name_Type
;
568 Get_Name_String
(Chars
(E
));
571 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
573 if Chars
(E
) = Name_uSize
then
576 elsif TSS_Name
= TSS_Stream_Read
then
579 elsif TSS_Name
= TSS_Stream_Write
then
582 elsif TSS_Name
= TSS_Stream_Input
then
585 elsif TSS_Name
= TSS_Stream_Output
then
588 elsif Chars
(E
) = Name_Op_Eq
then
591 elsif Chars
(E
) = Name_uAssign
then
594 elsif TSS_Name
= TSS_Deep_Adjust
then
597 elsif TSS_Name
= TSS_Deep_Finalize
then
600 -- In VM targets unconditionally allow obtaining the position associated
601 -- with predefined interface primitives since in these platforms any
602 -- tagged type has these primitives.
604 elsif Ada_Version
>= Ada_2005
or else not Tagged_Type_Expansion
then
605 if Chars
(E
) = Name_uDisp_Asynchronous_Select
then
608 elsif Chars
(E
) = Name_uDisp_Conditional_Select
then
611 elsif Chars
(E
) = Name_uDisp_Get_Prim_Op_Kind
then
614 elsif Chars
(E
) = Name_uDisp_Get_Task_Id
then
617 elsif Chars
(E
) = Name_uDisp_Requeue
then
620 elsif Chars
(E
) = Name_uDisp_Timed_Select
then
626 end Default_Prim_Op_Position
;
628 -----------------------------
629 -- Expand_Dispatching_Call --
630 -----------------------------
632 procedure Expand_Dispatching_Call
(Call_Node
: Node_Id
) is
633 Loc
: constant Source_Ptr
:= Sloc
(Call_Node
);
634 Call_Typ
: constant Entity_Id
:= Etype
(Call_Node
);
636 Ctrl_Arg
: constant Node_Id
:= Controlling_Argument
(Call_Node
);
637 Ctrl_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Ctrl_Arg
));
638 Param_List
: constant List_Id
:= Parameter_Associations
(Call_Node
);
643 New_Call_Name
: Node_Id
;
644 New_Params
: List_Id
:= No_List
;
647 Subp_Ptr_Typ
: Entity_Id
;
648 Subp_Typ
: Entity_Id
;
650 Eq_Prim_Op
: Entity_Id
:= Empty
;
651 Controlling_Tag
: Node_Id
;
653 procedure Build_Class_Wide_Check
;
654 -- If the denoted subprogram has a class-wide precondition, generate a
655 -- check using that precondition before the dispatching call, because
656 -- this is the only class-wide precondition that applies to the call.
658 function New_Value
(From
: Node_Id
) return Node_Id
;
659 -- From is the original Expression. New_Value is equivalent to a call
660 -- to Duplicate_Subexpr with an explicit dereference when From is an
663 ----------------------------
664 -- Build_Class_Wide_Check --
665 ----------------------------
667 procedure Build_Class_Wide_Check
is
668 function Replace_Formals
(N
: Node_Id
) return Traverse_Result
;
669 -- Replace occurrences of the formals of the subprogram by the
670 -- corresponding actuals in the call, given that this check is
671 -- performed outside of the body of the subprogram.
673 ---------------------
674 -- Replace_Formals --
675 ---------------------
677 function Replace_Formals
(N
: Node_Id
) return Traverse_Result
is
679 if Is_Entity_Name
(N
)
680 and then Present
(Entity
(N
))
681 and then Is_Formal
(Entity
(N
))
688 F
:= First_Formal
(Subp
);
689 A
:= First_Actual
(Call_Node
);
690 while Present
(F
) loop
691 if F
= Entity
(N
) then
692 Rewrite
(N
, New_Copy_Tree
(A
));
705 procedure Update
is new Traverse_Proc
(Replace_Formals
);
709 Str_Loc
: constant String := Build_Location_String
(Loc
);
715 -- Start of processing for Build_Class_Wide_Check
719 -- Locate class-wide precondition, if any
721 if Present
(Contract
(Subp
))
722 and then Present
(Pre_Post_Conditions
(Contract
(Subp
)))
724 Prec
:= Pre_Post_Conditions
(Contract
(Subp
));
726 while Present
(Prec
) loop
727 exit when Pragma_Name
(Prec
) = Name_Precondition
728 and then Class_Present
(Prec
);
729 Prec
:= Next_Pragma
(Prec
);
736 -- The expression for the precondition is analyzed within the
737 -- generated pragma. The message text is the last parameter of
738 -- the generated pragma, indicating source of precondition.
742 (Expression
(First
(Pragma_Argument_Associations
(Prec
))));
745 -- Build message indicating the failed precondition and the
746 -- dispatching call that caused it.
748 Msg
:= Expression
(Last
(Pragma_Argument_Associations
(Prec
)));
750 Append
(Global_Name_Buffer
, Strval
(Msg
));
751 Append
(Global_Name_Buffer
, " in dispatching call at ");
752 Append
(Global_Name_Buffer
, Str_Loc
);
753 Msg
:= Make_String_Literal
(Loc
, Name_Buffer
(1 .. Name_Len
));
755 Insert_Action
(Call_Node
,
756 Make_If_Statement
(Loc
,
757 Condition
=> Make_Op_Not
(Loc
, Cond
),
758 Then_Statements
=> New_List
(
759 Make_Procedure_Call_Statement
(Loc
,
761 New_Occurrence_Of
(RTE
(RE_Raise_Assert_Failure
), Loc
),
762 Parameter_Associations
=> New_List
(Msg
)))));
764 end Build_Class_Wide_Check
;
770 function New_Value
(From
: Node_Id
) return Node_Id
is
771 Res
: constant Node_Id
:= Duplicate_Subexpr
(From
);
773 if Is_Access_Type
(Etype
(From
)) then
775 Make_Explicit_Dereference
(Sloc
(From
),
785 SCIL_Node
: Node_Id
:= Empty
;
786 SCIL_Related_Node
: Node_Id
:= Call_Node
;
788 -- Start of processing for Expand_Dispatching_Call
791 if No_Run_Time_Mode
then
792 Error_Msg_CRT
("tagged types", Call_Node
);
796 -- Expand_Dispatching_Call is called directly from the semantics, so we
797 -- only proceed if the expander is active.
799 if not Expander_Active
801 -- And there is no need to expand the call if we are compiling under
802 -- restriction No_Dispatching_Calls; the semantic analyzer has
803 -- previously notified the violation of this restriction.
805 or else Restriction_Active
(No_Dispatching_Calls
)
807 -- No action needed if the dispatching call has been already expanded
809 or else Is_Expanded_Dispatching_Call
(Name
(Call_Node
))
814 -- Set subprogram. If this is an inherited operation that was
815 -- overridden, the body that is being called is its alias.
817 Subp
:= Entity
(Name
(Call_Node
));
819 if Present
(Alias
(Subp
))
820 and then Is_Inherited_Operation
(Subp
)
821 and then No
(DTC_Entity
(Subp
))
823 Subp
:= Alias
(Subp
);
826 Build_Class_Wide_Check
;
828 -- Definition of the class-wide type and the tagged type
830 -- If the controlling argument is itself a tag rather than a tagged
831 -- object, then use the class-wide type associated with the subprogram's
832 -- controlling type. This case can occur when a call to an inherited
833 -- primitive has an actual that originated from a default parameter
834 -- given by a tag-indeterminate call and when there is no other
835 -- controlling argument providing the tag (AI-239 requires dispatching).
836 -- This capability of dispatching directly by tag is also needed by the
837 -- implementation of AI-260 (for the generic dispatching constructors).
839 if Ctrl_Typ
= RTE
(RE_Tag
)
840 or else (RTE_Available
(RE_Interface_Tag
)
841 and then Ctrl_Typ
= RTE
(RE_Interface_Tag
))
843 CW_Typ
:= Class_Wide_Type
(Find_Dispatching_Type
(Subp
));
845 -- Class_Wide_Type is applied to the expressions used to initialize
846 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
847 -- there are cases where the controlling type is resolved to a specific
848 -- type (such as for designated types of arguments such as CW'Access).
850 elsif Is_Access_Type
(Ctrl_Typ
) then
851 CW_Typ
:= Class_Wide_Type
(Designated_Type
(Ctrl_Typ
));
854 CW_Typ
:= Class_Wide_Type
(Ctrl_Typ
);
857 Typ
:= Find_Specific_Type
(CW_Typ
);
859 if not Is_Limited_Type
(Typ
) then
860 Eq_Prim_Op
:= Find_Prim_Op
(Typ
, Name_Op_Eq
);
863 -- Dispatching call to C++ primitive. Create a new parameter list
864 -- with no tag checks.
866 New_Params
:= New_List
;
868 if Is_CPP_Class
(Typ
) then
869 Param
:= First_Actual
(Call_Node
);
870 while Present
(Param
) loop
871 Append_To
(New_Params
, Relocate_Node
(Param
));
875 -- Dispatching call to Ada primitive
877 elsif Present
(Param_List
) then
878 Apply_Tag_Checks
(Call_Node
);
880 Param
:= First_Actual
(Call_Node
);
881 while Present
(Param
) loop
883 -- Cases in which we may have generated run-time checks. Note that
884 -- we strip any qualification from Param before comparing with the
885 -- already-stripped controlling argument.
887 if Unqualify
(Param
) = Ctrl_Arg
or else Subp
= Eq_Prim_Op
then
888 Append_To
(New_Params
,
889 Duplicate_Subexpr_Move_Checks
(Param
));
891 elsif Nkind
(Parent
(Param
)) /= N_Parameter_Association
892 or else not Is_Accessibility_Actual
(Parent
(Param
))
894 Append_To
(New_Params
, Relocate_Node
(Param
));
901 -- Generate the appropriate subprogram pointer type
903 if Etype
(Subp
) = Typ
then
906 Res_Typ
:= Etype
(Subp
);
909 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, Call_Node
);
910 Subp_Ptr_Typ
:= Create_Itype
(E_Access_Subprogram_Type
, Call_Node
);
911 Set_Etype
(Subp_Typ
, Res_Typ
);
912 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
913 Set_Convention
(Subp_Typ
, Convention
(Subp
));
915 -- Notify gigi that the designated type is a dispatching primitive
917 Set_Is_Dispatch_Table_Entity
(Subp_Typ
);
919 -- Create a new list of parameters which is a copy of the old formal
920 -- list including the creation of a new set of matching entities.
923 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
924 New_Formal
: Entity_Id
;
925 Extra
: Entity_Id
:= Empty
;
928 if Present
(Old_Formal
) then
929 New_Formal
:= New_Copy
(Old_Formal
);
930 Set_First_Entity
(Subp_Typ
, New_Formal
);
931 Param
:= First_Actual
(Call_Node
);
934 Set_Scope
(New_Formal
, Subp_Typ
);
936 -- Change all the controlling argument types to be class-wide
937 -- to avoid a recursion in dispatching.
939 if Is_Controlling_Formal
(New_Formal
) then
940 Set_Etype
(New_Formal
, Etype
(Param
));
943 -- If the type of the formal is an itype, there was code here
944 -- introduced in 1998 in revision 1.46, to create a new itype
945 -- by copy. This seems useless, and in fact leads to semantic
946 -- errors when the itype is the completion of a type derived
947 -- from a private type.
950 Next_Formal
(Old_Formal
);
951 exit when No
(Old_Formal
);
953 Set_Next_Entity
(New_Formal
, New_Copy
(Old_Formal
));
954 Next_Entity
(New_Formal
);
958 Set_Next_Entity
(New_Formal
, Empty
);
959 Set_Last_Entity
(Subp_Typ
, Extra
);
962 -- Now that the explicit formals have been duplicated, any extra
963 -- formals needed by the subprogram must be created.
965 if Present
(Extra
) then
966 Set_Extra_Formal
(Extra
, Empty
);
969 Create_Extra_Formals
(Subp_Typ
);
972 -- Complete description of pointer type, including size information, as
973 -- must be done with itypes to prevent order-of-elaboration anomalies
976 Set_Etype
(Subp_Ptr_Typ
, Subp_Ptr_Typ
);
977 Set_Directly_Designated_Type
(Subp_Ptr_Typ
, Subp_Typ
);
978 Set_Convention
(Subp_Ptr_Typ
, Convention
(Subp_Typ
));
979 Layout_Type
(Subp_Ptr_Typ
);
981 -- If the controlling argument is a value of type Ada.Tag or an abstract
982 -- interface class-wide type then use it directly. Otherwise, the tag
983 -- must be extracted from the controlling object.
985 if Ctrl_Typ
= RTE
(RE_Tag
)
986 or else (RTE_Available
(RE_Interface_Tag
)
987 and then Ctrl_Typ
= RTE
(RE_Interface_Tag
))
989 Controlling_Tag
:= Duplicate_Subexpr
(Ctrl_Arg
);
991 -- Extract the tag from an unchecked type conversion. Done to avoid
992 -- the expansion of additional code just to obtain the value of such
993 -- tag because the current management of interface type conversions
994 -- generates in some cases this unchecked type conversion with the
995 -- tag of the object (see Expand_Interface_Conversion).
997 elsif Nkind
(Ctrl_Arg
) = N_Unchecked_Type_Conversion
999 (Etype
(Expression
(Ctrl_Arg
)) = RTE
(RE_Tag
)
1001 (RTE_Available
(RE_Interface_Tag
)
1003 Etype
(Expression
(Ctrl_Arg
)) = RTE
(RE_Interface_Tag
)))
1005 Controlling_Tag
:= Duplicate_Subexpr
(Expression
(Ctrl_Arg
));
1007 -- Ada 2005 (AI-251): Abstract interface class-wide type
1009 elsif Is_Interface
(Ctrl_Typ
)
1010 and then Is_Class_Wide_Type
(Ctrl_Typ
)
1012 Controlling_Tag
:= Duplicate_Subexpr
(Ctrl_Arg
);
1016 Make_Selected_Component
(Loc
,
1017 Prefix
=> Duplicate_Subexpr_Move_Checks
(Ctrl_Arg
),
1018 Selector_Name
=> New_Occurrence_Of
(DTC_Entity
(Subp
), Loc
));
1021 -- Handle dispatching calls to predefined primitives
1023 if Is_Predefined_Dispatching_Operation
(Subp
)
1024 or else Is_Predefined_Dispatching_Alias
(Subp
)
1026 Build_Get_Predefined_Prim_Op_Address
(Loc
,
1027 Tag_Node
=> Controlling_Tag
,
1028 Position
=> DT_Position
(Subp
),
1029 New_Node
=> New_Node
);
1031 -- Handle dispatching calls to user-defined primitives
1034 Build_Get_Prim_Op_Address
(Loc
,
1035 Typ
=> Underlying_Type
(Find_Dispatching_Type
(Subp
)),
1036 Tag_Node
=> Controlling_Tag
,
1037 Position
=> DT_Position
(Subp
),
1038 New_Node
=> New_Node
);
1042 Unchecked_Convert_To
(Subp_Ptr_Typ
, New_Node
);
1044 -- Generate the SCIL node for this dispatching call. Done now because
1045 -- attribute SCIL_Controlling_Tag must be set after the new call name
1046 -- is built to reference the nodes that will see the SCIL backend
1047 -- (because Build_Get_Prim_Op_Address generates an unchecked type
1048 -- conversion which relocates the controlling tag node).
1050 if Generate_SCIL
then
1051 SCIL_Node
:= Make_SCIL_Dispatching_Call
(Sloc
(Call_Node
));
1052 Set_SCIL_Entity
(SCIL_Node
, Typ
);
1053 Set_SCIL_Target_Prim
(SCIL_Node
, Subp
);
1055 -- Common case: the controlling tag is the tag of an object
1056 -- (for example, obj.tag)
1058 if Nkind
(Controlling_Tag
) = N_Selected_Component
then
1059 Set_SCIL_Controlling_Tag
(SCIL_Node
, Controlling_Tag
);
1061 -- Handle renaming of selected component
1063 elsif Nkind
(Controlling_Tag
) = N_Identifier
1064 and then Nkind
(Parent
(Entity
(Controlling_Tag
))) =
1065 N_Object_Renaming_Declaration
1066 and then Nkind
(Name
(Parent
(Entity
(Controlling_Tag
)))) =
1067 N_Selected_Component
1069 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1070 Name
(Parent
(Entity
(Controlling_Tag
))));
1072 -- If the controlling tag is an identifier, the SCIL node references
1073 -- the corresponding object or parameter declaration
1075 elsif Nkind
(Controlling_Tag
) = N_Identifier
1076 and then Nkind_In
(Parent
(Entity
(Controlling_Tag
)),
1077 N_Object_Declaration
,
1078 N_Parameter_Specification
)
1080 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1081 Parent
(Entity
(Controlling_Tag
)));
1083 -- If the controlling tag is a dereference, the SCIL node references
1084 -- the corresponding object or parameter declaration
1086 elsif Nkind
(Controlling_Tag
) = N_Explicit_Dereference
1087 and then Nkind
(Prefix
(Controlling_Tag
)) = N_Identifier
1088 and then Nkind_In
(Parent
(Entity
(Prefix
(Controlling_Tag
))),
1089 N_Object_Declaration
,
1090 N_Parameter_Specification
)
1092 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1093 Parent
(Entity
(Prefix
(Controlling_Tag
))));
1095 -- For a direct reference of the tag of the type the SCIL node
1096 -- references the internal object declaration containing the tag
1099 elsif Nkind
(Controlling_Tag
) = N_Attribute_Reference
1100 and then Attribute_Name
(Controlling_Tag
) = Name_Tag
1102 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1106 (Access_Disp_Table
(Entity
(Prefix
(Controlling_Tag
)))))));
1108 -- Interfaces are not supported. For now we leave the SCIL node
1109 -- decorated with the Controlling_Tag. More work needed here???
1111 elsif Is_Interface
(Etype
(Controlling_Tag
)) then
1112 Set_SCIL_Controlling_Tag
(SCIL_Node
, Controlling_Tag
);
1115 pragma Assert
(False);
1120 if Nkind
(Call_Node
) = N_Function_Call
then
1122 Make_Function_Call
(Loc
,
1123 Name
=> New_Call_Name
,
1124 Parameter_Associations
=> New_Params
);
1126 -- If this is a dispatching "=", we must first compare the tags so
1127 -- we generate: x.tag = y.tag and then x = y
1129 if Subp
= Eq_Prim_Op
then
1130 Param
:= First_Actual
(Call_Node
);
1136 Make_Selected_Component
(Loc
,
1137 Prefix
=> New_Value
(Param
),
1139 New_Occurrence_Of
(First_Tag_Component
(Typ
),
1143 Make_Selected_Component
(Loc
,
1145 Unchecked_Convert_To
(Typ
,
1146 New_Value
(Next_Actual
(Param
))),
1149 (First_Tag_Component
(Typ
), Loc
))),
1150 Right_Opnd
=> New_Call
);
1152 SCIL_Related_Node
:= Right_Opnd
(New_Call
);
1157 Make_Procedure_Call_Statement
(Loc
,
1158 Name
=> New_Call_Name
,
1159 Parameter_Associations
=> New_Params
);
1162 -- Register the dispatching call in the call graph nodes table
1164 Register_CG_Node
(Call_Node
);
1166 Rewrite
(Call_Node
, New_Call
);
1168 -- Associate the SCIL node of this dispatching call
1170 if Generate_SCIL
then
1171 Set_SCIL_Node
(SCIL_Related_Node
, SCIL_Node
);
1174 -- Suppress all checks during the analysis of the expanded code to avoid
1175 -- the generation of spurious warnings under ZFP run-time.
1177 Analyze_And_Resolve
(Call_Node
, Call_Typ
, Suppress
=> All_Checks
);
1178 end Expand_Dispatching_Call
;
1180 ---------------------------------
1181 -- Expand_Interface_Conversion --
1182 ---------------------------------
1184 procedure Expand_Interface_Conversion
(N
: Node_Id
) is
1185 function Underlying_Record_Type
(Typ
: Entity_Id
) return Entity_Id
;
1186 -- Return the underlying record type of Typ.
1188 ----------------------------
1189 -- Underlying_Record_Type --
1190 ----------------------------
1192 function Underlying_Record_Type
(Typ
: Entity_Id
) return Entity_Id
is
1193 E
: Entity_Id
:= Typ
;
1196 -- Handle access to class-wide interface types
1198 if Is_Access_Type
(E
) then
1199 E
:= Etype
(Directly_Designated_Type
(E
));
1202 -- Handle class-wide types. This conversion can appear explicitly in
1203 -- the source code. Example: I'Class (Obj)
1205 if Is_Class_Wide_Type
(E
) then
1209 -- If the target type is a tagged synchronized type, the dispatch
1210 -- table info is in the corresponding record type.
1212 if Is_Concurrent_Type
(E
) then
1213 E
:= Corresponding_Record_Type
(E
);
1216 -- Handle private types
1218 E
:= Underlying_Type
(E
);
1222 return Base_Type
(E
);
1223 end Underlying_Record_Type
;
1227 Loc
: constant Source_Ptr
:= Sloc
(N
);
1228 Etyp
: constant Entity_Id
:= Etype
(N
);
1229 Operand
: constant Node_Id
:= Expression
(N
);
1230 Operand_Typ
: Entity_Id
:= Etype
(Operand
);
1232 Iface_Typ
: constant Entity_Id
:= Underlying_Record_Type
(Etype
(N
));
1233 Iface_Tag
: Entity_Id
;
1234 Is_Static
: Boolean;
1236 -- Start of processing for Expand_Interface_Conversion
1239 -- Freeze the entity associated with the target interface to have
1240 -- available the attribute Access_Disp_Table.
1242 Freeze_Before
(N
, Iface_Typ
);
1244 -- Ada 2005 (AI-345): Handle synchronized interface type derivations
1246 if Is_Concurrent_Type
(Operand_Typ
) then
1247 Operand_Typ
:= Base_Type
(Corresponding_Record_Type
(Operand_Typ
));
1250 -- No displacement of the pointer to the object needed when the type of
1251 -- the operand is not an interface type and the interface is one of
1252 -- its parent types (since they share the primary dispatch table).
1255 Opnd
: Entity_Id
:= Operand_Typ
;
1258 if Is_Access_Type
(Opnd
) then
1259 Opnd
:= Designated_Type
(Opnd
);
1262 if not Is_Interface
(Opnd
)
1263 and then Is_Ancestor
(Iface_Typ
, Opnd
, Use_Full_View
=> True)
1269 -- Evaluate if we can statically displace the pointer to the object
1272 Opnd_Typ
: constant Node_Id
:= Underlying_Record_Type
(Operand_Typ
);
1276 not Is_Interface
(Opnd_Typ
)
1277 and then Interface_Present_In_Ancestor
1280 and then (Etype
(Opnd_Typ
) = Opnd_Typ
1282 Is_Variable_Size_Record
(Etype
(Opnd_Typ
)));
1285 if not Tagged_Type_Expansion
then
1288 -- A static conversion to an interface type that is not class-wide is
1289 -- curious but legal if the interface operation is a null procedure.
1290 -- If the operation is abstract it will be rejected later.
1293 and then Is_Interface
(Etype
(N
))
1294 and then not Is_Class_Wide_Type
(Etype
(N
))
1295 and then Comes_From_Source
(N
)
1297 Rewrite
(N
, Unchecked_Convert_To
(Etype
(N
), N
));
1302 if not Is_Static
then
1304 -- Give error if configurable run-time and Displace not available
1306 if not RTE_Available
(RE_Displace
) then
1307 Error_Msg_CRT
("dynamic interface conversion", N
);
1311 -- Handle conversion of access-to-class-wide interface types. Target
1312 -- can be an access to an object or an access to another class-wide
1313 -- interface (see -1- and -2- in the following example):
1315 -- type Iface1_Ref is access all Iface1'Class;
1316 -- type Iface2_Ref is access all Iface1'Class;
1318 -- Acc1 : Iface1_Ref := new ...
1319 -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1
1320 -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
1322 if Is_Access_Type
(Operand_Typ
) then
1324 Unchecked_Convert_To
(Etype
(N
),
1325 Make_Function_Call
(Loc
,
1326 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
1327 Parameter_Associations
=> New_List
(
1329 Unchecked_Convert_To
(RTE
(RE_Address
),
1330 Relocate_Node
(Expression
(N
))),
1333 (Node
(First_Elmt
(Access_Disp_Table
(Iface_Typ
))),
1341 Make_Function_Call
(Loc
,
1342 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
1343 Parameter_Associations
=> New_List
(
1344 Make_Attribute_Reference
(Loc
,
1345 Prefix
=> Relocate_Node
(Expression
(N
)),
1346 Attribute_Name
=> Name_Address
),
1349 (Node
(First_Elmt
(Access_Disp_Table
(Iface_Typ
))),
1354 -- If target is a class-wide interface, change the type of the data
1355 -- returned by IW_Convert to indicate this is a dispatching call.
1358 New_Itype
: Entity_Id
;
1361 New_Itype
:= Create_Itype
(E_Anonymous_Access_Type
, N
);
1362 Set_Etype
(New_Itype
, New_Itype
);
1363 Set_Directly_Designated_Type
(New_Itype
, Etyp
);
1366 Make_Explicit_Dereference
(Loc
,
1368 Unchecked_Convert_To
(New_Itype
, Relocate_Node
(N
))));
1370 Freeze_Itype
(New_Itype
, N
);
1376 Iface_Tag
:= Find_Interface_Tag
(Operand_Typ
, Iface_Typ
);
1377 pragma Assert
(Iface_Tag
/= Empty
);
1379 -- Keep separate access types to interfaces because one internal
1380 -- function is used to handle the null value (see following comments)
1382 if not Is_Access_Type
(Etype
(N
)) then
1384 -- Statically displace the pointer to the object to reference the
1385 -- component containing the secondary dispatch table.
1388 Convert_Tag_To_Interface
(Class_Wide_Type
(Iface_Typ
),
1389 Make_Selected_Component
(Loc
,
1390 Prefix
=> Relocate_Node
(Expression
(N
)),
1391 Selector_Name
=> New_Occurrence_Of
(Iface_Tag
, Loc
))));
1394 -- Build internal function to handle the case in which the actual is
1395 -- null. If the actual is null returns null because no displacement
1396 -- is required; otherwise performs a type conversion that will be
1397 -- expanded in the code that returns the value of the displaced
1400 -- function Func (O : Address) return Iface_Typ is
1401 -- type Op_Typ is access all Operand_Typ;
1402 -- Aux : Op_Typ := To_Op_Typ (O);
1404 -- if O = Null_Address then
1407 -- return Iface_Typ!(Aux.Iface_Tag'Address);
1412 Desig_Typ
: Entity_Id
;
1414 New_Typ_Decl
: Node_Id
;
1418 Desig_Typ
:= Etype
(Expression
(N
));
1420 if Is_Access_Type
(Desig_Typ
) then
1422 Available_View
(Directly_Designated_Type
(Desig_Typ
));
1425 if Is_Concurrent_Type
(Desig_Typ
) then
1426 Desig_Typ
:= Base_Type
(Corresponding_Record_Type
(Desig_Typ
));
1430 Make_Full_Type_Declaration
(Loc
,
1431 Defining_Identifier
=> Make_Temporary
(Loc
, 'T'),
1433 Make_Access_To_Object_Definition
(Loc
,
1434 All_Present
=> True,
1435 Null_Exclusion_Present
=> False,
1436 Constant_Present
=> False,
1437 Subtype_Indication
=>
1438 New_Occurrence_Of
(Desig_Typ
, Loc
)));
1441 Make_Simple_Return_Statement
(Loc
,
1442 Unchecked_Convert_To
(Etype
(N
),
1443 Make_Attribute_Reference
(Loc
,
1445 Make_Selected_Component
(Loc
,
1447 Unchecked_Convert_To
1448 (Defining_Identifier
(New_Typ_Decl
),
1449 Make_Identifier
(Loc
, Name_uO
)),
1451 New_Occurrence_Of
(Iface_Tag
, Loc
)),
1452 Attribute_Name
=> Name_Address
))));
1454 -- If the type is null-excluding, no need for the null branch.
1455 -- Otherwise we need to check for it and return null.
1457 if not Can_Never_Be_Null
(Etype
(N
)) then
1459 Make_If_Statement
(Loc
,
1462 Left_Opnd
=> Make_Identifier
(Loc
, Name_uO
),
1463 Right_Opnd
=> New_Occurrence_Of
1464 (RTE
(RE_Null_Address
), Loc
)),
1466 Then_Statements
=> New_List
(
1467 Make_Simple_Return_Statement
(Loc
, Make_Null
(Loc
))),
1468 Else_Statements
=> Stats
));
1471 Fent
:= Make_Temporary
(Loc
, 'F');
1473 Make_Subprogram_Body
(Loc
,
1475 Make_Function_Specification
(Loc
,
1476 Defining_Unit_Name
=> Fent
,
1478 Parameter_Specifications
=> New_List
(
1479 Make_Parameter_Specification
(Loc
,
1480 Defining_Identifier
=>
1481 Make_Defining_Identifier
(Loc
, Name_uO
),
1483 New_Occurrence_Of
(RTE
(RE_Address
), Loc
))),
1485 Result_Definition
=>
1486 New_Occurrence_Of
(Etype
(N
), Loc
)),
1488 Declarations
=> New_List
(New_Typ_Decl
),
1490 Handled_Statement_Sequence
=>
1491 Make_Handled_Sequence_Of_Statements
(Loc
, Stats
));
1493 -- Place function body before the expression containing the
1494 -- conversion. We suppress all checks because the body of the
1495 -- internally generated function already takes care of the case
1496 -- in which the actual is null; therefore there is no need to
1497 -- double check that the pointer is not null when the program
1498 -- executes the alternative that performs the type conversion).
1500 Insert_Action
(N
, Func
, Suppress
=> All_Checks
);
1502 if Is_Access_Type
(Etype
(Expression
(N
))) then
1504 Apply_Accessibility_Check
1505 (N
=> Expression
(N
),
1509 -- Generate: Func (Address!(Expression))
1512 Make_Function_Call
(Loc
,
1513 Name
=> New_Occurrence_Of
(Fent
, Loc
),
1514 Parameter_Associations
=> New_List
(
1515 Unchecked_Convert_To
(RTE
(RE_Address
),
1516 Relocate_Node
(Expression
(N
))))));
1519 -- Generate: Func (Operand_Typ!(Expression)'Address)
1522 Make_Function_Call
(Loc
,
1523 Name
=> New_Occurrence_Of
(Fent
, Loc
),
1524 Parameter_Associations
=> New_List
(
1525 Make_Attribute_Reference
(Loc
,
1526 Prefix
=> Unchecked_Convert_To
(Operand_Typ
,
1527 Relocate_Node
(Expression
(N
))),
1528 Attribute_Name
=> Name_Address
))));
1534 end Expand_Interface_Conversion
;
1536 ------------------------------
1537 -- Expand_Interface_Actuals --
1538 ------------------------------
1540 procedure Expand_Interface_Actuals
(Call_Node
: Node_Id
) is
1542 Actual_Dup
: Node_Id
;
1543 Actual_Typ
: Entity_Id
;
1545 Conversion
: Node_Id
;
1547 Formal_Typ
: Entity_Id
;
1549 Formal_DDT
: Entity_Id
:= Empty
; -- initialize to prevent warning
1550 Actual_DDT
: Entity_Id
:= Empty
; -- initialize to prevent warning
1553 -- This subprogram is called directly from the semantics, so we need a
1554 -- check to see whether expansion is active before proceeding.
1556 if not Expander_Active
then
1560 -- Call using access to subprogram with explicit dereference
1562 if Nkind
(Name
(Call_Node
)) = N_Explicit_Dereference
then
1563 Subp
:= Etype
(Name
(Call_Node
));
1565 -- Call using selected component
1567 elsif Nkind
(Name
(Call_Node
)) = N_Selected_Component
then
1568 Subp
:= Entity
(Selector_Name
(Name
(Call_Node
)));
1570 -- Call using direct name
1573 Subp
:= Entity
(Name
(Call_Node
));
1576 -- Ada 2005 (AI-251): Look for interface type formals to force "this"
1579 Formal
:= First_Formal
(Subp
);
1580 Actual
:= First_Actual
(Call_Node
);
1581 while Present
(Formal
) loop
1582 Formal_Typ
:= Etype
(Formal
);
1584 if Ekind
(Formal_Typ
) = E_Record_Type_With_Private
then
1585 Formal_Typ
:= Full_View
(Formal_Typ
);
1588 if Is_Access_Type
(Formal_Typ
) then
1589 Formal_DDT
:= Directly_Designated_Type
(Formal_Typ
);
1592 Actual_Typ
:= Etype
(Actual
);
1594 if Is_Access_Type
(Actual_Typ
) then
1595 Actual_DDT
:= Directly_Designated_Type
(Actual_Typ
);
1598 if Is_Interface
(Formal_Typ
)
1599 and then Is_Class_Wide_Type
(Formal_Typ
)
1601 -- No need to displace the pointer if the type of the actual
1602 -- coincides with the type of the formal.
1604 if Actual_Typ
= Formal_Typ
then
1607 -- No need to displace the pointer if the interface type is a
1608 -- parent of the type of the actual because in this case the
1609 -- interface primitives are located in the primary dispatch table.
1611 elsif Is_Ancestor
(Formal_Typ
, Actual_Typ
,
1612 Use_Full_View
=> True)
1616 -- Implicit conversion to the class-wide formal type to force the
1617 -- displacement of the pointer.
1620 -- Normally, expansion of actuals for calls to build-in-place
1621 -- functions happens as part of Expand_Actuals, but in this
1622 -- case the call will be wrapped in a conversion and soon after
1623 -- expanded further to handle the displacement for a class-wide
1624 -- interface conversion, so if this is a BIP call then we need
1625 -- to handle it now.
1627 if Ada_Version
>= Ada_2005
1628 and then Is_Build_In_Place_Function_Call
(Actual
)
1630 Make_Build_In_Place_Call_In_Anonymous_Context
(Actual
);
1633 Conversion
:= Convert_To
(Formal_Typ
, Relocate_Node
(Actual
));
1634 Rewrite
(Actual
, Conversion
);
1635 Analyze_And_Resolve
(Actual
, Formal_Typ
);
1638 -- Access to class-wide interface type
1640 elsif Is_Access_Type
(Formal_Typ
)
1641 and then Is_Interface
(Formal_DDT
)
1642 and then Is_Class_Wide_Type
(Formal_DDT
)
1643 and then Interface_Present_In_Ancestor
1645 Iface
=> Etype
(Formal_DDT
))
1647 -- Handle attributes 'Access and 'Unchecked_Access
1649 if Nkind
(Actual
) = N_Attribute_Reference
1651 (Attribute_Name
(Actual
) = Name_Access
1652 or else Attribute_Name
(Actual
) = Name_Unchecked_Access
)
1654 -- This case must have been handled by the analysis and
1655 -- expansion of 'Access. The only exception is when types
1656 -- match and no further expansion is required.
1658 pragma Assert
(Base_Type
(Etype
(Prefix
(Actual
)))
1659 = Base_Type
(Formal_DDT
));
1662 -- No need to displace the pointer if the type of the actual
1663 -- coincides with the type of the formal.
1665 elsif Actual_DDT
= Formal_DDT
then
1668 -- No need to displace the pointer if the interface type is
1669 -- a parent of the type of the actual because in this case the
1670 -- interface primitives are located in the primary dispatch table.
1672 elsif Is_Ancestor
(Formal_DDT
, Actual_DDT
,
1673 Use_Full_View
=> True)
1678 Actual_Dup
:= Relocate_Node
(Actual
);
1680 if From_Limited_With
(Actual_Typ
) then
1682 -- If the type of the actual parameter comes from a
1683 -- limited with-clause and the non-limited view is already
1684 -- available, we replace the anonymous access type by
1685 -- a duplicate declaration whose designated type is the
1686 -- non-limited view.
1688 if Has_Non_Limited_View
(Actual_DDT
) then
1689 Anon
:= New_Copy
(Actual_Typ
);
1691 if Is_Itype
(Anon
) then
1692 Set_Scope
(Anon
, Current_Scope
);
1695 Set_Directly_Designated_Type
1696 (Anon
, Non_Limited_View
(Actual_DDT
));
1697 Set_Etype
(Actual_Dup
, Anon
);
1701 Conversion
:= Convert_To
(Formal_Typ
, Actual_Dup
);
1702 Rewrite
(Actual
, Conversion
);
1703 Analyze_And_Resolve
(Actual
, Formal_Typ
);
1707 Next_Actual
(Actual
);
1708 Next_Formal
(Formal
);
1710 end Expand_Interface_Actuals
;
1712 ----------------------------
1713 -- Expand_Interface_Thunk --
1714 ----------------------------
1716 procedure Expand_Interface_Thunk
1718 Thunk_Id
: out Entity_Id
;
1719 Thunk_Code
: out Node_Id
)
1721 Loc
: constant Source_Ptr
:= Sloc
(Prim
);
1722 Actuals
: constant List_Id
:= New_List
;
1723 Decl
: constant List_Id
:= New_List
;
1724 Formals
: constant List_Id
:= New_List
;
1725 Target
: constant Entity_Id
:= Ultimate_Alias
(Prim
);
1732 Iface_Formal
: Node_Id
:= Empty
; -- initialize to prevent warning
1734 Offset_To_Top
: Node_Id
;
1735 Target_Formal
: Entity_Id
;
1739 Thunk_Code
:= Empty
;
1741 -- No thunk needed if the primitive has been eliminated
1743 if Is_Eliminated
(Ultimate_Alias
(Prim
)) then
1746 -- In case of primitives that are functions without formals and a
1747 -- controlling result there is no need to build the thunk.
1749 elsif not Present
(First_Formal
(Target
)) then
1750 pragma Assert
(Ekind
(Target
) = E_Function
1751 and then Has_Controlling_Result
(Target
));
1755 -- Duplicate the formals of the Target primitive. In the thunk, the type
1756 -- of the controlling formal is the covered interface type (instead of
1757 -- the target tagged type). Done to avoid problems with discriminated
1758 -- tagged types because, if the controlling type has discriminants with
1759 -- default values, then the type conversions done inside the body of
1760 -- the thunk (after the displacement of the pointer to the base of the
1761 -- actual object) generate code that modify its contents.
1763 -- Note: This special management is not done for predefined primitives
1766 if not Is_Predefined_Dispatching_Operation
(Prim
) then
1767 Iface_Formal
:= First_Formal
(Interface_Alias
(Prim
));
1770 Formal
:= First_Formal
(Target
);
1771 while Present
(Formal
) loop
1772 Ftyp
:= Etype
(Formal
);
1774 -- Use the interface type as the type of the controlling formal (see
1777 if not Is_Controlling_Formal
(Formal
)
1778 or else Is_Predefined_Dispatching_Operation
(Prim
)
1780 Ftyp
:= Etype
(Formal
);
1781 Expr
:= New_Copy_Tree
(Expression
(Parent
(Formal
)));
1783 Ftyp
:= Etype
(Iface_Formal
);
1788 Make_Parameter_Specification
(Loc
,
1789 Defining_Identifier
=>
1790 Make_Defining_Identifier
(Sloc
(Formal
),
1791 Chars
=> Chars
(Formal
)),
1792 In_Present
=> In_Present
(Parent
(Formal
)),
1793 Out_Present
=> Out_Present
(Parent
(Formal
)),
1794 Parameter_Type
=> New_Occurrence_Of
(Ftyp
, Loc
),
1795 Expression
=> Expr
));
1797 if not Is_Predefined_Dispatching_Operation
(Prim
) then
1798 Next_Formal
(Iface_Formal
);
1801 Next_Formal
(Formal
);
1804 Target_Formal
:= First_Formal
(Target
);
1805 Formal
:= First
(Formals
);
1806 while Present
(Formal
) loop
1808 -- If the parent is a constrained discriminated type, then the
1809 -- primitive operation will have been defined on a first subtype.
1810 -- For proper matching with controlling type, use base type.
1812 if Ekind
(Target_Formal
) = E_In_Parameter
1813 and then Ekind
(Etype
(Target_Formal
)) = E_Anonymous_Access_Type
1816 Base_Type
(Directly_Designated_Type
(Etype
(Target_Formal
)));
1818 Ftyp
:= Base_Type
(Etype
(Target_Formal
));
1821 -- For concurrent types, the relevant information is found in the
1822 -- Corresponding_Record_Type, rather than the type entity itself.
1824 if Is_Concurrent_Type
(Ftyp
) then
1825 Ftyp
:= Corresponding_Record_Type
(Ftyp
);
1828 if Ekind
(Target_Formal
) = E_In_Parameter
1829 and then Ekind
(Etype
(Target_Formal
)) = E_Anonymous_Access_Type
1830 and then Is_Controlling_Formal
(Target_Formal
)
1833 -- type T is access all <<type of the target formal>>
1834 -- S : Storage_Offset := Storage_Offset!(Formal)
1835 -- - Offset_To_Top (address!(Formal))
1838 Make_Full_Type_Declaration
(Loc
,
1839 Defining_Identifier
=> Make_Temporary
(Loc
, 'T'),
1841 Make_Access_To_Object_Definition
(Loc
,
1842 All_Present
=> True,
1843 Null_Exclusion_Present
=> False,
1844 Constant_Present
=> False,
1845 Subtype_Indication
=>
1846 New_Occurrence_Of
(Ftyp
, Loc
)));
1849 Unchecked_Convert_To
(RTE
(RE_Address
),
1850 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
1852 if not RTE_Available
(RE_Offset_To_Top
) then
1854 Build_Offset_To_Top
(Loc
, New_Arg
);
1857 Make_Function_Call
(Loc
,
1858 Name
=> New_Occurrence_Of
(RTE
(RE_Offset_To_Top
), Loc
),
1859 Parameter_Associations
=> New_List
(New_Arg
));
1863 Make_Object_Declaration
(Loc
,
1864 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
1865 Constant_Present
=> True,
1866 Object_Definition
=>
1867 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
1869 Make_Op_Subtract
(Loc
,
1871 Unchecked_Convert_To
1872 (RTE
(RE_Storage_Offset
),
1874 (Defining_Identifier
(Formal
), Loc
)),
1878 Append_To
(Decl
, Decl_2
);
1879 Append_To
(Decl
, Decl_1
);
1881 -- Reference the new actual. Generate:
1885 Unchecked_Convert_To
1886 (Defining_Identifier
(Decl_2
),
1887 New_Occurrence_Of
(Defining_Identifier
(Decl_1
), Loc
)));
1889 elsif Is_Controlling_Formal
(Target_Formal
) then
1892 -- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
1893 -- - Offset_To_Top (Formal'Address)
1894 -- S2 : Addr_Ptr := Addr_Ptr!(S1)
1897 Make_Attribute_Reference
(Loc
,
1899 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
),
1903 if not RTE_Available
(RE_Offset_To_Top
) then
1905 Build_Offset_To_Top
(Loc
, New_Arg
);
1908 Make_Function_Call
(Loc
,
1909 Name
=> New_Occurrence_Of
(RTE
(RE_Offset_To_Top
), Loc
),
1910 Parameter_Associations
=> New_List
(New_Arg
));
1914 Make_Object_Declaration
(Loc
,
1915 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
1916 Constant_Present
=> True,
1917 Object_Definition
=>
1918 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
1920 Make_Op_Subtract
(Loc
,
1922 Unchecked_Convert_To
1923 (RTE
(RE_Storage_Offset
),
1924 Make_Attribute_Reference
(Loc
,
1927 (Defining_Identifier
(Formal
), Loc
),
1928 Attribute_Name
=> Name_Address
)),
1933 Make_Object_Declaration
(Loc
,
1934 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
1935 Constant_Present
=> True,
1936 Object_Definition
=>
1937 New_Occurrence_Of
(RTE
(RE_Addr_Ptr
), Loc
),
1939 Unchecked_Convert_To
1941 New_Occurrence_Of
(Defining_Identifier
(Decl_1
), Loc
)));
1943 Append_To
(Decl
, Decl_1
);
1944 Append_To
(Decl
, Decl_2
);
1946 -- Reference the new actual, generate:
1947 -- Target_Formal (S2.all)
1950 Unchecked_Convert_To
(Ftyp
,
1951 Make_Explicit_Dereference
(Loc
,
1952 New_Occurrence_Of
(Defining_Identifier
(Decl_2
), Loc
))));
1954 -- Ensure proper matching of access types. Required to avoid
1955 -- reporting spurious errors.
1957 elsif Is_Access_Type
(Etype
(Target_Formal
)) then
1959 Unchecked_Convert_To
(Base_Type
(Etype
(Target_Formal
)),
1960 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
)));
1962 -- No special management required for this actual
1966 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
1969 Next_Formal
(Target_Formal
);
1973 Thunk_Id
:= Make_Temporary
(Loc
, 'T');
1974 Set_Ekind
(Thunk_Id
, Ekind
(Prim
));
1975 Set_Is_Thunk
(Thunk_Id
);
1976 Set_Convention
(Thunk_Id
, Convention
(Prim
));
1977 Set_Thunk_Entity
(Thunk_Id
, Target
);
1981 if Ekind
(Target
) = E_Procedure
then
1983 Make_Subprogram_Body
(Loc
,
1985 Make_Procedure_Specification
(Loc
,
1986 Defining_Unit_Name
=> Thunk_Id
,
1987 Parameter_Specifications
=> Formals
),
1988 Declarations
=> Decl
,
1989 Handled_Statement_Sequence
=>
1990 Make_Handled_Sequence_Of_Statements
(Loc
,
1991 Statements
=> New_List
(
1992 Make_Procedure_Call_Statement
(Loc
,
1993 Name
=> New_Occurrence_Of
(Target
, Loc
),
1994 Parameter_Associations
=> Actuals
))));
1998 else pragma Assert
(Ekind
(Target
) = E_Function
);
2000 Result_Def
: Node_Id
;
2001 Call_Node
: Node_Id
;
2005 Make_Function_Call
(Loc
,
2006 Name
=> New_Occurrence_Of
(Target
, Loc
),
2007 Parameter_Associations
=> Actuals
);
2009 if not Is_Interface
(Etype
(Prim
)) then
2010 Result_Def
:= New_Copy
(Result_Definition
(Parent
(Target
)));
2012 -- Thunk of function returning a class-wide interface object. No
2013 -- extra displacement needed since the displacement is generated
2014 -- in the return statement of Prim. Example:
2016 -- type Iface is interface ...
2017 -- function F (O : Iface) return Iface'Class;
2019 -- type T is new ... and Iface with ...
2020 -- function F (O : T) return Iface'Class;
2022 elsif Is_Class_Wide_Type
(Etype
(Prim
)) then
2023 Result_Def
:= New_Occurrence_Of
(Etype
(Prim
), Loc
);
2025 -- Thunk of function returning an interface object. Displacement
2028 -- type Iface is interface ...
2029 -- function F (O : Iface) return Iface;
2031 -- type T is new ... and Iface with ...
2032 -- function F (O : T) return T;
2036 New_Occurrence_Of
(Class_Wide_Type
(Etype
(Prim
)), Loc
);
2038 -- Adding implicit conversion to force the displacement of
2039 -- the pointer to the object to reference the corresponding
2040 -- secondary dispatch table.
2043 Make_Type_Conversion
(Loc
,
2045 New_Occurrence_Of
(Class_Wide_Type
(Etype
(Prim
)), Loc
),
2046 Expression
=> Relocate_Node
(Call_Node
));
2050 Make_Subprogram_Body
(Loc
,
2052 Make_Function_Specification
(Loc
,
2053 Defining_Unit_Name
=> Thunk_Id
,
2054 Parameter_Specifications
=> Formals
,
2055 Result_Definition
=> Result_Def
),
2056 Declarations
=> Decl
,
2057 Handled_Statement_Sequence
=>
2058 Make_Handled_Sequence_Of_Statements
(Loc
,
2059 Statements
=> New_List
(
2060 Make_Simple_Return_Statement
(Loc
, Call_Node
))));
2063 end Expand_Interface_Thunk
;
2065 --------------------------
2066 -- Has_CPP_Constructors --
2067 --------------------------
2069 function Has_CPP_Constructors
(Typ
: Entity_Id
) return Boolean is
2073 -- Look for the constructor entities
2075 E
:= Next_Entity
(Typ
);
2076 while Present
(E
) loop
2077 if Ekind
(E
) = E_Function
and then Is_Constructor
(E
) then
2085 end Has_CPP_Constructors
;
2091 function Has_DT
(Typ
: Entity_Id
) return Boolean is
2093 return not Is_Interface
(Typ
)
2094 and then not Restriction_Active
(No_Dispatching_Calls
);
2097 ----------------------------------
2098 -- Is_Expanded_Dispatching_Call --
2099 ----------------------------------
2101 function Is_Expanded_Dispatching_Call
(N
: Node_Id
) return Boolean is
2103 return Nkind
(N
) in N_Subprogram_Call
2104 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
2105 and then Is_Dispatch_Table_Entity
(Etype
(Name
(N
)));
2106 end Is_Expanded_Dispatching_Call
;
2108 -----------------------------------------
2109 -- Is_Predefined_Dispatching_Operation --
2110 -----------------------------------------
2112 function Is_Predefined_Dispatching_Operation
2113 (E
: Entity_Id
) return Boolean
2115 TSS_Name
: TSS_Name_Type
;
2118 if not Is_Dispatching_Operation
(E
) then
2122 Get_Name_String
(Chars
(E
));
2124 -- Most predefined primitives have internally generated names. Equality
2125 -- must be treated differently; the predefined operation is recognized
2126 -- as a homogeneous binary operator that returns Boolean.
2128 if Name_Len
> TSS_Name_Type
'Last then
2129 TSS_Name
:= TSS_Name_Type
(Name_Buffer
(Name_Len
- TSS_Name
'Length + 1
2131 if Chars
(E
) = Name_uSize
2132 or else TSS_Name
= TSS_Stream_Read
2133 or else TSS_Name
= TSS_Stream_Write
2134 or else TSS_Name
= TSS_Stream_Input
2135 or else TSS_Name
= TSS_Stream_Output
2137 (Chars
(E
) = Name_Op_Eq
2138 and then Etype
(First_Formal
(E
)) = Etype
(Last_Formal
(E
)))
2139 or else Chars
(E
) = Name_uAssign
2140 or else TSS_Name
= TSS_Deep_Adjust
2141 or else TSS_Name
= TSS_Deep_Finalize
2142 or else Is_Predefined_Interface_Primitive
(E
)
2149 end Is_Predefined_Dispatching_Operation
;
2151 ---------------------------------------
2152 -- Is_Predefined_Internal_Operation --
2153 ---------------------------------------
2155 function Is_Predefined_Internal_Operation
2156 (E
: Entity_Id
) return Boolean
2158 TSS_Name
: TSS_Name_Type
;
2161 if not Is_Dispatching_Operation
(E
) then
2165 Get_Name_String
(Chars
(E
));
2167 -- Most predefined primitives have internally generated names. Equality
2168 -- must be treated differently; the predefined operation is recognized
2169 -- as a homogeneous binary operator that returns Boolean.
2171 if Name_Len
> TSS_Name_Type
'Last then
2174 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
2176 if Nam_In
(Chars
(E
), Name_uSize
, Name_uAssign
)
2178 (Chars
(E
) = Name_Op_Eq
2179 and then Etype
(First_Formal
(E
)) = Etype
(Last_Formal
(E
)))
2180 or else TSS_Name
= TSS_Deep_Adjust
2181 or else TSS_Name
= TSS_Deep_Finalize
2182 or else Is_Predefined_Interface_Primitive
(E
)
2189 end Is_Predefined_Internal_Operation
;
2191 -------------------------------------
2192 -- Is_Predefined_Dispatching_Alias --
2193 -------------------------------------
2195 function Is_Predefined_Dispatching_Alias
(Prim
: Entity_Id
) return Boolean
2198 return not Is_Predefined_Dispatching_Operation
(Prim
)
2199 and then Present
(Alias
(Prim
))
2200 and then Is_Predefined_Dispatching_Operation
(Ultimate_Alias
(Prim
));
2201 end Is_Predefined_Dispatching_Alias
;
2203 ---------------------------------------
2204 -- Is_Predefined_Interface_Primitive --
2205 ---------------------------------------
2207 function Is_Predefined_Interface_Primitive
(E
: Entity_Id
) return Boolean is
2209 -- In VM targets we don't restrict the functionality of this test to
2210 -- compiling in Ada 2005 mode since in VM targets any tagged type has
2211 -- these primitives.
2213 return (Ada_Version
>= Ada_2005
or else not Tagged_Type_Expansion
)
2214 and then Nam_In
(Chars
(E
), Name_uDisp_Asynchronous_Select
,
2215 Name_uDisp_Conditional_Select
,
2216 Name_uDisp_Get_Prim_Op_Kind
,
2217 Name_uDisp_Get_Task_Id
,
2219 Name_uDisp_Timed_Select
);
2220 end Is_Predefined_Interface_Primitive
;
2222 ----------------------------------------
2223 -- Make_Disp_Asynchronous_Select_Body --
2224 ----------------------------------------
2226 -- For interface types, generate:
2228 -- procedure _Disp_Asynchronous_Select
2229 -- (T : in out <Typ>;
2231 -- P : System.Address;
2232 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2237 -- C := Ada.Tags.POK_Function;
2238 -- end _Disp_Asynchronous_Select;
2240 -- For protected types, generate:
2242 -- procedure _Disp_Asynchronous_Select
2243 -- (T : in out <Typ>;
2245 -- P : System.Address;
2246 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2250 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2251 -- Bnn : System.Tasking.Protected_Objects.Operations.
2252 -- Communication_Block;
2254 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2255 -- (T._object'Access,
2256 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2258 -- System.Tasking.Asynchronous_Call,
2260 -- B := System.Storage_Elements.Dummy_Communication_Block (Bnn);
2261 -- end _Disp_Asynchronous_Select;
2263 -- For task types, generate:
2265 -- procedure _Disp_Asynchronous_Select
2266 -- (T : in out <Typ>;
2268 -- P : System.Address;
2269 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2273 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2275 -- System.Tasking.Rendezvous.Task_Entry_Call
2277 -- System.Tasking.Task_Entry_Index (I),
2279 -- System.Tasking.Asynchronous_Call,
2281 -- end _Disp_Asynchronous_Select;
2283 function Make_Disp_Asynchronous_Select_Body
2284 (Typ
: Entity_Id
) return Node_Id
2286 Com_Block
: Entity_Id
;
2287 Conc_Typ
: Entity_Id
:= Empty
;
2288 Decls
: constant List_Id
:= New_List
;
2289 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2291 Stmts
: constant List_Id
:= New_List
;
2295 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2297 -- Null body is generated for interface types
2299 if Is_Interface
(Typ
) then
2301 Make_Subprogram_Body
(Loc
,
2303 Make_Disp_Asynchronous_Select_Spec
(Typ
),
2304 Declarations
=> New_List
,
2305 Handled_Statement_Sequence
=>
2306 Make_Handled_Sequence_Of_Statements
(Loc
,
2308 Make_Assignment_Statement
(Loc
,
2309 Name
=> Make_Identifier
(Loc
, Name_uF
),
2310 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
2313 if Is_Concurrent_Record_Type
(Typ
) then
2314 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
2318 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2320 -- where I will be used to capture the entry index of the primitive
2321 -- wrapper at position S.
2323 if Tagged_Type_Expansion
then
2325 Unchecked_Convert_To
(RTE
(RE_Tag
),
2327 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
2330 Make_Attribute_Reference
(Loc
,
2331 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
2332 Attribute_Name
=> Name_Tag
);
2336 Make_Object_Declaration
(Loc
,
2337 Defining_Identifier
=>
2338 Make_Defining_Identifier
(Loc
, Name_uI
),
2339 Object_Definition
=>
2340 New_Occurrence_Of
(Standard_Integer
, Loc
),
2342 Make_Function_Call
(Loc
,
2344 New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
2345 Parameter_Associations
=>
2346 New_List
(Tag_Node
, Make_Identifier
(Loc
, Name_uS
)))));
2348 if Ekind
(Conc_Typ
) = E_Protected_Type
then
2351 -- Bnn : Communication_Block;
2353 Com_Block
:= Make_Temporary
(Loc
, 'B');
2355 Make_Object_Declaration
(Loc
,
2356 Defining_Identifier
=> Com_Block
,
2357 Object_Definition
=>
2358 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
2360 -- Build T._object'Access for calls below
2363 Make_Attribute_Reference
(Loc
,
2364 Attribute_Name
=> Name_Unchecked_Access
,
2366 Make_Selected_Component
(Loc
,
2367 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2368 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
2370 case Corresponding_Runtime_Package
(Conc_Typ
) is
2371 when System_Tasking_Protected_Objects_Entries
=>
2374 -- Protected_Entry_Call
2375 -- (T._object'Access, -- Object
2376 -- Protected_Entry_Index! (I), -- E
2377 -- P, -- Uninterpreted_Data
2378 -- Asynchronous_Call, -- Mode
2379 -- Bnn); -- Communication_Block
2381 -- where T is the protected object, I is the entry index, P
2382 -- is the wrapped parameters and B is the name of the
2383 -- communication block.
2386 Make_Procedure_Call_Statement
(Loc
,
2388 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
2389 Parameter_Associations
=>
2393 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2396 (RTE
(RE_Protected_Entry_Index
), Loc
),
2397 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2399 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2400 New_Occurrence_Of
-- Asynchronous_Call
2401 (RTE
(RE_Asynchronous_Call
), Loc
),
2402 New_Occurrence_Of
-- comm block
2403 (Com_Block
, Loc
))));
2406 raise Program_Error
;
2410 -- B := Dummy_Communication_Block (Bnn);
2413 Make_Assignment_Statement
(Loc
,
2414 Name
=> Make_Identifier
(Loc
, Name_uB
),
2416 Make_Unchecked_Type_Conversion
(Loc
,
2419 (RTE
(RE_Dummy_Communication_Block
), Loc
),
2420 Expression
=> New_Occurrence_Of
(Com_Block
, Loc
))));
2426 Make_Assignment_Statement
(Loc
,
2427 Name
=> Make_Identifier
(Loc
, Name_uF
),
2428 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
2431 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
2435 -- (T._task_id, -- Acceptor
2436 -- Task_Entry_Index! (I), -- E
2437 -- P, -- Uninterpreted_Data
2438 -- Asynchronous_Call, -- Mode
2439 -- F); -- Rendezvous_Successful
2441 -- where T is the task object, I is the entry index, P is the
2442 -- wrapped parameters and F is the status flag.
2445 Make_Procedure_Call_Statement
(Loc
,
2447 New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
2448 Parameter_Associations
=>
2450 Make_Selected_Component
(Loc
, -- T._task_id
2451 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2452 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
2454 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2456 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
2457 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2459 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2460 New_Occurrence_Of
-- Asynchronous_Call
2461 (RTE
(RE_Asynchronous_Call
), Loc
),
2462 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
2466 -- Ensure that the statements list is non-empty
2469 Make_Assignment_Statement
(Loc
,
2470 Name
=> Make_Identifier
(Loc
, Name_uF
),
2471 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
2475 Make_Subprogram_Body
(Loc
,
2477 Make_Disp_Asynchronous_Select_Spec
(Typ
),
2478 Declarations
=> Decls
,
2479 Handled_Statement_Sequence
=>
2480 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
2481 end Make_Disp_Asynchronous_Select_Body
;
2483 ----------------------------------------
2484 -- Make_Disp_Asynchronous_Select_Spec --
2485 ----------------------------------------
2487 function Make_Disp_Asynchronous_Select_Spec
2488 (Typ
: Entity_Id
) return Node_Id
2490 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2491 Def_Id
: constant Node_Id
:=
2492 Make_Defining_Identifier
(Loc
,
2493 Name_uDisp_Asynchronous_Select
);
2494 Params
: constant List_Id
:= New_List
;
2497 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2499 -- T : in out Typ; -- Object parameter
2500 -- S : Integer; -- Primitive operation slot
2501 -- P : Address; -- Wrapped parameters
2502 -- B : out Dummy_Communication_Block; -- Communication block dummy
2503 -- F : out Boolean; -- Status flag
2505 Append_List_To
(Params
, New_List
(
2507 Make_Parameter_Specification
(Loc
,
2508 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
2509 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
2511 Out_Present
=> True),
2513 Make_Parameter_Specification
(Loc
,
2514 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
2515 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
2517 Make_Parameter_Specification
(Loc
,
2518 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
2519 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2521 Make_Parameter_Specification
(Loc
,
2522 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uB
),
2524 New_Occurrence_Of
(RTE
(RE_Dummy_Communication_Block
), Loc
),
2525 Out_Present
=> True),
2527 Make_Parameter_Specification
(Loc
,
2528 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
2529 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
2530 Out_Present
=> True)));
2533 Make_Procedure_Specification
(Loc
,
2534 Defining_Unit_Name
=> Def_Id
,
2535 Parameter_Specifications
=> Params
);
2536 end Make_Disp_Asynchronous_Select_Spec
;
2538 ---------------------------------------
2539 -- Make_Disp_Conditional_Select_Body --
2540 ---------------------------------------
2542 -- For interface types, generate:
2544 -- procedure _Disp_Conditional_Select
2545 -- (T : in out <Typ>;
2547 -- P : System.Address;
2548 -- C : out Ada.Tags.Prim_Op_Kind;
2553 -- C := Ada.Tags.POK_Function;
2554 -- end _Disp_Conditional_Select;
2556 -- For protected types, generate:
2558 -- procedure _Disp_Conditional_Select
2559 -- (T : in out <Typ>;
2561 -- P : System.Address;
2562 -- C : out Ada.Tags.Prim_Op_Kind;
2566 -- Bnn : System.Tasking.Protected_Objects.Operations.
2567 -- Communication_Block;
2570 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S));
2572 -- if C = Ada.Tags.POK_Procedure
2573 -- or else C = Ada.Tags.POK_Protected_Procedure
2574 -- or else C = Ada.Tags.POK_Task_Procedure
2580 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2581 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2582 -- (T.object'Access,
2583 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2585 -- System.Tasking.Conditional_Call,
2587 -- F := not Cancelled (Bnn);
2588 -- end _Disp_Conditional_Select;
2590 -- For task types, generate:
2592 -- procedure _Disp_Conditional_Select
2593 -- (T : in out <Typ>;
2595 -- P : System.Address;
2596 -- C : out Ada.Tags.Prim_Op_Kind;
2602 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2603 -- System.Tasking.Rendezvous.Task_Entry_Call
2605 -- System.Tasking.Task_Entry_Index (I),
2607 -- System.Tasking.Conditional_Call,
2609 -- end _Disp_Conditional_Select;
2611 function Make_Disp_Conditional_Select_Body
2612 (Typ
: Entity_Id
) return Node_Id
2614 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2615 Blk_Nam
: Entity_Id
;
2616 Conc_Typ
: Entity_Id
:= Empty
;
2617 Decls
: constant List_Id
:= New_List
;
2619 Stmts
: constant List_Id
:= New_List
;
2623 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2625 -- Null body is generated for interface types
2627 if Is_Interface
(Typ
) then
2629 Make_Subprogram_Body
(Loc
,
2631 Make_Disp_Conditional_Select_Spec
(Typ
),
2632 Declarations
=> No_List
,
2633 Handled_Statement_Sequence
=>
2634 Make_Handled_Sequence_Of_Statements
(Loc
,
2635 New_List
(Make_Assignment_Statement
(Loc
,
2636 Name
=> Make_Identifier
(Loc
, Name_uF
),
2637 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
2640 if Is_Concurrent_Record_Type
(Typ
) then
2641 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
2646 -- where I will be used to capture the entry index of the primitive
2647 -- wrapper at position S.
2650 Make_Object_Declaration
(Loc
,
2651 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uI
),
2652 Object_Definition
=>
2653 New_Occurrence_Of
(Standard_Integer
, Loc
)));
2656 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S);
2658 -- if C = POK_Procedure
2659 -- or else C = POK_Protected_Procedure
2660 -- or else C = POK_Task_Procedure;
2666 Build_Common_Dispatching_Select_Statements
(Typ
, Stmts
);
2669 -- Bnn : Communication_Block;
2671 -- where Bnn is the name of the communication block used in the
2672 -- call to Protected_Entry_Call.
2674 Blk_Nam
:= Make_Temporary
(Loc
, 'B');
2676 Make_Object_Declaration
(Loc
,
2677 Defining_Identifier
=> Blk_Nam
,
2678 Object_Definition
=>
2679 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
2682 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2684 -- I is the entry index and S is the dispatch table slot
2686 if Tagged_Type_Expansion
then
2688 Unchecked_Convert_To
(RTE
(RE_Tag
),
2690 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
2694 Make_Attribute_Reference
(Loc
,
2695 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
2696 Attribute_Name
=> Name_Tag
);
2700 Make_Assignment_Statement
(Loc
,
2701 Name
=> Make_Identifier
(Loc
, Name_uI
),
2703 Make_Function_Call
(Loc
,
2705 New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
2706 Parameter_Associations
=> New_List
(
2708 Make_Identifier
(Loc
, Name_uS
)))));
2710 if Ekind
(Conc_Typ
) = E_Protected_Type
then
2712 Obj_Ref
:= -- T._object'Access
2713 Make_Attribute_Reference
(Loc
,
2714 Attribute_Name
=> Name_Unchecked_Access
,
2716 Make_Selected_Component
(Loc
,
2717 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2718 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
2720 case Corresponding_Runtime_Package
(Conc_Typ
) is
2721 when System_Tasking_Protected_Objects_Entries
=>
2724 -- Protected_Entry_Call
2725 -- (T._object'Access, -- Object
2726 -- Protected_Entry_Index! (I), -- E
2727 -- P, -- Uninterpreted_Data
2728 -- Conditional_Call, -- Mode
2731 -- where T is the protected object, I is the entry index, P
2732 -- are the wrapped parameters and Bnn is the name of the
2733 -- communication block.
2736 Make_Procedure_Call_Statement
(Loc
,
2738 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
2739 Parameter_Associations
=> New_List
(
2742 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2745 (RTE
(RE_Protected_Entry_Index
), Loc
),
2746 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2748 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2750 New_Occurrence_Of
-- Conditional_Call
2751 (RTE
(RE_Conditional_Call
), Loc
),
2752 New_Occurrence_Of
-- Bnn
2755 when System_Tasking_Protected_Objects_Single_Entry
=>
2757 -- If we are compiling for a restricted run-time, the call
2758 -- uses the simpler form.
2761 Make_Procedure_Call_Statement
(Loc
,
2764 (RTE
(RE_Protected_Single_Entry_Call
), Loc
),
2765 Parameter_Associations
=> New_List
(
2768 Make_Attribute_Reference
(Loc
,
2769 Prefix
=> Make_Identifier
(Loc
, Name_uP
),
2770 Attribute_Name
=> Name_Address
),
2773 (RTE
(RE_Conditional_Call
), Loc
))));
2775 raise Program_Error
;
2779 -- F := not Cancelled (Bnn);
2781 -- where F is the success flag. The status of Cancelled is negated
2782 -- in order to match the behavior of the version for task types.
2785 Make_Assignment_Statement
(Loc
,
2786 Name
=> Make_Identifier
(Loc
, Name_uF
),
2790 Make_Function_Call
(Loc
,
2792 New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
2793 Parameter_Associations
=> New_List
(
2794 New_Occurrence_Of
(Blk_Nam
, Loc
))))));
2796 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
2800 -- (T._task_id, -- Acceptor
2801 -- Task_Entry_Index! (I), -- E
2802 -- P, -- Uninterpreted_Data
2803 -- Conditional_Call, -- Mode
2804 -- F); -- Rendezvous_Successful
2806 -- where T is the task object, I is the entry index, P are the
2807 -- wrapped parameters and F is the status flag.
2810 Make_Procedure_Call_Statement
(Loc
,
2812 New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
2813 Parameter_Associations
=> New_List
(
2815 Make_Selected_Component
(Loc
, -- T._task_id
2816 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2817 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
2819 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2821 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
2822 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2824 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2825 New_Occurrence_Of
-- Conditional_Call
2826 (RTE
(RE_Conditional_Call
), Loc
),
2827 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
2831 -- Initialize out parameters
2834 Make_Assignment_Statement
(Loc
,
2835 Name
=> Make_Identifier
(Loc
, Name_uF
),
2836 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
2838 Make_Assignment_Statement
(Loc
,
2839 Name
=> Make_Identifier
(Loc
, Name_uC
),
2840 Expression
=> New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
)));
2844 Make_Subprogram_Body
(Loc
,
2846 Make_Disp_Conditional_Select_Spec
(Typ
),
2847 Declarations
=> Decls
,
2848 Handled_Statement_Sequence
=>
2849 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
2850 end Make_Disp_Conditional_Select_Body
;
2852 ---------------------------------------
2853 -- Make_Disp_Conditional_Select_Spec --
2854 ---------------------------------------
2856 function Make_Disp_Conditional_Select_Spec
2857 (Typ
: Entity_Id
) return Node_Id
2859 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2860 Def_Id
: constant Node_Id
:=
2861 Make_Defining_Identifier
(Loc
,
2862 Name_uDisp_Conditional_Select
);
2863 Params
: constant List_Id
:= New_List
;
2866 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2868 -- T : in out Typ; -- Object parameter
2869 -- S : Integer; -- Primitive operation slot
2870 -- P : Address; -- Wrapped parameters
2871 -- C : out Prim_Op_Kind; -- Call kind
2872 -- F : out Boolean; -- Status flag
2874 Append_List_To
(Params
, New_List
(
2876 Make_Parameter_Specification
(Loc
,
2877 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
2878 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
2880 Out_Present
=> True),
2882 Make_Parameter_Specification
(Loc
,
2883 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
2884 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
2886 Make_Parameter_Specification
(Loc
,
2887 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
2888 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2890 Make_Parameter_Specification
(Loc
,
2891 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
2893 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
2894 Out_Present
=> True),
2896 Make_Parameter_Specification
(Loc
,
2897 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
2898 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
2899 Out_Present
=> True)));
2902 Make_Procedure_Specification
(Loc
,
2903 Defining_Unit_Name
=> Def_Id
,
2904 Parameter_Specifications
=> Params
);
2905 end Make_Disp_Conditional_Select_Spec
;
2907 -------------------------------------
2908 -- Make_Disp_Get_Prim_Op_Kind_Body --
2909 -------------------------------------
2911 function Make_Disp_Get_Prim_Op_Kind_Body
(Typ
: Entity_Id
) return Node_Id
is
2912 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2916 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2918 if Is_Interface
(Typ
) then
2920 Make_Subprogram_Body
(Loc
,
2922 Make_Disp_Get_Prim_Op_Kind_Spec
(Typ
),
2923 Declarations
=> New_List
,
2924 Handled_Statement_Sequence
=>
2925 Make_Handled_Sequence_Of_Statements
(Loc
,
2926 New_List
(Make_Null_Statement
(Loc
))));
2930 -- C := get_prim_op_kind (tag! (<type>VP), S);
2932 -- where C is the out parameter capturing the call kind and S is the
2933 -- dispatch table slot number.
2935 if Tagged_Type_Expansion
then
2937 Unchecked_Convert_To
(RTE
(RE_Tag
),
2939 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
2943 Make_Attribute_Reference
(Loc
,
2944 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
2945 Attribute_Name
=> Name_Tag
);
2949 Make_Subprogram_Body
(Loc
,
2951 Make_Disp_Get_Prim_Op_Kind_Spec
(Typ
),
2952 Declarations
=> New_List
,
2953 Handled_Statement_Sequence
=>
2954 Make_Handled_Sequence_Of_Statements
(Loc
,
2956 Make_Assignment_Statement
(Loc
,
2957 Name
=> Make_Identifier
(Loc
, Name_uC
),
2959 Make_Function_Call
(Loc
,
2961 New_Occurrence_Of
(RTE
(RE_Get_Prim_Op_Kind
), Loc
),
2962 Parameter_Associations
=> New_List
(
2964 Make_Identifier
(Loc
, Name_uS
)))))));
2965 end Make_Disp_Get_Prim_Op_Kind_Body
;
2967 -------------------------------------
2968 -- Make_Disp_Get_Prim_Op_Kind_Spec --
2969 -------------------------------------
2971 function Make_Disp_Get_Prim_Op_Kind_Spec
2972 (Typ
: Entity_Id
) return Node_Id
2974 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2975 Def_Id
: constant Node_Id
:=
2976 Make_Defining_Identifier
(Loc
, Name_uDisp_Get_Prim_Op_Kind
);
2977 Params
: constant List_Id
:= New_List
;
2980 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2982 -- T : in out Typ; -- Object parameter
2983 -- S : Integer; -- Primitive operation slot
2984 -- C : out Prim_Op_Kind; -- Call kind
2986 Append_List_To
(Params
, New_List
(
2988 Make_Parameter_Specification
(Loc
,
2989 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
2990 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
2992 Out_Present
=> True),
2994 Make_Parameter_Specification
(Loc
,
2995 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
2996 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
2998 Make_Parameter_Specification
(Loc
,
2999 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
3001 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
3002 Out_Present
=> True)));
3005 Make_Procedure_Specification
(Loc
,
3006 Defining_Unit_Name
=> Def_Id
,
3007 Parameter_Specifications
=> Params
);
3008 end Make_Disp_Get_Prim_Op_Kind_Spec
;
3010 --------------------------------
3011 -- Make_Disp_Get_Task_Id_Body --
3012 --------------------------------
3014 function Make_Disp_Get_Task_Id_Body
3015 (Typ
: Entity_Id
) return Node_Id
3017 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3021 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3023 if Is_Concurrent_Record_Type
(Typ
)
3024 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) = E_Task_Type
3027 -- return To_Address (_T._task_id);
3030 Make_Simple_Return_Statement
(Loc
,
3032 Make_Unchecked_Type_Conversion
(Loc
,
3033 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
3035 Make_Selected_Component
(Loc
,
3036 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
3037 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
))));
3039 -- A null body is constructed for non-task types
3043 -- return Null_Address;
3046 Make_Simple_Return_Statement
(Loc
,
3047 Expression
=> New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
3051 Make_Subprogram_Body
(Loc
,
3052 Specification
=> Make_Disp_Get_Task_Id_Spec
(Typ
),
3053 Declarations
=> New_List
,
3054 Handled_Statement_Sequence
=>
3055 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Ret
)));
3056 end Make_Disp_Get_Task_Id_Body
;
3058 --------------------------------
3059 -- Make_Disp_Get_Task_Id_Spec --
3060 --------------------------------
3062 function Make_Disp_Get_Task_Id_Spec
3063 (Typ
: Entity_Id
) return Node_Id
3065 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3068 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3071 Make_Function_Specification
(Loc
,
3072 Defining_Unit_Name
=>
3073 Make_Defining_Identifier
(Loc
, Name_uDisp_Get_Task_Id
),
3074 Parameter_Specifications
=> New_List
(
3075 Make_Parameter_Specification
(Loc
,
3076 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
3077 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
3078 Result_Definition
=>
3079 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
3080 end Make_Disp_Get_Task_Id_Spec
;
3082 ----------------------------
3083 -- Make_Disp_Requeue_Body --
3084 ----------------------------
3086 function Make_Disp_Requeue_Body
3087 (Typ
: Entity_Id
) return Node_Id
3089 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3090 Conc_Typ
: Entity_Id
:= Empty
;
3091 Stmts
: constant List_Id
:= New_List
;
3094 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3096 -- Null body is generated for interface types and non-concurrent
3099 if Is_Interface
(Typ
)
3100 or else not Is_Concurrent_Record_Type
(Typ
)
3103 Make_Subprogram_Body
(Loc
,
3104 Specification
=> Make_Disp_Requeue_Spec
(Typ
),
3105 Declarations
=> No_List
,
3106 Handled_Statement_Sequence
=>
3107 Make_Handled_Sequence_Of_Statements
(Loc
,
3108 New_List
(Make_Null_Statement
(Loc
))));
3111 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
3113 if Ekind
(Conc_Typ
) = E_Protected_Type
then
3115 -- Generate statements:
3117 -- System.Tasking.Protected_Objects.Operations.
3118 -- Requeue_Protected_Entry
3119 -- (Protection_Entries_Access (P),
3120 -- O._object'Unchecked_Access,
3121 -- Protected_Entry_Index (I),
3124 -- System.Tasking.Protected_Objects.Operations.
3125 -- Requeue_Task_To_Protected_Entry
3126 -- (O._object'Unchecked_Access,
3127 -- Protected_Entry_Index (I),
3131 if Restriction_Active
(No_Entry_Queue
) then
3132 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
3135 Make_If_Statement
(Loc
,
3136 Condition
=> Make_Identifier
(Loc
, Name_uF
),
3141 -- Call to Requeue_Protected_Entry
3143 Make_Procedure_Call_Statement
(Loc
,
3146 (RTE
(RE_Requeue_Protected_Entry
), Loc
),
3147 Parameter_Associations
=>
3150 Make_Unchecked_Type_Conversion
(Loc
, -- PEA (P)
3153 RTE
(RE_Protection_Entries_Access
), Loc
),
3155 Make_Identifier
(Loc
, Name_uP
)),
3157 Make_Attribute_Reference
(Loc
, -- O._object'Acc
3159 Name_Unchecked_Access
,
3161 Make_Selected_Component
(Loc
,
3163 Make_Identifier
(Loc
, Name_uO
),
3165 Make_Identifier
(Loc
, Name_uObject
))),
3167 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3170 (RTE
(RE_Protected_Entry_Index
), Loc
),
3171 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3173 Make_Identifier
(Loc
, Name_uA
)))), -- abort status
3178 -- Call to Requeue_Task_To_Protected_Entry
3180 Make_Procedure_Call_Statement
(Loc
,
3183 (RTE
(RE_Requeue_Task_To_Protected_Entry
), Loc
),
3184 Parameter_Associations
=>
3187 Make_Attribute_Reference
(Loc
, -- O._object'Acc
3188 Attribute_Name
=> Name_Unchecked_Access
,
3190 Make_Selected_Component
(Loc
,
3192 Make_Identifier
(Loc
, Name_uO
),
3194 Make_Identifier
(Loc
, Name_uObject
))),
3196 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3199 (RTE
(RE_Protected_Entry_Index
), Loc
),
3200 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3202 Make_Identifier
(Loc
, Name_uA
)))))); -- abort status
3206 pragma Assert
(Is_Task_Type
(Conc_Typ
));
3210 -- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry
3211 -- (Protection_Entries_Access (P),
3213 -- Task_Entry_Index (I),
3216 -- System.Tasking.Rendezvous.Requeue_Task_Entry
3218 -- Task_Entry_Index (I),
3223 Make_If_Statement
(Loc
,
3224 Condition
=> Make_Identifier
(Loc
, Name_uF
),
3226 Then_Statements
=> New_List
(
3228 -- Call to Requeue_Protected_To_Task_Entry
3230 Make_Procedure_Call_Statement
(Loc
,
3233 (RTE
(RE_Requeue_Protected_To_Task_Entry
), Loc
),
3235 Parameter_Associations
=> New_List
(
3237 Make_Unchecked_Type_Conversion
(Loc
, -- PEA (P)
3240 (RTE
(RE_Protection_Entries_Access
), Loc
),
3241 Expression
=> Make_Identifier
(Loc
, Name_uP
)),
3243 Make_Selected_Component
(Loc
, -- O._task_id
3244 Prefix
=> Make_Identifier
(Loc
, Name_uO
),
3245 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3247 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3249 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
3250 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3252 Make_Identifier
(Loc
, Name_uA
)))), -- abort status
3254 Else_Statements
=> New_List
(
3256 -- Call to Requeue_Task_Entry
3258 Make_Procedure_Call_Statement
(Loc
,
3260 New_Occurrence_Of
(RTE
(RE_Requeue_Task_Entry
), Loc
),
3262 Parameter_Associations
=> New_List
(
3264 Make_Selected_Component
(Loc
, -- O._task_id
3265 Prefix
=> Make_Identifier
(Loc
, Name_uO
),
3266 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3268 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3270 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
3271 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3273 Make_Identifier
(Loc
, Name_uA
)))))); -- abort status
3276 -- Even though no declarations are needed in both cases, we allocate
3277 -- a list for entities added by Freeze.
3280 Make_Subprogram_Body
(Loc
,
3281 Specification
=> Make_Disp_Requeue_Spec
(Typ
),
3282 Declarations
=> New_List
,
3283 Handled_Statement_Sequence
=>
3284 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
3285 end Make_Disp_Requeue_Body
;
3287 ----------------------------
3288 -- Make_Disp_Requeue_Spec --
3289 ----------------------------
3291 function Make_Disp_Requeue_Spec
3292 (Typ
: Entity_Id
) return Node_Id
3294 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3297 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3299 -- O : in out Typ; - Object parameter
3300 -- F : Boolean; - Protected (True) / task (False) flag
3301 -- P : Address; - Protection_Entries_Access value
3302 -- I : Entry_Index - Index of entry call
3303 -- A : Boolean - Abort flag
3305 -- Note that the Protection_Entries_Access value is represented as a
3306 -- System.Address in order to avoid dragging in the tasking runtime
3307 -- when compiling sources without tasking constructs.
3310 Make_Procedure_Specification
(Loc
,
3311 Defining_Unit_Name
=>
3312 Make_Defining_Identifier
(Loc
, Name_uDisp_Requeue
),
3314 Parameter_Specifications
=> New_List
(
3316 Make_Parameter_Specification
(Loc
, -- O
3317 Defining_Identifier
=>
3318 Make_Defining_Identifier
(Loc
, Name_uO
),
3320 New_Occurrence_Of
(Typ
, Loc
),
3322 Out_Present
=> True),
3324 Make_Parameter_Specification
(Loc
, -- F
3325 Defining_Identifier
=>
3326 Make_Defining_Identifier
(Loc
, Name_uF
),
3328 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
3330 Make_Parameter_Specification
(Loc
, -- P
3331 Defining_Identifier
=>
3332 Make_Defining_Identifier
(Loc
, Name_uP
),
3334 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3336 Make_Parameter_Specification
(Loc
, -- I
3337 Defining_Identifier
=>
3338 Make_Defining_Identifier
(Loc
, Name_uI
),
3340 New_Occurrence_Of
(Standard_Integer
, Loc
)),
3342 Make_Parameter_Specification
(Loc
, -- A
3343 Defining_Identifier
=>
3344 Make_Defining_Identifier
(Loc
, Name_uA
),
3346 New_Occurrence_Of
(Standard_Boolean
, Loc
))));
3347 end Make_Disp_Requeue_Spec
;
3349 ---------------------------------
3350 -- Make_Disp_Timed_Select_Body --
3351 ---------------------------------
3353 -- For interface types, generate:
3355 -- procedure _Disp_Timed_Select
3356 -- (T : in out <Typ>;
3358 -- P : System.Address;
3361 -- C : out Ada.Tags.Prim_Op_Kind;
3366 -- C := Ada.Tags.POK_Function;
3367 -- end _Disp_Timed_Select;
3369 -- For protected types, generate:
3371 -- procedure _Disp_Timed_Select
3372 -- (T : in out <Typ>;
3374 -- P : System.Address;
3377 -- C : out Ada.Tags.Prim_Op_Kind;
3383 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S);
3385 -- if C = Ada.Tags.POK_Procedure
3386 -- or else C = Ada.Tags.POK_Protected_Procedure
3387 -- or else C = Ada.Tags.POK_Task_Procedure
3393 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3394 -- System.Tasking.Protected_Objects.Operations.
3395 -- Timed_Protected_Entry_Call
3396 -- (T._object'Access,
3397 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
3402 -- end _Disp_Timed_Select;
3404 -- For task types, generate:
3406 -- procedure _Disp_Timed_Select
3407 -- (T : in out <Typ>;
3409 -- P : System.Address;
3412 -- C : out Ada.Tags.Prim_Op_Kind;
3418 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3419 -- System.Tasking.Rendezvous.Timed_Task_Entry_Call
3421 -- System.Tasking.Task_Entry_Index (I),
3426 -- end _Disp_Time_Select;
3428 function Make_Disp_Timed_Select_Body
3429 (Typ
: Entity_Id
) return Node_Id
3431 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3432 Conc_Typ
: Entity_Id
:= Empty
;
3433 Decls
: constant List_Id
:= New_List
;
3435 Stmts
: constant List_Id
:= New_List
;
3439 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3441 -- Null body is generated for interface types
3443 if Is_Interface
(Typ
) then
3445 Make_Subprogram_Body
(Loc
,
3446 Specification
=> Make_Disp_Timed_Select_Spec
(Typ
),
3447 Declarations
=> New_List
,
3448 Handled_Statement_Sequence
=>
3449 Make_Handled_Sequence_Of_Statements
(Loc
,
3451 Make_Assignment_Statement
(Loc
,
3452 Name
=> Make_Identifier
(Loc
, Name_uF
),
3453 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
3456 if Is_Concurrent_Record_Type
(Typ
) then
3457 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
3462 -- where I will be used to capture the entry index of the primitive
3463 -- wrapper at position S.
3466 Make_Object_Declaration
(Loc
,
3467 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uI
),
3468 Object_Definition
=>
3469 New_Occurrence_Of
(Standard_Integer
, Loc
)));
3472 -- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
3474 -- if C = POK_Procedure
3475 -- or else C = POK_Protected_Procedure
3476 -- or else C = POK_Task_Procedure;
3482 Build_Common_Dispatching_Select_Statements
(Typ
, Stmts
);
3485 -- I := Get_Entry_Index (tag! (<type>VP), S);
3487 -- I is the entry index and S is the dispatch table slot
3489 if Tagged_Type_Expansion
then
3491 Unchecked_Convert_To
(RTE
(RE_Tag
),
3493 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
3497 Make_Attribute_Reference
(Loc
,
3498 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
3499 Attribute_Name
=> Name_Tag
);
3503 Make_Assignment_Statement
(Loc
,
3504 Name
=> Make_Identifier
(Loc
, Name_uI
),
3506 Make_Function_Call
(Loc
,
3507 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
3508 Parameter_Associations
=> New_List
(
3510 Make_Identifier
(Loc
, Name_uS
)))));
3514 if Ekind
(Conc_Typ
) = E_Protected_Type
then
3516 -- Build T._object'Access
3519 Make_Attribute_Reference
(Loc
,
3520 Attribute_Name
=> Name_Unchecked_Access
,
3522 Make_Selected_Component
(Loc
,
3523 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
3524 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
3526 -- Normal case, No_Entry_Queue restriction not active. In this
3527 -- case we generate:
3529 -- Timed_Protected_Entry_Call
3530 -- (T._object'access,
3531 -- Protected_Entry_Index! (I),
3534 -- where T is the protected object, I is the entry index, P are
3535 -- the wrapped parameters, D is the delay amount, M is the delay
3536 -- mode and F is the status flag.
3538 -- Historically, there was also an implementation for single
3539 -- entry protected types (in s-tposen). However, it was removed
3540 -- by also testing for no No_Select_Statements restriction in
3541 -- Exp_Utils.Corresponding_Runtime_Package. This simplified the
3542 -- implementation of s-tposen.adb and provided consistency between
3543 -- all versions of System.Tasking.Protected_Objects.Single_Entry
3546 case Corresponding_Runtime_Package
(Conc_Typ
) is
3547 when System_Tasking_Protected_Objects_Entries
=>
3549 Make_Procedure_Call_Statement
(Loc
,
3552 (RTE
(RE_Timed_Protected_Entry_Call
), Loc
),
3553 Parameter_Associations
=> New_List
(
3556 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3559 (RTE
(RE_Protected_Entry_Index
), Loc
),
3560 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3562 Make_Identifier
(Loc
, Name_uP
), -- parameter block
3563 Make_Identifier
(Loc
, Name_uD
), -- delay
3564 Make_Identifier
(Loc
, Name_uM
), -- delay mode
3565 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
3568 raise Program_Error
;
3574 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
3577 -- Timed_Task_Entry_Call (
3579 -- Task_Entry_Index! (I),
3585 -- where T is the task object, I is the entry index, P are the
3586 -- wrapped parameters, D is the delay amount, M is the delay
3587 -- mode and F is the status flag.
3590 Make_Procedure_Call_Statement
(Loc
,
3592 New_Occurrence_Of
(RTE
(RE_Timed_Task_Entry_Call
), Loc
),
3594 Parameter_Associations
=> New_List
(
3595 Make_Selected_Component
(Loc
, -- T._task_id
3596 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
3597 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3599 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3601 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
3602 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3604 Make_Identifier
(Loc
, Name_uP
), -- parameter block
3605 Make_Identifier
(Loc
, Name_uD
), -- delay
3606 Make_Identifier
(Loc
, Name_uM
), -- delay mode
3607 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
3611 -- Initialize out parameters
3614 Make_Assignment_Statement
(Loc
,
3615 Name
=> Make_Identifier
(Loc
, Name_uF
),
3616 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3618 Make_Assignment_Statement
(Loc
,
3619 Name
=> Make_Identifier
(Loc
, Name_uC
),
3620 Expression
=> New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
)));
3624 Make_Subprogram_Body
(Loc
,
3625 Specification
=> Make_Disp_Timed_Select_Spec
(Typ
),
3626 Declarations
=> Decls
,
3627 Handled_Statement_Sequence
=>
3628 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
3629 end Make_Disp_Timed_Select_Body
;
3631 ---------------------------------
3632 -- Make_Disp_Timed_Select_Spec --
3633 ---------------------------------
3635 function Make_Disp_Timed_Select_Spec
3636 (Typ
: Entity_Id
) return Node_Id
3638 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3639 Def_Id
: constant Node_Id
:=
3640 Make_Defining_Identifier
(Loc
,
3641 Name_uDisp_Timed_Select
);
3642 Params
: constant List_Id
:= New_List
;
3645 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3647 -- T : in out Typ; -- Object parameter
3648 -- S : Integer; -- Primitive operation slot
3649 -- P : Address; -- Wrapped parameters
3650 -- D : Duration; -- Delay
3651 -- M : Integer; -- Delay Mode
3652 -- C : out Prim_Op_Kind; -- Call kind
3653 -- F : out Boolean; -- Status flag
3655 Append_List_To
(Params
, New_List
(
3657 Make_Parameter_Specification
(Loc
,
3658 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
3659 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
3661 Out_Present
=> True),
3663 Make_Parameter_Specification
(Loc
,
3664 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
3665 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3667 Make_Parameter_Specification
(Loc
,
3668 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
3669 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3671 Make_Parameter_Specification
(Loc
,
3672 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uD
),
3673 Parameter_Type
=> New_Occurrence_Of
(Standard_Duration
, Loc
)),
3675 Make_Parameter_Specification
(Loc
,
3676 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uM
),
3677 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3679 Make_Parameter_Specification
(Loc
,
3680 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
3682 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
3683 Out_Present
=> True)));
3686 Make_Parameter_Specification
(Loc
,
3687 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
3688 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3689 Out_Present
=> True));
3692 Make_Procedure_Specification
(Loc
,
3693 Defining_Unit_Name
=> Def_Id
,
3694 Parameter_Specifications
=> Params
);
3695 end Make_Disp_Timed_Select_Spec
;
3701 -- The frontend supports two models for expanding dispatch tables
3702 -- associated with library-level defined tagged types: statically and
3703 -- non-statically allocated dispatch tables. In the former case the object
3704 -- containing the dispatch table is constant and it is initialized by means
3705 -- of a positional aggregate. In the latter case, the object containing
3706 -- the dispatch table is a variable which is initialized by means of
3709 -- In case of locally defined tagged types, the object containing the
3710 -- object containing the dispatch table is always a variable (instead of a
3711 -- constant). This is currently required to give support to late overriding
3712 -- of primitives. For example:
3714 -- procedure Example is
3716 -- type T1 is tagged null record;
3717 -- procedure Prim (O : T1);
3720 -- type T2 is new Pkg.T1 with null record;
3721 -- procedure Prim (X : T2) is -- late overriding
3727 -- WARNING: This routine manages Ghost regions. Return statements must be
3728 -- replaced by gotos which jump to the end of the routine and restore the
3731 function Make_DT
(Typ
: Entity_Id
; N
: Node_Id
:= Empty
) return List_Id
is
3732 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3734 Max_Predef_Prims
: constant Int
:=
3738 (Parent
(RTE
(RE_Max_Predef_Prims
)))));
3740 DT_Decl
: constant Elist_Id
:= New_Elmt_List
;
3741 DT_Aggr
: constant Elist_Id
:= New_Elmt_List
;
3742 -- Entities marked with attribute Is_Dispatch_Table_Entity
3744 procedure Check_Premature_Freezing
3746 Tagged_Type
: Entity_Id
;
3748 -- Verify that all untagged types in the profile of a subprogram are
3749 -- frozen at the point the subprogram is frozen. This enforces the rule
3750 -- on RM 13.14 (14) as modified by AI05-019. At the point a subprogram
3751 -- is frozen, enough must be known about it to build the activation
3752 -- record for it, which requires at least that the size of all
3753 -- parameters be known. Controlling arguments are by-reference,
3754 -- and therefore the rule only applies to untagged types. Typical
3755 -- violation of the rule involves an object declaration that freezes a
3756 -- tagged type, when one of its primitive operations has a type in its
3757 -- profile whose full view has not been analyzed yet. More complex cases
3758 -- involve composite types that have one private unfrozen subcomponent.
3760 procedure Export_DT
(Typ
: Entity_Id
; DT
: Entity_Id
; Index
: Nat
:= 0);
3761 -- Export the dispatch table DT of tagged type Typ. Required to generate
3762 -- forward references and statically allocate the table. For primary
3763 -- dispatch tables Index is 0; for secondary dispatch tables the value
3764 -- of index must match the Suffix_Index value assigned to the table by
3765 -- Make_Tags when generating its unique external name, and it is used to
3766 -- retrieve from the Dispatch_Table_Wrappers list associated with Typ
3767 -- the external name generated by Import_DT.
3769 procedure Make_Secondary_DT
3773 Num_Iface_Prims
: Nat
;
3774 Iface_DT_Ptr
: Entity_Id
;
3775 Predef_Prims_Ptr
: Entity_Id
;
3776 Build_Thunks
: Boolean;
3778 -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch
3779 -- Table of Typ associated with Iface. Each abstract interface of Typ
3780 -- has two secondary dispatch tables: one containing pointers to thunks
3781 -- and another containing pointers to the primitives covering the
3782 -- interface primitives. The former secondary table is generated when
3783 -- Build_Thunks is True, and provides common support for dispatching
3784 -- calls through interface types; the latter secondary table is
3785 -- generated when Build_Thunks is False, and provides support for
3786 -- Generic Dispatching Constructors that dispatch calls through
3787 -- interface types. When constructing this latter table the value of
3788 -- Suffix_Index is -1 to indicate that there is no need to export such
3789 -- table when building statically allocated dispatch tables; a positive
3790 -- value of Suffix_Index must match the Suffix_Index value assigned to
3791 -- this secondary dispatch table by Make_Tags when its unique external
3792 -- name was generated.
3794 ------------------------------
3795 -- Check_Premature_Freezing --
3796 ------------------------------
3798 procedure Check_Premature_Freezing
3800 Tagged_Type
: Entity_Id
;
3805 function Is_Actual_For_Formal_Incomplete_Type
3806 (T
: Entity_Id
) return Boolean;
3807 -- In Ada 2012, if a nested generic has an incomplete formal type,
3808 -- the actual may be (and usually is) a private type whose completion
3809 -- appears later. It is safe to build the dispatch table in this
3810 -- case, gigi will have full views available.
3812 ------------------------------------------
3813 -- Is_Actual_For_Formal_Incomplete_Type --
3814 ------------------------------------------
3816 function Is_Actual_For_Formal_Incomplete_Type
3817 (T
: Entity_Id
) return Boolean
3819 Gen_Par
: Entity_Id
;
3823 if not Is_Generic_Instance
(Current_Scope
)
3824 or else not Used_As_Generic_Actual
(T
)
3828 Gen_Par
:= Generic_Parent
(Parent
(Current_Scope
));
3833 (Generic_Formal_Declarations
3834 (Unit_Declaration_Node
(Gen_Par
)));
3835 while Present
(F
) loop
3836 if Ekind
(Defining_Identifier
(F
)) = E_Incomplete_Type
then
3844 end Is_Actual_For_Formal_Incomplete_Type
;
3846 -- Start of processing for Check_Premature_Freezing
3849 -- Note that if the type is a (subtype of) a generic actual, the
3850 -- actual will have been frozen by the instantiation.
3853 and then Is_Private_Type
(Typ
)
3854 and then No
(Full_View
(Typ
))
3855 and then not Is_Generic_Type
(Typ
)
3856 and then not Is_Tagged_Type
(Typ
)
3857 and then not Is_Frozen
(Typ
)
3858 and then not Is_Generic_Actual_Type
(Typ
)
3860 Error_Msg_Sloc
:= Sloc
(Subp
);
3862 ("declaration must appear after completion of type &", N
, Typ
);
3864 ("\which is an untagged type in the profile of "
3865 & "primitive operation & declared#", N
, Subp
);
3868 Comp
:= Private_Component
(Typ
);
3870 if not Is_Tagged_Type
(Typ
)
3871 and then Present
(Comp
)
3872 and then not Is_Frozen
(Comp
)
3873 and then not Is_Actual_For_Formal_Incomplete_Type
(Comp
)
3875 Error_Msg_Sloc
:= Sloc
(Subp
);
3876 Error_Msg_Node_2
:= Subp
;
3877 Error_Msg_Name_1
:= Chars
(Tagged_Type
);
3879 ("declaration must appear after completion of type &",
3882 ("\which is a component of untagged type& in the profile "
3883 & "of primitive & of type % that is frozen by the "
3884 & "declaration ", N
, Typ
);
3887 end Check_Premature_Freezing
;
3893 procedure Export_DT
(Typ
: Entity_Id
; DT
: Entity_Id
; Index
: Nat
:= 0)
3899 Set_Is_Statically_Allocated
(DT
);
3900 Set_Is_True_Constant
(DT
);
3901 Set_Is_Exported
(DT
);
3904 Elmt
:= First_Elmt
(Dispatch_Table_Wrappers
(Typ
));
3905 while Count
/= Index
loop
3910 pragma Assert
(Related_Type
(Node
(Elmt
)) = Typ
);
3912 Get_External_Name
(Node
(Elmt
));
3913 Set_Interface_Name
(DT
,
3914 Make_String_Literal
(Loc
,
3915 Strval
=> String_From_Name_Buffer
));
3917 -- Ensure proper Sprint output of this implicit importation
3919 Set_Is_Internal
(DT
);
3923 -----------------------
3924 -- Make_Secondary_DT --
3925 -----------------------
3927 procedure Make_Secondary_DT
3931 Num_Iface_Prims
: Nat
;
3932 Iface_DT_Ptr
: Entity_Id
;
3933 Predef_Prims_Ptr
: Entity_Id
;
3934 Build_Thunks
: Boolean;
3937 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3938 Exporting_Table
: constant Boolean :=
3939 Building_Static_DT
(Typ
)
3940 and then Suffix_Index
> 0;
3941 Iface_DT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
3942 Predef_Prims
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
3943 DT_Constr_List
: List_Id
;
3944 DT_Aggr_List
: List_Id
;
3945 Empty_DT
: Boolean := False;
3946 Nb_Predef_Prims
: Nat
:= 0;
3950 OSD_Aggr_List
: List_Id
;
3953 Prim_Elmt
: Elmt_Id
;
3954 Prim_Ops_Aggr_List
: List_Id
;
3957 -- Handle cases in which we do not generate statically allocated
3960 if not Building_Static_DT
(Typ
) then
3961 Set_Ekind
(Predef_Prims
, E_Variable
);
3962 Set_Ekind
(Iface_DT
, E_Variable
);
3964 -- Statically allocated dispatch tables and related entities are
3968 Set_Ekind
(Predef_Prims
, E_Constant
);
3969 Set_Is_Statically_Allocated
(Predef_Prims
);
3970 Set_Is_True_Constant
(Predef_Prims
);
3972 Set_Ekind
(Iface_DT
, E_Constant
);
3973 Set_Is_Statically_Allocated
(Iface_DT
);
3974 Set_Is_True_Constant
(Iface_DT
);
3977 -- Calculate the number of slots of the dispatch table. If the number
3978 -- of primitives of Typ is 0 we reserve a dummy single entry for its
3979 -- DT because at run time the pointer to this dummy entry will be
3982 if Num_Iface_Prims
= 0 then
3986 Nb_Prim
:= Num_Iface_Prims
;
3991 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
3992 -- (predef-prim-op-thunk-1'address,
3993 -- predef-prim-op-thunk-2'address,
3995 -- predef-prim-op-thunk-n'address);
3996 -- for Predef_Prims'Alignment use Address'Alignment
3998 -- Stage 1: Calculate the number of predefined primitives
4000 if not Building_Static_DT
(Typ
) then
4001 Nb_Predef_Prims
:= Max_Predef_Prims
;
4003 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4004 while Present
(Prim_Elmt
) loop
4005 Prim
:= Node
(Prim_Elmt
);
4007 if Is_Predefined_Dispatching_Operation
(Prim
)
4008 and then not Is_Abstract_Subprogram
(Prim
)
4010 Pos
:= UI_To_Int
(DT_Position
(Prim
));
4012 if Pos
> Nb_Predef_Prims
then
4013 Nb_Predef_Prims
:= Pos
;
4017 Next_Elmt
(Prim_Elmt
);
4021 if Generate_SCIL
then
4022 Nb_Predef_Prims
:= 0;
4025 -- Stage 2: Create the thunks associated with the predefined
4026 -- primitives and save their entity to fill the aggregate.
4029 Prim_Table
: array (Nat
range 1 .. Nb_Predef_Prims
) of Entity_Id
;
4031 Thunk_Id
: Entity_Id
;
4032 Thunk_Code
: Node_Id
;
4035 Prim_Ops_Aggr_List
:= New_List
;
4036 Prim_Table
:= (others => Empty
);
4038 if Building_Static_DT
(Typ
) then
4039 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4040 while Present
(Prim_Elmt
) loop
4041 Prim
:= Node
(Prim_Elmt
);
4043 if Is_Predefined_Dispatching_Operation
(Prim
)
4044 and then not Is_Abstract_Subprogram
(Prim
)
4045 and then not Is_Eliminated
(Prim
)
4046 and then not Generate_SCIL
4047 and then not Present
(Prim_Table
4048 (UI_To_Int
(DT_Position
(Prim
))))
4050 if not Build_Thunks
then
4051 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) :=
4055 Expand_Interface_Thunk
4056 (Ultimate_Alias
(Prim
), Thunk_Id
, Thunk_Code
);
4058 if Present
(Thunk_Id
) then
4059 Append_To
(Result
, Thunk_Code
);
4060 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) :=
4066 Next_Elmt
(Prim_Elmt
);
4070 for J
in Prim_Table
'Range loop
4071 if Present
(Prim_Table
(J
)) then
4073 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
4074 Make_Attribute_Reference
(Loc
,
4075 Prefix
=> New_Occurrence_Of
(Prim_Table
(J
), Loc
),
4076 Attribute_Name
=> Name_Unrestricted_Access
));
4078 New_Node
:= Make_Null
(Loc
);
4081 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
4085 Make_Aggregate
(Loc
, Expressions
=> Prim_Ops_Aggr_List
);
4087 -- Remember aggregates initializing dispatch tables
4089 Append_Elmt
(New_Node
, DT_Aggr
);
4092 Make_Subtype_Declaration
(Loc
,
4093 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
4094 Subtype_Indication
=>
4095 New_Occurrence_Of
(RTE
(RE_Address_Array
), Loc
));
4097 Append_To
(Result
, Decl
);
4100 Make_Object_Declaration
(Loc
,
4101 Defining_Identifier
=> Predef_Prims
,
4102 Constant_Present
=> Building_Static_DT
(Typ
),
4103 Aliased_Present
=> True,
4104 Object_Definition
=> New_Occurrence_Of
4105 (Defining_Identifier
(Decl
), Loc
),
4106 Expression
=> New_Node
));
4109 Make_Attribute_Definition_Clause
(Loc
,
4110 Name
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
4111 Chars
=> Name_Alignment
,
4113 Make_Attribute_Reference
(Loc
,
4115 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4116 Attribute_Name
=> Name_Alignment
)));
4121 -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
4122 -- (OSD_Table => (1 => <value>,
4126 -- Iface_DT : Dispatch_Table (Nb_Prims) :=
4127 -- ([ Signature => <sig-value> ],
4128 -- Tag_Kind => <tag_kind-value>,
4129 -- Predef_Prims => Predef_Prims'Address,
4130 -- Offset_To_Top => 0,
4131 -- OSD => OSD'Address,
4132 -- Prims_Ptr => (prim-op-1'address,
4133 -- prim-op-2'address,
4135 -- prim-op-n'address));
4136 -- for Iface_DT'Alignment use Address'Alignment;
4138 -- Stage 3: Initialize the discriminant and the record components
4140 DT_Constr_List
:= New_List
;
4141 DT_Aggr_List
:= New_List
;
4145 Append_To
(DT_Constr_List
, Make_Integer_Literal
(Loc
, Nb_Prim
));
4146 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, Nb_Prim
));
4150 if RTE_Record_Component_Available
(RE_Signature
) then
4151 Append_To
(DT_Aggr_List
,
4152 New_Occurrence_Of
(RTE
(RE_Secondary_DT
), Loc
));
4157 if RTE_Record_Component_Available
(RE_Tag_Kind
) then
4158 Append_To
(DT_Aggr_List
, Tagged_Kind
(Typ
));
4163 Append_To
(DT_Aggr_List
,
4164 Make_Attribute_Reference
(Loc
,
4165 Prefix
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
4166 Attribute_Name
=> Name_Address
));
4168 -- Note: The correct value of Offset_To_Top will be set by the init
4171 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
4173 -- Generate the Object Specific Data table required to dispatch calls
4174 -- through synchronized interfaces.
4177 or else Is_Abstract_Type
(Typ
)
4178 or else Is_Controlled
(Typ
)
4179 or else Restriction_Active
(No_Dispatching_Calls
)
4180 or else not Is_Limited_Type
(Typ
)
4181 or else not Has_Interfaces
(Typ
)
4182 or else not Build_Thunks
4183 or else not RTE_Record_Component_Available
(RE_OSD_Table
)
4185 -- No OSD table required
4187 Append_To
(DT_Aggr_List
,
4188 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
4191 OSD_Aggr_List
:= New_List
;
4194 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
4196 Prim_Alias
: Entity_Id
;
4197 Prim_Elmt
: Elmt_Id
;
4203 Prim_Table
:= (others => Empty
);
4204 Prim_Alias
:= Empty
;
4206 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4207 while Present
(Prim_Elmt
) loop
4208 Prim
:= Node
(Prim_Elmt
);
4210 if Present
(Interface_Alias
(Prim
))
4211 and then Find_Dispatching_Type
4212 (Interface_Alias
(Prim
)) = Iface
4214 Prim_Alias
:= Interface_Alias
(Prim
);
4215 E
:= Ultimate_Alias
(Prim
);
4216 Pos
:= UI_To_Int
(DT_Position
(Prim_Alias
));
4218 if Present
(Prim_Table
(Pos
)) then
4219 pragma Assert
(Prim_Table
(Pos
) = E
);
4223 Prim_Table
(Pos
) := E
;
4225 Append_To
(OSD_Aggr_List
,
4226 Make_Component_Association
(Loc
,
4227 Choices
=> New_List
(
4228 Make_Integer_Literal
(Loc
,
4229 DT_Position
(Prim_Alias
))),
4231 Make_Integer_Literal
(Loc
,
4232 DT_Position
(Alias
(Prim
)))));
4238 Next_Elmt
(Prim_Elmt
);
4240 pragma Assert
(Count
= Nb_Prim
);
4243 OSD
:= Make_Temporary
(Loc
, 'I');
4246 Make_Object_Declaration
(Loc
,
4247 Defining_Identifier
=> OSD
,
4248 Object_Definition
=>
4249 Make_Subtype_Indication
(Loc
,
4251 New_Occurrence_Of
(RTE
(RE_Object_Specific_Data
), Loc
),
4253 Make_Index_Or_Discriminant_Constraint
(Loc
,
4254 Constraints
=> New_List
(
4255 Make_Integer_Literal
(Loc
, Nb_Prim
)))),
4258 Make_Aggregate
(Loc
,
4259 Component_Associations
=> New_List
(
4260 Make_Component_Association
(Loc
,
4261 Choices
=> New_List
(
4263 (RTE_Record_Component
(RE_OSD_Num_Prims
), Loc
)),
4265 Make_Integer_Literal
(Loc
, Nb_Prim
)),
4267 Make_Component_Association
(Loc
,
4268 Choices
=> New_List
(
4270 (RTE_Record_Component
(RE_OSD_Table
), Loc
)),
4271 Expression
=> Make_Aggregate
(Loc
,
4272 Component_Associations
=> OSD_Aggr_List
))))));
4275 Make_Attribute_Definition_Clause
(Loc
,
4276 Name
=> New_Occurrence_Of
(OSD
, Loc
),
4277 Chars
=> Name_Alignment
,
4279 Make_Attribute_Reference
(Loc
,
4281 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4282 Attribute_Name
=> Name_Alignment
)));
4284 -- In secondary dispatch tables the Typeinfo component contains
4285 -- the address of the Object Specific Data (see a-tags.ads)
4287 Append_To
(DT_Aggr_List
,
4288 Make_Attribute_Reference
(Loc
,
4289 Prefix
=> New_Occurrence_Of
(OSD
, Loc
),
4290 Attribute_Name
=> Name_Address
));
4293 -- Initialize the table of primitive operations
4295 Prim_Ops_Aggr_List
:= New_List
;
4298 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
4300 elsif Is_Abstract_Type
(Typ
)
4301 or else not Building_Static_DT
(Typ
)
4303 for J
in 1 .. Nb_Prim
loop
4304 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
4309 CPP_Nb_Prims
: constant Nat
:= CPP_Num_Prims
(Typ
);
4312 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
4313 Thunk_Code
: Node_Id
;
4314 Thunk_Id
: Entity_Id
;
4317 Prim_Table
:= (others => Empty
);
4319 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4320 while Present
(Prim_Elmt
) loop
4321 Prim
:= Node
(Prim_Elmt
);
4322 E
:= Ultimate_Alias
(Prim
);
4323 Prim_Pos
:= UI_To_Int
(DT_Position
(E
));
4325 -- Do not reference predefined primitives because they are
4326 -- located in a separate dispatch table; skip abstract and
4327 -- eliminated primitives; skip primitives located in the C++
4328 -- part of the dispatch table because their slot is set by
4331 if not Is_Predefined_Dispatching_Operation
(Prim
)
4332 and then Present
(Interface_Alias
(Prim
))
4333 and then not Is_Abstract_Subprogram
(Alias
(Prim
))
4334 and then not Is_Eliminated
(Alias
(Prim
))
4335 and then (not Is_CPP_Class
(Root_Type
(Typ
))
4336 or else Prim_Pos
> CPP_Nb_Prims
)
4337 and then Find_Dispatching_Type
4338 (Interface_Alias
(Prim
)) = Iface
4340 -- Generate the code of the thunk only if the abstract
4341 -- interface type is not an immediate ancestor of
4342 -- Tagged_Type. Otherwise the DT associated with the
4343 -- interface is the primary DT.
4345 and then not Is_Ancestor
(Iface
, Typ
,
4346 Use_Full_View
=> True)
4348 if not Build_Thunks
then
4350 UI_To_Int
(DT_Position
(Interface_Alias
(Prim
)));
4351 Prim_Table
(Prim_Pos
) := Alias
(Prim
);
4354 Expand_Interface_Thunk
(Prim
, Thunk_Id
, Thunk_Code
);
4356 if Present
(Thunk_Id
) then
4358 UI_To_Int
(DT_Position
(Interface_Alias
(Prim
)));
4360 Prim_Table
(Prim_Pos
) := Thunk_Id
;
4361 Append_To
(Result
, Thunk_Code
);
4366 Next_Elmt
(Prim_Elmt
);
4369 for J
in Prim_Table
'Range loop
4370 if Present
(Prim_Table
(J
)) then
4372 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
4373 Make_Attribute_Reference
(Loc
,
4374 Prefix
=> New_Occurrence_Of
(Prim_Table
(J
), Loc
),
4375 Attribute_Name
=> Name_Unrestricted_Access
));
4378 New_Node
:= Make_Null
(Loc
);
4381 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
4387 Make_Aggregate
(Loc
,
4388 Expressions
=> Prim_Ops_Aggr_List
);
4390 Append_To
(DT_Aggr_List
, New_Node
);
4392 -- Remember aggregates initializing dispatch tables
4394 Append_Elmt
(New_Node
, DT_Aggr
);
4396 -- Note: Secondary dispatch tables cannot be declared constant
4397 -- because the component Offset_To_Top is currently initialized
4398 -- by the IP routine.
4401 Make_Object_Declaration
(Loc
,
4402 Defining_Identifier
=> Iface_DT
,
4403 Aliased_Present
=> True,
4404 Constant_Present
=> False,
4406 Object_Definition
=>
4407 Make_Subtype_Indication
(Loc
,
4408 Subtype_Mark
=> New_Occurrence_Of
4409 (RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
4410 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
4411 Constraints
=> DT_Constr_List
)),
4414 Make_Aggregate
(Loc
,
4415 Expressions
=> DT_Aggr_List
)));
4418 Make_Attribute_Definition_Clause
(Loc
,
4419 Name
=> New_Occurrence_Of
(Iface_DT
, Loc
),
4420 Chars
=> Name_Alignment
,
4423 Make_Attribute_Reference
(Loc
,
4425 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4426 Attribute_Name
=> Name_Alignment
)));
4428 if Exporting_Table
then
4429 Export_DT
(Typ
, Iface_DT
, Suffix_Index
);
4431 -- Generate code to create the pointer to the dispatch table
4433 -- Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address);
4435 -- Note: This declaration is not added here if the table is exported
4436 -- because in such case Make_Tags has already added this declaration.
4440 Make_Object_Declaration
(Loc
,
4441 Defining_Identifier
=> Iface_DT_Ptr
,
4442 Constant_Present
=> True,
4444 Object_Definition
=>
4445 New_Occurrence_Of
(RTE
(RE_Interface_Tag
), Loc
),
4448 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
4449 Make_Attribute_Reference
(Loc
,
4451 Make_Selected_Component
(Loc
,
4452 Prefix
=> New_Occurrence_Of
(Iface_DT
, Loc
),
4455 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
4456 Attribute_Name
=> Name_Address
))));
4460 Make_Object_Declaration
(Loc
,
4461 Defining_Identifier
=> Predef_Prims_Ptr
,
4462 Constant_Present
=> True,
4464 Object_Definition
=>
4465 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
4468 Make_Attribute_Reference
(Loc
,
4470 Make_Selected_Component
(Loc
,
4471 Prefix
=> New_Occurrence_Of
(Iface_DT
, Loc
),
4474 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
4475 Attribute_Name
=> Name_Address
)));
4477 -- Remember entities containing dispatch tables
4479 Append_Elmt
(Predef_Prims
, DT_Decl
);
4480 Append_Elmt
(Iface_DT
, DT_Decl
);
4481 end Make_Secondary_DT
;
4485 Elab_Code
: constant List_Id
:= New_List
;
4486 Result
: constant List_Id
:= New_List
;
4487 Tname
: constant Name_Id
:= Chars
(Typ
);
4489 -- The following name entries are used by Make_DT to generate a number
4490 -- of entities related to a tagged type. These entities may be generated
4491 -- in a scope other than that of the tagged type declaration, and if
4492 -- the entities for two tagged types with the same name happen to be
4493 -- generated in the same scope, we have to take care to use different
4494 -- names. This is achieved by means of a unique serial number appended
4495 -- to each generated entity name.
4497 Name_DT
: constant Name_Id
:=
4498 New_External_Name
(Tname
, 'T', Suffix_Index
=> -1);
4499 Name_Exname
: constant Name_Id
:=
4500 New_External_Name
(Tname
, 'E', Suffix_Index
=> -1);
4501 Name_HT_Link
: constant Name_Id
:=
4502 New_External_Name
(Tname
, 'H', Suffix_Index
=> -1);
4503 Name_Predef_Prims
: constant Name_Id
:=
4504 New_External_Name
(Tname
, 'R', Suffix_Index
=> -1);
4505 Name_SSD
: constant Name_Id
:=
4506 New_External_Name
(Tname
, 'S', Suffix_Index
=> -1);
4507 Name_TSD
: constant Name_Id
:=
4508 New_External_Name
(Tname
, 'B', Suffix_Index
=> -1);
4510 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
4511 -- Save the Ghost mode to restore on exit
4514 AI_Tag_Elmt
: Elmt_Id
;
4515 AI_Tag_Comp
: Elmt_Id
;
4517 DT_Aggr_List
: List_Id
;
4518 DT_Constr_List
: List_Id
;
4521 HT_Link
: Entity_Id
;
4524 Iface_Table_Node
: Node_Id
;
4525 Name_ITable
: Name_Id
;
4526 Nb_Predef_Prims
: Nat
:= 0;
4529 Num_Ifaces
: Nat
:= 0;
4530 Parent_Typ
: Entity_Id
;
4531 Predef_Prims
: Entity_Id
;
4533 Prim_Elmt
: Elmt_Id
;
4534 Prim_Ops_Aggr_List
: List_Id
;
4537 Typ_Comps
: Elist_Id
;
4538 Typ_Ifaces
: Elist_Id
;
4540 TSD_Aggr_List
: List_Id
;
4541 TSD_Tags_List
: List_Id
;
4543 -- Start of processing for Make_DT
4546 pragma Assert
(Is_Frozen
(Typ
));
4548 -- The tagged type being processed may be subject to pragma Ghost. Set
4549 -- the mode now to ensure that any nodes generated during dispatch table
4550 -- creation are properly marked as Ghost.
4552 Set_Ghost_Mode
(Typ
);
4554 -- Handle cases in which there is no need to build the dispatch table
4556 if Has_Dispatch_Table
(Typ
)
4557 or else No
(Access_Disp_Table
(Typ
))
4558 or else Is_CPP_Class
(Typ
)
4562 elsif No_Run_Time_Mode
then
4563 Error_Msg_CRT
("tagged types", Typ
);
4566 elsif not RTE_Available
(RE_Tag
) then
4568 Make_Object_Declaration
(Loc
,
4569 Defining_Identifier
=>
4570 Node
(First_Elmt
(Access_Disp_Table
(Typ
))),
4571 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
4572 Constant_Present
=> True,
4574 Unchecked_Convert_To
(RTE
(RE_Tag
),
4575 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
4577 Analyze_List
(Result
, Suppress
=> All_Checks
);
4578 Error_Msg_CRT
("tagged types", Typ
);
4582 -- Ensure that the value of Max_Predef_Prims defined in a-tags is
4583 -- correct. Valid values are 9 under configurable runtime or 15
4584 -- with full runtime.
4586 if RTE_Available
(RE_Interface_Data
) then
4587 if Max_Predef_Prims
/= 15 then
4588 Error_Msg_N
("run-time library configuration error", Typ
);
4592 if Max_Predef_Prims
/= 9 then
4593 Error_Msg_N
("run-time library configuration error", Typ
);
4594 Error_Msg_CRT
("tagged types", Typ
);
4599 DT
:= Make_Defining_Identifier
(Loc
, Name_DT
);
4600 Exname
:= Make_Defining_Identifier
(Loc
, Name_Exname
);
4601 HT_Link
:= Make_Defining_Identifier
(Loc
, Name_HT_Link
);
4602 Predef_Prims
:= Make_Defining_Identifier
(Loc
, Name_Predef_Prims
);
4603 SSD
:= Make_Defining_Identifier
(Loc
, Name_SSD
);
4604 TSD
:= Make_Defining_Identifier
(Loc
, Name_TSD
);
4606 -- Initialize Parent_Typ handling private types
4608 Parent_Typ
:= Etype
(Typ
);
4610 if Present
(Full_View
(Parent_Typ
)) then
4611 Parent_Typ
:= Full_View
(Parent_Typ
);
4614 -- Ensure that all the primitives are frozen. This is only required when
4615 -- building static dispatch tables --- the primitives must be frozen to
4616 -- be referenced (otherwise we have problems with the backend). It is
4617 -- not a requirement with nonstatic dispatch tables because in this case
4618 -- we generate now an empty dispatch table; the extra code required to
4619 -- register the primitives in the slots will be generated later --- when
4620 -- each primitive is frozen (see Freeze_Subprogram).
4622 if Building_Static_DT
(Typ
) then
4624 Saved_FLLTT
: constant Boolean :=
4625 Freezing_Library_Level_Tagged_Type
;
4630 Prim_Elmt
: Elmt_Id
;
4633 Freezing_Library_Level_Tagged_Type
:= True;
4635 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4636 while Present
(Prim_Elmt
) loop
4637 Prim
:= Node
(Prim_Elmt
);
4638 Frnodes
:= Freeze_Entity
(Prim
, Typ
);
4640 -- We disable this check for abstract subprograms, given that
4641 -- they cannot be called directly and thus the state of their
4642 -- untagged formals is of no concern. The RM is unclear in any
4643 -- case concerning the need for this check, and this topic may
4644 -- go back to the ARG.
4646 if not Is_Abstract_Subprogram
(Prim
) then
4647 Formal
:= First_Formal
(Prim
);
4648 while Present
(Formal
) loop
4649 Check_Premature_Freezing
(Prim
, Typ
, Etype
(Formal
));
4650 Next_Formal
(Formal
);
4653 Check_Premature_Freezing
(Prim
, Typ
, Etype
(Prim
));
4656 if Present
(Frnodes
) then
4657 Append_List_To
(Result
, Frnodes
);
4660 Next_Elmt
(Prim_Elmt
);
4663 Freezing_Library_Level_Tagged_Type
:= Saved_FLLTT
;
4667 -- Ada 2005 (AI-251): Build the secondary dispatch tables
4669 if Has_Interfaces
(Typ
) then
4670 Collect_Interface_Components
(Typ
, Typ_Comps
);
4672 -- Each secondary dispatch table is assigned an unique positive
4673 -- suffix index; such value also corresponds with the location of
4674 -- its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
4676 -- Note: This value must be kept sync with the Suffix_Index values
4677 -- generated by Make_Tags
4681 Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
4683 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
4684 while Present
(AI_Tag_Comp
) loop
4685 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'P'));
4687 -- Build the secondary table containing pointers to thunks
4692 (Related_Type
(Node
(AI_Tag_Comp
))),
4693 Suffix_Index
=> Suffix_Index
,
4694 Num_Iface_Prims
=> UI_To_Int
4695 (DT_Entry_Count
(Node
(AI_Tag_Comp
))),
4696 Iface_DT_Ptr
=> Node
(AI_Tag_Elmt
),
4697 Predef_Prims_Ptr
=> Node
(Next_Elmt
(AI_Tag_Elmt
)),
4698 Build_Thunks
=> True,
4701 -- Skip secondary dispatch table referencing thunks to predefined
4704 Next_Elmt
(AI_Tag_Elmt
);
4705 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'Y'));
4707 -- Secondary dispatch table referencing user-defined primitives
4708 -- covered by this interface.
4710 Next_Elmt
(AI_Tag_Elmt
);
4711 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'D'));
4713 -- Build the secondary table containing pointers to primitives
4714 -- (used to give support to Generic Dispatching Constructors).
4719 (Related_Type
(Node
(AI_Tag_Comp
))),
4721 Num_Iface_Prims
=> UI_To_Int
4722 (DT_Entry_Count
(Node
(AI_Tag_Comp
))),
4723 Iface_DT_Ptr
=> Node
(AI_Tag_Elmt
),
4724 Predef_Prims_Ptr
=> Node
(Next_Elmt
(AI_Tag_Elmt
)),
4725 Build_Thunks
=> False,
4728 -- Skip secondary dispatch table referencing predefined primitives
4730 Next_Elmt
(AI_Tag_Elmt
);
4731 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'Z'));
4733 Suffix_Index
:= Suffix_Index
+ 1;
4734 Next_Elmt
(AI_Tag_Elmt
);
4735 Next_Elmt
(AI_Tag_Comp
);
4739 -- Get the _tag entity and number of primitives of its dispatch table
4741 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
4742 Nb_Prim
:= UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Typ
)));
4744 if Generate_SCIL
then
4748 Set_Is_Statically_Allocated
(DT
, Is_Library_Level_Tagged_Type
(Typ
));
4749 Set_Is_Statically_Allocated
(SSD
, Is_Library_Level_Tagged_Type
(Typ
));
4750 Set_Is_Statically_Allocated
(TSD
, Is_Library_Level_Tagged_Type
(Typ
));
4751 Set_Is_Statically_Allocated
(Predef_Prims
,
4752 Is_Library_Level_Tagged_Type
(Typ
));
4754 -- In case of locally defined tagged type we declare the object
4755 -- containing the dispatch table by means of a variable. Its
4756 -- initialization is done later by means of an assignment. This is
4757 -- required to generate its External_Tag.
4759 if not Building_Static_DT
(Typ
) then
4762 -- DT : No_Dispatch_Table_Wrapper;
4763 -- for DT'Alignment use Address'Alignment;
4764 -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
4766 if not Has_DT
(Typ
) then
4768 Make_Object_Declaration
(Loc
,
4769 Defining_Identifier
=> DT
,
4770 Aliased_Present
=> True,
4771 Constant_Present
=> False,
4772 Object_Definition
=>
4774 (RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
)));
4777 Make_Attribute_Definition_Clause
(Loc
,
4778 Name
=> New_Occurrence_Of
(DT
, Loc
),
4779 Chars
=> Name_Alignment
,
4781 Make_Attribute_Reference
(Loc
,
4783 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4784 Attribute_Name
=> Name_Alignment
)));
4787 Make_Object_Declaration
(Loc
,
4788 Defining_Identifier
=> DT_Ptr
,
4789 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
4790 Constant_Present
=> True,
4792 Unchecked_Convert_To
(RTE
(RE_Tag
),
4793 Make_Attribute_Reference
(Loc
,
4795 Make_Selected_Component
(Loc
,
4796 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
4799 (RTE_Record_Component
(RE_NDT_Prims_Ptr
), Loc
)),
4800 Attribute_Name
=> Name_Address
))));
4802 Set_Is_Statically_Allocated
(DT_Ptr
,
4803 Is_Library_Level_Tagged_Type
(Typ
));
4805 -- Generate the SCIL node for the previous object declaration
4806 -- because it has a tag initialization.
4808 if Generate_SCIL
then
4810 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
4811 Set_SCIL_Entity
(New_Node
, Typ
);
4812 Set_SCIL_Node
(Last
(Result
), New_Node
);
4816 -- Gnat2scil has its own implementation of dispatch tables,
4817 -- different than what is being implemented here. Generating
4818 -- further dispatch table initialization code would just
4819 -- cause gnat2scil to generate useless Scil which CodePeer
4820 -- would waste time and space analyzing, so we skip it.
4824 -- DT : Dispatch_Table_Wrapper (Nb_Prim);
4825 -- for DT'Alignment use Address'Alignment;
4826 -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
4829 -- If the tagged type has no primitives we add a dummy slot
4830 -- whose address will be the tag of this type.
4834 New_List
(Make_Integer_Literal
(Loc
, 1));
4837 New_List
(Make_Integer_Literal
(Loc
, Nb_Prim
));
4841 Make_Object_Declaration
(Loc
,
4842 Defining_Identifier
=> DT
,
4843 Aliased_Present
=> True,
4844 Constant_Present
=> False,
4845 Object_Definition
=>
4846 Make_Subtype_Indication
(Loc
,
4848 New_Occurrence_Of
(RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
4850 Make_Index_Or_Discriminant_Constraint
(Loc
,
4851 Constraints
=> DT_Constr_List
))));
4854 Make_Attribute_Definition_Clause
(Loc
,
4855 Name
=> New_Occurrence_Of
(DT
, Loc
),
4856 Chars
=> Name_Alignment
,
4858 Make_Attribute_Reference
(Loc
,
4860 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4861 Attribute_Name
=> Name_Alignment
)));
4864 Make_Object_Declaration
(Loc
,
4865 Defining_Identifier
=> DT_Ptr
,
4866 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
4867 Constant_Present
=> True,
4869 Unchecked_Convert_To
(RTE
(RE_Tag
),
4870 Make_Attribute_Reference
(Loc
,
4872 Make_Selected_Component
(Loc
,
4873 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
4876 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
4877 Attribute_Name
=> Name_Address
))));
4879 Set_Is_Statically_Allocated
(DT_Ptr
,
4880 Is_Library_Level_Tagged_Type
(Typ
));
4882 -- Generate the SCIL node for the previous object declaration
4883 -- because it has a tag initialization.
4885 if Generate_SCIL
then
4887 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
4888 Set_SCIL_Entity
(New_Node
, Typ
);
4889 Set_SCIL_Node
(Last
(Result
), New_Node
);
4893 -- Gnat2scil has its own implementation of dispatch tables,
4894 -- different than what is being implemented here. Generating
4895 -- further dispatch table initialization code would just
4896 -- cause gnat2scil to generate useless Scil which CodePeer
4897 -- would waste time and space analyzing, so we skip it.
4901 Make_Object_Declaration
(Loc
,
4902 Defining_Identifier
=>
4903 Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
)))),
4904 Constant_Present
=> True,
4905 Object_Definition
=>
4906 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
4908 Make_Attribute_Reference
(Loc
,
4910 Make_Selected_Component
(Loc
,
4911 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
4914 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
4915 Attribute_Name
=> Name_Address
)));
4919 -- Generate: Exname : constant String := full_qualified_name (typ);
4920 -- The type itself may be an anonymous parent type, so use the first
4921 -- subtype to have a user-recognizable name.
4924 Make_Object_Declaration
(Loc
,
4925 Defining_Identifier
=> Exname
,
4926 Constant_Present
=> True,
4927 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
4929 Make_String_Literal
(Loc
,
4930 Strval
=> Fully_Qualified_Name_String
(First_Subtype
(Typ
)))));
4931 Set_Is_Statically_Allocated
(Exname
);
4932 Set_Is_True_Constant
(Exname
);
4934 -- Declare the object used by Ada.Tags.Register_Tag
4936 if RTE_Available
(RE_Register_Tag
) then
4938 Make_Object_Declaration
(Loc
,
4939 Defining_Identifier
=> HT_Link
,
4940 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
)));
4943 -- Generate code to create the storage for the type specific data object
4944 -- with enough space to store the tags of the ancestors plus the tags
4945 -- of all the implemented interfaces (as described in a-tags.adb).
4947 -- TSD : Type_Specific_Data (I_Depth) :=
4948 -- (Idepth => I_Depth,
4949 -- Access_Level => Type_Access_Level (Typ),
4950 -- Alignment => Typ'Alignment,
4951 -- Expanded_Name => Cstring_Ptr!(Exname'Address))
4952 -- External_Tag => Cstring_Ptr!(Exname'Address))
4953 -- HT_Link => HT_Link'Address,
4954 -- Transportable => <<boolean-value>>,
4955 -- Is_Abstract => <<boolean-value>>,
4956 -- Needs_Finalization => <<boolean-value>>,
4957 -- [ Size_Func => Size_Prim'Access, ]
4958 -- [ Interfaces_Table => <<access-value>>, ]
4959 -- [ SSD => SSD_Table'Address ]
4960 -- Tags_Table => (0 => null,
4963 -- for TSD'Alignment use Address'Alignment
4965 TSD_Aggr_List
:= New_List
;
4967 -- Idepth: Count ancestors to compute the inheritance depth. For private
4968 -- extensions, always go to the full view in order to compute the real
4969 -- inheritance depth.
4972 Current_Typ
: Entity_Id
;
4973 Parent_Typ
: Entity_Id
;
4979 Parent_Typ
:= Etype
(Current_Typ
);
4981 if Is_Private_Type
(Parent_Typ
) then
4982 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
4985 exit when Parent_Typ
= Current_Typ
;
4987 I_Depth
:= I_Depth
+ 1;
4988 Current_Typ
:= Parent_Typ
;
4992 Append_To
(TSD_Aggr_List
,
4993 Make_Integer_Literal
(Loc
, I_Depth
));
4997 Append_To
(TSD_Aggr_List
,
4998 Make_Integer_Literal
(Loc
, Type_Access_Level
(Typ
)));
5002 -- For CPP types we cannot rely on the value of 'Alignment provided
5003 -- by the backend to initialize this TSD field.
5005 if Convention
(Typ
) = Convention_CPP
5006 or else Is_CPP_Class
(Root_Type
(Typ
))
5008 Append_To
(TSD_Aggr_List
,
5009 Make_Integer_Literal
(Loc
, 0));
5011 Append_To
(TSD_Aggr_List
,
5012 Make_Attribute_Reference
(Loc
,
5013 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
5014 Attribute_Name
=> Name_Alignment
));
5019 Append_To
(TSD_Aggr_List
,
5020 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5021 Make_Attribute_Reference
(Loc
,
5022 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5023 Attribute_Name
=> Name_Address
)));
5025 -- External_Tag of a local tagged type
5027 -- <typ>A : constant String :=
5028 -- "Internal tag at 16#tag-addr#: <full-name-of-typ>";
5030 -- The reason we generate this strange name is that we do not want to
5031 -- enter local tagged types in the global hash table used to compute
5032 -- the Internal_Tag attribute for two reasons:
5034 -- 1. It is hard to avoid a tasking race condition for entering the
5035 -- entry into the hash table.
5037 -- 2. It would cause a storage leak, unless we rig up considerable
5038 -- mechanism to remove the entry from the hash table on exit.
5040 -- So what we do is to generate the above external tag name, where the
5041 -- hex address is the address of the local dispatch table (i.e. exactly
5042 -- the value we want if Internal_Tag is computed from this string).
5044 -- Of course this value will only be valid if the tagged type is still
5045 -- in scope, but it clearly must be erroneous to compute the internal
5046 -- tag of a tagged type that is out of scope.
5048 -- We don't do this processing if an explicit external tag has been
5049 -- specified. That's an odd case for which we have already issued a
5050 -- warning, where we will not be able to compute the internal tag.
5052 if not Is_Library_Level_Entity
(Typ
)
5053 and then not Has_External_Tag_Rep_Clause
(Typ
)
5056 Exname
: constant Entity_Id
:=
5057 Make_Defining_Identifier
(Loc
,
5058 Chars
=> New_External_Name
(Tname
, 'A'));
5059 Full_Name
: constant String_Id
:=
5060 Fully_Qualified_Name_String
(First_Subtype
(Typ
));
5061 Str1_Id
: String_Id
;
5062 Str2_Id
: String_Id
;
5066 -- Str1 = "Internal tag at 16#";
5069 Store_String_Chars
("Internal tag at 16#");
5070 Str1_Id
:= End_String
;
5073 -- Str2 = "#: <type-full-name>";
5076 Store_String_Chars
("#: ");
5077 Store_String_Chars
(Full_Name
);
5078 Str2_Id
:= End_String
;
5081 -- Exname : constant String :=
5082 -- Str1 & Address_Image (Tag) & Str2;
5084 if RTE_Available
(RE_Address_Image
) then
5086 Make_Object_Declaration
(Loc
,
5087 Defining_Identifier
=> Exname
,
5088 Constant_Present
=> True,
5089 Object_Definition
=> New_Occurrence_Of
5090 (Standard_String
, Loc
),
5092 Make_Op_Concat
(Loc
,
5093 Left_Opnd
=> Make_String_Literal
(Loc
, Str1_Id
),
5095 Make_Op_Concat
(Loc
,
5097 Make_Function_Call
(Loc
,
5100 (RTE
(RE_Address_Image
), Loc
),
5101 Parameter_Associations
=> New_List
(
5102 Unchecked_Convert_To
(RTE
(RE_Address
),
5103 New_Occurrence_Of
(DT_Ptr
, Loc
)))),
5105 Make_String_Literal
(Loc
, Str2_Id
)))));
5109 Make_Object_Declaration
(Loc
,
5110 Defining_Identifier
=> Exname
,
5111 Constant_Present
=> True,
5112 Object_Definition
=>
5113 New_Occurrence_Of
(Standard_String
, Loc
),
5115 Make_Op_Concat
(Loc
,
5116 Left_Opnd
=> Make_String_Literal
(Loc
, Str1_Id
),
5117 Right_Opnd
=> Make_String_Literal
(Loc
, Str2_Id
))));
5121 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5122 Make_Attribute_Reference
(Loc
,
5123 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5124 Attribute_Name
=> Name_Address
));
5127 -- External tag of a library-level tagged type: Check for a definition
5128 -- of External_Tag. The clause is considered only if it applies to this
5129 -- specific tagged type, as opposed to one of its ancestors.
5130 -- If the type is an unconstrained type extension, we are building the
5131 -- dispatch table of its anonymous base type, so the external tag, if
5132 -- any was specified, must be retrieved from the first subtype. Go to
5133 -- the full view in case the clause is in the private part.
5137 Def
: constant Node_Id
:= Get_Attribute_Definition_Clause
5138 (Underlying_Type
(First_Subtype
(Typ
)),
5139 Attribute_External_Tag
);
5141 Old_Val
: String_Id
;
5142 New_Val
: String_Id
;
5146 if not Present
(Def
)
5147 or else Entity
(Name
(Def
)) /= First_Subtype
(Typ
)
5150 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5151 Make_Attribute_Reference
(Loc
,
5152 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5153 Attribute_Name
=> Name_Address
));
5155 Old_Val
:= Strval
(Expr_Value_S
(Expression
(Def
)));
5157 -- For the rep clause "for <typ>'external_tag use y" generate:
5159 -- <typ>A : constant string := y;
5161 -- <typ>A'Address is used to set the External_Tag component
5164 -- Create a new nul terminated string if it is not already
5166 if String_Length
(Old_Val
) > 0
5168 Get_String_Char
(Old_Val
, String_Length
(Old_Val
)) = 0
5172 Start_String
(Old_Val
);
5173 Store_String_Char
(Get_Char_Code
(ASCII
.NUL
));
5174 New_Val
:= End_String
;
5177 E
:= Make_Defining_Identifier
(Loc
,
5178 New_External_Name
(Chars
(Typ
), 'A'));
5181 Make_Object_Declaration
(Loc
,
5182 Defining_Identifier
=> E
,
5183 Constant_Present
=> True,
5184 Object_Definition
=>
5185 New_Occurrence_Of
(Standard_String
, Loc
),
5187 Make_String_Literal
(Loc
, New_Val
)));
5190 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5191 Make_Attribute_Reference
(Loc
,
5192 Prefix
=> New_Occurrence_Of
(E
, Loc
),
5193 Attribute_Name
=> Name_Address
));
5198 Append_To
(TSD_Aggr_List
, New_Node
);
5202 if RTE_Available
(RE_Register_Tag
) then
5203 Append_To
(TSD_Aggr_List
,
5204 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
5205 Make_Attribute_Reference
(Loc
,
5206 Prefix
=> New_Occurrence_Of
(HT_Link
, Loc
),
5207 Attribute_Name
=> Name_Address
)));
5209 Append_To
(TSD_Aggr_List
,
5210 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
5211 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5214 -- Transportable: Set for types that can be used in remote calls
5215 -- with respect to E.4(18) legality rules.
5218 Transportable
: Entity_Id
;
5224 or else Is_Shared_Passive
(Typ
)
5226 ((Is_Remote_Types
(Typ
)
5227 or else Is_Remote_Call_Interface
(Typ
))
5228 and then Original_View_In_Visible_Part
(Typ
))
5229 or else not Comes_From_Source
(Typ
));
5231 Append_To
(TSD_Aggr_List
,
5232 New_Occurrence_Of
(Transportable
, Loc
));
5235 -- Is_Abstract (Ada 2012: AI05-0173). This functionality is not
5236 -- available in the HIE runtime.
5238 if RTE_Record_Component_Available
(RE_Is_Abstract
) then
5240 Is_Abstract
: Entity_Id
;
5242 Is_Abstract
:= Boolean_Literals
(Is_Abstract_Type
(Typ
));
5243 Append_To
(TSD_Aggr_List
,
5244 New_Occurrence_Of
(Is_Abstract
, Loc
));
5248 -- Needs_Finalization: Set if the type is controlled or has controlled
5252 Needs_Fin
: Entity_Id
;
5254 Needs_Fin
:= Boolean_Literals
(Needs_Finalization
(Typ
));
5255 Append_To
(TSD_Aggr_List
, New_Occurrence_Of
(Needs_Fin
, Loc
));
5260 if RTE_Record_Component_Available
(RE_Size_Func
) then
5262 -- Initialize this field to Null_Address if we are not building
5263 -- static dispatch tables static or if the size function is not
5264 -- available. In the former case we cannot initialize this field
5265 -- until the function is frozen and registered in the dispatch
5266 -- table (see Register_Primitive).
5268 if not Building_Static_DT
(Typ
) or else not Has_DT
(Typ
) then
5269 Append_To
(TSD_Aggr_List
,
5270 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5271 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5275 Prim_Elmt
: Elmt_Id
;
5277 Size_Comp
: Node_Id
:= Empty
;
5280 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5281 while Present
(Prim_Elmt
) loop
5282 Prim
:= Node
(Prim_Elmt
);
5284 if Chars
(Prim
) = Name_uSize
then
5285 Prim
:= Ultimate_Alias
(Prim
);
5287 if Is_Abstract_Subprogram
(Prim
) then
5289 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5290 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
5293 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5294 Make_Attribute_Reference
(Loc
,
5295 Prefix
=> New_Occurrence_Of
(Prim
, Loc
),
5296 Attribute_Name
=> Name_Unrestricted_Access
));
5302 Next_Elmt
(Prim_Elmt
);
5305 pragma Assert
(Present
(Size_Comp
));
5306 Append_To
(TSD_Aggr_List
, Size_Comp
);
5311 -- Interfaces_Table (required for AI-405)
5313 if RTE_Record_Component_Available
(RE_Interfaces_Table
) then
5315 -- Count the number of interface types implemented by Typ
5317 Collect_Interfaces
(Typ
, Typ_Ifaces
);
5319 AI
:= First_Elmt
(Typ_Ifaces
);
5320 while Present
(AI
) loop
5321 Num_Ifaces
:= Num_Ifaces
+ 1;
5325 if Num_Ifaces
= 0 then
5326 Iface_Table_Node
:= Make_Null
(Loc
);
5328 -- Generate the Interface_Table object
5332 TSD_Ifaces_List
: constant List_Id
:= New_List
;
5334 Sec_DT_Tag
: Node_Id
;
5337 AI
:= First_Elmt
(Typ_Ifaces
);
5338 while Present
(AI
) loop
5339 if Is_Ancestor
(Node
(AI
), Typ
, Use_Full_View
=> True) then
5341 New_Occurrence_Of
(DT_Ptr
, Loc
);
5345 (Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
5346 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5348 while Is_Tag
(Node
(Elmt
))
5350 Is_Ancestor
(Node
(AI
), Related_Type
(Node
(Elmt
)),
5351 Use_Full_View
=> True)
5353 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5355 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5357 pragma Assert
(not Has_Thunks
(Node
(Elmt
)));
5359 pragma Assert
(not Has_Thunks
(Node
(Elmt
)));
5363 pragma Assert
(Ekind
(Node
(Elmt
)) = E_Constant
5365 Has_Thunks
(Node
(Next_Elmt
(Next_Elmt
(Elmt
)))));
5367 New_Occurrence_Of
(Node
(Next_Elmt
(Next_Elmt
(Elmt
))),
5371 Append_To
(TSD_Ifaces_List
,
5372 Make_Aggregate
(Loc
,
5373 Expressions
=> New_List
(
5377 Unchecked_Convert_To
(RTE
(RE_Tag
),
5379 (Node
(First_Elmt
(Access_Disp_Table
(Node
(AI
)))),
5382 -- Static_Offset_To_Top
5384 New_Occurrence_Of
(Standard_True
, Loc
),
5386 -- Offset_To_Top_Value
5388 Make_Integer_Literal
(Loc
, 0),
5390 -- Offset_To_Top_Func
5396 Unchecked_Convert_To
(RTE
(RE_Tag
), Sec_DT_Tag
)
5403 Name_ITable
:= New_External_Name
(Tname
, 'I');
5404 ITable
:= Make_Defining_Identifier
(Loc
, Name_ITable
);
5405 Set_Is_Statically_Allocated
(ITable
,
5406 Is_Library_Level_Tagged_Type
(Typ
));
5408 -- The table of interfaces is not constant; its slots are
5409 -- filled at run time by the IP routine using attribute
5410 -- 'Position to know the location of the tag components
5411 -- (and this attribute cannot be safely used before the
5412 -- object is initialized).
5415 Make_Object_Declaration
(Loc
,
5416 Defining_Identifier
=> ITable
,
5417 Aliased_Present
=> True,
5418 Constant_Present
=> False,
5419 Object_Definition
=>
5420 Make_Subtype_Indication
(Loc
,
5422 New_Occurrence_Of
(RTE
(RE_Interface_Data
), Loc
),
5424 Make_Index_Or_Discriminant_Constraint
(Loc
,
5425 Constraints
=> New_List
(
5426 Make_Integer_Literal
(Loc
, Num_Ifaces
)))),
5428 Expression
=> Make_Aggregate
(Loc
,
5429 Expressions
=> New_List
(
5430 Make_Integer_Literal
(Loc
, Num_Ifaces
),
5431 Make_Aggregate
(Loc
, TSD_Ifaces_List
)))));
5434 Make_Attribute_Definition_Clause
(Loc
,
5435 Name
=> New_Occurrence_Of
(ITable
, Loc
),
5436 Chars
=> Name_Alignment
,
5438 Make_Attribute_Reference
(Loc
,
5440 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5441 Attribute_Name
=> Name_Alignment
)));
5444 Make_Attribute_Reference
(Loc
,
5445 Prefix
=> New_Occurrence_Of
(ITable
, Loc
),
5446 Attribute_Name
=> Name_Unchecked_Access
);
5450 Append_To
(TSD_Aggr_List
, Iface_Table_Node
);
5453 -- Generate the Select Specific Data table for synchronized types that
5454 -- implement synchronized interfaces. The size of the table is
5455 -- constrained by the number of non-predefined primitive operations.
5457 if RTE_Record_Component_Available
(RE_SSD
) then
5458 if Ada_Version
>= Ada_2005
5459 and then Has_DT
(Typ
)
5460 and then Is_Concurrent_Record_Type
(Typ
)
5461 and then Has_Interfaces
(Typ
)
5462 and then Nb_Prim
> 0
5463 and then not Is_Abstract_Type
(Typ
)
5464 and then not Is_Controlled
(Typ
)
5465 and then not Restriction_Active
(No_Dispatching_Calls
)
5466 and then not Restriction_Active
(No_Select_Statements
)
5469 Make_Object_Declaration
(Loc
,
5470 Defining_Identifier
=> SSD
,
5471 Aliased_Present
=> True,
5472 Object_Definition
=>
5473 Make_Subtype_Indication
(Loc
,
5474 Subtype_Mark
=> New_Occurrence_Of
(
5475 RTE
(RE_Select_Specific_Data
), Loc
),
5477 Make_Index_Or_Discriminant_Constraint
(Loc
,
5478 Constraints
=> New_List
(
5479 Make_Integer_Literal
(Loc
, Nb_Prim
))))));
5482 Make_Attribute_Definition_Clause
(Loc
,
5483 Name
=> New_Occurrence_Of
(SSD
, Loc
),
5484 Chars
=> Name_Alignment
,
5486 Make_Attribute_Reference
(Loc
,
5488 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5489 Attribute_Name
=> Name_Alignment
)));
5491 -- This table is initialized by Make_Select_Specific_Data_Table,
5492 -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
5494 Append_To
(TSD_Aggr_List
,
5495 Make_Attribute_Reference
(Loc
,
5496 Prefix
=> New_Occurrence_Of
(SSD
, Loc
),
5497 Attribute_Name
=> Name_Unchecked_Access
));
5499 Append_To
(TSD_Aggr_List
, Make_Null
(Loc
));
5503 -- Initialize the table of ancestor tags. In case of interface types
5504 -- this table is not needed.
5506 TSD_Tags_List
:= New_List
;
5508 -- If we are not statically allocating the dispatch table then we must
5509 -- fill position 0 with null because we still have not generated the
5512 if not Building_Static_DT
(Typ
)
5513 or else Is_Interface
(Typ
)
5515 Append_To
(TSD_Tags_List
,
5516 Unchecked_Convert_To
(RTE
(RE_Tag
),
5517 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5519 -- Otherwise we can safely reference the tag
5522 Append_To
(TSD_Tags_List
,
5523 New_Occurrence_Of
(DT_Ptr
, Loc
));
5526 -- Fill the rest of the table with the tags of the ancestors
5529 Current_Typ
: Entity_Id
;
5530 Parent_Typ
: Entity_Id
;
5538 Parent_Typ
:= Etype
(Current_Typ
);
5540 if Is_Private_Type
(Parent_Typ
) then
5541 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
5544 exit when Parent_Typ
= Current_Typ
;
5546 if Is_CPP_Class
(Parent_Typ
) then
5548 -- The tags defined in the C++ side will be inherited when
5549 -- the object is constructed (Exp_Ch3.Build_Init_Procedure)
5551 Append_To
(TSD_Tags_List
,
5552 Unchecked_Convert_To
(RTE
(RE_Tag
),
5553 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5555 Append_To
(TSD_Tags_List
,
5557 (Node
(First_Elmt
(Access_Disp_Table
(Parent_Typ
))),
5562 Current_Typ
:= Parent_Typ
;
5565 pragma Assert
(Pos
= I_Depth
+ 1);
5568 Append_To
(TSD_Aggr_List
,
5569 Make_Aggregate
(Loc
,
5570 Expressions
=> TSD_Tags_List
));
5572 -- Build the TSD object
5575 Make_Object_Declaration
(Loc
,
5576 Defining_Identifier
=> TSD
,
5577 Aliased_Present
=> True,
5578 Constant_Present
=> Building_Static_DT
(Typ
),
5579 Object_Definition
=>
5580 Make_Subtype_Indication
(Loc
,
5581 Subtype_Mark
=> New_Occurrence_Of
(
5582 RTE
(RE_Type_Specific_Data
), Loc
),
5584 Make_Index_Or_Discriminant_Constraint
(Loc
,
5585 Constraints
=> New_List
(
5586 Make_Integer_Literal
(Loc
, I_Depth
)))),
5588 Expression
=> Make_Aggregate
(Loc
,
5589 Expressions
=> TSD_Aggr_List
)));
5591 Set_Is_True_Constant
(TSD
, Building_Static_DT
(Typ
));
5594 Make_Attribute_Definition_Clause
(Loc
,
5595 Name
=> New_Occurrence_Of
(TSD
, Loc
),
5596 Chars
=> Name_Alignment
,
5598 Make_Attribute_Reference
(Loc
,
5600 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5601 Attribute_Name
=> Name_Alignment
)));
5603 -- Initialize or declare the dispatch table object
5605 if not Has_DT
(Typ
) then
5606 DT_Constr_List
:= New_List
;
5607 DT_Aggr_List
:= New_List
;
5612 Make_Attribute_Reference
(Loc
,
5613 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
5614 Attribute_Name
=> Name_Address
);
5616 Append_To
(DT_Constr_List
, New_Node
);
5617 Append_To
(DT_Aggr_List
, New_Copy
(New_Node
));
5618 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
5620 -- In case of locally defined tagged types we have already declared
5621 -- and uninitialized object for the dispatch table, which is now
5622 -- initialized by means of the following assignment:
5624 -- DT := (TSD'Address, 0);
5626 if not Building_Static_DT
(Typ
) then
5628 Make_Assignment_Statement
(Loc
,
5629 Name
=> New_Occurrence_Of
(DT
, Loc
),
5630 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5632 -- In case of library level tagged types we declare and export now
5633 -- the constant object containing the dummy dispatch table. There
5634 -- is no need to declare the tag here because it has been previously
5635 -- declared by Make_Tags
5637 -- DT : aliased constant No_Dispatch_Table :=
5638 -- (NDT_TSD => TSD'Address;
5639 -- NDT_Prims_Ptr => 0);
5640 -- for DT'Alignment use Address'Alignment;
5644 Make_Object_Declaration
(Loc
,
5645 Defining_Identifier
=> DT
,
5646 Aliased_Present
=> True,
5647 Constant_Present
=> True,
5648 Object_Definition
=>
5649 New_Occurrence_Of
(RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
),
5650 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5653 Make_Attribute_Definition_Clause
(Loc
,
5654 Name
=> New_Occurrence_Of
(DT
, Loc
),
5655 Chars
=> Name_Alignment
,
5657 Make_Attribute_Reference
(Loc
,
5659 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5660 Attribute_Name
=> Name_Alignment
)));
5662 Export_DT
(Typ
, DT
);
5665 -- Common case: Typ has a dispatch table
5669 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
5670 -- (predef-prim-op-1'address,
5671 -- predef-prim-op-2'address,
5673 -- predef-prim-op-n'address);
5674 -- for Predef_Prims'Alignment use Address'Alignment
5676 -- DT : Dispatch_Table (Nb_Prims) :=
5677 -- (Signature => <sig-value>,
5678 -- Tag_Kind => <tag_kind-value>,
5679 -- Predef_Prims => Predef_Prims'First'Address,
5680 -- Offset_To_Top => 0,
5681 -- TSD => TSD'Address;
5682 -- Prims_Ptr => (prim-op-1'address,
5683 -- prim-op-2'address,
5685 -- prim-op-n'address));
5686 -- for DT'Alignment use Address'Alignment
5693 if not Building_Static_DT
(Typ
) then
5694 Nb_Predef_Prims
:= Max_Predef_Prims
;
5697 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5698 while Present
(Prim_Elmt
) loop
5699 Prim
:= Node
(Prim_Elmt
);
5701 if Is_Predefined_Dispatching_Operation
(Prim
)
5702 and then not Is_Abstract_Subprogram
(Prim
)
5704 Pos
:= UI_To_Int
(DT_Position
(Prim
));
5706 if Pos
> Nb_Predef_Prims
then
5707 Nb_Predef_Prims
:= Pos
;
5711 Next_Elmt
(Prim_Elmt
);
5717 (Nat
range 1 .. Nb_Predef_Prims
) of Entity_Id
;
5722 Prim_Ops_Aggr_List
:= New_List
;
5724 Prim_Table
:= (others => Empty
);
5726 if Building_Static_DT
(Typ
) then
5727 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5728 while Present
(Prim_Elmt
) loop
5729 Prim
:= Node
(Prim_Elmt
);
5731 if Is_Predefined_Dispatching_Operation
(Prim
)
5732 and then not Is_Abstract_Subprogram
(Prim
)
5733 and then not Is_Eliminated
(Prim
)
5734 and then not Present
(Prim_Table
5735 (UI_To_Int
(DT_Position
(Prim
))))
5737 E
:= Ultimate_Alias
(Prim
);
5738 pragma Assert
(not Is_Abstract_Subprogram
(E
));
5739 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) := E
;
5742 Next_Elmt
(Prim_Elmt
);
5746 for J
in Prim_Table
'Range loop
5747 if Present
(Prim_Table
(J
)) then
5749 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
5750 Make_Attribute_Reference
(Loc
,
5752 New_Occurrence_Of
(Prim_Table
(J
), Loc
),
5753 Attribute_Name
=> Name_Unrestricted_Access
));
5755 New_Node
:= Make_Null
(Loc
);
5758 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
5762 Make_Aggregate
(Loc
,
5763 Expressions
=> Prim_Ops_Aggr_List
);
5766 Make_Subtype_Declaration
(Loc
,
5767 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
5768 Subtype_Indication
=>
5769 New_Occurrence_Of
(RTE
(RE_Address_Array
), Loc
));
5771 Append_To
(Result
, Decl
);
5774 Make_Object_Declaration
(Loc
,
5775 Defining_Identifier
=> Predef_Prims
,
5776 Aliased_Present
=> True,
5777 Constant_Present
=> Building_Static_DT
(Typ
),
5778 Object_Definition
=>
5779 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
),
5780 Expression
=> New_Node
));
5782 -- Remember aggregates initializing dispatch tables
5784 Append_Elmt
(New_Node
, DT_Aggr
);
5787 Make_Attribute_Definition_Clause
(Loc
,
5788 Name
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
5789 Chars
=> Name_Alignment
,
5791 Make_Attribute_Reference
(Loc
,
5793 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5794 Attribute_Name
=> Name_Alignment
)));
5798 -- Stage 1: Initialize the discriminant and the record components
5800 DT_Constr_List
:= New_List
;
5801 DT_Aggr_List
:= New_List
;
5803 -- Num_Prims. If the tagged type has no primitives we add a dummy
5804 -- slot whose address will be the tag of this type.
5807 New_Node
:= Make_Integer_Literal
(Loc
, 1);
5809 New_Node
:= Make_Integer_Literal
(Loc
, Nb_Prim
);
5812 Append_To
(DT_Constr_List
, New_Node
);
5813 Append_To
(DT_Aggr_List
, New_Copy
(New_Node
));
5817 if RTE_Record_Component_Available
(RE_Signature
) then
5818 Append_To
(DT_Aggr_List
,
5819 New_Occurrence_Of
(RTE
(RE_Primary_DT
), Loc
));
5824 if RTE_Record_Component_Available
(RE_Tag_Kind
) then
5825 Append_To
(DT_Aggr_List
, Tagged_Kind
(Typ
));
5830 Append_To
(DT_Aggr_List
,
5831 Make_Attribute_Reference
(Loc
,
5832 Prefix
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
5833 Attribute_Name
=> Name_Address
));
5837 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
5841 Append_To
(DT_Aggr_List
,
5842 Make_Attribute_Reference
(Loc
,
5843 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
5844 Attribute_Name
=> Name_Address
));
5846 -- Stage 2: Initialize the table of user-defined primitive operations
5848 Prim_Ops_Aggr_List
:= New_List
;
5851 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
5853 elsif not Building_Static_DT
(Typ
) then
5854 for J
in 1 .. Nb_Prim
loop
5855 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
5860 CPP_Nb_Prims
: constant Nat
:= CPP_Num_Prims
(Typ
);
5863 Prim_Elmt
: Elmt_Id
;
5865 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
5868 Prim_Table
:= (others => Empty
);
5870 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5871 while Present
(Prim_Elmt
) loop
5872 Prim
:= Node
(Prim_Elmt
);
5874 -- Retrieve the ultimate alias of the primitive for proper
5875 -- handling of renamings and eliminated primitives.
5877 E
:= Ultimate_Alias
(Prim
);
5878 Prim_Pos
:= UI_To_Int
(DT_Position
(E
));
5880 -- Skip predefined primitives because they are located in a
5881 -- separate dispatch table.
5883 if not Is_Predefined_Dispatching_Operation
(Prim
)
5884 and then not Is_Predefined_Dispatching_Operation
(E
)
5886 -- Skip entities with attribute Interface_Alias because
5887 -- those are only required to build secondary dispatch
5890 and then not Present
(Interface_Alias
(Prim
))
5892 -- Skip abstract and eliminated primitives
5894 and then not Is_Abstract_Subprogram
(E
)
5895 and then not Is_Eliminated
(E
)
5897 -- For derivations of CPP types skip primitives located in
5898 -- the C++ part of the dispatch table because their slots
5899 -- are initialized by the IC routine.
5901 and then (not Is_CPP_Class
(Root_Type
(Typ
))
5902 or else Prim_Pos
> CPP_Nb_Prims
)
5904 -- Skip ignored Ghost subprograms as those will be removed
5905 -- from the executable.
5907 and then not Is_Ignored_Ghost_Entity
(E
)
5910 (UI_To_Int
(DT_Position
(Prim
)) <= Nb_Prim
);
5912 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) := E
;
5915 Next_Elmt
(Prim_Elmt
);
5918 for J
in Prim_Table
'Range loop
5919 if Present
(Prim_Table
(J
)) then
5921 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
5922 Make_Attribute_Reference
(Loc
,
5924 New_Occurrence_Of
(Prim_Table
(J
), Loc
),
5925 Attribute_Name
=> Name_Unrestricted_Access
));
5927 New_Node
:= Make_Null
(Loc
);
5930 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
5936 Make_Aggregate
(Loc
,
5937 Expressions
=> Prim_Ops_Aggr_List
);
5939 Append_To
(DT_Aggr_List
, New_Node
);
5941 -- Remember aggregates initializing dispatch tables
5943 Append_Elmt
(New_Node
, DT_Aggr
);
5945 -- In case of locally defined tagged types we have already declared
5946 -- and uninitialized object for the dispatch table, which is now
5947 -- initialized by means of an assignment.
5949 if not Building_Static_DT
(Typ
) then
5951 Make_Assignment_Statement
(Loc
,
5952 Name
=> New_Occurrence_Of
(DT
, Loc
),
5953 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5955 -- In case of library level tagged types we declare now and export
5956 -- the constant object containing the dispatch table.
5960 Make_Object_Declaration
(Loc
,
5961 Defining_Identifier
=> DT
,
5962 Aliased_Present
=> True,
5963 Constant_Present
=> True,
5964 Object_Definition
=>
5965 Make_Subtype_Indication
(Loc
,
5966 Subtype_Mark
=> New_Occurrence_Of
5967 (RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
5968 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
5969 Constraints
=> DT_Constr_List
)),
5970 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5973 Make_Attribute_Definition_Clause
(Loc
,
5974 Name
=> New_Occurrence_Of
(DT
, Loc
),
5975 Chars
=> Name_Alignment
,
5977 Make_Attribute_Reference
(Loc
,
5979 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5980 Attribute_Name
=> Name_Alignment
)));
5982 Export_DT
(Typ
, DT
);
5986 -- Initialize the table of ancestor tags if not building static
5989 if not Building_Static_DT
(Typ
)
5990 and then not Is_Interface
(Typ
)
5991 and then not Is_CPP_Class
(Typ
)
5994 Make_Assignment_Statement
(Loc
,
5996 Make_Indexed_Component
(Loc
,
5998 Make_Selected_Component
(Loc
,
5999 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6002 (RTE_Record_Component
(RE_Tags_Table
), Loc
)),
6004 New_List
(Make_Integer_Literal
(Loc
, 0))),
6008 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
)));
6011 -- Inherit the dispatch tables of the parent. There is no need to
6012 -- inherit anything from the parent when building static dispatch tables
6013 -- because the whole dispatch table (including inherited primitives) has
6014 -- been already built.
6016 if Building_Static_DT
(Typ
) then
6019 -- If the ancestor is a CPP_Class type we inherit the dispatch tables
6020 -- in the init proc, and we don't need to fill them in here.
6022 elsif Is_CPP_Class
(Parent_Typ
) then
6025 -- Otherwise we fill in the dispatch tables here
6028 if Typ
/= Parent_Typ
6029 and then not Is_Interface
(Typ
)
6030 and then not Restriction_Active
(No_Dispatching_Calls
)
6032 -- Inherit the dispatch table
6034 if not Is_Interface
(Typ
)
6035 and then not Is_Interface
(Parent_Typ
)
6036 and then not Is_CPP_Class
(Parent_Typ
)
6039 Nb_Prims
: constant Int
:=
6040 UI_To_Int
(DT_Entry_Count
6041 (First_Tag_Component
(Parent_Typ
)));
6044 Append_To
(Elab_Code
,
6045 Build_Inherit_Predefined_Prims
(Loc
,
6051 (Access_Disp_Table
(Parent_Typ
)))), Loc
),
6057 (Access_Disp_Table
(Typ
)))), Loc
)));
6059 if Nb_Prims
/= 0 then
6060 Append_To
(Elab_Code
,
6061 Build_Inherit_Prims
(Loc
,
6067 (Access_Disp_Table
(Parent_Typ
))), Loc
),
6068 New_Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
6069 Num_Prims
=> Nb_Prims
));
6074 -- Inherit the secondary dispatch tables of the ancestor
6076 if not Is_CPP_Class
(Parent_Typ
) then
6078 Sec_DT_Ancestor
: Elmt_Id
:=
6084 Sec_DT_Typ
: Elmt_Id
:=
6088 (Access_Disp_Table
(Typ
))));
6090 procedure Copy_Secondary_DTs
(Typ
: Entity_Id
);
6091 -- Local procedure required to climb through the ancestors
6092 -- and copy the contents of all their secondary dispatch
6095 ------------------------
6096 -- Copy_Secondary_DTs --
6097 ------------------------
6099 procedure Copy_Secondary_DTs
(Typ
: Entity_Id
) is
6104 -- Climb to the ancestor (if any) handling private types
6106 if Present
(Full_View
(Etype
(Typ
))) then
6107 if Full_View
(Etype
(Typ
)) /= Typ
then
6108 Copy_Secondary_DTs
(Full_View
(Etype
(Typ
)));
6111 elsif Etype
(Typ
) /= Typ
then
6112 Copy_Secondary_DTs
(Etype
(Typ
));
6115 if Present
(Interfaces
(Typ
))
6116 and then not Is_Empty_Elmt_List
(Interfaces
(Typ
))
6118 Iface
:= First_Elmt
(Interfaces
(Typ
));
6119 E
:= First_Entity
(Typ
);
6121 and then Present
(Node
(Sec_DT_Ancestor
))
6122 and then Ekind
(Node
(Sec_DT_Ancestor
)) = E_Constant
6124 if Is_Tag
(E
) and then Chars
(E
) /= Name_uTag
then
6126 Num_Prims
: constant Int
:=
6127 UI_To_Int
(DT_Entry_Count
(E
));
6130 if not Is_Interface
(Etype
(Typ
)) then
6132 -- Inherit first secondary dispatch table
6134 Append_To
(Elab_Code
,
6135 Build_Inherit_Predefined_Prims
(Loc
,
6137 Unchecked_Convert_To
(RTE
(RE_Tag
),
6140 (Next_Elmt
(Sec_DT_Ancestor
)),
6143 Unchecked_Convert_To
(RTE
(RE_Tag
),
6145 (Node
(Next_Elmt
(Sec_DT_Typ
)),
6148 if Num_Prims
/= 0 then
6149 Append_To
(Elab_Code
,
6150 Build_Inherit_Prims
(Loc
,
6151 Typ
=> Node
(Iface
),
6153 Unchecked_Convert_To
6156 (Node
(Sec_DT_Ancestor
),
6159 Unchecked_Convert_To
6162 (Node
(Sec_DT_Typ
), Loc
)),
6163 Num_Prims
=> Num_Prims
));
6167 Next_Elmt
(Sec_DT_Ancestor
);
6168 Next_Elmt
(Sec_DT_Typ
);
6170 -- Skip the secondary dispatch table of
6171 -- predefined primitives
6173 Next_Elmt
(Sec_DT_Ancestor
);
6174 Next_Elmt
(Sec_DT_Typ
);
6176 if not Is_Interface
(Etype
(Typ
)) then
6178 -- Inherit second secondary dispatch table
6180 Append_To
(Elab_Code
,
6181 Build_Inherit_Predefined_Prims
(Loc
,
6183 Unchecked_Convert_To
(RTE
(RE_Tag
),
6186 (Next_Elmt
(Sec_DT_Ancestor
)),
6189 Unchecked_Convert_To
(RTE
(RE_Tag
),
6191 (Node
(Next_Elmt
(Sec_DT_Typ
)),
6194 if Num_Prims
/= 0 then
6195 Append_To
(Elab_Code
,
6196 Build_Inherit_Prims
(Loc
,
6197 Typ
=> Node
(Iface
),
6199 Unchecked_Convert_To
6202 (Node
(Sec_DT_Ancestor
),
6205 Unchecked_Convert_To
6208 (Node
(Sec_DT_Typ
), Loc
)),
6209 Num_Prims
=> Num_Prims
));
6214 Next_Elmt
(Sec_DT_Ancestor
);
6215 Next_Elmt
(Sec_DT_Typ
);
6217 -- Skip the secondary dispatch table of
6218 -- predefined primitives
6220 Next_Elmt
(Sec_DT_Ancestor
);
6221 Next_Elmt
(Sec_DT_Typ
);
6229 end Copy_Secondary_DTs
;
6232 if Present
(Node
(Sec_DT_Ancestor
))
6233 and then Ekind
(Node
(Sec_DT_Ancestor
)) = E_Constant
6235 -- Handle private types
6237 if Present
(Full_View
(Typ
)) then
6238 Copy_Secondary_DTs
(Full_View
(Typ
));
6240 Copy_Secondary_DTs
(Typ
);
6248 -- Generate code to check if the external tag of this type is the same
6249 -- as the external tag of some other declaration.
6251 -- Check_TSD (TSD'Unrestricted_Access);
6253 -- This check is a consequence of AI05-0113-1/06, so it officially
6254 -- applies to Ada 2005 (and Ada 2012). It might be argued that it is
6255 -- a desirable check to add in Ada 95 mode, but we hesitate to make
6256 -- this change, as it would be incompatible, and could conceivably
6257 -- cause a problem in existing Aa 95 code.
6259 -- We check for No_Run_Time_Mode here, because we do not want to pick
6260 -- up the RE_Check_TSD entity and call it in No_Run_Time mode.
6262 if not No_Run_Time_Mode
6263 and then Ada_Version
>= Ada_2005
6264 and then RTE_Available
(RE_Check_TSD
)
6265 and then not Duplicated_Tag_Checks_Suppressed
(Typ
)
6267 Append_To
(Elab_Code
,
6268 Make_Procedure_Call_Statement
(Loc
,
6270 New_Occurrence_Of
(RTE
(RE_Check_TSD
), Loc
),
6271 Parameter_Associations
=> New_List
(
6272 Make_Attribute_Reference
(Loc
,
6273 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6274 Attribute_Name
=> Name_Unchecked_Access
))));
6277 -- Generate code to register the Tag in the External_Tag hash table for
6278 -- the pure Ada type only.
6280 -- Register_Tag (Dt_Ptr);
6282 -- Skip this action in the following cases:
6283 -- 1) if Register_Tag is not available.
6284 -- 2) in No_Run_Time mode.
6285 -- 3) if Typ is not defined at the library level (this is required
6286 -- to avoid adding concurrency control to the hash table used
6287 -- by the run-time to register the tags).
6289 if not No_Run_Time_Mode
6290 and then Is_Library_Level_Entity
(Typ
)
6291 and then RTE_Available
(RE_Register_Tag
)
6293 Append_To
(Elab_Code
,
6294 Make_Procedure_Call_Statement
(Loc
,
6296 New_Occurrence_Of
(RTE
(RE_Register_Tag
), Loc
),
6297 Parameter_Associations
=>
6298 New_List
(New_Occurrence_Of
(DT_Ptr
, Loc
))));
6301 if not Is_Empty_List
(Elab_Code
) then
6302 Append_List_To
(Result
, Elab_Code
);
6305 -- Populate the two auxiliary tables used for dispatching asynchronous,
6306 -- conditional and timed selects for synchronized types that implement
6307 -- a limited interface. Skip this step in Ravenscar profile or when
6308 -- general dispatching is forbidden.
6310 if Ada_Version
>= Ada_2005
6311 and then Is_Concurrent_Record_Type
(Typ
)
6312 and then Has_Interfaces
(Typ
)
6313 and then not Restriction_Active
(No_Dispatching_Calls
)
6314 and then not Restriction_Active
(No_Select_Statements
)
6316 Append_List_To
(Result
,
6317 Make_Select_Specific_Data_Table
(Typ
));
6320 -- Remember entities containing dispatch tables
6322 Append_Elmt
(Predef_Prims
, DT_Decl
);
6323 Append_Elmt
(DT
, DT_Decl
);
6325 Analyze_List
(Result
, Suppress
=> All_Checks
);
6326 Set_Has_Dispatch_Table
(Typ
);
6328 -- Mark entities containing dispatch tables. Required by the backend to
6329 -- handle them properly.
6331 if Has_DT
(Typ
) then
6336 -- Object declarations
6338 Elmt
:= First_Elmt
(DT_Decl
);
6339 while Present
(Elmt
) loop
6340 Set_Is_Dispatch_Table_Entity
(Node
(Elmt
));
6341 pragma Assert
(Ekind
(Etype
(Node
(Elmt
))) = E_Array_Subtype
6342 or else Ekind
(Etype
(Node
(Elmt
))) = E_Record_Subtype
);
6343 Set_Is_Dispatch_Table_Entity
(Etype
(Node
(Elmt
)));
6347 -- Aggregates initializing dispatch tables
6349 Elmt
:= First_Elmt
(DT_Aggr
);
6350 while Present
(Elmt
) loop
6351 Set_Is_Dispatch_Table_Entity
(Etype
(Node
(Elmt
)));
6359 -- Register the tagged type in the call graph nodes table
6361 Register_CG_Node
(Typ
);
6364 Restore_Ghost_Mode
(Saved_GM
);
6369 -------------------------------------
6370 -- Make_Select_Specific_Data_Table --
6371 -------------------------------------
6373 function Make_Select_Specific_Data_Table
6374 (Typ
: Entity_Id
) return List_Id
6376 Assignments
: constant List_Id
:= New_List
;
6377 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6379 Conc_Typ
: Entity_Id
;
6380 Decls
: List_Id
:= No_List
;
6382 Prim_Als
: Entity_Id
;
6383 Prim_Elmt
: Elmt_Id
;
6387 type Examined_Array
is array (Int
range <>) of Boolean;
6389 function Find_Entry_Index
(E
: Entity_Id
) return Uint
;
6390 -- Given an entry, find its index in the visible declarations of the
6391 -- corresponding concurrent type of Typ.
6393 ----------------------
6394 -- Find_Entry_Index --
6395 ----------------------
6397 function Find_Entry_Index
(E
: Entity_Id
) return Uint
is
6398 Index
: Uint
:= Uint_1
;
6399 Subp_Decl
: Entity_Id
;
6403 and then not Is_Empty_List
(Decls
)
6405 Subp_Decl
:= First
(Decls
);
6406 while Present
(Subp_Decl
) loop
6407 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
6408 if Defining_Identifier
(Subp_Decl
) = E
then
6420 end Find_Entry_Index
;
6426 -- Start of processing for Make_Select_Specific_Data_Table
6429 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
6431 if Present
(Corresponding_Concurrent_Type
(Typ
)) then
6432 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
6434 if Present
(Full_View
(Conc_Typ
)) then
6435 Conc_Typ
:= Full_View
(Conc_Typ
);
6438 if Ekind
(Conc_Typ
) = E_Protected_Type
then
6439 Decls
:= Visible_Declarations
(Protected_Definition
(
6440 Parent
(Conc_Typ
)));
6442 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
6443 Decls
:= Visible_Declarations
(Task_Definition
(
6444 Parent
(Conc_Typ
)));
6448 -- Count the non-predefined primitive operations
6450 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6451 while Present
(Prim_Elmt
) loop
6452 Prim
:= Node
(Prim_Elmt
);
6454 if not (Is_Predefined_Dispatching_Operation
(Prim
)
6455 or else Is_Predefined_Dispatching_Alias
(Prim
))
6457 Nb_Prim
:= Nb_Prim
+ 1;
6460 Next_Elmt
(Prim_Elmt
);
6464 Examined
: Examined_Array
(1 .. Nb_Prim
) := (others => False);
6467 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6468 while Present
(Prim_Elmt
) loop
6469 Prim
:= Node
(Prim_Elmt
);
6471 -- Look for primitive overriding an abstract interface subprogram
6473 if Present
(Interface_Alias
(Prim
))
6476 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
6477 Use_Full_View
=> True)
6478 and then not Examined
(UI_To_Int
(DT_Position
(Alias
(Prim
))))
6480 Prim_Pos
:= DT_Position
(Alias
(Prim
));
6481 pragma Assert
(UI_To_Int
(Prim_Pos
) <= Nb_Prim
);
6482 Examined
(UI_To_Int
(Prim_Pos
)) := True;
6484 -- Set the primitive operation kind regardless of subprogram
6486 -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
6488 if Tagged_Type_Expansion
then
6491 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
);
6495 Make_Attribute_Reference
(Loc
,
6496 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6497 Attribute_Name
=> Name_Tag
);
6500 Append_To
(Assignments
,
6501 Make_Procedure_Call_Statement
(Loc
,
6502 Name
=> New_Occurrence_Of
(RTE
(RE_Set_Prim_Op_Kind
), Loc
),
6503 Parameter_Associations
=> New_List
(
6505 Make_Integer_Literal
(Loc
, Prim_Pos
),
6506 Prim_Op_Kind
(Alias
(Prim
), Typ
))));
6508 -- Retrieve the root of the alias chain
6510 Prim_Als
:= Ultimate_Alias
(Prim
);
6512 -- In the case of an entry wrapper, set the entry index
6514 if Ekind
(Prim
) = E_Procedure
6515 and then Is_Primitive_Wrapper
(Prim_Als
)
6516 and then Ekind
(Wrapped_Entity
(Prim_Als
)) = E_Entry
6519 -- Ada.Tags.Set_Entry_Index
6520 -- (DT_Ptr, <position>, <index>);
6522 if Tagged_Type_Expansion
then
6525 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
);
6528 Make_Attribute_Reference
(Loc
,
6529 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6530 Attribute_Name
=> Name_Tag
);
6533 Append_To
(Assignments
,
6534 Make_Procedure_Call_Statement
(Loc
,
6536 New_Occurrence_Of
(RTE
(RE_Set_Entry_Index
), Loc
),
6537 Parameter_Associations
=> New_List
(
6539 Make_Integer_Literal
(Loc
, Prim_Pos
),
6540 Make_Integer_Literal
(Loc
,
6541 Find_Entry_Index
(Wrapped_Entity
(Prim_Als
))))));
6545 Next_Elmt
(Prim_Elmt
);
6550 end Make_Select_Specific_Data_Table
;
6556 function Make_Tags
(Typ
: Entity_Id
) return List_Id
is
6557 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6558 Result
: constant List_Id
:= New_List
;
6561 (Tag_Typ
: Entity_Id
;
6563 Is_Secondary_DT
: Boolean);
6564 -- Import the dispatch table DT of tagged type Tag_Typ. Required to
6565 -- generate forward references and statically allocate the table. For
6566 -- primary dispatch tables that require no dispatch table generate:
6568 -- DT : static aliased constant Non_Dispatch_Table_Wrapper;
6569 -- pragma Import (Ada, DT);
6571 -- Otherwise generate:
6573 -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
6574 -- pragma Import (Ada, DT);
6581 (Tag_Typ
: Entity_Id
;
6583 Is_Secondary_DT
: Boolean)
6585 DT_Constr_List
: List_Id
;
6589 Set_Is_Imported
(DT
);
6590 Set_Ekind
(DT
, E_Constant
);
6591 Set_Related_Type
(DT
, Typ
);
6593 -- The scope must be set now to call Get_External_Name
6595 Set_Scope
(DT
, Current_Scope
);
6597 Get_External_Name
(DT
);
6598 Set_Interface_Name
(DT
,
6599 Make_String_Literal
(Loc
, Strval
=> String_From_Name_Buffer
));
6601 -- Ensure proper Sprint output of this implicit importation
6603 Set_Is_Internal
(DT
);
6605 -- Save this entity to allow Make_DT to generate its exportation
6607 Append_Elmt
(DT
, Dispatch_Table_Wrappers
(Typ
));
6609 -- No dispatch table required
6611 if not Is_Secondary_DT
and then not Has_DT
(Tag_Typ
) then
6613 Make_Object_Declaration
(Loc
,
6614 Defining_Identifier
=> DT
,
6615 Aliased_Present
=> True,
6616 Constant_Present
=> True,
6617 Object_Definition
=>
6619 (RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
)));
6622 -- Calculate the number of primitives of the dispatch table and
6623 -- the size of the Type_Specific_Data record.
6626 UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Tag_Typ
)));
6628 -- If the tagged type has no primitives we add a dummy slot whose
6629 -- address will be the tag of this type.
6633 New_List
(Make_Integer_Literal
(Loc
, 1));
6636 New_List
(Make_Integer_Literal
(Loc
, Nb_Prim
));
6640 Make_Object_Declaration
(Loc
,
6641 Defining_Identifier
=> DT
,
6642 Aliased_Present
=> True,
6643 Constant_Present
=> True,
6644 Object_Definition
=>
6645 Make_Subtype_Indication
(Loc
,
6647 New_Occurrence_Of
(RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
6648 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
6649 Constraints
=> DT_Constr_List
))));
6655 Tname
: constant Name_Id
:= Chars
(Typ
);
6656 AI_Tag_Comp
: Elmt_Id
;
6657 DT
: Node_Id
:= Empty
;
6659 Predef_Prims_Ptr
: Node_Id
;
6660 Iface_DT
: Node_Id
:= Empty
;
6661 Iface_DT_Ptr
: Node_Id
;
6665 Typ_Comps
: Elist_Id
;
6667 -- Start of processing for Make_Tags
6670 pragma Assert
(No
(Access_Disp_Table
(Typ
)));
6671 Set_Access_Disp_Table
(Typ
, New_Elmt_List
);
6673 -- 1) Generate the primary tag entities
6675 -- Primary dispatch table containing user-defined primitives
6677 DT_Ptr
:= Make_Defining_Identifier
(Loc
, New_External_Name
(Tname
, 'P'));
6678 Set_Etype
(DT_Ptr
, RTE
(RE_Tag
));
6679 Append_Elmt
(DT_Ptr
, Access_Disp_Table
(Typ
));
6681 -- Minimum decoration
6683 Set_Ekind
(DT_Ptr
, E_Variable
);
6684 Set_Related_Type
(DT_Ptr
, Typ
);
6686 -- Notify back end that the types are associated with a dispatch table
6688 Set_Is_Dispatch_Table_Entity
(RTE
(RE_Prim_Ptr
));
6689 Set_Is_Dispatch_Table_Entity
(RTE
(RE_Predef_Prims_Table_Ptr
));
6691 -- For CPP types there is no need to build the dispatch tables since
6692 -- they are imported from the C++ side. If the CPP type has an IP then
6693 -- we declare now the variable that will store the copy of the C++ tag.
6694 -- If the CPP type is an interface, we need the variable as well because
6695 -- it becomes the pointer to the corresponding secondary table.
6697 if Is_CPP_Class
(Typ
) then
6698 if Has_CPP_Constructors
(Typ
) or else Is_Interface
(Typ
) then
6700 Make_Object_Declaration
(Loc
,
6701 Defining_Identifier
=> DT_Ptr
,
6702 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
6704 Unchecked_Convert_To
(RTE
(RE_Tag
),
6705 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
6707 Set_Is_Statically_Allocated
(DT_Ptr
,
6708 Is_Library_Level_Tagged_Type
(Typ
));
6714 -- Primary dispatch table containing predefined primitives
6717 Make_Defining_Identifier
(Loc
,
6718 Chars
=> New_External_Name
(Tname
, 'Y'));
6719 Set_Etype
(Predef_Prims_Ptr
, RTE
(RE_Address
));
6720 Append_Elmt
(Predef_Prims_Ptr
, Access_Disp_Table
(Typ
));
6722 -- Import the forward declaration of the Dispatch Table wrapper
6723 -- record (Make_DT will take care of exporting it).
6725 if Building_Static_DT
(Typ
) then
6726 Set_Dispatch_Table_Wrappers
(Typ
, New_Elmt_List
);
6729 Make_Defining_Identifier
(Loc
,
6730 Chars
=> New_External_Name
(Tname
, 'T'));
6732 Import_DT
(Typ
, DT
, Is_Secondary_DT
=> False);
6734 if Has_DT
(Typ
) then
6736 Make_Object_Declaration
(Loc
,
6737 Defining_Identifier
=> DT_Ptr
,
6738 Constant_Present
=> True,
6739 Object_Definition
=>
6740 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
6742 Unchecked_Convert_To
(RTE
(RE_Tag
),
6743 Make_Attribute_Reference
(Loc
,
6745 Make_Selected_Component
(Loc
,
6746 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
6749 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
6750 Attribute_Name
=> Name_Address
))));
6752 -- Generate the SCIL node for the previous object declaration
6753 -- because it has a tag initialization.
6755 if Generate_SCIL
then
6757 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
6758 Set_SCIL_Entity
(New_Node
, Typ
);
6759 Set_SCIL_Node
(Last
(Result
), New_Node
);
6763 Make_Object_Declaration
(Loc
,
6764 Defining_Identifier
=> Predef_Prims_Ptr
,
6765 Constant_Present
=> True,
6766 Object_Definition
=>
6767 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
6769 Make_Attribute_Reference
(Loc
,
6771 Make_Selected_Component
(Loc
,
6772 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
6775 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
6776 Attribute_Name
=> Name_Address
)));
6778 -- No dispatch table required
6782 Make_Object_Declaration
(Loc
,
6783 Defining_Identifier
=> DT_Ptr
,
6784 Constant_Present
=> True,
6785 Object_Definition
=>
6786 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
6788 Unchecked_Convert_To
(RTE
(RE_Tag
),
6789 Make_Attribute_Reference
(Loc
,
6791 Make_Selected_Component
(Loc
,
6792 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
6795 (RTE_Record_Component
(RE_NDT_Prims_Ptr
),
6797 Attribute_Name
=> Name_Address
))));
6800 Set_Is_True_Constant
(DT_Ptr
);
6801 Set_Is_Statically_Allocated
(DT_Ptr
);
6805 -- 2) Generate the secondary tag entities
6807 -- Collect the components associated with secondary dispatch tables
6809 if Has_Interfaces
(Typ
) then
6810 Collect_Interface_Components
(Typ
, Typ_Comps
);
6812 -- For each interface type we build a unique external name associated
6813 -- with its secondary dispatch table. This name is used to declare an
6814 -- object that references this secondary dispatch table, whose value
6815 -- will be used for the elaboration of Typ objects, and also for the
6816 -- elaboration of objects of types derived from Typ that do not
6817 -- override the primitives of this interface type.
6821 -- Note: The value of Suffix_Index must be in sync with the values of
6822 -- Suffix_Index in secondary dispatch tables generated by Make_DT.
6824 if Is_CPP_Class
(Typ
) then
6825 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
6826 while Present
(AI_Tag_Comp
) loop
6827 Get_Secondary_DT_External_Name
6828 (Typ
, Related_Type
(Node
(AI_Tag_Comp
)), Suffix_Index
);
6829 Typ_Name
:= Name_Find
;
6831 -- Declare variables to store copy of the C++ secondary tags
6834 Make_Defining_Identifier
(Loc
,
6835 Chars
=> New_External_Name
(Typ_Name
, 'P'));
6836 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
6837 Set_Ekind
(Iface_DT_Ptr
, E_Variable
);
6838 Set_Is_Tag
(Iface_DT_Ptr
);
6840 Set_Has_Thunks
(Iface_DT_Ptr
);
6842 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
6843 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
6846 Make_Object_Declaration
(Loc
,
6847 Defining_Identifier
=> Iface_DT_Ptr
,
6848 Object_Definition
=> New_Occurrence_Of
6849 (RTE
(RE_Interface_Tag
), Loc
),
6851 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
6852 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
6854 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
6855 Is_Library_Level_Tagged_Type
(Typ
));
6857 Next_Elmt
(AI_Tag_Comp
);
6860 -- This is not a CPP_Class type
6863 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
6864 while Present
(AI_Tag_Comp
) loop
6865 Get_Secondary_DT_External_Name
6866 (Typ
, Related_Type
(Node
(AI_Tag_Comp
)), Suffix_Index
);
6867 Typ_Name
:= Name_Find
;
6869 if Building_Static_DT
(Typ
) then
6871 Make_Defining_Identifier
(Loc
,
6872 Chars
=> New_External_Name
(Typ_Name
, 'T'));
6874 (Tag_Typ
=> Related_Type
(Node
(AI_Tag_Comp
)),
6876 Is_Secondary_DT
=> True);
6879 -- Secondary dispatch table referencing thunks to user-defined
6880 -- primitives covered by this interface.
6883 Make_Defining_Identifier
(Loc
,
6884 Chars
=> New_External_Name
(Typ_Name
, 'P'));
6885 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
6886 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
6887 Set_Is_Tag
(Iface_DT_Ptr
);
6888 Set_Has_Thunks
(Iface_DT_Ptr
);
6889 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
6890 Is_Library_Level_Tagged_Type
(Typ
));
6891 Set_Is_True_Constant
(Iface_DT_Ptr
);
6893 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
6894 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
6896 if Building_Static_DT
(Typ
) then
6898 Make_Object_Declaration
(Loc
,
6899 Defining_Identifier
=> Iface_DT_Ptr
,
6900 Constant_Present
=> True,
6901 Object_Definition
=> New_Occurrence_Of
6902 (RTE
(RE_Interface_Tag
), Loc
),
6904 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
6905 Make_Attribute_Reference
(Loc
,
6907 Make_Selected_Component
(Loc
,
6909 New_Occurrence_Of
(Iface_DT
, Loc
),
6912 (RTE_Record_Component
(RE_Prims_Ptr
),
6914 Attribute_Name
=> Name_Address
))));
6917 -- Secondary dispatch table referencing thunks to predefined
6921 Make_Defining_Identifier
(Loc
,
6922 Chars
=> New_External_Name
(Typ_Name
, 'Y'));
6923 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Address
));
6924 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
6925 Set_Is_Tag
(Iface_DT_Ptr
);
6926 Set_Has_Thunks
(Iface_DT_Ptr
);
6927 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
6928 Is_Library_Level_Tagged_Type
(Typ
));
6929 Set_Is_True_Constant
(Iface_DT_Ptr
);
6931 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
6932 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
6934 -- Secondary dispatch table referencing user-defined primitives
6935 -- covered by this interface.
6938 Make_Defining_Identifier
(Loc
,
6939 Chars
=> New_External_Name
(Typ_Name
, 'D'));
6940 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
6941 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
6942 Set_Is_Tag
(Iface_DT_Ptr
);
6943 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
6944 Is_Library_Level_Tagged_Type
(Typ
));
6945 Set_Is_True_Constant
(Iface_DT_Ptr
);
6947 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
6948 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
6950 -- Secondary dispatch table referencing predefined primitives
6953 Make_Defining_Identifier
(Loc
,
6954 Chars
=> New_External_Name
(Typ_Name
, 'Z'));
6955 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Address
));
6956 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
6957 Set_Is_Tag
(Iface_DT_Ptr
);
6958 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
6959 Is_Library_Level_Tagged_Type
(Typ
));
6960 Set_Is_True_Constant
(Iface_DT_Ptr
);
6962 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
6963 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
6965 Next_Elmt
(AI_Tag_Comp
);
6970 -- 3) At the end of Access_Disp_Table, if the type has user-defined
6971 -- primitives, we add the entity of an access type declaration that
6972 -- is used by Build_Get_Prim_Op_Address to expand dispatching calls
6973 -- through the primary dispatch table.
6975 if UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Typ
))) = 0 then
6976 Analyze_List
(Result
);
6979 -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
6980 -- type Typ_DT_Acc is access Typ_DT;
6984 Name_DT_Prims
: constant Name_Id
:=
6985 New_External_Name
(Tname
, 'G');
6986 Name_DT_Prims_Acc
: constant Name_Id
:=
6987 New_External_Name
(Tname
, 'H');
6988 DT_Prims
: constant Entity_Id
:=
6989 Make_Defining_Identifier
(Loc
,
6991 DT_Prims_Acc
: constant Entity_Id
:=
6992 Make_Defining_Identifier
(Loc
,
6996 Make_Full_Type_Declaration
(Loc
,
6997 Defining_Identifier
=> DT_Prims
,
6999 Make_Constrained_Array_Definition
(Loc
,
7000 Discrete_Subtype_Definitions
=> New_List
(
7002 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
7003 High_Bound
=> Make_Integer_Literal
(Loc
,
7005 (First_Tag_Component
(Typ
))))),
7006 Component_Definition
=>
7007 Make_Component_Definition
(Loc
,
7008 Subtype_Indication
=>
7009 New_Occurrence_Of
(RTE
(RE_Prim_Ptr
), Loc
)))));
7012 Make_Full_Type_Declaration
(Loc
,
7013 Defining_Identifier
=> DT_Prims_Acc
,
7015 Make_Access_To_Object_Definition
(Loc
,
7016 Subtype_Indication
=>
7017 New_Occurrence_Of
(DT_Prims
, Loc
))));
7019 Append_Elmt
(DT_Prims_Acc
, Access_Disp_Table
(Typ
));
7021 -- Analyze the resulting list and suppress the generation of the
7022 -- Init_Proc associated with the above array declaration because
7023 -- this type is never used in object declarations. It is only used
7024 -- to simplify the expansion associated with dispatching calls.
7026 Analyze_List
(Result
);
7027 Set_Suppress_Initialization
(Base_Type
(DT_Prims
));
7029 -- Disable backend optimizations based on assumptions about the
7030 -- aliasing status of objects designated by the access to the
7031 -- dispatch table. Required to handle dispatch tables imported
7034 Set_No_Strict_Aliasing
(Base_Type
(DT_Prims_Acc
));
7036 -- Add the freezing nodes of these declarations; required to avoid
7037 -- generating these freezing nodes in wrong scopes (for example in
7038 -- the IC routine of a derivation of Typ).
7040 -- What is an "IC routine"? Is "init_proc" meant here???
7042 Append_List_To
(Result
, Freeze_Entity
(DT_Prims
, Typ
));
7043 Append_List_To
(Result
, Freeze_Entity
(DT_Prims_Acc
, Typ
));
7045 -- Mark entity of dispatch table. Required by the back end to
7046 -- handle them properly.
7048 Set_Is_Dispatch_Table_Entity
(DT_Prims
);
7052 -- Mark entities of dispatch table. Required by the back end to handle
7055 if Present
(DT
) then
7056 Set_Is_Dispatch_Table_Entity
(DT
);
7057 Set_Is_Dispatch_Table_Entity
(Etype
(DT
));
7060 if Present
(Iface_DT
) then
7061 Set_Is_Dispatch_Table_Entity
(Iface_DT
);
7062 Set_Is_Dispatch_Table_Entity
(Etype
(Iface_DT
));
7065 if Is_CPP_Class
(Root_Type
(Typ
)) then
7066 Set_Ekind
(DT_Ptr
, E_Variable
);
7068 Set_Ekind
(DT_Ptr
, E_Constant
);
7071 Set_Is_Tag
(DT_Ptr
);
7072 Set_Related_Type
(DT_Ptr
, Typ
);
7081 function New_Value
(From
: Node_Id
) return Node_Id
is
7082 Res
: constant Node_Id
:= Duplicate_Subexpr
(From
);
7084 if Is_Access_Type
(Etype
(From
)) then
7085 return Make_Explicit_Dereference
(Sloc
(From
), Prefix
=> Res
);
7091 -----------------------------------
7092 -- Original_View_In_Visible_Part --
7093 -----------------------------------
7095 function Original_View_In_Visible_Part
(Typ
: Entity_Id
) return Boolean is
7096 Scop
: constant Entity_Id
:= Scope
(Typ
);
7099 -- The scope must be a package
7101 if not Is_Package_Or_Generic_Package
(Scop
) then
7105 -- A type with a private declaration has a private view declared in
7106 -- the visible part.
7108 if Has_Private_Declaration
(Typ
) then
7112 return List_Containing
(Parent
(Typ
)) =
7113 Visible_Declarations
(Package_Specification
(Scop
));
7114 end Original_View_In_Visible_Part
;
7120 function Prim_Op_Kind
7122 Typ
: Entity_Id
) return Node_Id
7124 Full_Typ
: Entity_Id
:= Typ
;
7125 Loc
: constant Source_Ptr
:= Sloc
(Prim
);
7126 Prim_Op
: Entity_Id
;
7129 -- Retrieve the original primitive operation
7131 Prim_Op
:= Ultimate_Alias
(Prim
);
7133 if Ekind
(Typ
) = E_Record_Type
7134 and then Present
(Corresponding_Concurrent_Type
(Typ
))
7136 Full_Typ
:= Corresponding_Concurrent_Type
(Typ
);
7139 -- When a private tagged type is completed by a concurrent type,
7140 -- retrieve the full view.
7142 if Is_Private_Type
(Full_Typ
) then
7143 Full_Typ
:= Full_View
(Full_Typ
);
7146 if Ekind
(Prim_Op
) = E_Function
then
7148 -- Protected function
7150 if Ekind
(Full_Typ
) = E_Protected_Type
then
7151 return New_Occurrence_Of
(RTE
(RE_POK_Protected_Function
), Loc
);
7155 elsif Ekind
(Full_Typ
) = E_Task_Type
then
7156 return New_Occurrence_Of
(RTE
(RE_POK_Task_Function
), Loc
);
7161 return New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
);
7165 pragma Assert
(Ekind
(Prim_Op
) = E_Procedure
);
7167 if Ekind
(Full_Typ
) = E_Protected_Type
then
7171 if Is_Primitive_Wrapper
(Prim_Op
)
7172 and then Ekind
(Wrapped_Entity
(Prim_Op
)) = E_Entry
7174 return New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
);
7176 -- Protected procedure
7180 New_Occurrence_Of
(RTE
(RE_POK_Protected_Procedure
), Loc
);
7183 elsif Ekind
(Full_Typ
) = E_Task_Type
then
7187 if Is_Primitive_Wrapper
(Prim_Op
)
7188 and then Ekind
(Wrapped_Entity
(Prim_Op
)) = E_Entry
7190 return New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
);
7192 -- Task "procedure". These are the internally Expander-generated
7193 -- procedures (task body for instance).
7196 return New_Occurrence_Of
(RTE
(RE_POK_Task_Procedure
), Loc
);
7199 -- Regular procedure
7202 return New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
);
7207 ------------------------
7208 -- Register_Primitive --
7209 ------------------------
7211 function Register_Primitive
7213 Prim
: Entity_Id
) return List_Id
7216 Iface_Prim
: Entity_Id
;
7217 Iface_Typ
: Entity_Id
;
7218 Iface_DT_Ptr
: Entity_Id
;
7219 Iface_DT_Elmt
: Elmt_Id
;
7220 L
: constant List_Id
:= New_List
;
7223 Tag_Typ
: Entity_Id
;
7224 Thunk_Id
: Entity_Id
;
7225 Thunk_Code
: Node_Id
;
7228 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
7230 -- Do not register in the dispatch table eliminated primitives
7232 if not RTE_Available
(RE_Tag
)
7233 or else Is_Eliminated
(Ultimate_Alias
(Prim
))
7234 or else Generate_SCIL
7239 if not Present
(Interface_Alias
(Prim
)) then
7240 Tag_Typ
:= Scope
(DTC_Entity
(Prim
));
7241 Pos
:= DT_Position
(Prim
);
7242 Tag
:= First_Tag_Component
(Tag_Typ
);
7244 if Is_Predefined_Dispatching_Operation
(Prim
)
7245 or else Is_Predefined_Dispatching_Alias
(Prim
)
7248 Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Tag_Typ
))));
7251 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7252 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7255 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7256 Make_Attribute_Reference
(Loc
,
7257 Prefix
=> New_Occurrence_Of
(Prim
, Loc
),
7258 Attribute_Name
=> Name_Unrestricted_Access
))));
7260 -- Register copy of the pointer to the 'size primitive in the TSD
7262 if Chars
(Prim
) = Name_uSize
7263 and then RTE_Record_Component_Available
(RE_Size_Func
)
7265 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Tag_Typ
)));
7267 Build_Set_Size_Function
(Loc
,
7268 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7269 Size_Func
=> Prim
));
7273 pragma Assert
(Pos
/= Uint_0
and then Pos
<= DT_Entry_Count
(Tag
));
7275 -- Skip registration of primitives located in the C++ part of the
7276 -- dispatch table. Their slot is set by the IC routine.
7278 if not Is_CPP_Class
(Root_Type
(Tag_Typ
))
7279 or else Pos
> CPP_Num_Prims
(Tag_Typ
)
7281 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Tag_Typ
)));
7283 Build_Set_Prim_Op_Address
(Loc
,
7285 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7288 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7289 Make_Attribute_Reference
(Loc
,
7290 Prefix
=> New_Occurrence_Of
(Prim
, Loc
),
7291 Attribute_Name
=> Name_Unrestricted_Access
))));
7295 -- Ada 2005 (AI-251): Primitive associated with an interface type
7297 -- Generate the code of the thunk only if the interface type is not an
7298 -- immediate ancestor of Typ; otherwise the dispatch table associated
7299 -- with the interface is the primary dispatch table and we have nothing
7303 Tag_Typ
:= Find_Dispatching_Type
(Alias
(Prim
));
7304 Iface_Typ
:= Find_Dispatching_Type
(Interface_Alias
(Prim
));
7306 pragma Assert
(Is_Interface
(Iface_Typ
));
7308 -- No action needed for interfaces that are ancestors of Typ because
7309 -- their primitives are located in the primary dispatch table.
7311 if Is_Ancestor
(Iface_Typ
, Tag_Typ
, Use_Full_View
=> True) then
7314 -- No action needed for primitives located in the C++ part of the
7315 -- dispatch table. Their slot is set by the IC routine.
7317 elsif Is_CPP_Class
(Root_Type
(Tag_Typ
))
7318 and then DT_Position
(Alias
(Prim
)) <= CPP_Num_Prims
(Tag_Typ
)
7319 and then not Is_Predefined_Dispatching_Operation
(Prim
)
7320 and then not Is_Predefined_Dispatching_Alias
(Prim
)
7325 Expand_Interface_Thunk
(Prim
, Thunk_Id
, Thunk_Code
);
7327 if not Is_Ancestor
(Iface_Typ
, Tag_Typ
, Use_Full_View
=> True)
7328 and then Present
(Thunk_Code
)
7330 -- Generate the code necessary to fill the appropriate entry of
7331 -- the secondary dispatch table of Prim's controlling type with
7332 -- Thunk_Id's address.
7334 Iface_DT_Elmt
:= Find_Interface_ADT
(Tag_Typ
, Iface_Typ
);
7335 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7336 pragma Assert
(Has_Thunks
(Iface_DT_Ptr
));
7338 Iface_Prim
:= Interface_Alias
(Prim
);
7339 Pos
:= DT_Position
(Iface_Prim
);
7340 Tag
:= First_Tag_Component
(Iface_Typ
);
7342 Prepend_To
(L
, Thunk_Code
);
7344 if Is_Predefined_Dispatching_Operation
(Prim
)
7345 or else Is_Predefined_Dispatching_Alias
(Prim
)
7348 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7350 New_Occurrence_Of
(Node
(Next_Elmt
(Iface_DT_Elmt
)), Loc
),
7353 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7354 Make_Attribute_Reference
(Loc
,
7355 Prefix
=> New_Occurrence_Of
(Thunk_Id
, Loc
),
7356 Attribute_Name
=> Name_Unrestricted_Access
))));
7358 Next_Elmt
(Iface_DT_Elmt
);
7359 Next_Elmt
(Iface_DT_Elmt
);
7360 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7361 pragma Assert
(not Has_Thunks
(Iface_DT_Ptr
));
7364 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7366 New_Occurrence_Of
(Node
(Next_Elmt
(Iface_DT_Elmt
)), Loc
),
7369 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7370 Make_Attribute_Reference
(Loc
,
7372 New_Occurrence_Of
(Alias
(Prim
), Loc
),
7373 Attribute_Name
=> Name_Unrestricted_Access
))));
7376 pragma Assert
(Pos
/= Uint_0
7377 and then Pos
<= DT_Entry_Count
(Tag
));
7380 Build_Set_Prim_Op_Address
(Loc
,
7382 Tag_Node
=> New_Occurrence_Of
(Iface_DT_Ptr
, Loc
),
7385 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7386 Make_Attribute_Reference
(Loc
,
7387 Prefix
=> New_Occurrence_Of
(Thunk_Id
, Loc
),
7388 Attribute_Name
=> Name_Unrestricted_Access
))));
7390 Next_Elmt
(Iface_DT_Elmt
);
7391 Next_Elmt
(Iface_DT_Elmt
);
7392 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7393 pragma Assert
(not Has_Thunks
(Iface_DT_Ptr
));
7396 Build_Set_Prim_Op_Address
(Loc
,
7398 Tag_Node
=> New_Occurrence_Of
(Iface_DT_Ptr
, Loc
),
7401 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7402 Make_Attribute_Reference
(Loc
,
7404 New_Occurrence_Of
(Alias
(Prim
), Loc
),
7405 Attribute_Name
=> Name_Unrestricted_Access
))));
7412 end Register_Primitive
;
7414 -------------------------
7415 -- Set_All_DT_Position --
7416 -------------------------
7418 procedure Set_All_DT_Position
(Typ
: Entity_Id
) is
7420 function In_Predef_Prims_DT
(Prim
: Entity_Id
) return Boolean;
7421 -- Returns True if Prim is located in the dispatch table of
7422 -- predefined primitives
7424 procedure Validate_Position
(Prim
: Entity_Id
);
7425 -- Check that position assigned to Prim is completely safe (it has not
7426 -- been assigned to a previously defined primitive operation of Typ).
7428 ------------------------
7429 -- In_Predef_Prims_DT --
7430 ------------------------
7432 function In_Predef_Prims_DT
(Prim
: Entity_Id
) return Boolean is
7434 -- Predefined primitives
7436 if Is_Predefined_Dispatching_Operation
(Prim
) then
7439 -- Renamings of predefined primitives
7441 elsif Present
(Alias
(Prim
))
7442 and then Is_Predefined_Dispatching_Operation
(Ultimate_Alias
(Prim
))
7444 if Chars
(Ultimate_Alias
(Prim
)) /= Name_Op_Eq
then
7447 -- An overriding operation that is a user-defined renaming of
7448 -- predefined equality inherits its slot from the overridden
7449 -- operation. Otherwise it is treated as a predefined op and
7450 -- occupies the same predefined slot as equality. A call to it is
7451 -- transformed into a call to its alias, which is the predefined
7452 -- equality op. A dispatching call thus uses the proper slot if
7453 -- operation is further inherited and called with class-wide
7458 not Comes_From_Source
(Prim
)
7459 or else No
(Overridden_Operation
(Prim
));
7462 -- User-defined primitives
7467 end In_Predef_Prims_DT
;
7469 -----------------------
7470 -- Validate_Position --
7471 -----------------------
7473 procedure Validate_Position
(Prim
: Entity_Id
) is
7478 -- Aliased primitives are safe
7480 if Present
(Alias
(Prim
)) then
7484 Op_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
7485 while Present
(Op_Elmt
) loop
7486 Op
:= Node
(Op_Elmt
);
7488 -- No need to check against itself
7493 -- Primitive operations covering abstract interfaces are
7496 elsif Present
(Interface_Alias
(Op
)) then
7499 -- Predefined dispatching operations are completely safe. They
7500 -- are allocated at fixed positions in a separate table.
7502 elsif Is_Predefined_Dispatching_Operation
(Op
)
7503 or else Is_Predefined_Dispatching_Alias
(Op
)
7507 -- Aliased subprograms are safe
7509 elsif Present
(Alias
(Op
)) then
7512 elsif DT_Position
(Op
) = DT_Position
(Prim
)
7513 and then not Is_Predefined_Dispatching_Operation
(Op
)
7514 and then not Is_Predefined_Dispatching_Operation
(Prim
)
7515 and then not Is_Predefined_Dispatching_Alias
(Op
)
7516 and then not Is_Predefined_Dispatching_Alias
(Prim
)
7518 -- Handle aliased subprograms
7527 if Present
(Overridden_Operation
(Op_1
)) then
7528 Op_1
:= Overridden_Operation
(Op_1
);
7529 elsif Present
(Alias
(Op_1
)) then
7530 Op_1
:= Alias
(Op_1
);
7538 if Present
(Overridden_Operation
(Op_2
)) then
7539 Op_2
:= Overridden_Operation
(Op_2
);
7540 elsif Present
(Alias
(Op_2
)) then
7541 Op_2
:= Alias
(Op_2
);
7547 if Op_1
/= Op_2
then
7548 raise Program_Error
;
7553 Next_Elmt
(Op_Elmt
);
7555 end Validate_Position
;
7559 Parent_Typ
: constant Entity_Id
:= Etype
(Typ
);
7560 First_Prim
: constant Elmt_Id
:= First_Elmt
(Primitive_Operations
(Typ
));
7561 The_Tag
: constant Entity_Id
:= First_Tag_Component
(Typ
);
7563 Adjusted
: Boolean := False;
7564 Finalized
: Boolean := False;
7570 Prim_Elmt
: Elmt_Id
;
7572 -- Start of processing for Set_All_DT_Position
7575 pragma Assert
(Present
(First_Tag_Component
(Typ
)));
7577 -- Set the DT_Position for each primitive operation. Perform some sanity
7578 -- checks to avoid building inconsistent dispatch tables.
7580 -- First stage: Set DTC entity of all the primitive operations. This is
7581 -- required to properly read the DT_Position attribute in latter stages.
7583 Prim_Elmt
:= First_Prim
;
7585 while Present
(Prim_Elmt
) loop
7586 Prim
:= Node
(Prim_Elmt
);
7588 -- Predefined primitives have a separate dispatch table
7590 if not In_Predef_Prims_DT
(Prim
) then
7591 Count_Prim
:= Count_Prim
+ 1;
7594 Set_DTC_Entity_Value
(Typ
, Prim
);
7596 -- Clear any previous value of the DT_Position attribute. In this
7597 -- way we ensure that the final position of all the primitives is
7598 -- established by the following stages of this algorithm.
7600 Set_DT_Position_Value
(Prim
, No_Uint
);
7602 Next_Elmt
(Prim_Elmt
);
7606 Fixed_Prim
: array (Int
range 0 .. Count_Prim
) of Boolean :=
7611 procedure Handle_Inherited_Private_Subprograms
(Typ
: Entity_Id
);
7612 -- Called if Typ is declared in a nested package or a public child
7613 -- package to handle inherited primitives that were inherited by Typ
7614 -- in the visible part, but whose declaration was deferred because
7615 -- the parent operation was private and not visible at that point.
7617 procedure Set_Fixed_Prim
(Pos
: Nat
);
7618 -- Sets to true an element of the Fixed_Prim table to indicate
7619 -- that this entry of the dispatch table of Typ is occupied.
7621 ------------------------------------------
7622 -- Handle_Inherited_Private_Subprograms --
7623 ------------------------------------------
7625 procedure Handle_Inherited_Private_Subprograms
(Typ
: Entity_Id
) is
7628 Op_Elmt_2
: Elmt_Id
;
7629 Prim_Op
: Entity_Id
;
7630 Parent_Subp
: Entity_Id
;
7633 Op_List
:= Primitive_Operations
(Typ
);
7635 Op_Elmt
:= First_Elmt
(Op_List
);
7636 while Present
(Op_Elmt
) loop
7637 Prim_Op
:= Node
(Op_Elmt
);
7639 -- Search primitives that are implicit operations with an
7640 -- internal name whose parent operation has a normal name.
7642 if Present
(Alias
(Prim_Op
))
7643 and then Find_Dispatching_Type
(Alias
(Prim_Op
)) /= Typ
7644 and then not Comes_From_Source
(Prim_Op
)
7645 and then Is_Internal_Name
(Chars
(Prim_Op
))
7646 and then not Is_Internal_Name
(Chars
(Alias
(Prim_Op
)))
7648 Parent_Subp
:= Alias
(Prim_Op
);
7650 -- Check if the type has an explicit overriding for this
7653 Op_Elmt_2
:= Next_Elmt
(Op_Elmt
);
7654 while Present
(Op_Elmt_2
) loop
7655 if Chars
(Node
(Op_Elmt_2
)) = Chars
(Parent_Subp
)
7656 and then Type_Conformant
(Prim_Op
, Node
(Op_Elmt_2
))
7658 Set_DT_Position_Value
(Prim_Op
,
7659 DT_Position
(Parent_Subp
));
7660 Set_DT_Position_Value
(Node
(Op_Elmt_2
),
7661 DT_Position
(Parent_Subp
));
7662 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(Prim_Op
)));
7664 goto Next_Primitive
;
7667 Next_Elmt
(Op_Elmt_2
);
7672 Next_Elmt
(Op_Elmt
);
7674 end Handle_Inherited_Private_Subprograms
;
7676 --------------------
7677 -- Set_Fixed_Prim --
7678 --------------------
7680 procedure Set_Fixed_Prim
(Pos
: Nat
) is
7682 pragma Assert
(Pos
<= Count_Prim
);
7683 Fixed_Prim
(Pos
) := True;
7685 when Constraint_Error
=>
7686 raise Program_Error
;
7690 -- In case of nested packages and public child package it may be
7691 -- necessary a special management on inherited subprograms so that
7692 -- the dispatch table is properly filled.
7694 if Ekind
(Scope
(Scope
(Typ
))) = E_Package
7695 and then Scope
(Scope
(Typ
)) /= Standard_Standard
7696 and then ((Is_Derived_Type
(Typ
) and then not Is_Private_Type
(Typ
))
7698 (Nkind
(Parent
(Typ
)) = N_Private_Extension_Declaration
7699 and then Is_Generic_Type
(Typ
)))
7700 and then In_Open_Scopes
(Scope
(Etype
(Typ
)))
7701 and then Is_Base_Type
(Typ
)
7703 Handle_Inherited_Private_Subprograms
(Typ
);
7706 -- Second stage: Register fixed entries
7709 Prim_Elmt
:= First_Prim
;
7710 while Present
(Prim_Elmt
) loop
7711 Prim
:= Node
(Prim_Elmt
);
7713 -- Predefined primitives have a separate table and all its
7714 -- entries are at predefined fixed positions.
7716 if In_Predef_Prims_DT
(Prim
) then
7717 if Is_Predefined_Dispatching_Operation
(Prim
) then
7718 Set_DT_Position_Value
(Prim
,
7719 Default_Prim_Op_Position
(Prim
));
7721 else pragma Assert
(Present
(Alias
(Prim
)));
7722 Set_DT_Position_Value
(Prim
,
7723 Default_Prim_Op_Position
(Ultimate_Alias
(Prim
)));
7726 -- Overriding primitives of ancestor abstract interfaces
7728 elsif Present
(Interface_Alias
(Prim
))
7729 and then Is_Ancestor
7730 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
7731 Use_Full_View
=> True)
7733 pragma Assert
(DT_Position
(Prim
) = No_Uint
7734 and then Present
(DTC_Entity
(Interface_Alias
(Prim
))));
7736 E
:= Interface_Alias
(Prim
);
7737 Set_DT_Position_Value
(Prim
, DT_Position
(E
));
7740 (DT_Position
(Alias
(Prim
)) = No_Uint
7741 or else DT_Position
(Alias
(Prim
)) = DT_Position
(E
));
7742 Set_DT_Position_Value
(Alias
(Prim
), DT_Position
(E
));
7743 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(Prim
)));
7745 -- Overriding primitives must use the same entry as the
7746 -- overridden primitive.
7748 elsif not Present
(Interface_Alias
(Prim
))
7749 and then Present
(Alias
(Prim
))
7750 and then Chars
(Prim
) = Chars
(Alias
(Prim
))
7751 and then Find_Dispatching_Type
(Alias
(Prim
)) /= Typ
7752 and then Is_Ancestor
7753 (Find_Dispatching_Type
(Alias
(Prim
)), Typ
,
7754 Use_Full_View
=> True)
7755 and then Present
(DTC_Entity
(Alias
(Prim
)))
7758 Set_DT_Position_Value
(Prim
, DT_Position
(E
));
7760 if not Is_Predefined_Dispatching_Alias
(E
) then
7761 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(E
)));
7765 Next_Elmt
(Prim_Elmt
);
7768 -- Third stage: Fix the position of all the new primitives. Entries
7769 -- associated with primitives covering interfaces are handled in a
7772 Prim_Elmt
:= First_Prim
;
7773 while Present
(Prim_Elmt
) loop
7774 Prim
:= Node
(Prim_Elmt
);
7776 -- Skip primitives previously set entries
7778 if DT_Position
(Prim
) /= No_Uint
then
7781 -- Primitives covering interface primitives are handled later
7783 elsif Present
(Interface_Alias
(Prim
)) then
7787 -- Take the next available position in the DT
7790 Nb_Prim
:= Nb_Prim
+ 1;
7791 pragma Assert
(Nb_Prim
<= Count_Prim
);
7792 exit when not Fixed_Prim
(Nb_Prim
);
7795 Set_DT_Position_Value
(Prim
, UI_From_Int
(Nb_Prim
));
7796 Set_Fixed_Prim
(Nb_Prim
);
7799 Next_Elmt
(Prim_Elmt
);
7803 -- Fourth stage: Complete the decoration of primitives covering
7804 -- interfaces (that is, propagate the DT_Position attribute from
7805 -- the aliased primitive)
7807 Prim_Elmt
:= First_Prim
;
7808 while Present
(Prim_Elmt
) loop
7809 Prim
:= Node
(Prim_Elmt
);
7811 if DT_Position
(Prim
) = No_Uint
7812 and then Present
(Interface_Alias
(Prim
))
7814 pragma Assert
(Present
(Alias
(Prim
))
7815 and then Find_Dispatching_Type
(Alias
(Prim
)) = Typ
);
7817 -- Check if this entry will be placed in the primary DT
7820 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
7821 Use_Full_View
=> True)
7823 pragma Assert
(DT_Position
(Alias
(Prim
)) /= No_Uint
);
7824 Set_DT_Position_Value
(Prim
, DT_Position
(Alias
(Prim
)));
7826 -- Otherwise it will be placed in the secondary DT
7830 (DT_Position
(Interface_Alias
(Prim
)) /= No_Uint
);
7831 Set_DT_Position_Value
(Prim
,
7832 DT_Position
(Interface_Alias
(Prim
)));
7836 Next_Elmt
(Prim_Elmt
);
7839 -- Generate listing showing the contents of the dispatch tables. This
7840 -- action is done before some further static checks because in case of
7841 -- critical errors caused by a wrong dispatch table we need to see the
7842 -- contents of such table.
7844 if Debug_Flag_ZZ
then
7848 -- Final stage: Ensure that the table is correct plus some further
7849 -- verifications concerning the primitives.
7851 Prim_Elmt
:= First_Prim
;
7853 while Present
(Prim_Elmt
) loop
7854 Prim
:= Node
(Prim_Elmt
);
7856 -- At this point all the primitives MUST have a position in the
7859 if DT_Position
(Prim
) = No_Uint
then
7860 raise Program_Error
;
7863 -- Calculate real size of the dispatch table
7865 if not In_Predef_Prims_DT
(Prim
)
7866 and then UI_To_Int
(DT_Position
(Prim
)) > DT_Length
7868 DT_Length
:= UI_To_Int
(DT_Position
(Prim
));
7871 -- Ensure that the assigned position to non-predefined dispatching
7872 -- operations in the dispatch table is correct.
7874 if not Is_Predefined_Dispatching_Operation
(Prim
)
7875 and then not Is_Predefined_Dispatching_Alias
(Prim
)
7877 Validate_Position
(Prim
);
7880 if Chars
(Prim
) = Name_Finalize
then
7884 if Chars
(Prim
) = Name_Adjust
then
7888 -- An abstract operation cannot be declared in the private part for a
7889 -- visible abstract type, because it can't be overridden outside this
7890 -- package hierarchy. For explicit declarations this is checked at
7891 -- the point of declaration, but for inherited operations it must be
7892 -- done when building the dispatch table.
7894 -- Ada 2005 (AI-251): Primitives associated with interfaces are
7895 -- excluded from this check because interfaces must be visible in
7896 -- the public and private part (RM 7.3 (7.3/2))
7898 -- We disable this check in Relaxed_RM_Semantics mode, to accommodate
7901 if not Relaxed_RM_Semantics
7902 and then Is_Abstract_Type
(Typ
)
7903 and then Is_Abstract_Subprogram
(Prim
)
7904 and then Present
(Alias
(Prim
))
7905 and then not Is_Interface
7906 (Find_Dispatching_Type
(Ultimate_Alias
(Prim
)))
7907 and then not Present
(Interface_Alias
(Prim
))
7908 and then Is_Derived_Type
(Typ
)
7909 and then In_Private_Part
(Current_Scope
)
7911 List_Containing
(Parent
(Prim
)) =
7912 Private_Declarations
(Package_Specification
(Current_Scope
))
7913 and then Original_View_In_Visible_Part
(Typ
)
7915 -- We exclude Input and Output stream operations because
7916 -- Limited_Controlled inherits useless Input and Output stream
7917 -- operations from Root_Controlled, which can never be overridden.
7919 if not Is_TSS
(Prim
, TSS_Stream_Input
)
7921 not Is_TSS
(Prim
, TSS_Stream_Output
)
7924 ("abstract inherited private operation&" &
7925 " must be overridden (RM 3.9.3(10))",
7926 Parent
(Typ
), Prim
);
7930 Next_Elmt
(Prim_Elmt
);
7935 if Is_Controlled
(Typ
) then
7936 if not Finalized
then
7938 ("controlled type has no explicit Finalize method??", Typ
);
7940 elsif not Adjusted
then
7942 ("controlled type has no explicit Adjust method??", Typ
);
7946 -- Set the final size of the Dispatch Table
7948 Set_DT_Entry_Count
(The_Tag
, UI_From_Int
(DT_Length
));
7950 -- The derived type must have at least as many components as its parent
7951 -- (for root types Etype points to itself and the test cannot fail).
7953 if DT_Entry_Count
(The_Tag
) <
7954 DT_Entry_Count
(First_Tag_Component
(Parent_Typ
))
7956 raise Program_Error
;
7958 end Set_All_DT_Position
;
7960 --------------------------
7961 -- Set_CPP_Constructors --
7962 --------------------------
7964 procedure Set_CPP_Constructors
(Typ
: Entity_Id
) is
7966 function Gen_Parameters_Profile
(E
: Entity_Id
) return List_Id
;
7967 -- Duplicate the parameters profile of the imported C++ constructor
7968 -- adding an access to the object as an additional parameter.
7970 ----------------------------
7971 -- Gen_Parameters_Profile --
7972 ----------------------------
7974 function Gen_Parameters_Profile
(E
: Entity_Id
) return List_Id
is
7975 Loc
: constant Source_Ptr
:= Sloc
(E
);
7982 Make_Parameter_Specification
(Loc
,
7983 Defining_Identifier
=>
7984 Make_Defining_Identifier
(Loc
, Name_uInit
),
7985 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
7987 if Present
(Parameter_Specifications
(Parent
(E
))) then
7988 P
:= First
(Parameter_Specifications
(Parent
(E
)));
7989 while Present
(P
) loop
7991 Make_Parameter_Specification
(Loc
,
7992 Defining_Identifier
=>
7993 Make_Defining_Identifier
(Loc
,
7994 Chars
=> Chars
(Defining_Identifier
(P
))),
7995 Parameter_Type
=> New_Copy_Tree
(Parameter_Type
(P
)),
7996 Expression
=> New_Copy_Tree
(Expression
(P
))));
8002 end Gen_Parameters_Profile
;
8008 Found
: Boolean := False;
8014 Covers_Default_Constructor
: Entity_Id
:= Empty
;
8016 -- Start of processing for Set_CPP_Constructor
8019 pragma Assert
(Is_CPP_Class
(Typ
));
8021 -- Look for the constructor entities
8023 E
:= Next_Entity
(Typ
);
8024 while Present
(E
) loop
8025 if Ekind
(E
) = E_Function
8026 and then Is_Constructor
(E
)
8030 Parms
:= Gen_Parameters_Profile
(E
);
8032 Make_Defining_Identifier
(Loc
,
8033 Chars
=> Make_Init_Proc_Name
(Typ
));
8035 -- Case 1: Constructor of untagged type
8037 -- If the C++ class has no virtual methods then the matching Ada
8038 -- type is an untagged record type. In such case there is no need
8039 -- to generate a wrapper of the C++ constructor because the _tag
8040 -- component is not available.
8042 if not Is_Tagged_Type
(Typ
) then
8044 (Make_Subprogram_Declaration
(Loc
,
8046 Make_Procedure_Specification
(Loc
,
8047 Defining_Unit_Name
=> IP
,
8048 Parameter_Specifications
=> Parms
)));
8050 Set_Init_Proc
(Typ
, IP
);
8051 Set_Is_Imported
(IP
);
8052 Set_Is_Constructor
(IP
);
8053 Set_Interface_Name
(IP
, Interface_Name
(E
));
8054 Set_Convention
(IP
, Convention_CPP
);
8056 Set_Has_Completion
(IP
);
8058 -- Case 2: Constructor of a tagged type
8060 -- In this case we generate the IP as a wrapper of the the
8061 -- C++ constructor because IP must also save copy of the _tag
8062 -- generated in the C++ side. The copy of the _tag is used by
8063 -- Build_CPP_Init_Procedure to elaborate derivations of C++ types.
8066 -- procedure IP (_init : Typ; ...) is
8067 -- procedure ConstructorP (_init : Typ; ...);
8068 -- pragma Import (ConstructorP);
8070 -- ConstructorP (_init, ...);
8071 -- if Typ._tag = null then
8072 -- Typ._tag := _init._tag;
8078 Body_Stmts
: constant List_Id
:= New_List
;
8079 Constructor_Id
: Entity_Id
;
8080 Constructor_Decl_Node
: Node_Id
;
8081 Init_Tags_List
: List_Id
;
8084 Constructor_Id
:= Make_Temporary
(Loc
, 'P');
8086 Constructor_Decl_Node
:=
8087 Make_Subprogram_Declaration
(Loc
,
8088 Make_Procedure_Specification
(Loc
,
8089 Defining_Unit_Name
=> Constructor_Id
,
8090 Parameter_Specifications
=> Parms
));
8092 Set_Is_Imported
(Constructor_Id
);
8093 Set_Is_Constructor
(Constructor_Id
);
8094 Set_Interface_Name
(Constructor_Id
, Interface_Name
(E
));
8095 Set_Convention
(Constructor_Id
, Convention_CPP
);
8096 Set_Is_Public
(Constructor_Id
);
8097 Set_Has_Completion
(Constructor_Id
);
8099 -- Build the init procedure as a wrapper of this constructor
8101 Parms
:= Gen_Parameters_Profile
(E
);
8103 -- Invoke the C++ constructor
8106 Actuals
: constant List_Id
:= New_List
;
8110 while Present
(P
) loop
8112 New_Occurrence_Of
(Defining_Identifier
(P
), Loc
));
8116 Append_To
(Body_Stmts
,
8117 Make_Procedure_Call_Statement
(Loc
,
8118 Name
=> New_Occurrence_Of
(Constructor_Id
, Loc
),
8119 Parameter_Associations
=> Actuals
));
8122 -- Initialize copies of C++ primary and secondary tags
8124 Init_Tags_List
:= New_List
;
8131 Tag_Elmt
:= First_Elmt
(Access_Disp_Table
(Typ
));
8132 Tag_Comp
:= First_Tag_Component
(Typ
);
8134 while Present
(Tag_Elmt
)
8135 and then Is_Tag
(Node
(Tag_Elmt
))
8137 -- Skip the following assertion with primary tags
8138 -- because Related_Type is not set on primary tag
8142 (Tag_Comp
= First_Tag_Component
(Typ
)
8143 or else Related_Type
(Node
(Tag_Elmt
))
8144 = Related_Type
(Tag_Comp
));
8146 Append_To
(Init_Tags_List
,
8147 Make_Assignment_Statement
(Loc
,
8149 New_Occurrence_Of
(Node
(Tag_Elmt
), Loc
),
8151 Make_Selected_Component
(Loc
,
8153 Make_Identifier
(Loc
, Name_uInit
),
8155 New_Occurrence_Of
(Tag_Comp
, Loc
))));
8157 Tag_Comp
:= Next_Tag_Component
(Tag_Comp
);
8158 Next_Elmt
(Tag_Elmt
);
8162 Append_To
(Body_Stmts
,
8163 Make_If_Statement
(Loc
,
8168 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))),
8171 Unchecked_Convert_To
(RTE
(RE_Tag
),
8172 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))),
8173 Then_Statements
=> Init_Tags_List
));
8176 Make_Subprogram_Body
(Loc
,
8178 Make_Procedure_Specification
(Loc
,
8179 Defining_Unit_Name
=> IP
,
8180 Parameter_Specifications
=> Parms
),
8181 Declarations
=> New_List
(Constructor_Decl_Node
),
8182 Handled_Statement_Sequence
=>
8183 Make_Handled_Sequence_Of_Statements
(Loc
,
8184 Statements
=> Body_Stmts
,
8185 Exception_Handlers
=> No_List
));
8187 Discard_Node
(IP_Body
);
8188 Set_Init_Proc
(Typ
, IP
);
8192 -- If this constructor has parameters and all its parameters have
8193 -- defaults then it covers the default constructor. The semantic
8194 -- analyzer ensures that only one constructor with defaults covers
8195 -- the default constructor.
8197 if Present
(Parameter_Specifications
(Parent
(E
)))
8198 and then Needs_No_Actuals
(E
)
8200 Covers_Default_Constructor
:= IP
;
8207 -- If there are no constructors, mark the type as abstract since we
8208 -- won't be able to declare objects of that type.
8211 Set_Is_Abstract_Type
(Typ
);
8214 -- Handle constructor that has all its parameters with defaults and
8215 -- hence it covers the default constructor. We generate a wrapper IP
8216 -- which calls the covering constructor.
8218 if Present
(Covers_Default_Constructor
) then
8220 Body_Stmts
: List_Id
;
8223 Loc
:= Sloc
(Covers_Default_Constructor
);
8225 Body_Stmts
:= New_List
(
8226 Make_Procedure_Call_Statement
(Loc
,
8228 New_Occurrence_Of
(Covers_Default_Constructor
, Loc
),
8229 Parameter_Associations
=> New_List
(
8230 Make_Identifier
(Loc
, Name_uInit
))));
8232 IP
:= Make_Defining_Identifier
(Loc
, Make_Init_Proc_Name
(Typ
));
8235 Make_Subprogram_Body
(Loc
,
8237 Make_Procedure_Specification
(Loc
,
8238 Defining_Unit_Name
=> IP
,
8239 Parameter_Specifications
=> New_List
(
8240 Make_Parameter_Specification
(Loc
,
8241 Defining_Identifier
=>
8242 Make_Defining_Identifier
(Loc
, Name_uInit
),
8243 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)))),
8245 Declarations
=> No_List
,
8247 Handled_Statement_Sequence
=>
8248 Make_Handled_Sequence_Of_Statements
(Loc
,
8249 Statements
=> Body_Stmts
,
8250 Exception_Handlers
=> No_List
));
8252 Discard_Node
(IP_Body
);
8253 Set_Init_Proc
(Typ
, IP
);
8257 -- If the CPP type has constructors then it must import also the default
8258 -- C++ constructor. It is required for default initialization of objects
8259 -- of the type. It is also required to elaborate objects of Ada types
8260 -- that are defined as derivations of this CPP type.
8262 if Has_CPP_Constructors
(Typ
)
8263 and then No
(Init_Proc
(Typ
))
8265 Error_Msg_N
("??default constructor must be imported from C++", Typ
);
8267 end Set_CPP_Constructors
;
8269 ---------------------------
8270 -- Set_DT_Position_Value --
8271 ---------------------------
8273 procedure Set_DT_Position_Value
(Prim
: Entity_Id
; Value
: Uint
) is
8275 Set_DT_Position
(Prim
, Value
);
8277 -- Propagate the value to the wrapped subprogram (if one is present)
8279 if Ekind_In
(Prim
, E_Function
, E_Procedure
)
8280 and then Is_Primitive_Wrapper
(Prim
)
8281 and then Present
(Wrapped_Entity
(Prim
))
8282 and then Is_Dispatching_Operation
(Wrapped_Entity
(Prim
))
8284 Set_DT_Position
(Wrapped_Entity
(Prim
), Value
);
8286 end Set_DT_Position_Value
;
8288 --------------------------
8289 -- Set_DTC_Entity_Value --
8290 --------------------------
8292 procedure Set_DTC_Entity_Value
8293 (Tagged_Type
: Entity_Id
;
8297 if Present
(Interface_Alias
(Prim
))
8298 and then Is_Interface
8299 (Find_Dispatching_Type
(Interface_Alias
(Prim
)))
8301 Set_DTC_Entity
(Prim
,
8304 Iface
=> Find_Dispatching_Type
(Interface_Alias
(Prim
))));
8306 Set_DTC_Entity
(Prim
,
8307 First_Tag_Component
(Tagged_Type
));
8310 -- Propagate the value to the wrapped subprogram (if one is present)
8312 if Ekind_In
(Prim
, E_Function
, E_Procedure
)
8313 and then Is_Primitive_Wrapper
(Prim
)
8314 and then Present
(Wrapped_Entity
(Prim
))
8315 and then Is_Dispatching_Operation
(Wrapped_Entity
(Prim
))
8317 Set_DTC_Entity
(Wrapped_Entity
(Prim
), DTC_Entity
(Prim
));
8319 end Set_DTC_Entity_Value
;
8325 function Tagged_Kind
(T
: Entity_Id
) return Node_Id
is
8326 Conc_Typ
: Entity_Id
;
8327 Loc
: constant Source_Ptr
:= Sloc
(T
);
8331 (Is_Tagged_Type
(T
) and then RTE_Available
(RE_Tagged_Kind
));
8335 if Is_Abstract_Type
(T
) then
8336 if Is_Limited_Record
(T
) then
8337 return New_Occurrence_Of
8338 (RTE
(RE_TK_Abstract_Limited_Tagged
), Loc
);
8340 return New_Occurrence_Of
8341 (RTE
(RE_TK_Abstract_Tagged
), Loc
);
8346 elsif Is_Concurrent_Record_Type
(T
) then
8347 Conc_Typ
:= Corresponding_Concurrent_Type
(T
);
8349 if Present
(Full_View
(Conc_Typ
)) then
8350 Conc_Typ
:= Full_View
(Conc_Typ
);
8353 if Ekind
(Conc_Typ
) = E_Protected_Type
then
8354 return New_Occurrence_Of
(RTE
(RE_TK_Protected
), Loc
);
8356 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
8357 return New_Occurrence_Of
(RTE
(RE_TK_Task
), Loc
);
8360 -- Regular tagged kinds
8363 if Is_Limited_Record
(T
) then
8364 return New_Occurrence_Of
(RTE
(RE_TK_Limited_Tagged
), Loc
);
8366 return New_Occurrence_Of
(RTE
(RE_TK_Tagged
), Loc
);
8375 procedure Write_DT
(Typ
: Entity_Id
) is
8380 -- Protect this procedure against wrong usage. Required because it will
8381 -- be used directly from GDB
8383 if not (Typ
<= Last_Node_Id
)
8384 or else not Is_Tagged_Type
(Typ
)
8386 Write_Str
("wrong usage: Write_DT must be used with tagged types");
8391 Write_Int
(Int
(Typ
));
8393 Write_Name
(Chars
(Typ
));
8395 if Is_Interface
(Typ
) then
8396 Write_Str
(" is interface");
8401 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
8402 while Present
(Elmt
) loop
8403 Prim
:= Node
(Elmt
);
8406 -- Indicate if this primitive will be allocated in the primary
8407 -- dispatch table or in a secondary dispatch table associated
8408 -- with an abstract interface type
8410 if Present
(DTC_Entity
(Prim
)) then
8411 if Etype
(DTC_Entity
(Prim
)) = RTE
(RE_Tag
) then
8418 -- Output the node of this primitive operation and its name
8420 Write_Int
(Int
(Prim
));
8423 if Is_Predefined_Dispatching_Operation
(Prim
) then
8424 Write_Str
("(predefined) ");
8427 -- Prefix the name of the primitive with its corresponding tagged
8428 -- type to facilitate seeing inherited primitives.
8430 if Present
(Alias
(Prim
)) then
8432 (Chars
(Find_Dispatching_Type
(Ultimate_Alias
(Prim
))));
8434 Write_Name
(Chars
(Typ
));
8438 Write_Name
(Chars
(Prim
));
8440 -- Indicate if this primitive has an aliased primitive
8442 if Present
(Alias
(Prim
)) then
8443 Write_Str
(" (alias = ");
8444 Write_Int
(Int
(Alias
(Prim
)));
8446 -- If the DTC_Entity attribute is already set we can also output
8447 -- the name of the interface covered by this primitive (if any).
8449 if Ekind_In
(Alias
(Prim
), E_Function
, E_Procedure
)
8450 and then Present
(DTC_Entity
(Alias
(Prim
)))
8451 and then Is_Interface
(Scope
(DTC_Entity
(Alias
(Prim
))))
8453 Write_Str
(" from interface ");
8454 Write_Name
(Chars
(Scope
(DTC_Entity
(Alias
(Prim
)))));
8457 if Present
(Interface_Alias
(Prim
)) then
8458 Write_Str
(", AI_Alias of ");
8460 if Is_Null_Interface_Primitive
(Interface_Alias
(Prim
)) then
8461 Write_Str
("null primitive ");
8465 (Chars
(Find_Dispatching_Type
(Interface_Alias
(Prim
))));
8467 Write_Int
(Int
(Interface_Alias
(Prim
)));
8473 -- Display the final position of this primitive in its associated
8474 -- (primary or secondary) dispatch table.
8476 if Present
(DTC_Entity
(Prim
))
8477 and then DT_Position
(Prim
) /= No_Uint
8479 Write_Str
(" at #");
8480 Write_Int
(UI_To_Int
(DT_Position
(Prim
)));
8483 if Is_Abstract_Subprogram
(Prim
) then
8484 Write_Str
(" is abstract;");
8486 -- Check if this is a null primitive
8488 elsif Comes_From_Source
(Prim
)
8489 and then Ekind
(Prim
) = E_Procedure
8490 and then Null_Present
(Parent
(Prim
))
8492 Write_Str
(" is null;");
8495 if Is_Eliminated
(Ultimate_Alias
(Prim
)) then
8496 Write_Str
(" (eliminated)");
8499 if Is_Imported
(Prim
)
8500 and then Convention
(Prim
) = Convention_CPP
8502 Write_Str
(" (C++)");