1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, 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 Expander
; use Expander
;
33 with Exp_Atag
; use Exp_Atag
;
34 with Exp_Ch6
; use Exp_Ch6
;
35 with Exp_CG
; use Exp_CG
;
36 with Exp_Dbug
; use Exp_Dbug
;
37 with Exp_Tss
; use Exp_Tss
;
38 with Exp_Util
; use Exp_Util
;
39 with Freeze
; use Freeze
;
40 with Ghost
; use Ghost
;
41 with Itypes
; use Itypes
;
42 with Layout
; use Layout
;
43 with Nlists
; use Nlists
;
44 with Nmake
; use Nmake
;
45 with Namet
; use Namet
;
47 with Output
; use Output
;
48 with Restrict
; use Restrict
;
49 with Rident
; use Rident
;
50 with Rtsfind
; use Rtsfind
;
52 with Sem_Aux
; use Sem_Aux
;
53 with Sem_Ch6
; use Sem_Ch6
;
54 with Sem_Ch7
; use Sem_Ch7
;
55 with Sem_Ch8
; use Sem_Ch8
;
56 with Sem_Disp
; use Sem_Disp
;
57 with Sem_Eval
; use Sem_Eval
;
58 with Sem_Res
; use Sem_Res
;
59 with Sem_Type
; use Sem_Type
;
60 with Sem_Util
; use Sem_Util
;
61 with Sinfo
; use Sinfo
;
62 with Sinput
; use Sinput
;
63 with Snames
; use Snames
;
64 with Stand
; use Stand
;
65 with Stringt
; use Stringt
;
66 with SCIL_LL
; use SCIL_LL
;
67 with Tbuild
; use Tbuild
;
69 package body Exp_Disp
is
71 -----------------------
72 -- Local Subprograms --
73 -----------------------
75 function Default_Prim_Op_Position
(E
: Entity_Id
) return Uint
;
76 -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
77 -- of the default primitive operations.
79 function Has_DT
(Typ
: Entity_Id
) return Boolean;
80 pragma Inline
(Has_DT
);
81 -- Returns true if we generate a dispatch table for tagged type Typ
83 function Is_Predefined_Dispatching_Alias
(Prim
: Entity_Id
) return Boolean;
84 -- Returns true if Prim is not a predefined dispatching primitive but it is
85 -- an alias of a predefined dispatching primitive (i.e. through a renaming)
87 function New_Value
(From
: Node_Id
) return Node_Id
;
88 -- From is the original Expression. New_Value is equivalent to a call to
89 -- Duplicate_Subexpr with an explicit dereference when From is an access
92 function Original_View_In_Visible_Part
(Typ
: Entity_Id
) return Boolean;
93 -- Check if the type has a private view or if the public view appears in
94 -- the visible part of a package spec.
98 Typ
: Entity_Id
) return Node_Id
;
99 -- Ada 2005 (AI-345): Determine the primitive operation kind of Prim
100 -- according to its type Typ. Return a reference to an RE_Prim_Op_Kind
101 -- enumeration value.
103 function Tagged_Kind
(T
: Entity_Id
) return Node_Id
;
104 -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
105 -- to an RE_Tagged_Kind enumeration value.
107 ----------------------
108 -- Apply_Tag_Checks --
109 ----------------------
111 procedure Apply_Tag_Checks
(Call_Node
: Node_Id
) is
112 Loc
: constant Source_Ptr
:= Sloc
(Call_Node
);
113 Ctrl_Arg
: constant Node_Id
:= Controlling_Argument
(Call_Node
);
114 Ctrl_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Ctrl_Arg
));
115 Param_List
: constant List_Id
:= Parameter_Associations
(Call_Node
);
121 Eq_Prim_Op
: Entity_Id
:= Empty
;
124 if No_Run_Time_Mode
then
125 Error_Msg_CRT
("tagged types", Call_Node
);
129 -- Apply_Tag_Checks is called directly from the semantics, so we
130 -- need a check to see whether expansion is active before proceeding.
131 -- In addition, there is no need to expand the call when compiling
132 -- under restriction No_Dispatching_Calls; the semantic analyzer has
133 -- previously notified the violation of this restriction.
135 if not Expander_Active
136 or else Restriction_Active
(No_Dispatching_Calls
)
141 -- Set subprogram. If this is an inherited operation that was
142 -- overridden, the body that is being called is its alias.
144 Subp
:= Entity
(Name
(Call_Node
));
146 if Present
(Alias
(Subp
))
147 and then Is_Inherited_Operation
(Subp
)
148 and then No
(DTC_Entity
(Subp
))
150 Subp
:= Alias
(Subp
);
153 -- Definition of the class-wide type and the tagged type
155 -- If the controlling argument is itself a tag rather than a tagged
156 -- object, then use the class-wide type associated with the subprogram's
157 -- controlling type. This case can occur when a call to an inherited
158 -- primitive has an actual that originated from a default parameter
159 -- given by a tag-indeterminate call and when there is no other
160 -- controlling argument providing the tag (AI-239 requires dispatching).
161 -- This capability of dispatching directly by tag is also needed by the
162 -- implementation of AI-260 (for the generic dispatching constructors).
164 if Ctrl_Typ
= RTE
(RE_Tag
)
165 or else (RTE_Available
(RE_Interface_Tag
)
166 and then Ctrl_Typ
= RTE
(RE_Interface_Tag
))
168 CW_Typ
:= Class_Wide_Type
(Find_Dispatching_Type
(Subp
));
170 -- Class_Wide_Type is applied to the expressions used to initialize
171 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
172 -- there are cases where the controlling type is resolved to a specific
173 -- type (such as for designated types of arguments such as CW'Access).
175 elsif Is_Access_Type
(Ctrl_Typ
) then
176 CW_Typ
:= Class_Wide_Type
(Designated_Type
(Ctrl_Typ
));
179 CW_Typ
:= Class_Wide_Type
(Ctrl_Typ
);
182 Typ
:= Find_Specific_Type
(CW_Typ
);
184 if not Is_Limited_Type
(Typ
) then
185 Eq_Prim_Op
:= Find_Prim_Op
(Typ
, Name_Op_Eq
);
188 -- Dispatching call to C++ primitive
190 if Is_CPP_Class
(Typ
) then
193 -- Dispatching call to Ada primitive
195 elsif Present
(Param_List
) then
197 -- Generate the Tag checks when appropriate
199 Param
:= First_Actual
(Call_Node
);
200 while Present
(Param
) loop
202 -- No tag check with itself
204 if Param
= Ctrl_Arg
then
207 -- No tag check for parameter whose type is neither tagged nor
208 -- access to tagged (for access parameters)
210 elsif No
(Find_Controlling_Arg
(Param
)) then
213 -- No tag check for function dispatching on result if the
214 -- Tag given by the context is this one
216 elsif Find_Controlling_Arg
(Param
) = Ctrl_Arg
then
219 -- "=" is the only dispatching operation allowed to get operands
220 -- with incompatible tags (it just returns false). We use
221 -- Duplicate_Subexpr_Move_Checks instead of calling Relocate_Node
222 -- because the value will be duplicated to check the tags.
224 elsif Subp
= Eq_Prim_Op
then
227 -- No check in presence of suppress flags
229 elsif Tag_Checks_Suppressed
(Etype
(Param
))
230 or else (Is_Access_Type
(Etype
(Param
))
231 and then Tag_Checks_Suppressed
232 (Designated_Type
(Etype
(Param
))))
236 -- Optimization: no tag checks if the parameters are identical
238 elsif Is_Entity_Name
(Param
)
239 and then Is_Entity_Name
(Ctrl_Arg
)
240 and then Entity
(Param
) = Entity
(Ctrl_Arg
)
244 -- Now we need to generate the Tag check
247 -- Generate code for tag equality check
249 -- Perhaps should have Checks.Apply_Tag_Equality_Check???
251 Insert_Action
(Ctrl_Arg
,
252 Make_Implicit_If_Statement
(Call_Node
,
256 Make_Selected_Component
(Loc
,
257 Prefix
=> New_Value
(Ctrl_Arg
),
260 (First_Tag_Component
(Typ
), Loc
)),
263 Make_Selected_Component
(Loc
,
265 Unchecked_Convert_To
(Typ
, New_Value
(Param
)),
268 (First_Tag_Component
(Typ
), Loc
))),
271 New_List
(New_Constraint_Error
(Loc
))));
277 end Apply_Tag_Checks
;
279 ------------------------
280 -- Building_Static_DT --
281 ------------------------
283 function Building_Static_DT
(Typ
: Entity_Id
) return Boolean is
284 Root_Typ
: Entity_Id
:= Root_Type
(Typ
);
288 -- Handle private types
290 if Present
(Full_View
(Root_Typ
)) then
291 Root_Typ
:= Full_View
(Root_Typ
);
295 Building_Static_Dispatch_Tables
296 and then Is_Library_Level_Tagged_Type
(Typ
)
298 -- If the type is derived from a CPP class we cannot statically
299 -- build the dispatch tables because we must inherit primitives
300 -- from the CPP side.
302 and then not Is_CPP_Class
(Root_Typ
);
304 if not Static_DT
then
305 Check_Restriction
(Static_Dispatch_Tables
, Typ
);
309 end Building_Static_DT
;
311 ----------------------------------
312 -- Building_Static_Secondary_DT --
313 ----------------------------------
315 function Building_Static_Secondary_DT
(Typ
: Entity_Id
) return Boolean is
316 Full_Typ
: Entity_Id
:= Typ
;
317 Root_Typ
: Entity_Id
:= Root_Type
(Typ
);
321 -- Handle private types
323 if Present
(Full_View
(Typ
)) then
324 Full_Typ
:= Full_View
(Typ
);
327 if Present
(Full_View
(Root_Typ
)) then
328 Root_Typ
:= Full_View
(Root_Typ
);
332 Building_Static_DT
(Full_Typ
)
333 and then not Is_Interface
(Full_Typ
)
334 and then Has_Interfaces
(Full_Typ
)
335 and then (Full_Typ
= Root_Typ
336 or else not Is_Variable_Size_Record
(Etype
(Full_Typ
)));
339 and then not Is_Interface
(Full_Typ
)
340 and then Has_Interfaces
(Full_Typ
)
342 Check_Restriction
(Static_Dispatch_Tables
, Typ
);
346 end Building_Static_Secondary_DT
;
348 ----------------------------------
349 -- Build_Static_Dispatch_Tables --
350 ----------------------------------
352 procedure Build_Static_Dispatch_Tables
(N
: Entity_Id
) is
353 Target_List
: List_Id
;
355 procedure Build_Dispatch_Tables
(List
: List_Id
);
356 -- Build the static dispatch table of tagged types found in the list of
357 -- declarations. The generated nodes are added at the end of Target_List
359 procedure Build_Package_Dispatch_Tables
(N
: Node_Id
);
360 -- Build static dispatch tables associated with package declaration N
362 ---------------------------
363 -- Build_Dispatch_Tables --
364 ---------------------------
366 procedure Build_Dispatch_Tables
(List
: List_Id
) is
371 while Present
(D
) loop
373 -- Handle nested packages and package bodies recursively. The
374 -- generated code is placed on the Target_List established for
375 -- the enclosing compilation unit.
377 if Nkind
(D
) = N_Package_Declaration
then
378 Build_Package_Dispatch_Tables
(D
);
380 elsif Nkind
(D
) = N_Package_Body
then
381 Build_Dispatch_Tables
(Declarations
(D
));
383 elsif Nkind
(D
) = N_Package_Body_Stub
384 and then Present
(Library_Unit
(D
))
386 Build_Dispatch_Tables
387 (Declarations
(Proper_Body
(Unit
(Library_Unit
(D
)))));
389 -- Handle full type declarations and derivations of library level
392 elsif Nkind_In
(D
, N_Full_Type_Declaration
,
393 N_Derived_Type_Definition
)
394 and then Is_Library_Level_Tagged_Type
(Defining_Entity
(D
))
395 and then Ekind
(Defining_Entity
(D
)) /= E_Record_Subtype
396 and then not Is_Private_Type
(Defining_Entity
(D
))
398 -- We do not generate dispatch tables for the internal types
399 -- created for a type extension with unknown discriminants
400 -- The needed information is shared with the source type,
401 -- See Expand_N_Record_Extension.
403 if Is_Underlying_Record_View
(Defining_Entity
(D
))
405 (not Comes_From_Source
(Defining_Entity
(D
))
407 Has_Unknown_Discriminants
(Etype
(Defining_Entity
(D
)))
409 not Comes_From_Source
410 (First_Subtype
(Defining_Entity
(D
))))
414 Insert_List_After_And_Analyze
(Last
(Target_List
),
415 Make_DT
(Defining_Entity
(D
)));
418 -- Handle private types of library level tagged types. We must
419 -- exchange the private and full-view to ensure the correct
420 -- expansion. If the full view is a synchronized type ignore
421 -- the type because the table will be built for the corresponding
422 -- record type, that has its own declaration.
424 elsif (Nkind
(D
) = N_Private_Type_Declaration
425 or else Nkind
(D
) = N_Private_Extension_Declaration
)
426 and then Present
(Full_View
(Defining_Entity
(D
)))
429 E1
: constant Entity_Id
:= Defining_Entity
(D
);
430 E2
: constant Entity_Id
:= Full_View
(E1
);
433 if Is_Library_Level_Tagged_Type
(E2
)
434 and then Ekind
(E2
) /= E_Record_Subtype
435 and then not Is_Concurrent_Type
(E2
)
437 Exchange_Declarations
(E1
);
438 Insert_List_After_And_Analyze
(Last
(Target_List
),
440 Exchange_Declarations
(E2
);
447 end Build_Dispatch_Tables
;
449 -----------------------------------
450 -- Build_Package_Dispatch_Tables --
451 -----------------------------------
453 procedure Build_Package_Dispatch_Tables
(N
: Node_Id
) is
454 Spec
: constant Node_Id
:= Specification
(N
);
455 Id
: constant Entity_Id
:= Defining_Entity
(N
);
456 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
457 Priv_Decls
: constant List_Id
:= Private_Declarations
(Spec
);
462 if Present
(Priv_Decls
) then
463 Build_Dispatch_Tables
(Vis_Decls
);
464 Build_Dispatch_Tables
(Priv_Decls
);
466 elsif Present
(Vis_Decls
) then
467 Build_Dispatch_Tables
(Vis_Decls
);
471 end Build_Package_Dispatch_Tables
;
473 -- Start of processing for Build_Static_Dispatch_Tables
476 if not Expander_Active
477 or else not Tagged_Type_Expansion
482 if Nkind
(N
) = N_Package_Declaration
then
484 Spec
: constant Node_Id
:= Specification
(N
);
485 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
486 Priv_Decls
: constant List_Id
:= Private_Declarations
(Spec
);
489 if Present
(Priv_Decls
)
490 and then Is_Non_Empty_List
(Priv_Decls
)
492 Target_List
:= Priv_Decls
;
494 elsif not Present
(Vis_Decls
) then
495 Target_List
:= New_List
;
496 Set_Private_Declarations
(Spec
, Target_List
);
498 Target_List
:= Vis_Decls
;
501 Build_Package_Dispatch_Tables
(N
);
504 else pragma Assert
(Nkind
(N
) = N_Package_Body
);
505 Target_List
:= Declarations
(N
);
506 Build_Dispatch_Tables
(Target_List
);
508 end Build_Static_Dispatch_Tables
;
510 ------------------------------
511 -- Convert_Tag_To_Interface --
512 ------------------------------
514 function Convert_Tag_To_Interface
516 Expr
: Node_Id
) return Node_Id
518 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
519 Anon_Type
: Entity_Id
;
523 pragma Assert
(Is_Class_Wide_Type
(Typ
)
524 and then Is_Interface
(Typ
)
526 ((Nkind
(Expr
) = N_Selected_Component
527 and then Is_Tag
(Entity
(Selector_Name
(Expr
))))
529 (Nkind
(Expr
) = N_Function_Call
530 and then RTE_Available
(RE_Displace
)
531 and then Entity
(Name
(Expr
)) = RTE
(RE_Displace
))));
533 Anon_Type
:= Create_Itype
(E_Anonymous_Access_Type
, Expr
);
534 Set_Directly_Designated_Type
(Anon_Type
, Typ
);
535 Set_Etype
(Anon_Type
, Anon_Type
);
536 Set_Can_Never_Be_Null
(Anon_Type
);
538 -- Decorate the size and alignment attributes of the anonymous access
539 -- type, as required by the back end.
541 Layout_Type
(Anon_Type
);
543 if Nkind
(Expr
) = N_Selected_Component
544 and then Is_Tag
(Entity
(Selector_Name
(Expr
)))
547 Make_Explicit_Dereference
(Loc
,
548 Unchecked_Convert_To
(Anon_Type
,
549 Make_Attribute_Reference
(Loc
,
551 Attribute_Name
=> Name_Address
)));
554 Make_Explicit_Dereference
(Loc
,
555 Unchecked_Convert_To
(Anon_Type
, Expr
));
559 end Convert_Tag_To_Interface
;
565 function CPP_Num_Prims
(Typ
: Entity_Id
) return Nat
is
567 Tag_Comp
: Entity_Id
;
570 if not Is_Tagged_Type
(Typ
)
571 or else not Is_CPP_Class
(Root_Type
(Typ
))
576 CPP_Typ
:= Enclosing_CPP_Parent
(Typ
);
577 Tag_Comp
:= First_Tag_Component
(CPP_Typ
);
579 -- If number of primitives already set in the tag component, use it
581 if Present
(Tag_Comp
)
582 and then DT_Entry_Count
(Tag_Comp
) /= No_Uint
584 return UI_To_Int
(DT_Entry_Count
(Tag_Comp
));
586 -- Otherwise, count the primitives of the enclosing CPP type
594 Elmt
:= First_Elmt
(Primitive_Operations
(CPP_Typ
));
595 while Present
(Elmt
) loop
606 ------------------------------
607 -- Default_Prim_Op_Position --
608 ------------------------------
610 function Default_Prim_Op_Position
(E
: Entity_Id
) return Uint
is
611 TSS_Name
: TSS_Name_Type
;
614 Get_Name_String
(Chars
(E
));
617 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
619 if Chars
(E
) = Name_uSize
then
622 elsif TSS_Name
= TSS_Stream_Read
then
625 elsif TSS_Name
= TSS_Stream_Write
then
628 elsif TSS_Name
= TSS_Stream_Input
then
631 elsif TSS_Name
= TSS_Stream_Output
then
634 elsif Chars
(E
) = Name_Op_Eq
then
637 elsif Chars
(E
) = Name_uAssign
then
640 elsif TSS_Name
= TSS_Deep_Adjust
then
643 elsif TSS_Name
= TSS_Deep_Finalize
then
646 -- In VM targets unconditionally allow obtaining the position associated
647 -- with predefined interface primitives since in these platforms any
648 -- tagged type has these primitives.
650 elsif Ada_Version
>= Ada_2005
or else not Tagged_Type_Expansion
then
651 if Chars
(E
) = Name_uDisp_Asynchronous_Select
then
654 elsif Chars
(E
) = Name_uDisp_Conditional_Select
then
657 elsif Chars
(E
) = Name_uDisp_Get_Prim_Op_Kind
then
660 elsif Chars
(E
) = Name_uDisp_Get_Task_Id
then
663 elsif Chars
(E
) = Name_uDisp_Requeue
then
666 elsif Chars
(E
) = Name_uDisp_Timed_Select
then
672 end Default_Prim_Op_Position
;
674 ----------------------
675 -- Elab_Flag_Needed --
676 ----------------------
678 function Elab_Flag_Needed
(Typ
: Entity_Id
) return Boolean is
680 return Ada_Version
>= Ada_2005
681 and then not Is_Interface
(Typ
)
682 and then Has_Interfaces
(Typ
)
683 and then not Building_Static_DT
(Typ
);
684 end Elab_Flag_Needed
;
686 -----------------------------
687 -- Expand_Dispatching_Call --
688 -----------------------------
690 procedure Expand_Dispatching_Call
(Call_Node
: Node_Id
) is
691 Loc
: constant Source_Ptr
:= Sloc
(Call_Node
);
692 Call_Typ
: constant Entity_Id
:= Etype
(Call_Node
);
694 Ctrl_Arg
: constant Node_Id
:= Controlling_Argument
(Call_Node
);
695 Ctrl_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Ctrl_Arg
));
696 Param_List
: constant List_Id
:= Parameter_Associations
(Call_Node
);
701 New_Call_Name
: Node_Id
;
702 New_Params
: List_Id
:= No_List
;
705 Subp_Ptr_Typ
: Entity_Id
;
706 Subp_Typ
: Entity_Id
;
708 Eq_Prim_Op
: Entity_Id
:= Empty
;
709 Controlling_Tag
: Node_Id
;
711 procedure Build_Class_Wide_Check
;
712 -- If the denoted subprogram has a class-wide precondition, generate a
713 -- check using that precondition before the dispatching call, because
714 -- this is the only class-wide precondition that applies to the call.
716 function New_Value
(From
: Node_Id
) return Node_Id
;
717 -- From is the original Expression. New_Value is equivalent to a call
718 -- to Duplicate_Subexpr with an explicit dereference when From is an
721 ----------------------------
722 -- Build_Class_Wide_Check --
723 ----------------------------
725 procedure Build_Class_Wide_Check
is
726 function Replace_Formals
(N
: Node_Id
) return Traverse_Result
;
727 -- Replace occurrences of the formals of the subprogram by the
728 -- corresponding actuals in the call, given that this check is
729 -- performed outside of the body of the subprogram.
731 ---------------------
732 -- Replace_Formals --
733 ---------------------
735 function Replace_Formals
(N
: Node_Id
) return Traverse_Result
is
737 if Is_Entity_Name
(N
)
738 and then Present
(Entity
(N
))
739 and then Is_Formal
(Entity
(N
))
746 F
:= First_Formal
(Subp
);
747 A
:= First_Actual
(Call_Node
);
748 while Present
(F
) loop
749 if F
= Entity
(N
) then
750 Rewrite
(N
, New_Copy_Tree
(A
));
752 -- If the formal is class-wide, and thus not a
753 -- controlling argument, preserve its type because
754 -- it may appear in a nested call with a class-wide
757 if Is_Class_Wide_Type
(Etype
(F
)) then
758 Set_Etype
(N
, Etype
(F
));
760 -- Conversely, if this is a controlling argument
761 -- (in a dispatching call in the condition) that is a
762 -- dereference, the source is an access-to-class-wide
763 -- type, so preserve the dispatching nature of the
764 -- call in the rewritten condition.
766 elsif Nkind
(Parent
(N
)) = N_Explicit_Dereference
767 and then Is_Controlling_Actual
(Parent
(N
))
769 Set_Controlling_Argument
(Parent
(Parent
(N
)),
785 procedure Update
is new Traverse_Proc
(Replace_Formals
);
789 Str_Loc
: constant String := Build_Location_String
(Loc
);
795 -- Start of processing for Build_Class_Wide_Check
799 -- Locate class-wide precondition, if any
801 if Present
(Contract
(Subp
))
802 and then Present
(Pre_Post_Conditions
(Contract
(Subp
)))
804 Prec
:= Pre_Post_Conditions
(Contract
(Subp
));
806 while Present
(Prec
) loop
807 exit when Pragma_Name
(Prec
) = Name_Precondition
808 and then Class_Present
(Prec
);
809 Prec
:= Next_Pragma
(Prec
);
812 if No
(Prec
) or else Is_Ignored
(Prec
) then
816 -- The expression for the precondition is analyzed within the
817 -- generated pragma. The message text is the last parameter of
818 -- the generated pragma, indicating source of precondition.
822 (Expression
(First
(Pragma_Argument_Associations
(Prec
))));
825 -- Build message indicating the failed precondition and the
826 -- dispatching call that caused it.
828 Msg
:= Expression
(Last
(Pragma_Argument_Associations
(Prec
)));
830 Append
(Global_Name_Buffer
, Strval
(Msg
));
831 Append
(Global_Name_Buffer
, " in dispatching call at ");
832 Append
(Global_Name_Buffer
, Str_Loc
);
833 Msg
:= Make_String_Literal
(Loc
, Name_Buffer
(1 .. Name_Len
));
835 Insert_Action
(Call_Node
,
836 Make_If_Statement
(Loc
,
837 Condition
=> Make_Op_Not
(Loc
, Cond
),
838 Then_Statements
=> New_List
(
839 Make_Procedure_Call_Statement
(Loc
,
841 New_Occurrence_Of
(RTE
(RE_Raise_Assert_Failure
), Loc
),
842 Parameter_Associations
=> New_List
(Msg
)))));
844 end Build_Class_Wide_Check
;
850 function New_Value
(From
: Node_Id
) return Node_Id
is
851 Res
: constant Node_Id
:= Duplicate_Subexpr
(From
);
853 if Is_Access_Type
(Etype
(From
)) then
855 Make_Explicit_Dereference
(Sloc
(From
),
865 SCIL_Node
: Node_Id
:= Empty
;
866 SCIL_Related_Node
: Node_Id
:= Call_Node
;
868 -- Start of processing for Expand_Dispatching_Call
871 if No_Run_Time_Mode
then
872 Error_Msg_CRT
("tagged types", Call_Node
);
876 -- Expand_Dispatching_Call is called directly from the semantics, so we
877 -- only proceed if the expander is active.
879 if not Expander_Active
881 -- And there is no need to expand the call if we are compiling under
882 -- restriction No_Dispatching_Calls; the semantic analyzer has
883 -- previously notified the violation of this restriction.
885 or else Restriction_Active
(No_Dispatching_Calls
)
887 -- No action needed if the dispatching call has been already expanded
889 or else Is_Expanded_Dispatching_Call
(Name
(Call_Node
))
894 -- Set subprogram. If this is an inherited operation that was
895 -- overridden, the body that is being called is its alias.
897 Subp
:= Entity
(Name
(Call_Node
));
899 if Present
(Alias
(Subp
))
900 and then Is_Inherited_Operation
(Subp
)
901 and then No
(DTC_Entity
(Subp
))
903 Subp
:= Alias
(Subp
);
906 Build_Class_Wide_Check
;
908 -- Definition of the class-wide type and the tagged type
910 -- If the controlling argument is itself a tag rather than a tagged
911 -- object, then use the class-wide type associated with the subprogram's
912 -- controlling type. This case can occur when a call to an inherited
913 -- primitive has an actual that originated from a default parameter
914 -- given by a tag-indeterminate call and when there is no other
915 -- controlling argument providing the tag (AI-239 requires dispatching).
916 -- This capability of dispatching directly by tag is also needed by the
917 -- implementation of AI-260 (for the generic dispatching constructors).
919 if Ctrl_Typ
= RTE
(RE_Tag
)
920 or else (RTE_Available
(RE_Interface_Tag
)
921 and then Ctrl_Typ
= RTE
(RE_Interface_Tag
))
923 CW_Typ
:= Class_Wide_Type
(Find_Dispatching_Type
(Subp
));
925 -- Class_Wide_Type is applied to the expressions used to initialize
926 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
927 -- there are cases where the controlling type is resolved to a specific
928 -- type (such as for designated types of arguments such as CW'Access).
930 elsif Is_Access_Type
(Ctrl_Typ
) then
931 CW_Typ
:= Class_Wide_Type
(Designated_Type
(Ctrl_Typ
));
934 CW_Typ
:= Class_Wide_Type
(Ctrl_Typ
);
937 Typ
:= Find_Specific_Type
(CW_Typ
);
939 if not Is_Limited_Type
(Typ
) then
940 Eq_Prim_Op
:= Find_Prim_Op
(Typ
, Name_Op_Eq
);
943 -- Dispatching call to C++ primitive. Create a new parameter list
944 -- with no tag checks.
946 New_Params
:= New_List
;
948 if Is_CPP_Class
(Typ
) then
949 Param
:= First_Actual
(Call_Node
);
950 while Present
(Param
) loop
951 Append_To
(New_Params
, Relocate_Node
(Param
));
955 -- Dispatching call to Ada primitive
957 elsif Present
(Param_List
) then
958 Apply_Tag_Checks
(Call_Node
);
960 Param
:= First_Actual
(Call_Node
);
961 while Present
(Param
) loop
963 -- Cases in which we may have generated run-time checks. Note that
964 -- we strip any qualification from Param before comparing with the
965 -- already-stripped controlling argument.
967 if Unqualify
(Param
) = Ctrl_Arg
or else Subp
= Eq_Prim_Op
then
968 Append_To
(New_Params
,
969 Duplicate_Subexpr_Move_Checks
(Param
));
971 elsif Nkind
(Parent
(Param
)) /= N_Parameter_Association
972 or else not Is_Accessibility_Actual
(Parent
(Param
))
974 Append_To
(New_Params
, Relocate_Node
(Param
));
981 -- Generate the appropriate subprogram pointer type
983 if Etype
(Subp
) = Typ
then
986 Res_Typ
:= Etype
(Subp
);
989 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, Call_Node
);
990 Subp_Ptr_Typ
:= Create_Itype
(E_Access_Subprogram_Type
, Call_Node
);
991 Set_Etype
(Subp_Typ
, Res_Typ
);
992 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
993 Set_Convention
(Subp_Typ
, Convention
(Subp
));
995 -- Notify gigi that the designated type is a dispatching primitive
997 Set_Is_Dispatch_Table_Entity
(Subp_Typ
);
999 -- Create a new list of parameters which is a copy of the old formal
1000 -- list including the creation of a new set of matching entities.
1003 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
1004 New_Formal
: Entity_Id
;
1005 Extra
: Entity_Id
:= Empty
;
1008 if Present
(Old_Formal
) then
1009 New_Formal
:= New_Copy
(Old_Formal
);
1010 Set_First_Entity
(Subp_Typ
, New_Formal
);
1011 Param
:= First_Actual
(Call_Node
);
1014 Set_Scope
(New_Formal
, Subp_Typ
);
1016 -- Change all the controlling argument types to be class-wide
1017 -- to avoid a recursion in dispatching.
1019 if Is_Controlling_Formal
(New_Formal
) then
1020 Set_Etype
(New_Formal
, Etype
(Param
));
1023 -- If the type of the formal is an itype, there was code here
1024 -- introduced in 1998 in revision 1.46, to create a new itype
1025 -- by copy. This seems useless, and in fact leads to semantic
1026 -- errors when the itype is the completion of a type derived
1027 -- from a private type.
1029 Extra
:= New_Formal
;
1030 Next_Formal
(Old_Formal
);
1031 exit when No
(Old_Formal
);
1033 Link_Entities
(New_Formal
, New_Copy
(Old_Formal
));
1034 Next_Entity
(New_Formal
);
1035 Next_Actual
(Param
);
1038 Unlink_Next_Entity
(New_Formal
);
1039 Set_Last_Entity
(Subp_Typ
, Extra
);
1042 -- Now that the explicit formals have been duplicated, any extra
1043 -- formals needed by the subprogram must be created.
1045 if Present
(Extra
) then
1046 Set_Extra_Formal
(Extra
, Empty
);
1049 Create_Extra_Formals
(Subp_Typ
);
1052 -- Complete description of pointer type, including size information, as
1053 -- must be done with itypes to prevent order-of-elaboration anomalies
1056 Set_Etype
(Subp_Ptr_Typ
, Subp_Ptr_Typ
);
1057 Set_Directly_Designated_Type
(Subp_Ptr_Typ
, Subp_Typ
);
1058 Set_Convention
(Subp_Ptr_Typ
, Convention
(Subp_Typ
));
1059 Layout_Type
(Subp_Ptr_Typ
);
1061 -- If the controlling argument is a value of type Ada.Tag or an abstract
1062 -- interface class-wide type then use it directly. Otherwise, the tag
1063 -- must be extracted from the controlling object.
1065 if Ctrl_Typ
= RTE
(RE_Tag
)
1066 or else (RTE_Available
(RE_Interface_Tag
)
1067 and then Ctrl_Typ
= RTE
(RE_Interface_Tag
))
1069 Controlling_Tag
:= Duplicate_Subexpr
(Ctrl_Arg
);
1071 -- Extract the tag from an unchecked type conversion. Done to avoid
1072 -- the expansion of additional code just to obtain the value of such
1073 -- tag because the current management of interface type conversions
1074 -- generates in some cases this unchecked type conversion with the
1075 -- tag of the object (see Expand_Interface_Conversion).
1077 elsif Nkind
(Ctrl_Arg
) = N_Unchecked_Type_Conversion
1079 (Etype
(Expression
(Ctrl_Arg
)) = RTE
(RE_Tag
)
1081 (RTE_Available
(RE_Interface_Tag
)
1083 Etype
(Expression
(Ctrl_Arg
)) = RTE
(RE_Interface_Tag
)))
1085 Controlling_Tag
:= Duplicate_Subexpr
(Expression
(Ctrl_Arg
));
1087 -- Ada 2005 (AI-251): Abstract interface class-wide type
1089 elsif Is_Interface
(Ctrl_Typ
)
1090 and then Is_Class_Wide_Type
(Ctrl_Typ
)
1092 Controlling_Tag
:= Duplicate_Subexpr
(Ctrl_Arg
);
1096 Make_Selected_Component
(Loc
,
1097 Prefix
=> Duplicate_Subexpr_Move_Checks
(Ctrl_Arg
),
1098 Selector_Name
=> New_Occurrence_Of
(DTC_Entity
(Subp
), Loc
));
1101 -- Handle dispatching calls to predefined primitives
1103 if Is_Predefined_Dispatching_Operation
(Subp
)
1104 or else Is_Predefined_Dispatching_Alias
(Subp
)
1106 Build_Get_Predefined_Prim_Op_Address
(Loc
,
1107 Tag_Node
=> Controlling_Tag
,
1108 Position
=> DT_Position
(Subp
),
1109 New_Node
=> New_Node
);
1111 -- Handle dispatching calls to user-defined primitives
1114 Build_Get_Prim_Op_Address
(Loc
,
1115 Typ
=> Underlying_Type
(Find_Dispatching_Type
(Subp
)),
1116 Tag_Node
=> Controlling_Tag
,
1117 Position
=> DT_Position
(Subp
),
1118 New_Node
=> New_Node
);
1122 Unchecked_Convert_To
(Subp_Ptr_Typ
, New_Node
);
1124 -- Generate the SCIL node for this dispatching call. Done now because
1125 -- attribute SCIL_Controlling_Tag must be set after the new call name
1126 -- is built to reference the nodes that will see the SCIL backend
1127 -- (because Build_Get_Prim_Op_Address generates an unchecked type
1128 -- conversion which relocates the controlling tag node).
1130 if Generate_SCIL
then
1131 SCIL_Node
:= Make_SCIL_Dispatching_Call
(Sloc
(Call_Node
));
1132 Set_SCIL_Entity
(SCIL_Node
, Typ
);
1133 Set_SCIL_Target_Prim
(SCIL_Node
, Subp
);
1135 -- Common case: the controlling tag is the tag of an object
1136 -- (for example, obj.tag)
1138 if Nkind
(Controlling_Tag
) = N_Selected_Component
then
1139 Set_SCIL_Controlling_Tag
(SCIL_Node
, Controlling_Tag
);
1141 -- Handle renaming of selected component
1143 elsif Nkind
(Controlling_Tag
) = N_Identifier
1144 and then Nkind
(Parent
(Entity
(Controlling_Tag
))) =
1145 N_Object_Renaming_Declaration
1146 and then Nkind
(Name
(Parent
(Entity
(Controlling_Tag
)))) =
1147 N_Selected_Component
1149 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1150 Name
(Parent
(Entity
(Controlling_Tag
))));
1152 -- If the controlling tag is an identifier, the SCIL node references
1153 -- the corresponding object or parameter declaration
1155 elsif Nkind
(Controlling_Tag
) = N_Identifier
1156 and then Nkind_In
(Parent
(Entity
(Controlling_Tag
)),
1157 N_Object_Declaration
,
1158 N_Parameter_Specification
)
1160 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1161 Parent
(Entity
(Controlling_Tag
)));
1163 -- If the controlling tag is a dereference, the SCIL node references
1164 -- the corresponding object or parameter declaration
1166 elsif Nkind
(Controlling_Tag
) = N_Explicit_Dereference
1167 and then Nkind
(Prefix
(Controlling_Tag
)) = N_Identifier
1168 and then Nkind_In
(Parent
(Entity
(Prefix
(Controlling_Tag
))),
1169 N_Object_Declaration
,
1170 N_Parameter_Specification
)
1172 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1173 Parent
(Entity
(Prefix
(Controlling_Tag
))));
1175 -- For a direct reference of the tag of the type the SCIL node
1176 -- references the internal object declaration containing the tag
1179 elsif Nkind
(Controlling_Tag
) = N_Attribute_Reference
1180 and then Attribute_Name
(Controlling_Tag
) = Name_Tag
1182 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1186 (Access_Disp_Table
(Entity
(Prefix
(Controlling_Tag
)))))));
1188 -- Interfaces are not supported. For now we leave the SCIL node
1189 -- decorated with the Controlling_Tag. More work needed here???
1191 elsif Is_Interface
(Etype
(Controlling_Tag
)) then
1192 Set_SCIL_Controlling_Tag
(SCIL_Node
, Controlling_Tag
);
1195 pragma Assert
(False);
1200 if Nkind
(Call_Node
) = N_Function_Call
then
1202 Make_Function_Call
(Loc
,
1203 Name
=> New_Call_Name
,
1204 Parameter_Associations
=> New_Params
);
1206 -- If this is a dispatching "=", we must first compare the tags so
1207 -- we generate: x.tag = y.tag and then x = y
1209 if Subp
= Eq_Prim_Op
then
1210 Param
:= First_Actual
(Call_Node
);
1216 Make_Selected_Component
(Loc
,
1217 Prefix
=> New_Value
(Param
),
1219 New_Occurrence_Of
(First_Tag_Component
(Typ
),
1223 Make_Selected_Component
(Loc
,
1225 Unchecked_Convert_To
(Typ
,
1226 New_Value
(Next_Actual
(Param
))),
1229 (First_Tag_Component
(Typ
), Loc
))),
1230 Right_Opnd
=> New_Call
);
1232 SCIL_Related_Node
:= Right_Opnd
(New_Call
);
1237 Make_Procedure_Call_Statement
(Loc
,
1238 Name
=> New_Call_Name
,
1239 Parameter_Associations
=> New_Params
);
1242 -- Register the dispatching call in the call graph nodes table
1244 Register_CG_Node
(Call_Node
);
1246 Rewrite
(Call_Node
, New_Call
);
1248 -- Associate the SCIL node of this dispatching call
1250 if Generate_SCIL
then
1251 Set_SCIL_Node
(SCIL_Related_Node
, SCIL_Node
);
1254 -- Suppress all checks during the analysis of the expanded code to avoid
1255 -- the generation of spurious warnings under ZFP run-time.
1257 Analyze_And_Resolve
(Call_Node
, Call_Typ
, Suppress
=> All_Checks
);
1258 end Expand_Dispatching_Call
;
1260 ---------------------------------
1261 -- Expand_Interface_Conversion --
1262 ---------------------------------
1264 procedure Expand_Interface_Conversion
(N
: Node_Id
) is
1265 function Underlying_Record_Type
(Typ
: Entity_Id
) return Entity_Id
;
1266 -- Return the underlying record type of Typ
1268 ----------------------------
1269 -- Underlying_Record_Type --
1270 ----------------------------
1272 function Underlying_Record_Type
(Typ
: Entity_Id
) return Entity_Id
is
1273 E
: Entity_Id
:= Typ
;
1276 -- Handle access types
1278 if Is_Access_Type
(E
) then
1279 E
:= Directly_Designated_Type
(E
);
1282 -- Handle class-wide types. This conversion can appear explicitly in
1283 -- the source code. Example: I'Class (Obj)
1285 if Is_Class_Wide_Type
(E
) then
1289 -- If the target type is a tagged synchronized type, the dispatch
1290 -- table info is in the corresponding record type.
1292 if Is_Concurrent_Type
(E
) then
1293 E
:= Corresponding_Record_Type
(E
);
1296 -- Handle private types
1298 E
:= Underlying_Type
(E
);
1302 return Base_Type
(E
);
1303 end Underlying_Record_Type
;
1307 Loc
: constant Source_Ptr
:= Sloc
(N
);
1308 Etyp
: constant Entity_Id
:= Etype
(N
);
1309 Operand
: constant Node_Id
:= Expression
(N
);
1310 Operand_Typ
: Entity_Id
:= Etype
(Operand
);
1312 Iface_Typ
: constant Entity_Id
:= Underlying_Record_Type
(Etype
(N
));
1313 Iface_Tag
: Entity_Id
;
1314 Is_Static
: Boolean;
1316 -- Start of processing for Expand_Interface_Conversion
1319 -- Freeze the entity associated with the target interface to have
1320 -- available the attribute Access_Disp_Table.
1322 Freeze_Before
(N
, Iface_Typ
);
1324 -- Ada 2005 (AI-345): Handle synchronized interface type derivations
1326 if Is_Concurrent_Type
(Operand_Typ
) then
1327 Operand_Typ
:= Base_Type
(Corresponding_Record_Type
(Operand_Typ
));
1330 -- No displacement of the pointer to the object needed when the type of
1331 -- the operand is not an interface type and the interface is one of
1332 -- its parent types (since they share the primary dispatch table).
1335 Opnd
: Entity_Id
:= Operand_Typ
;
1338 if Is_Access_Type
(Opnd
) then
1339 Opnd
:= Designated_Type
(Opnd
);
1342 Opnd
:= Underlying_Record_Type
(Opnd
);
1344 if not Is_Interface
(Opnd
)
1345 and then Is_Ancestor
(Iface_Typ
, Opnd
, Use_Full_View
=> True)
1350 -- When the type of the operand and the target interface type match,
1351 -- it is generally safe to skip generating code to displace the
1352 -- pointer to the object to reference the secondary dispatch table
1353 -- associated with the target interface type. The exception to this
1354 -- general rule is when the underlying object of the type conversion
1355 -- is an object built by means of a dispatching constructor (since in
1356 -- such case the expansion of the constructor call is a direct call
1357 -- to an object primitive, i.e. without thunks, and the expansion of
1358 -- the constructor call adds an explicit conversion to the target
1359 -- interface type to force the displacement of the pointer to the
1360 -- object to reference the corresponding secondary dispatch table
1361 -- (cf. Make_DT and Expand_Dispatching_Constructor_Call)).
1363 -- At this stage we cannot identify whether the underlying object is
1364 -- a BIP object and hence we cannot skip generating the code to try
1365 -- displacing the pointer to the object. However, under configurable
1366 -- runtime it is safe to skip generating code to displace the pointer
1367 -- to the object, because generic dispatching constructors are not
1370 if Opnd
= Iface_Typ
and then not RTE_Available
(RE_Displace
) then
1375 -- Evaluate if we can statically displace the pointer to the object
1378 Opnd_Typ
: constant Node_Id
:= Underlying_Record_Type
(Operand_Typ
);
1382 not Is_Interface
(Opnd_Typ
)
1383 and then Interface_Present_In_Ancestor
1386 and then (Etype
(Opnd_Typ
) = Opnd_Typ
1388 Is_Variable_Size_Record
(Etype
(Opnd_Typ
)));
1391 if not Tagged_Type_Expansion
then
1394 -- A static conversion to an interface type that is not class-wide is
1395 -- curious but legal if the interface operation is a null procedure.
1396 -- If the operation is abstract it will be rejected later.
1399 and then Is_Interface
(Etype
(N
))
1400 and then not Is_Class_Wide_Type
(Etype
(N
))
1401 and then Comes_From_Source
(N
)
1403 Rewrite
(N
, Unchecked_Convert_To
(Etype
(N
), N
));
1408 if not Is_Static
then
1410 -- Give error if configurable run-time and Displace not available
1412 if not RTE_Available
(RE_Displace
) then
1413 Error_Msg_CRT
("dynamic interface conversion", N
);
1417 -- Handle conversion of access-to-class-wide interface types. Target
1418 -- can be an access to an object or an access to another class-wide
1419 -- interface (see -1- and -2- in the following example):
1421 -- type Iface1_Ref is access all Iface1'Class;
1422 -- type Iface2_Ref is access all Iface1'Class;
1424 -- Acc1 : Iface1_Ref := new ...
1425 -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1
1426 -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
1428 if Is_Access_Type
(Operand_Typ
) then
1430 Unchecked_Convert_To
(Etype
(N
),
1431 Make_Function_Call
(Loc
,
1432 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
1433 Parameter_Associations
=> New_List
(
1435 Unchecked_Convert_To
(RTE
(RE_Address
),
1436 Relocate_Node
(Expression
(N
))),
1439 (Node
(First_Elmt
(Access_Disp_Table
(Iface_Typ
))),
1447 Make_Function_Call
(Loc
,
1448 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
1449 Parameter_Associations
=> New_List
(
1450 Make_Attribute_Reference
(Loc
,
1451 Prefix
=> Relocate_Node
(Expression
(N
)),
1452 Attribute_Name
=> Name_Address
),
1455 (Node
(First_Elmt
(Access_Disp_Table
(Iface_Typ
))),
1460 -- If target is a class-wide interface, change the type of the data
1461 -- returned by IW_Convert to indicate this is a dispatching call.
1464 New_Itype
: Entity_Id
;
1467 New_Itype
:= Create_Itype
(E_Anonymous_Access_Type
, N
);
1468 Set_Etype
(New_Itype
, New_Itype
);
1469 Set_Directly_Designated_Type
(New_Itype
, Etyp
);
1472 Make_Explicit_Dereference
(Loc
,
1474 Unchecked_Convert_To
(New_Itype
, Relocate_Node
(N
))));
1476 Freeze_Itype
(New_Itype
, N
);
1482 Iface_Tag
:= Find_Interface_Tag
(Operand_Typ
, Iface_Typ
);
1483 pragma Assert
(Present
(Iface_Tag
));
1485 -- Keep separate access types to interfaces because one internal
1486 -- function is used to handle the null value (see following comments)
1488 if not Is_Access_Type
(Etype
(N
)) then
1490 -- Statically displace the pointer to the object to reference the
1491 -- component containing the secondary dispatch table.
1494 Convert_Tag_To_Interface
(Class_Wide_Type
(Iface_Typ
),
1495 Make_Selected_Component
(Loc
,
1496 Prefix
=> Relocate_Node
(Expression
(N
)),
1497 Selector_Name
=> New_Occurrence_Of
(Iface_Tag
, Loc
))));
1500 -- Build internal function to handle the case in which the actual is
1501 -- null. If the actual is null returns null because no displacement
1502 -- is required; otherwise performs a type conversion that will be
1503 -- expanded in the code that returns the value of the displaced
1506 -- function Func (O : Address) return Iface_Typ is
1507 -- type Op_Typ is access all Operand_Typ;
1508 -- Aux : Op_Typ := To_Op_Typ (O);
1510 -- if O = Null_Address then
1513 -- return Iface_Typ!(Aux.Iface_Tag'Address);
1518 Desig_Typ
: Entity_Id
;
1520 New_Typ_Decl
: Node_Id
;
1524 Desig_Typ
:= Etype
(Expression
(N
));
1526 if Is_Access_Type
(Desig_Typ
) then
1528 Available_View
(Directly_Designated_Type
(Desig_Typ
));
1531 if Is_Concurrent_Type
(Desig_Typ
) then
1532 Desig_Typ
:= Base_Type
(Corresponding_Record_Type
(Desig_Typ
));
1536 Make_Full_Type_Declaration
(Loc
,
1537 Defining_Identifier
=> Make_Temporary
(Loc
, 'T'),
1539 Make_Access_To_Object_Definition
(Loc
,
1540 All_Present
=> True,
1541 Null_Exclusion_Present
=> False,
1542 Constant_Present
=> False,
1543 Subtype_Indication
=>
1544 New_Occurrence_Of
(Desig_Typ
, Loc
)));
1547 Make_Simple_Return_Statement
(Loc
,
1548 Unchecked_Convert_To
(Etype
(N
),
1549 Make_Attribute_Reference
(Loc
,
1551 Make_Selected_Component
(Loc
,
1553 Unchecked_Convert_To
1554 (Defining_Identifier
(New_Typ_Decl
),
1555 Make_Identifier
(Loc
, Name_uO
)),
1557 New_Occurrence_Of
(Iface_Tag
, Loc
)),
1558 Attribute_Name
=> Name_Address
))));
1560 -- If the type is null-excluding, no need for the null branch.
1561 -- Otherwise we need to check for it and return null.
1563 if not Can_Never_Be_Null
(Etype
(N
)) then
1565 Make_If_Statement
(Loc
,
1568 Left_Opnd
=> Make_Identifier
(Loc
, Name_uO
),
1569 Right_Opnd
=> New_Occurrence_Of
1570 (RTE
(RE_Null_Address
), Loc
)),
1572 Then_Statements
=> New_List
(
1573 Make_Simple_Return_Statement
(Loc
, Make_Null
(Loc
))),
1574 Else_Statements
=> Stats
));
1577 Fent
:= Make_Temporary
(Loc
, 'F');
1579 Make_Subprogram_Body
(Loc
,
1581 Make_Function_Specification
(Loc
,
1582 Defining_Unit_Name
=> Fent
,
1584 Parameter_Specifications
=> New_List
(
1585 Make_Parameter_Specification
(Loc
,
1586 Defining_Identifier
=>
1587 Make_Defining_Identifier
(Loc
, Name_uO
),
1589 New_Occurrence_Of
(RTE
(RE_Address
), Loc
))),
1591 Result_Definition
=>
1592 New_Occurrence_Of
(Etype
(N
), Loc
)),
1594 Declarations
=> New_List
(New_Typ_Decl
),
1596 Handled_Statement_Sequence
=>
1597 Make_Handled_Sequence_Of_Statements
(Loc
, Stats
));
1599 -- Place function body before the expression containing the
1600 -- conversion. We suppress all checks because the body of the
1601 -- internally generated function already takes care of the case
1602 -- in which the actual is null; therefore there is no need to
1603 -- double check that the pointer is not null when the program
1604 -- executes the alternative that performs the type conversion).
1606 Insert_Action
(N
, Func
, Suppress
=> All_Checks
);
1608 if Is_Access_Type
(Etype
(Expression
(N
))) then
1610 -- Generate: Func (Address!(Expression))
1613 Make_Function_Call
(Loc
,
1614 Name
=> New_Occurrence_Of
(Fent
, Loc
),
1615 Parameter_Associations
=> New_List
(
1616 Unchecked_Convert_To
(RTE
(RE_Address
),
1617 Relocate_Node
(Expression
(N
))))));
1620 -- Generate: Func (Operand_Typ!(Expression)'Address)
1623 Make_Function_Call
(Loc
,
1624 Name
=> New_Occurrence_Of
(Fent
, Loc
),
1625 Parameter_Associations
=> New_List
(
1626 Make_Attribute_Reference
(Loc
,
1627 Prefix
=> Unchecked_Convert_To
(Operand_Typ
,
1628 Relocate_Node
(Expression
(N
))),
1629 Attribute_Name
=> Name_Address
))));
1635 end Expand_Interface_Conversion
;
1637 ------------------------------
1638 -- Expand_Interface_Actuals --
1639 ------------------------------
1641 procedure Expand_Interface_Actuals
(Call_Node
: Node_Id
) is
1643 Actual_Dup
: Node_Id
;
1644 Actual_Typ
: Entity_Id
;
1646 Conversion
: Node_Id
;
1648 Formal_Typ
: Entity_Id
;
1650 Formal_DDT
: Entity_Id
:= Empty
; -- initialize to prevent warning
1651 Actual_DDT
: Entity_Id
:= Empty
; -- initialize to prevent warning
1654 -- This subprogram is called directly from the semantics, so we need a
1655 -- check to see whether expansion is active before proceeding.
1657 if not Expander_Active
then
1661 -- Call using access to subprogram with explicit dereference
1663 if Nkind
(Name
(Call_Node
)) = N_Explicit_Dereference
then
1664 Subp
:= Etype
(Name
(Call_Node
));
1666 -- Call using selected component
1668 elsif Nkind
(Name
(Call_Node
)) = N_Selected_Component
then
1669 Subp
:= Entity
(Selector_Name
(Name
(Call_Node
)));
1671 -- Call using direct name
1674 Subp
:= Entity
(Name
(Call_Node
));
1677 -- Ada 2005 (AI-251): Look for interface type formals to force "this"
1680 Formal
:= First_Formal
(Subp
);
1681 Actual
:= First_Actual
(Call_Node
);
1682 while Present
(Formal
) loop
1683 Formal_Typ
:= Etype
(Formal
);
1685 if Ekind
(Formal_Typ
) = E_Record_Type_With_Private
then
1686 Formal_Typ
:= Full_View
(Formal_Typ
);
1689 if Is_Access_Type
(Formal_Typ
) then
1690 Formal_DDT
:= Directly_Designated_Type
(Formal_Typ
);
1693 Actual_Typ
:= Etype
(Actual
);
1695 if Is_Access_Type
(Actual_Typ
) then
1696 Actual_DDT
:= Directly_Designated_Type
(Actual_Typ
);
1699 if Is_Interface
(Formal_Typ
)
1700 and then Is_Class_Wide_Type
(Formal_Typ
)
1702 -- No need to displace the pointer if the type of the actual
1703 -- coincides with the type of the formal.
1705 if Actual_Typ
= Formal_Typ
then
1708 -- No need to displace the pointer if the interface type is a
1709 -- parent of the type of the actual because in this case the
1710 -- interface primitives are located in the primary dispatch table.
1712 elsif Is_Ancestor
(Formal_Typ
, Actual_Typ
,
1713 Use_Full_View
=> True)
1717 -- Implicit conversion to the class-wide formal type to force the
1718 -- displacement of the pointer.
1721 -- Normally, expansion of actuals for calls to build-in-place
1722 -- functions happens as part of Expand_Actuals, but in this
1723 -- case the call will be wrapped in a conversion and soon after
1724 -- expanded further to handle the displacement for a class-wide
1725 -- interface conversion, so if this is a BIP call then we need
1726 -- to handle it now.
1728 if Is_Build_In_Place_Function_Call
(Actual
) then
1729 Make_Build_In_Place_Call_In_Anonymous_Context
(Actual
);
1732 Conversion
:= Convert_To
(Formal_Typ
, Relocate_Node
(Actual
));
1733 Rewrite
(Actual
, Conversion
);
1734 Analyze_And_Resolve
(Actual
, Formal_Typ
);
1737 -- Access to class-wide interface type
1739 elsif Is_Access_Type
(Formal_Typ
)
1740 and then Is_Interface
(Formal_DDT
)
1741 and then Is_Class_Wide_Type
(Formal_DDT
)
1742 and then Interface_Present_In_Ancestor
1744 Iface
=> Etype
(Formal_DDT
))
1746 -- Handle attributes 'Access and 'Unchecked_Access
1748 if Nkind
(Actual
) = N_Attribute_Reference
1750 (Attribute_Name
(Actual
) = Name_Access
1751 or else Attribute_Name
(Actual
) = Name_Unchecked_Access
)
1753 -- This case must have been handled by the analysis and
1754 -- expansion of 'Access. The only exception is when types
1755 -- match and no further expansion is required.
1757 pragma Assert
(Base_Type
(Etype
(Prefix
(Actual
)))
1758 = Base_Type
(Formal_DDT
));
1761 -- No need to displace the pointer if the type of the actual
1762 -- coincides with the type of the formal.
1764 elsif Actual_DDT
= Formal_DDT
then
1767 -- No need to displace the pointer if the interface type is
1768 -- a parent of the type of the actual because in this case the
1769 -- interface primitives are located in the primary dispatch table.
1771 elsif Is_Ancestor
(Formal_DDT
, Actual_DDT
,
1772 Use_Full_View
=> True)
1777 Actual_Dup
:= Relocate_Node
(Actual
);
1779 if From_Limited_With
(Actual_Typ
) then
1781 -- If the type of the actual parameter comes from a limited
1782 -- with_clause and the nonlimited view is already available,
1783 -- we replace the anonymous access type by a duplicate
1784 -- declaration whose designated type is the nonlimited view.
1786 if Has_Non_Limited_View
(Actual_DDT
) then
1787 Anon
:= New_Copy
(Actual_Typ
);
1789 if Is_Itype
(Anon
) then
1790 Set_Scope
(Anon
, Current_Scope
);
1793 Set_Directly_Designated_Type
1794 (Anon
, Non_Limited_View
(Actual_DDT
));
1795 Set_Etype
(Actual_Dup
, Anon
);
1799 Conversion
:= Convert_To
(Formal_Typ
, Actual_Dup
);
1800 Rewrite
(Actual
, Conversion
);
1801 Analyze_And_Resolve
(Actual
, Formal_Typ
);
1805 Next_Actual
(Actual
);
1806 Next_Formal
(Formal
);
1808 end Expand_Interface_Actuals
;
1810 ----------------------------
1811 -- Expand_Interface_Thunk --
1812 ----------------------------
1814 procedure Expand_Interface_Thunk
1816 Thunk_Id
: out Entity_Id
;
1817 Thunk_Code
: out Node_Id
)
1819 Loc
: constant Source_Ptr
:= Sloc
(Prim
);
1820 Actuals
: constant List_Id
:= New_List
;
1821 Decl
: constant List_Id
:= New_List
;
1822 Formals
: constant List_Id
:= New_List
;
1823 Target
: constant Entity_Id
:= Ultimate_Alias
(Prim
);
1830 Iface_Formal
: Node_Id
:= Empty
; -- initialize to prevent warning
1831 Is_Predef_Op
: constant Boolean :=
1832 Is_Predefined_Dispatching_Operation
(Prim
)
1833 or else Is_Predefined_Dispatching_Operation
(Target
);
1835 Offset_To_Top
: Node_Id
;
1836 Target_Formal
: Entity_Id
;
1840 Thunk_Code
:= Empty
;
1842 -- No thunk needed if the primitive has been eliminated
1844 if Is_Eliminated
(Target
) then
1847 -- In case of primitives that are functions without formals and a
1848 -- controlling result there is no need to build the thunk.
1850 elsif not Present
(First_Formal
(Target
)) then
1851 pragma Assert
(Ekind
(Target
) = E_Function
1852 and then Has_Controlling_Result
(Target
));
1856 -- Duplicate the formals of the Target primitive. In the thunk, the type
1857 -- of the controlling formal is the covered interface type (instead of
1858 -- the target tagged type). Done to avoid problems with discriminated
1859 -- tagged types because, if the controlling type has discriminants with
1860 -- default values, then the type conversions done inside the body of
1861 -- the thunk (after the displacement of the pointer to the base of the
1862 -- actual object) generate code that modify its contents.
1864 -- Note: This special management is not done for predefined primitives
1865 -- because they don't have available the Interface_Alias attribute (see
1866 -- Sem_Ch3.Add_Internal_Interface_Entities).
1868 if not Is_Predef_Op
then
1869 Iface_Formal
:= First_Formal
(Interface_Alias
(Prim
));
1872 Formal
:= First_Formal
(Target
);
1873 while Present
(Formal
) loop
1874 Ftyp
:= Etype
(Formal
);
1876 -- Use the interface type as the type of the controlling formal (see
1879 if not Is_Controlling_Formal
(Formal
) or else Is_Predef_Op
then
1880 Ftyp
:= Etype
(Formal
);
1881 Expr
:= New_Copy_Tree
(Expression
(Parent
(Formal
)));
1883 Ftyp
:= Etype
(Iface_Formal
);
1888 Make_Parameter_Specification
(Loc
,
1889 Defining_Identifier
=>
1890 Make_Defining_Identifier
(Sloc
(Formal
),
1891 Chars
=> Chars
(Formal
)),
1892 In_Present
=> In_Present
(Parent
(Formal
)),
1893 Out_Present
=> Out_Present
(Parent
(Formal
)),
1894 Parameter_Type
=> New_Occurrence_Of
(Ftyp
, Loc
),
1895 Expression
=> Expr
));
1897 if not Is_Predef_Op
then
1898 Next_Formal
(Iface_Formal
);
1901 Next_Formal
(Formal
);
1904 Target_Formal
:= First_Formal
(Target
);
1905 Formal
:= First
(Formals
);
1906 while Present
(Formal
) loop
1908 -- If the parent is a constrained discriminated type, then the
1909 -- primitive operation will have been defined on a first subtype.
1910 -- For proper matching with controlling type, use base type.
1912 if Ekind
(Target_Formal
) = E_In_Parameter
1913 and then Ekind
(Etype
(Target_Formal
)) = E_Anonymous_Access_Type
1916 Base_Type
(Directly_Designated_Type
(Etype
(Target_Formal
)));
1918 Ftyp
:= Base_Type
(Etype
(Target_Formal
));
1921 -- For concurrent types, the relevant information is found in the
1922 -- Corresponding_Record_Type, rather than the type entity itself.
1924 if Is_Concurrent_Type
(Ftyp
) then
1925 Ftyp
:= Corresponding_Record_Type
(Ftyp
);
1928 if Ekind
(Target_Formal
) = E_In_Parameter
1929 and then Ekind
(Etype
(Target_Formal
)) = E_Anonymous_Access_Type
1930 and then Is_Controlling_Formal
(Target_Formal
)
1933 -- type T is access all <<type of the target formal>>
1934 -- S : Storage_Offset := Storage_Offset!(Formal)
1935 -- + Offset_To_Top (address!(Formal))
1938 Make_Full_Type_Declaration
(Loc
,
1939 Defining_Identifier
=> Make_Temporary
(Loc
, 'T'),
1941 Make_Access_To_Object_Definition
(Loc
,
1942 All_Present
=> True,
1943 Null_Exclusion_Present
=> False,
1944 Constant_Present
=> False,
1945 Subtype_Indication
=>
1946 New_Occurrence_Of
(Ftyp
, Loc
)));
1949 Unchecked_Convert_To
(RTE
(RE_Address
),
1950 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
1952 if not RTE_Available
(RE_Offset_To_Top
) then
1954 Build_Offset_To_Top
(Loc
, New_Arg
);
1957 Make_Function_Call
(Loc
,
1958 Name
=> New_Occurrence_Of
(RTE
(RE_Offset_To_Top
), Loc
),
1959 Parameter_Associations
=> New_List
(New_Arg
));
1963 Make_Object_Declaration
(Loc
,
1964 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
1965 Constant_Present
=> True,
1966 Object_Definition
=>
1967 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
1971 Unchecked_Convert_To
1972 (RTE
(RE_Storage_Offset
),
1974 (Defining_Identifier
(Formal
), Loc
)),
1978 Append_To
(Decl
, Decl_2
);
1979 Append_To
(Decl
, Decl_1
);
1981 -- Reference the new actual. Generate:
1985 Unchecked_Convert_To
1986 (Defining_Identifier
(Decl_2
),
1987 New_Occurrence_Of
(Defining_Identifier
(Decl_1
), Loc
)));
1989 elsif Is_Controlling_Formal
(Target_Formal
) then
1992 -- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
1993 -- + Offset_To_Top (Formal'Address)
1994 -- S2 : Addr_Ptr := Addr_Ptr!(S1)
1997 Make_Attribute_Reference
(Loc
,
1999 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
),
2003 if not RTE_Available
(RE_Offset_To_Top
) then
2005 Build_Offset_To_Top
(Loc
, New_Arg
);
2008 Make_Function_Call
(Loc
,
2009 Name
=> New_Occurrence_Of
(RTE
(RE_Offset_To_Top
), Loc
),
2010 Parameter_Associations
=> New_List
(New_Arg
));
2014 Make_Object_Declaration
(Loc
,
2015 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
2016 Constant_Present
=> True,
2017 Object_Definition
=>
2018 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
2022 Unchecked_Convert_To
2023 (RTE
(RE_Storage_Offset
),
2024 Make_Attribute_Reference
(Loc
,
2027 (Defining_Identifier
(Formal
), Loc
),
2028 Attribute_Name
=> Name_Address
)),
2033 Make_Object_Declaration
(Loc
,
2034 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
2035 Constant_Present
=> True,
2036 Object_Definition
=>
2037 New_Occurrence_Of
(RTE
(RE_Addr_Ptr
), Loc
),
2039 Unchecked_Convert_To
2041 New_Occurrence_Of
(Defining_Identifier
(Decl_1
), Loc
)));
2043 Append_To
(Decl
, Decl_1
);
2044 Append_To
(Decl
, Decl_2
);
2046 -- Reference the new actual, generate:
2047 -- Target_Formal (S2.all)
2050 Unchecked_Convert_To
(Ftyp
,
2051 Make_Explicit_Dereference
(Loc
,
2052 New_Occurrence_Of
(Defining_Identifier
(Decl_2
), Loc
))));
2054 -- Ensure proper matching of access types. Required to avoid
2055 -- reporting spurious errors.
2057 elsif Is_Access_Type
(Etype
(Target_Formal
)) then
2059 Unchecked_Convert_To
(Base_Type
(Etype
(Target_Formal
)),
2060 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
)));
2062 -- No special management required for this actual
2066 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
2069 Next_Formal
(Target_Formal
);
2073 Thunk_Id
:= Make_Temporary
(Loc
, 'T');
2074 Set_Ekind
(Thunk_Id
, Ekind
(Prim
));
2075 Set_Is_Thunk
(Thunk_Id
);
2076 Set_Convention
(Thunk_Id
, Convention
(Prim
));
2077 Set_Needs_Debug_Info
(Thunk_Id
, Needs_Debug_Info
(Target
));
2078 Set_Thunk_Entity
(Thunk_Id
, Target
);
2082 if Ekind
(Target
) = E_Procedure
then
2084 Make_Subprogram_Body
(Loc
,
2086 Make_Procedure_Specification
(Loc
,
2087 Defining_Unit_Name
=> Thunk_Id
,
2088 Parameter_Specifications
=> Formals
),
2089 Declarations
=> Decl
,
2090 Handled_Statement_Sequence
=>
2091 Make_Handled_Sequence_Of_Statements
(Loc
,
2092 Statements
=> New_List
(
2093 Make_Procedure_Call_Statement
(Loc
,
2094 Name
=> New_Occurrence_Of
(Target
, Loc
),
2095 Parameter_Associations
=> Actuals
))));
2099 else pragma Assert
(Ekind
(Target
) = E_Function
);
2101 Result_Def
: Node_Id
;
2102 Call_Node
: Node_Id
;
2106 Make_Function_Call
(Loc
,
2107 Name
=> New_Occurrence_Of
(Target
, Loc
),
2108 Parameter_Associations
=> Actuals
);
2110 if not Is_Interface
(Etype
(Prim
)) then
2111 Result_Def
:= New_Copy
(Result_Definition
(Parent
(Target
)));
2113 -- Thunk of function returning a class-wide interface object. No
2114 -- extra displacement needed since the displacement is generated
2115 -- in the return statement of Prim. Example:
2117 -- type Iface is interface ...
2118 -- function F (O : Iface) return Iface'Class;
2120 -- type T is new ... and Iface with ...
2121 -- function F (O : T) return Iface'Class;
2123 elsif Is_Class_Wide_Type
(Etype
(Prim
)) then
2124 Result_Def
:= New_Occurrence_Of
(Etype
(Prim
), Loc
);
2126 -- Thunk of function returning an interface object. Displacement
2129 -- type Iface is interface ...
2130 -- function F (O : Iface) return Iface;
2132 -- type T is new ... and Iface with ...
2133 -- function F (O : T) return T;
2137 New_Occurrence_Of
(Class_Wide_Type
(Etype
(Prim
)), Loc
);
2139 -- Adding implicit conversion to force the displacement of
2140 -- the pointer to the object to reference the corresponding
2141 -- secondary dispatch table.
2144 Make_Type_Conversion
(Loc
,
2146 New_Occurrence_Of
(Class_Wide_Type
(Etype
(Prim
)), Loc
),
2147 Expression
=> Relocate_Node
(Call_Node
));
2151 Make_Subprogram_Body
(Loc
,
2153 Make_Function_Specification
(Loc
,
2154 Defining_Unit_Name
=> Thunk_Id
,
2155 Parameter_Specifications
=> Formals
,
2156 Result_Definition
=> Result_Def
),
2157 Declarations
=> Decl
,
2158 Handled_Statement_Sequence
=>
2159 Make_Handled_Sequence_Of_Statements
(Loc
,
2160 Statements
=> New_List
(
2161 Make_Simple_Return_Statement
(Loc
, Call_Node
))));
2164 end Expand_Interface_Thunk
;
2166 --------------------------
2167 -- Has_CPP_Constructors --
2168 --------------------------
2170 function Has_CPP_Constructors
(Typ
: Entity_Id
) return Boolean is
2174 -- Look for the constructor entities
2176 E
:= Next_Entity
(Typ
);
2177 while Present
(E
) loop
2178 if Ekind
(E
) = E_Function
and then Is_Constructor
(E
) then
2186 end Has_CPP_Constructors
;
2192 function Has_DT
(Typ
: Entity_Id
) return Boolean is
2194 return not Is_Interface
(Typ
)
2195 and then not Restriction_Active
(No_Dispatching_Calls
);
2198 ----------------------------------
2199 -- Is_Expanded_Dispatching_Call --
2200 ----------------------------------
2202 function Is_Expanded_Dispatching_Call
(N
: Node_Id
) return Boolean is
2204 return Nkind
(N
) in N_Subprogram_Call
2205 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
2206 and then Is_Dispatch_Table_Entity
(Etype
(Name
(N
)));
2207 end Is_Expanded_Dispatching_Call
;
2209 -------------------------------------
2210 -- Is_Predefined_Dispatching_Alias --
2211 -------------------------------------
2213 function Is_Predefined_Dispatching_Alias
(Prim
: Entity_Id
) return Boolean
2216 return not Is_Predefined_Dispatching_Operation
(Prim
)
2217 and then Present
(Alias
(Prim
))
2218 and then Is_Predefined_Dispatching_Operation
(Ultimate_Alias
(Prim
));
2219 end Is_Predefined_Dispatching_Alias
;
2221 ----------------------------------------
2222 -- Make_Disp_Asynchronous_Select_Body --
2223 ----------------------------------------
2225 -- For interface types, generate:
2227 -- procedure _Disp_Asynchronous_Select
2228 -- (T : in out <Typ>;
2230 -- P : System.Address;
2231 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2236 -- C := Ada.Tags.POK_Function;
2237 -- end _Disp_Asynchronous_Select;
2239 -- For protected types, generate:
2241 -- procedure _Disp_Asynchronous_Select
2242 -- (T : in out <Typ>;
2244 -- P : System.Address;
2245 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2249 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2250 -- Bnn : System.Tasking.Protected_Objects.Operations.
2251 -- Communication_Block;
2253 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2254 -- (T._object'Access,
2255 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2257 -- System.Tasking.Asynchronous_Call,
2259 -- B := System.Storage_Elements.Dummy_Communication_Block (Bnn);
2260 -- end _Disp_Asynchronous_Select;
2262 -- For task types, generate:
2264 -- procedure _Disp_Asynchronous_Select
2265 -- (T : in out <Typ>;
2267 -- P : System.Address;
2268 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2272 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2274 -- System.Tasking.Rendezvous.Task_Entry_Call
2276 -- System.Tasking.Task_Entry_Index (I),
2278 -- System.Tasking.Asynchronous_Call,
2280 -- end _Disp_Asynchronous_Select;
2282 function Make_Disp_Asynchronous_Select_Body
2283 (Typ
: Entity_Id
) return Node_Id
2285 Com_Block
: Entity_Id
;
2286 Conc_Typ
: Entity_Id
:= Empty
;
2287 Decls
: constant List_Id
:= New_List
;
2288 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2290 Stmts
: constant List_Id
:= New_List
;
2294 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2296 -- Null body is generated for interface types
2298 if Is_Interface
(Typ
) then
2300 Make_Subprogram_Body
(Loc
,
2302 Make_Disp_Asynchronous_Select_Spec
(Typ
),
2303 Declarations
=> New_List
,
2304 Handled_Statement_Sequence
=>
2305 Make_Handled_Sequence_Of_Statements
(Loc
,
2307 Make_Assignment_Statement
(Loc
,
2308 Name
=> Make_Identifier
(Loc
, Name_uF
),
2309 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
2312 if Is_Concurrent_Record_Type
(Typ
) then
2313 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
2317 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2319 -- where I will be used to capture the entry index of the primitive
2320 -- wrapper at position S.
2322 if Tagged_Type_Expansion
then
2324 Unchecked_Convert_To
(RTE
(RE_Tag
),
2326 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
2329 Make_Attribute_Reference
(Loc
,
2330 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
2331 Attribute_Name
=> Name_Tag
);
2335 Make_Object_Declaration
(Loc
,
2336 Defining_Identifier
=>
2337 Make_Defining_Identifier
(Loc
, Name_uI
),
2338 Object_Definition
=>
2339 New_Occurrence_Of
(Standard_Integer
, Loc
),
2341 Make_Function_Call
(Loc
,
2343 New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
2344 Parameter_Associations
=>
2345 New_List
(Tag_Node
, Make_Identifier
(Loc
, Name_uS
)))));
2347 if Ekind
(Conc_Typ
) = E_Protected_Type
then
2350 -- Bnn : Communication_Block;
2352 Com_Block
:= Make_Temporary
(Loc
, 'B');
2354 Make_Object_Declaration
(Loc
,
2355 Defining_Identifier
=> Com_Block
,
2356 Object_Definition
=>
2357 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
2359 -- Build T._object'Access for calls below
2362 Make_Attribute_Reference
(Loc
,
2363 Attribute_Name
=> Name_Unchecked_Access
,
2365 Make_Selected_Component
(Loc
,
2366 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2367 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
2369 case Corresponding_Runtime_Package
(Conc_Typ
) is
2370 when System_Tasking_Protected_Objects_Entries
=>
2373 -- Protected_Entry_Call
2374 -- (T._object'Access, -- Object
2375 -- Protected_Entry_Index! (I), -- E
2376 -- P, -- Uninterpreted_Data
2377 -- Asynchronous_Call, -- Mode
2378 -- Bnn); -- Communication_Block
2380 -- where T is the protected object, I is the entry index, P
2381 -- is the wrapped parameters and B is the name of the
2382 -- communication block.
2385 Make_Procedure_Call_Statement
(Loc
,
2387 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
2388 Parameter_Associations
=>
2392 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2395 (RTE
(RE_Protected_Entry_Index
), Loc
),
2396 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2398 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2399 New_Occurrence_Of
-- Asynchronous_Call
2400 (RTE
(RE_Asynchronous_Call
), Loc
),
2401 New_Occurrence_Of
-- comm block
2402 (Com_Block
, Loc
))));
2405 raise Program_Error
;
2409 -- B := Dummy_Communication_Block (Bnn);
2412 Make_Assignment_Statement
(Loc
,
2413 Name
=> Make_Identifier
(Loc
, Name_uB
),
2415 Make_Unchecked_Type_Conversion
(Loc
,
2418 (RTE
(RE_Dummy_Communication_Block
), Loc
),
2419 Expression
=> New_Occurrence_Of
(Com_Block
, Loc
))));
2425 Make_Assignment_Statement
(Loc
,
2426 Name
=> Make_Identifier
(Loc
, Name_uF
),
2427 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
2430 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
2434 -- (T._task_id, -- Acceptor
2435 -- Task_Entry_Index! (I), -- E
2436 -- P, -- Uninterpreted_Data
2437 -- Asynchronous_Call, -- Mode
2438 -- F); -- Rendezvous_Successful
2440 -- where T is the task object, I is the entry index, P is the
2441 -- wrapped parameters and F is the status flag.
2444 Make_Procedure_Call_Statement
(Loc
,
2446 New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
2447 Parameter_Associations
=>
2449 Make_Selected_Component
(Loc
, -- T._task_id
2450 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2451 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
2453 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2455 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
2456 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2458 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2459 New_Occurrence_Of
-- Asynchronous_Call
2460 (RTE
(RE_Asynchronous_Call
), Loc
),
2461 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
2465 -- Ensure that the statements list is non-empty
2468 Make_Assignment_Statement
(Loc
,
2469 Name
=> Make_Identifier
(Loc
, Name_uF
),
2470 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
2474 Make_Subprogram_Body
(Loc
,
2476 Make_Disp_Asynchronous_Select_Spec
(Typ
),
2477 Declarations
=> Decls
,
2478 Handled_Statement_Sequence
=>
2479 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
2480 end Make_Disp_Asynchronous_Select_Body
;
2482 ----------------------------------------
2483 -- Make_Disp_Asynchronous_Select_Spec --
2484 ----------------------------------------
2486 function Make_Disp_Asynchronous_Select_Spec
2487 (Typ
: Entity_Id
) return Node_Id
2489 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2490 B_Id
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
2491 Def_Id
: constant Entity_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 -- The B parameter may be left uninitialized
2507 Set_Warnings_Off
(B_Id
);
2509 Append_List_To
(Params
, New_List
(
2511 Make_Parameter_Specification
(Loc
,
2512 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
2513 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
2515 Out_Present
=> True),
2517 Make_Parameter_Specification
(Loc
,
2518 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
2519 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
2521 Make_Parameter_Specification
(Loc
,
2522 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
2523 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2525 Make_Parameter_Specification
(Loc
,
2526 Defining_Identifier
=> B_Id
,
2528 New_Occurrence_Of
(RTE
(RE_Dummy_Communication_Block
), Loc
),
2529 Out_Present
=> True),
2531 Make_Parameter_Specification
(Loc
,
2532 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
2533 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
2534 Out_Present
=> True)));
2537 Make_Procedure_Specification
(Loc
,
2538 Defining_Unit_Name
=> Def_Id
,
2539 Parameter_Specifications
=> Params
);
2540 end Make_Disp_Asynchronous_Select_Spec
;
2542 ---------------------------------------
2543 -- Make_Disp_Conditional_Select_Body --
2544 ---------------------------------------
2546 -- For interface types, generate:
2548 -- procedure _Disp_Conditional_Select
2549 -- (T : in out <Typ>;
2551 -- P : System.Address;
2552 -- C : out Ada.Tags.Prim_Op_Kind;
2557 -- C := Ada.Tags.POK_Function;
2558 -- end _Disp_Conditional_Select;
2560 -- For protected types, generate:
2562 -- procedure _Disp_Conditional_Select
2563 -- (T : in out <Typ>;
2565 -- P : System.Address;
2566 -- C : out Ada.Tags.Prim_Op_Kind;
2570 -- Bnn : System.Tasking.Protected_Objects.Operations.
2571 -- Communication_Block;
2574 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S));
2576 -- if C = Ada.Tags.POK_Procedure
2577 -- or else C = Ada.Tags.POK_Protected_Procedure
2578 -- or else C = Ada.Tags.POK_Task_Procedure
2584 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2585 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2586 -- (T.object'Access,
2587 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2589 -- System.Tasking.Conditional_Call,
2591 -- F := not Cancelled (Bnn);
2592 -- end _Disp_Conditional_Select;
2594 -- For task types, generate:
2596 -- procedure _Disp_Conditional_Select
2597 -- (T : in out <Typ>;
2599 -- P : System.Address;
2600 -- C : out Ada.Tags.Prim_Op_Kind;
2606 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2607 -- System.Tasking.Rendezvous.Task_Entry_Call
2609 -- System.Tasking.Task_Entry_Index (I),
2611 -- System.Tasking.Conditional_Call,
2613 -- end _Disp_Conditional_Select;
2615 function Make_Disp_Conditional_Select_Body
2616 (Typ
: Entity_Id
) return Node_Id
2618 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2619 Blk_Nam
: Entity_Id
;
2620 Conc_Typ
: Entity_Id
:= Empty
;
2621 Decls
: constant List_Id
:= New_List
;
2623 Stmts
: constant List_Id
:= New_List
;
2627 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2629 -- Null body is generated for interface types
2631 if Is_Interface
(Typ
) then
2633 Make_Subprogram_Body
(Loc
,
2635 Make_Disp_Conditional_Select_Spec
(Typ
),
2636 Declarations
=> No_List
,
2637 Handled_Statement_Sequence
=>
2638 Make_Handled_Sequence_Of_Statements
(Loc
,
2639 New_List
(Make_Assignment_Statement
(Loc
,
2640 Name
=> Make_Identifier
(Loc
, Name_uF
),
2641 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
2644 if Is_Concurrent_Record_Type
(Typ
) then
2645 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
2650 -- where I will be used to capture the entry index of the primitive
2651 -- wrapper at position S.
2654 Make_Object_Declaration
(Loc
,
2655 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uI
),
2656 Object_Definition
=>
2657 New_Occurrence_Of
(Standard_Integer
, Loc
)));
2660 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S);
2662 -- if C = POK_Procedure
2663 -- or else C = POK_Protected_Procedure
2664 -- or else C = POK_Task_Procedure;
2670 Build_Common_Dispatching_Select_Statements
(Typ
, Stmts
);
2673 -- Bnn : Communication_Block;
2675 -- where Bnn is the name of the communication block used in the
2676 -- call to Protected_Entry_Call.
2678 Blk_Nam
:= Make_Temporary
(Loc
, 'B');
2680 Make_Object_Declaration
(Loc
,
2681 Defining_Identifier
=> Blk_Nam
,
2682 Object_Definition
=>
2683 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
2686 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2688 -- I is the entry index and S is the dispatch table slot
2690 if Tagged_Type_Expansion
then
2692 Unchecked_Convert_To
(RTE
(RE_Tag
),
2694 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
2698 Make_Attribute_Reference
(Loc
,
2699 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
2700 Attribute_Name
=> Name_Tag
);
2704 Make_Assignment_Statement
(Loc
,
2705 Name
=> Make_Identifier
(Loc
, Name_uI
),
2707 Make_Function_Call
(Loc
,
2709 New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
2710 Parameter_Associations
=> New_List
(
2712 Make_Identifier
(Loc
, Name_uS
)))));
2714 if Ekind
(Conc_Typ
) = E_Protected_Type
then
2716 Obj_Ref
:= -- T._object'Access
2717 Make_Attribute_Reference
(Loc
,
2718 Attribute_Name
=> Name_Unchecked_Access
,
2720 Make_Selected_Component
(Loc
,
2721 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2722 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
2724 case Corresponding_Runtime_Package
(Conc_Typ
) is
2725 when System_Tasking_Protected_Objects_Entries
=>
2728 -- Protected_Entry_Call
2729 -- (T._object'Access, -- Object
2730 -- Protected_Entry_Index! (I), -- E
2731 -- P, -- Uninterpreted_Data
2732 -- Conditional_Call, -- Mode
2735 -- where T is the protected object, I is the entry index, P
2736 -- are the wrapped parameters and Bnn is the name of the
2737 -- communication block.
2740 Make_Procedure_Call_Statement
(Loc
,
2742 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
2743 Parameter_Associations
=> New_List
(
2746 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2749 (RTE
(RE_Protected_Entry_Index
), Loc
),
2750 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2752 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2754 New_Occurrence_Of
-- Conditional_Call
2755 (RTE
(RE_Conditional_Call
), Loc
),
2756 New_Occurrence_Of
-- Bnn
2759 when System_Tasking_Protected_Objects_Single_Entry
=>
2761 -- If we are compiling for a restricted run-time, the call
2762 -- uses the simpler form.
2765 Make_Procedure_Call_Statement
(Loc
,
2768 (RTE
(RE_Protected_Single_Entry_Call
), Loc
),
2769 Parameter_Associations
=> New_List
(
2772 Make_Attribute_Reference
(Loc
,
2773 Prefix
=> Make_Identifier
(Loc
, Name_uP
),
2774 Attribute_Name
=> Name_Address
),
2777 (RTE
(RE_Conditional_Call
), Loc
))));
2779 raise Program_Error
;
2783 -- F := not Cancelled (Bnn);
2785 -- where F is the success flag. The status of Cancelled is negated
2786 -- in order to match the behavior of the version for task types.
2789 Make_Assignment_Statement
(Loc
,
2790 Name
=> Make_Identifier
(Loc
, Name_uF
),
2794 Make_Function_Call
(Loc
,
2796 New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
2797 Parameter_Associations
=> New_List
(
2798 New_Occurrence_Of
(Blk_Nam
, Loc
))))));
2800 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
2804 -- (T._task_id, -- Acceptor
2805 -- Task_Entry_Index! (I), -- E
2806 -- P, -- Uninterpreted_Data
2807 -- Conditional_Call, -- Mode
2808 -- F); -- Rendezvous_Successful
2810 -- where T is the task object, I is the entry index, P are the
2811 -- wrapped parameters and F is the status flag.
2814 Make_Procedure_Call_Statement
(Loc
,
2816 New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
2817 Parameter_Associations
=> New_List
(
2819 Make_Selected_Component
(Loc
, -- T._task_id
2820 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2821 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
2823 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2825 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
2826 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2828 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2829 New_Occurrence_Of
-- Conditional_Call
2830 (RTE
(RE_Conditional_Call
), Loc
),
2831 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
2835 -- Initialize out parameters
2838 Make_Assignment_Statement
(Loc
,
2839 Name
=> Make_Identifier
(Loc
, Name_uF
),
2840 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
2842 Make_Assignment_Statement
(Loc
,
2843 Name
=> Make_Identifier
(Loc
, Name_uC
),
2844 Expression
=> New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
)));
2848 Make_Subprogram_Body
(Loc
,
2850 Make_Disp_Conditional_Select_Spec
(Typ
),
2851 Declarations
=> Decls
,
2852 Handled_Statement_Sequence
=>
2853 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
2854 end Make_Disp_Conditional_Select_Body
;
2856 ---------------------------------------
2857 -- Make_Disp_Conditional_Select_Spec --
2858 ---------------------------------------
2860 function Make_Disp_Conditional_Select_Spec
2861 (Typ
: Entity_Id
) return Node_Id
2863 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2864 Def_Id
: constant Node_Id
:=
2865 Make_Defining_Identifier
(Loc
,
2866 Name_uDisp_Conditional_Select
);
2867 Params
: constant List_Id
:= New_List
;
2870 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2872 -- T : in out Typ; -- Object parameter
2873 -- S : Integer; -- Primitive operation slot
2874 -- P : Address; -- Wrapped parameters
2875 -- C : out Prim_Op_Kind; -- Call kind
2876 -- F : out Boolean; -- Status flag
2878 Append_List_To
(Params
, New_List
(
2880 Make_Parameter_Specification
(Loc
,
2881 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
2882 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
2884 Out_Present
=> True),
2886 Make_Parameter_Specification
(Loc
,
2887 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
2888 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
2890 Make_Parameter_Specification
(Loc
,
2891 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
2892 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2894 Make_Parameter_Specification
(Loc
,
2895 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
2897 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
2898 Out_Present
=> True),
2900 Make_Parameter_Specification
(Loc
,
2901 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
2902 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
2903 Out_Present
=> True)));
2906 Make_Procedure_Specification
(Loc
,
2907 Defining_Unit_Name
=> Def_Id
,
2908 Parameter_Specifications
=> Params
);
2909 end Make_Disp_Conditional_Select_Spec
;
2911 -------------------------------------
2912 -- Make_Disp_Get_Prim_Op_Kind_Body --
2913 -------------------------------------
2915 function Make_Disp_Get_Prim_Op_Kind_Body
(Typ
: Entity_Id
) return Node_Id
is
2916 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2920 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2922 if Is_Interface
(Typ
) then
2924 Make_Subprogram_Body
(Loc
,
2926 Make_Disp_Get_Prim_Op_Kind_Spec
(Typ
),
2927 Declarations
=> New_List
,
2928 Handled_Statement_Sequence
=>
2929 Make_Handled_Sequence_Of_Statements
(Loc
,
2930 New_List
(Make_Null_Statement
(Loc
))));
2934 -- C := get_prim_op_kind (tag! (<type>VP), S);
2936 -- where C is the out parameter capturing the call kind and S is the
2937 -- dispatch table slot number.
2939 if Tagged_Type_Expansion
then
2941 Unchecked_Convert_To
(RTE
(RE_Tag
),
2943 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
2947 Make_Attribute_Reference
(Loc
,
2948 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
2949 Attribute_Name
=> Name_Tag
);
2953 Make_Subprogram_Body
(Loc
,
2955 Make_Disp_Get_Prim_Op_Kind_Spec
(Typ
),
2956 Declarations
=> New_List
,
2957 Handled_Statement_Sequence
=>
2958 Make_Handled_Sequence_Of_Statements
(Loc
,
2960 Make_Assignment_Statement
(Loc
,
2961 Name
=> Make_Identifier
(Loc
, Name_uC
),
2963 Make_Function_Call
(Loc
,
2965 New_Occurrence_Of
(RTE
(RE_Get_Prim_Op_Kind
), Loc
),
2966 Parameter_Associations
=> New_List
(
2968 Make_Identifier
(Loc
, Name_uS
)))))));
2969 end Make_Disp_Get_Prim_Op_Kind_Body
;
2971 -------------------------------------
2972 -- Make_Disp_Get_Prim_Op_Kind_Spec --
2973 -------------------------------------
2975 function Make_Disp_Get_Prim_Op_Kind_Spec
2976 (Typ
: Entity_Id
) return Node_Id
2978 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2979 Def_Id
: constant Node_Id
:=
2980 Make_Defining_Identifier
(Loc
, Name_uDisp_Get_Prim_Op_Kind
);
2981 Params
: constant List_Id
:= New_List
;
2984 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2986 -- T : in out Typ; -- Object parameter
2987 -- S : Integer; -- Primitive operation slot
2988 -- C : out Prim_Op_Kind; -- Call kind
2990 Append_List_To
(Params
, New_List
(
2992 Make_Parameter_Specification
(Loc
,
2993 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
2994 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
2996 Out_Present
=> True),
2998 Make_Parameter_Specification
(Loc
,
2999 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
3000 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3002 Make_Parameter_Specification
(Loc
,
3003 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
3005 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
3006 Out_Present
=> True)));
3009 Make_Procedure_Specification
(Loc
,
3010 Defining_Unit_Name
=> Def_Id
,
3011 Parameter_Specifications
=> Params
);
3012 end Make_Disp_Get_Prim_Op_Kind_Spec
;
3014 --------------------------------
3015 -- Make_Disp_Get_Task_Id_Body --
3016 --------------------------------
3018 function Make_Disp_Get_Task_Id_Body
3019 (Typ
: Entity_Id
) return Node_Id
3021 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3025 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3027 if Is_Concurrent_Record_Type
(Typ
)
3028 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) = E_Task_Type
3031 -- return To_Address (_T._task_id);
3034 Make_Simple_Return_Statement
(Loc
,
3036 Make_Unchecked_Type_Conversion
(Loc
,
3037 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
3039 Make_Selected_Component
(Loc
,
3040 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
3041 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
))));
3043 -- A null body is constructed for non-task types
3047 -- return Null_Address;
3050 Make_Simple_Return_Statement
(Loc
,
3051 Expression
=> New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
3055 Make_Subprogram_Body
(Loc
,
3056 Specification
=> Make_Disp_Get_Task_Id_Spec
(Typ
),
3057 Declarations
=> New_List
,
3058 Handled_Statement_Sequence
=>
3059 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Ret
)));
3060 end Make_Disp_Get_Task_Id_Body
;
3062 --------------------------------
3063 -- Make_Disp_Get_Task_Id_Spec --
3064 --------------------------------
3066 function Make_Disp_Get_Task_Id_Spec
3067 (Typ
: Entity_Id
) return Node_Id
3069 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3072 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3075 Make_Function_Specification
(Loc
,
3076 Defining_Unit_Name
=>
3077 Make_Defining_Identifier
(Loc
, Name_uDisp_Get_Task_Id
),
3078 Parameter_Specifications
=> New_List
(
3079 Make_Parameter_Specification
(Loc
,
3080 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
3081 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
3082 Result_Definition
=>
3083 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
3084 end Make_Disp_Get_Task_Id_Spec
;
3086 ----------------------------
3087 -- Make_Disp_Requeue_Body --
3088 ----------------------------
3090 function Make_Disp_Requeue_Body
3091 (Typ
: Entity_Id
) return Node_Id
3093 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3094 Conc_Typ
: Entity_Id
:= Empty
;
3095 Stmts
: constant List_Id
:= New_List
;
3098 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3100 -- Null body is generated for interface types and non-concurrent
3103 if Is_Interface
(Typ
)
3104 or else not Is_Concurrent_Record_Type
(Typ
)
3107 Make_Subprogram_Body
(Loc
,
3108 Specification
=> Make_Disp_Requeue_Spec
(Typ
),
3109 Declarations
=> No_List
,
3110 Handled_Statement_Sequence
=>
3111 Make_Handled_Sequence_Of_Statements
(Loc
,
3112 New_List
(Make_Null_Statement
(Loc
))));
3115 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
3117 if Ekind
(Conc_Typ
) = E_Protected_Type
then
3119 -- Generate statements:
3121 -- System.Tasking.Protected_Objects.Operations.
3122 -- Requeue_Protected_Entry
3123 -- (Protection_Entries_Access (P),
3124 -- O._object'Unchecked_Access,
3125 -- Protected_Entry_Index (I),
3128 -- System.Tasking.Protected_Objects.Operations.
3129 -- Requeue_Task_To_Protected_Entry
3130 -- (O._object'Unchecked_Access,
3131 -- Protected_Entry_Index (I),
3135 if Restriction_Active
(No_Entry_Queue
) then
3136 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
3139 Make_If_Statement
(Loc
,
3140 Condition
=> Make_Identifier
(Loc
, Name_uF
),
3145 -- Call to Requeue_Protected_Entry
3147 Make_Procedure_Call_Statement
(Loc
,
3150 (RTE
(RE_Requeue_Protected_Entry
), Loc
),
3151 Parameter_Associations
=>
3154 Make_Unchecked_Type_Conversion
(Loc
, -- PEA (P)
3157 RTE
(RE_Protection_Entries_Access
), Loc
),
3159 Make_Identifier
(Loc
, Name_uP
)),
3161 Make_Attribute_Reference
(Loc
, -- O._object'Acc
3163 Name_Unchecked_Access
,
3165 Make_Selected_Component
(Loc
,
3167 Make_Identifier
(Loc
, Name_uO
),
3169 Make_Identifier
(Loc
, Name_uObject
))),
3171 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3174 (RTE
(RE_Protected_Entry_Index
), Loc
),
3175 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3177 Make_Identifier
(Loc
, Name_uA
)))), -- abort status
3182 -- Call to Requeue_Task_To_Protected_Entry
3184 Make_Procedure_Call_Statement
(Loc
,
3187 (RTE
(RE_Requeue_Task_To_Protected_Entry
), Loc
),
3188 Parameter_Associations
=>
3191 Make_Attribute_Reference
(Loc
, -- O._object'Acc
3192 Attribute_Name
=> Name_Unchecked_Access
,
3194 Make_Selected_Component
(Loc
,
3196 Make_Identifier
(Loc
, Name_uO
),
3198 Make_Identifier
(Loc
, Name_uObject
))),
3200 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3203 (RTE
(RE_Protected_Entry_Index
), Loc
),
3204 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3206 Make_Identifier
(Loc
, Name_uA
)))))); -- abort status
3210 pragma Assert
(Is_Task_Type
(Conc_Typ
));
3214 -- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry
3215 -- (Protection_Entries_Access (P),
3217 -- Task_Entry_Index (I),
3220 -- System.Tasking.Rendezvous.Requeue_Task_Entry
3222 -- Task_Entry_Index (I),
3227 Make_If_Statement
(Loc
,
3228 Condition
=> Make_Identifier
(Loc
, Name_uF
),
3230 Then_Statements
=> New_List
(
3232 -- Call to Requeue_Protected_To_Task_Entry
3234 Make_Procedure_Call_Statement
(Loc
,
3237 (RTE
(RE_Requeue_Protected_To_Task_Entry
), Loc
),
3239 Parameter_Associations
=> New_List
(
3241 Make_Unchecked_Type_Conversion
(Loc
, -- PEA (P)
3244 (RTE
(RE_Protection_Entries_Access
), Loc
),
3245 Expression
=> Make_Identifier
(Loc
, Name_uP
)),
3247 Make_Selected_Component
(Loc
, -- O._task_id
3248 Prefix
=> Make_Identifier
(Loc
, Name_uO
),
3249 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3251 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3253 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
3254 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3256 Make_Identifier
(Loc
, Name_uA
)))), -- abort status
3258 Else_Statements
=> New_List
(
3260 -- Call to Requeue_Task_Entry
3262 Make_Procedure_Call_Statement
(Loc
,
3264 New_Occurrence_Of
(RTE
(RE_Requeue_Task_Entry
), Loc
),
3266 Parameter_Associations
=> New_List
(
3268 Make_Selected_Component
(Loc
, -- O._task_id
3269 Prefix
=> Make_Identifier
(Loc
, Name_uO
),
3270 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3272 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3274 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
3275 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3277 Make_Identifier
(Loc
, Name_uA
)))))); -- abort status
3280 -- Even though no declarations are needed in both cases, we allocate
3281 -- a list for entities added by Freeze.
3284 Make_Subprogram_Body
(Loc
,
3285 Specification
=> Make_Disp_Requeue_Spec
(Typ
),
3286 Declarations
=> New_List
,
3287 Handled_Statement_Sequence
=>
3288 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
3289 end Make_Disp_Requeue_Body
;
3291 ----------------------------
3292 -- Make_Disp_Requeue_Spec --
3293 ----------------------------
3295 function Make_Disp_Requeue_Spec
3296 (Typ
: Entity_Id
) return Node_Id
3298 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3301 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3303 -- O : in out Typ; - Object parameter
3304 -- F : Boolean; - Protected (True) / task (False) flag
3305 -- P : Address; - Protection_Entries_Access value
3306 -- I : Entry_Index - Index of entry call
3307 -- A : Boolean - Abort flag
3309 -- Note that the Protection_Entries_Access value is represented as a
3310 -- System.Address in order to avoid dragging in the tasking runtime
3311 -- when compiling sources without tasking constructs.
3314 Make_Procedure_Specification
(Loc
,
3315 Defining_Unit_Name
=>
3316 Make_Defining_Identifier
(Loc
, Name_uDisp_Requeue
),
3318 Parameter_Specifications
=> New_List
(
3320 Make_Parameter_Specification
(Loc
, -- O
3321 Defining_Identifier
=>
3322 Make_Defining_Identifier
(Loc
, Name_uO
),
3324 New_Occurrence_Of
(Typ
, Loc
),
3326 Out_Present
=> True),
3328 Make_Parameter_Specification
(Loc
, -- F
3329 Defining_Identifier
=>
3330 Make_Defining_Identifier
(Loc
, Name_uF
),
3332 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
3334 Make_Parameter_Specification
(Loc
, -- P
3335 Defining_Identifier
=>
3336 Make_Defining_Identifier
(Loc
, Name_uP
),
3338 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3340 Make_Parameter_Specification
(Loc
, -- I
3341 Defining_Identifier
=>
3342 Make_Defining_Identifier
(Loc
, Name_uI
),
3344 New_Occurrence_Of
(Standard_Integer
, Loc
)),
3346 Make_Parameter_Specification
(Loc
, -- A
3347 Defining_Identifier
=>
3348 Make_Defining_Identifier
(Loc
, Name_uA
),
3350 New_Occurrence_Of
(Standard_Boolean
, Loc
))));
3351 end Make_Disp_Requeue_Spec
;
3353 ---------------------------------
3354 -- Make_Disp_Timed_Select_Body --
3355 ---------------------------------
3357 -- For interface types, generate:
3359 -- procedure _Disp_Timed_Select
3360 -- (T : in out <Typ>;
3362 -- P : System.Address;
3365 -- C : out Ada.Tags.Prim_Op_Kind;
3370 -- C := Ada.Tags.POK_Function;
3371 -- end _Disp_Timed_Select;
3373 -- For protected types, generate:
3375 -- procedure _Disp_Timed_Select
3376 -- (T : in out <Typ>;
3378 -- P : System.Address;
3381 -- C : out Ada.Tags.Prim_Op_Kind;
3387 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S);
3389 -- if C = Ada.Tags.POK_Procedure
3390 -- or else C = Ada.Tags.POK_Protected_Procedure
3391 -- or else C = Ada.Tags.POK_Task_Procedure
3397 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3398 -- System.Tasking.Protected_Objects.Operations.
3399 -- Timed_Protected_Entry_Call
3400 -- (T._object'Access,
3401 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
3406 -- end _Disp_Timed_Select;
3408 -- For task types, generate:
3410 -- procedure _Disp_Timed_Select
3411 -- (T : in out <Typ>;
3413 -- P : System.Address;
3416 -- C : out Ada.Tags.Prim_Op_Kind;
3422 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3423 -- System.Tasking.Rendezvous.Timed_Task_Entry_Call
3425 -- System.Tasking.Task_Entry_Index (I),
3430 -- end _Disp_Time_Select;
3432 function Make_Disp_Timed_Select_Body
3433 (Typ
: Entity_Id
) return Node_Id
3435 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3436 Conc_Typ
: Entity_Id
:= Empty
;
3437 Decls
: constant List_Id
:= New_List
;
3439 Stmts
: constant List_Id
:= New_List
;
3443 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3445 -- Null body is generated for interface types
3447 if Is_Interface
(Typ
) then
3449 Make_Subprogram_Body
(Loc
,
3450 Specification
=> Make_Disp_Timed_Select_Spec
(Typ
),
3451 Declarations
=> New_List
,
3452 Handled_Statement_Sequence
=>
3453 Make_Handled_Sequence_Of_Statements
(Loc
,
3455 Make_Assignment_Statement
(Loc
,
3456 Name
=> Make_Identifier
(Loc
, Name_uF
),
3457 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
3460 if Is_Concurrent_Record_Type
(Typ
) then
3461 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
3466 -- where I will be used to capture the entry index of the primitive
3467 -- wrapper at position S.
3470 Make_Object_Declaration
(Loc
,
3471 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uI
),
3472 Object_Definition
=>
3473 New_Occurrence_Of
(Standard_Integer
, Loc
)));
3476 -- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
3478 -- if C = POK_Procedure
3479 -- or else C = POK_Protected_Procedure
3480 -- or else C = POK_Task_Procedure;
3486 Build_Common_Dispatching_Select_Statements
(Typ
, Stmts
);
3489 -- I := Get_Entry_Index (tag! (<type>VP), S);
3491 -- I is the entry index and S is the dispatch table slot
3493 if Tagged_Type_Expansion
then
3495 Unchecked_Convert_To
(RTE
(RE_Tag
),
3497 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
3501 Make_Attribute_Reference
(Loc
,
3502 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
3503 Attribute_Name
=> Name_Tag
);
3507 Make_Assignment_Statement
(Loc
,
3508 Name
=> Make_Identifier
(Loc
, Name_uI
),
3510 Make_Function_Call
(Loc
,
3511 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
3512 Parameter_Associations
=> New_List
(
3514 Make_Identifier
(Loc
, Name_uS
)))));
3518 if Ekind
(Conc_Typ
) = E_Protected_Type
then
3520 -- Build T._object'Access
3523 Make_Attribute_Reference
(Loc
,
3524 Attribute_Name
=> Name_Unchecked_Access
,
3526 Make_Selected_Component
(Loc
,
3527 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
3528 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
3530 -- Normal case, No_Entry_Queue restriction not active. In this
3531 -- case we generate:
3533 -- Timed_Protected_Entry_Call
3534 -- (T._object'access,
3535 -- Protected_Entry_Index! (I),
3538 -- where T is the protected object, I is the entry index, P are
3539 -- the wrapped parameters, D is the delay amount, M is the delay
3540 -- mode and F is the status flag.
3542 -- Historically, there was also an implementation for single
3543 -- entry protected types (in s-tposen). However, it was removed
3544 -- by also testing for no No_Select_Statements restriction in
3545 -- Exp_Utils.Corresponding_Runtime_Package. This simplified the
3546 -- implementation of s-tposen.adb and provided consistency between
3547 -- all versions of System.Tasking.Protected_Objects.Single_Entry
3550 case Corresponding_Runtime_Package
(Conc_Typ
) is
3551 when System_Tasking_Protected_Objects_Entries
=>
3553 Make_Procedure_Call_Statement
(Loc
,
3556 (RTE
(RE_Timed_Protected_Entry_Call
), Loc
),
3557 Parameter_Associations
=> New_List
(
3560 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3563 (RTE
(RE_Protected_Entry_Index
), Loc
),
3564 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3566 Make_Identifier
(Loc
, Name_uP
), -- parameter block
3567 Make_Identifier
(Loc
, Name_uD
), -- delay
3568 Make_Identifier
(Loc
, Name_uM
), -- delay mode
3569 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
3572 raise Program_Error
;
3578 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
3581 -- Timed_Task_Entry_Call (
3583 -- Task_Entry_Index! (I),
3589 -- where T is the task object, I is the entry index, P are the
3590 -- wrapped parameters, D is the delay amount, M is the delay
3591 -- mode and F is the status flag.
3594 Make_Procedure_Call_Statement
(Loc
,
3596 New_Occurrence_Of
(RTE
(RE_Timed_Task_Entry_Call
), Loc
),
3598 Parameter_Associations
=> New_List
(
3599 Make_Selected_Component
(Loc
, -- T._task_id
3600 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
3601 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3603 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3605 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
3606 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3608 Make_Identifier
(Loc
, Name_uP
), -- parameter block
3609 Make_Identifier
(Loc
, Name_uD
), -- delay
3610 Make_Identifier
(Loc
, Name_uM
), -- delay mode
3611 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
3615 -- Initialize out parameters
3618 Make_Assignment_Statement
(Loc
,
3619 Name
=> Make_Identifier
(Loc
, Name_uF
),
3620 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3622 Make_Assignment_Statement
(Loc
,
3623 Name
=> Make_Identifier
(Loc
, Name_uC
),
3624 Expression
=> New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
)));
3628 Make_Subprogram_Body
(Loc
,
3629 Specification
=> Make_Disp_Timed_Select_Spec
(Typ
),
3630 Declarations
=> Decls
,
3631 Handled_Statement_Sequence
=>
3632 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
3633 end Make_Disp_Timed_Select_Body
;
3635 ---------------------------------
3636 -- Make_Disp_Timed_Select_Spec --
3637 ---------------------------------
3639 function Make_Disp_Timed_Select_Spec
3640 (Typ
: Entity_Id
) return Node_Id
3642 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3643 Def_Id
: constant Node_Id
:=
3644 Make_Defining_Identifier
(Loc
,
3645 Name_uDisp_Timed_Select
);
3646 Params
: constant List_Id
:= New_List
;
3649 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3651 -- T : in out Typ; -- Object parameter
3652 -- S : Integer; -- Primitive operation slot
3653 -- P : Address; -- Wrapped parameters
3654 -- D : Duration; -- Delay
3655 -- M : Integer; -- Delay Mode
3656 -- C : out Prim_Op_Kind; -- Call kind
3657 -- F : out Boolean; -- Status flag
3659 Append_List_To
(Params
, New_List
(
3661 Make_Parameter_Specification
(Loc
,
3662 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
3663 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
3665 Out_Present
=> True),
3667 Make_Parameter_Specification
(Loc
,
3668 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
3669 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3671 Make_Parameter_Specification
(Loc
,
3672 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
3673 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3675 Make_Parameter_Specification
(Loc
,
3676 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uD
),
3677 Parameter_Type
=> New_Occurrence_Of
(Standard_Duration
, Loc
)),
3679 Make_Parameter_Specification
(Loc
,
3680 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uM
),
3681 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3683 Make_Parameter_Specification
(Loc
,
3684 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
3686 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
3687 Out_Present
=> True)));
3690 Make_Parameter_Specification
(Loc
,
3691 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
3692 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3693 Out_Present
=> True));
3696 Make_Procedure_Specification
(Loc
,
3697 Defining_Unit_Name
=> Def_Id
,
3698 Parameter_Specifications
=> Params
);
3699 end Make_Disp_Timed_Select_Spec
;
3705 -- The frontend supports two models for expanding dispatch tables
3706 -- associated with library-level defined tagged types: statically and
3707 -- non-statically allocated dispatch tables. In the former case the object
3708 -- containing the dispatch table is constant and it is initialized by means
3709 -- of a positional aggregate. In the latter case, the object containing
3710 -- the dispatch table is a variable which is initialized by means of
3713 -- In case of locally defined tagged types, the object containing the
3714 -- object containing the dispatch table is always a variable (instead of a
3715 -- constant). This is currently required to give support to late overriding
3716 -- of primitives. For example:
3718 -- procedure Example is
3720 -- type T1 is tagged null record;
3721 -- procedure Prim (O : T1);
3724 -- type T2 is new Pkg.T1 with null record;
3725 -- procedure Prim (X : T2) is -- late overriding
3731 -- WARNING: This routine manages Ghost regions. Return statements must be
3732 -- replaced by gotos which jump to the end of the routine and restore the
3735 function Make_DT
(Typ
: Entity_Id
; N
: Node_Id
:= Empty
) return List_Id
is
3736 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3738 Max_Predef_Prims
: constant Int
:=
3742 (Parent
(RTE
(RE_Max_Predef_Prims
)))));
3744 DT_Decl
: constant Elist_Id
:= New_Elmt_List
;
3745 DT_Aggr
: constant Elist_Id
:= New_Elmt_List
;
3746 -- Entities marked with attribute Is_Dispatch_Table_Entity
3748 Dummy_Object
: Entity_Id
:= Empty
;
3749 -- Extra nonexistent object of type Typ internally used to compute the
3750 -- offset to the components that reference secondary dispatch tables.
3751 -- Used to statically allocate secondary dispatch tables.
3753 procedure Check_Premature_Freezing
3755 Tagged_Type
: Entity_Id
;
3757 -- Verify that all untagged types in the profile of a subprogram are
3758 -- frozen at the point the subprogram is frozen. This enforces the rule
3759 -- on RM 13.14 (14) as modified by AI05-019. At the point a subprogram
3760 -- is frozen, enough must be known about it to build the activation
3761 -- record for it, which requires at least that the size of all
3762 -- parameters be known. Controlling arguments are by-reference,
3763 -- and therefore the rule only applies to untagged types. Typical
3764 -- violation of the rule involves an object declaration that freezes a
3765 -- tagged type, when one of its primitive operations has a type in its
3766 -- profile whose full view has not been analyzed yet. More complex cases
3767 -- involve composite types that have one private unfrozen subcomponent.
3769 procedure Export_DT
(Typ
: Entity_Id
; DT
: Entity_Id
; Index
: Nat
:= 0);
3770 -- Export the dispatch table DT of tagged type Typ. Required to generate
3771 -- forward references and statically allocate the table. For primary
3772 -- dispatch tables Index is 0; for secondary dispatch tables the value
3773 -- of index must match the Suffix_Index value assigned to the table by
3774 -- Make_Tags when generating its unique external name, and it is used to
3775 -- retrieve from the Dispatch_Table_Wrappers list associated with Typ
3776 -- the external name generated by Import_DT.
3778 procedure Make_Secondary_DT
3781 Iface_Comp
: Node_Id
;
3783 Num_Iface_Prims
: Nat
;
3784 Iface_DT_Ptr
: Entity_Id
;
3785 Predef_Prims_Ptr
: Entity_Id
;
3786 Build_Thunks
: Boolean;
3788 -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch
3789 -- Table of Typ associated with Iface. Each abstract interface of Typ
3790 -- has two secondary dispatch tables: one containing pointers to thunks
3791 -- and another containing pointers to the primitives covering the
3792 -- interface primitives. The former secondary table is generated when
3793 -- Build_Thunks is True, and provides common support for dispatching
3794 -- calls through interface types; the latter secondary table is
3795 -- generated when Build_Thunks is False, and provides support for
3796 -- Generic Dispatching Constructors that dispatch calls through
3797 -- interface types. When constructing this latter table the value of
3798 -- Suffix_Index is -1 to indicate that there is no need to export such
3799 -- table when building statically allocated dispatch tables; a positive
3800 -- value of Suffix_Index must match the Suffix_Index value assigned to
3801 -- this secondary dispatch table by Make_Tags when its unique external
3802 -- name was generated.
3804 ------------------------------
3805 -- Check_Premature_Freezing --
3806 ------------------------------
3808 procedure Check_Premature_Freezing
3810 Tagged_Type
: Entity_Id
;
3815 function Is_Actual_For_Formal_Incomplete_Type
3816 (T
: Entity_Id
) return Boolean;
3817 -- In Ada 2012, if a nested generic has an incomplete formal type,
3818 -- the actual may be (and usually is) a private type whose completion
3819 -- appears later. It is safe to build the dispatch table in this
3820 -- case, gigi will have full views available.
3822 ------------------------------------------
3823 -- Is_Actual_For_Formal_Incomplete_Type --
3824 ------------------------------------------
3826 function Is_Actual_For_Formal_Incomplete_Type
3827 (T
: Entity_Id
) return Boolean
3829 Gen_Par
: Entity_Id
;
3833 if not Is_Generic_Instance
(Current_Scope
)
3834 or else not Used_As_Generic_Actual
(T
)
3838 Gen_Par
:= Generic_Parent
(Parent
(Current_Scope
));
3843 (Generic_Formal_Declarations
3844 (Unit_Declaration_Node
(Gen_Par
)));
3845 while Present
(F
) loop
3846 if Ekind
(Defining_Identifier
(F
)) = E_Incomplete_Type
then
3854 end Is_Actual_For_Formal_Incomplete_Type
;
3856 -- Start of processing for Check_Premature_Freezing
3859 -- Note that if the type is a (subtype of) a generic actual, the
3860 -- actual will have been frozen by the instantiation.
3863 and then Is_Private_Type
(Typ
)
3864 and then No
(Full_View
(Typ
))
3865 and then not Is_Generic_Type
(Typ
)
3866 and then not Is_Tagged_Type
(Typ
)
3867 and then not Is_Frozen
(Typ
)
3868 and then not Is_Generic_Actual_Type
(Typ
)
3870 Error_Msg_Sloc
:= Sloc
(Subp
);
3872 ("declaration must appear after completion of type &", N
, Typ
);
3874 ("\which is an untagged type in the profile of "
3875 & "primitive operation & declared#", N
, Subp
);
3878 Comp
:= Private_Component
(Typ
);
3880 if not Is_Tagged_Type
(Typ
)
3881 and then Present
(Comp
)
3882 and then not Is_Frozen
(Comp
)
3883 and then not Is_Actual_For_Formal_Incomplete_Type
(Comp
)
3885 Error_Msg_Sloc
:= Sloc
(Subp
);
3886 Error_Msg_Node_2
:= Subp
;
3887 Error_Msg_Name_1
:= Chars
(Tagged_Type
);
3889 ("declaration must appear after completion of type &",
3892 ("\which is a component of untagged type& in the profile "
3893 & "of primitive & of type % that is frozen by the "
3894 & "declaration ", N
, Typ
);
3897 end Check_Premature_Freezing
;
3903 procedure Export_DT
(Typ
: Entity_Id
; DT
: Entity_Id
; Index
: Nat
:= 0)
3909 Set_Is_Statically_Allocated
(DT
);
3910 Set_Is_True_Constant
(DT
);
3911 Set_Is_Exported
(DT
);
3914 Elmt
:= First_Elmt
(Dispatch_Table_Wrappers
(Typ
));
3915 while Count
/= Index
loop
3920 pragma Assert
(Related_Type
(Node
(Elmt
)) = Typ
);
3922 Get_External_Name
(Node
(Elmt
));
3923 Set_Interface_Name
(DT
,
3924 Make_String_Literal
(Loc
,
3925 Strval
=> String_From_Name_Buffer
));
3927 -- Ensure proper Sprint output of this implicit importation
3929 Set_Is_Internal
(DT
);
3933 -----------------------
3934 -- Make_Secondary_DT --
3935 -----------------------
3937 procedure Make_Secondary_DT
3940 Iface_Comp
: Node_Id
;
3942 Num_Iface_Prims
: Nat
;
3943 Iface_DT_Ptr
: Entity_Id
;
3944 Predef_Prims_Ptr
: Entity_Id
;
3945 Build_Thunks
: Boolean;
3948 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3949 Exporting_Table
: constant Boolean :=
3950 Building_Static_DT
(Typ
)
3951 and then Suffix_Index
> 0;
3952 Iface_DT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
3953 Predef_Prims
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
3954 DT_Constr_List
: List_Id
;
3955 DT_Aggr_List
: List_Id
;
3956 Empty_DT
: Boolean := False;
3957 Nb_Predef_Prims
: Nat
:= 0;
3961 OSD_Aggr_List
: List_Id
;
3964 Prim_Elmt
: Elmt_Id
;
3965 Prim_Ops_Aggr_List
: List_Id
;
3968 -- Handle cases in which we do not generate statically allocated
3971 if not Building_Static_DT
(Typ
) then
3972 Set_Ekind
(Predef_Prims
, E_Variable
);
3973 Set_Ekind
(Iface_DT
, E_Variable
);
3975 -- Statically allocated dispatch tables and related entities are
3979 Set_Ekind
(Predef_Prims
, E_Constant
);
3980 Set_Is_Statically_Allocated
(Predef_Prims
);
3981 Set_Is_True_Constant
(Predef_Prims
);
3983 Set_Ekind
(Iface_DT
, E_Constant
);
3984 Set_Is_Statically_Allocated
(Iface_DT
);
3985 Set_Is_True_Constant
(Iface_DT
);
3988 -- Calculate the number of slots of the dispatch table. If the number
3989 -- of primitives of Typ is 0 we reserve a dummy single entry for its
3990 -- DT because at run time the pointer to this dummy entry will be
3993 if Num_Iface_Prims
= 0 then
3997 Nb_Prim
:= Num_Iface_Prims
;
4002 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
4003 -- (predef-prim-op-thunk-1'address,
4004 -- predef-prim-op-thunk-2'address,
4006 -- predef-prim-op-thunk-n'address);
4007 -- for Predef_Prims'Alignment use Address'Alignment
4009 -- Stage 1: Calculate the number of predefined primitives
4011 if not Building_Static_DT
(Typ
) then
4012 Nb_Predef_Prims
:= Max_Predef_Prims
;
4014 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4015 while Present
(Prim_Elmt
) loop
4016 Prim
:= Node
(Prim_Elmt
);
4018 if Is_Predefined_Dispatching_Operation
(Prim
)
4019 and then not Is_Abstract_Subprogram
(Prim
)
4021 Pos
:= UI_To_Int
(DT_Position
(Prim
));
4023 if Pos
> Nb_Predef_Prims
then
4024 Nb_Predef_Prims
:= Pos
;
4028 Next_Elmt
(Prim_Elmt
);
4032 if Generate_SCIL
then
4033 Nb_Predef_Prims
:= 0;
4036 -- Stage 2: Create the thunks associated with the predefined
4037 -- primitives and save their entity to fill the aggregate.
4040 Prim_Table
: array (Nat
range 1 .. Nb_Predef_Prims
) of Entity_Id
;
4042 Thunk_Id
: Entity_Id
;
4043 Thunk_Code
: Node_Id
;
4046 Prim_Ops_Aggr_List
:= New_List
;
4047 Prim_Table
:= (others => Empty
);
4049 if Building_Static_DT
(Typ
) then
4050 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4051 while Present
(Prim_Elmt
) loop
4052 Prim
:= Node
(Prim_Elmt
);
4054 if Is_Predefined_Dispatching_Operation
(Prim
)
4055 and then not Is_Abstract_Subprogram
(Prim
)
4056 and then not Is_Eliminated
(Prim
)
4057 and then not Generate_SCIL
4058 and then not Present
(Prim_Table
4059 (UI_To_Int
(DT_Position
(Prim
))))
4061 if not Build_Thunks
then
4062 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) :=
4066 Expand_Interface_Thunk
(Prim
, Thunk_Id
, Thunk_Code
);
4068 if Present
(Thunk_Id
) then
4069 Append_To
(Result
, Thunk_Code
);
4070 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) :=
4076 Next_Elmt
(Prim_Elmt
);
4080 for J
in Prim_Table
'Range loop
4081 if Present
(Prim_Table
(J
)) then
4083 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
4084 Make_Attribute_Reference
(Loc
,
4085 Prefix
=> New_Occurrence_Of
(Prim_Table
(J
), Loc
),
4086 Attribute_Name
=> Name_Unrestricted_Access
));
4088 New_Node
:= Make_Null
(Loc
);
4091 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
4095 Make_Aggregate
(Loc
, Expressions
=> Prim_Ops_Aggr_List
);
4097 -- Remember aggregates initializing dispatch tables
4099 Append_Elmt
(New_Node
, DT_Aggr
);
4102 Make_Subtype_Declaration
(Loc
,
4103 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
4104 Subtype_Indication
=>
4105 New_Occurrence_Of
(RTE
(RE_Address_Array
), Loc
));
4107 Append_To
(Result
, Decl
);
4110 Make_Object_Declaration
(Loc
,
4111 Defining_Identifier
=> Predef_Prims
,
4112 Constant_Present
=> Building_Static_DT
(Typ
),
4113 Aliased_Present
=> True,
4114 Object_Definition
=> New_Occurrence_Of
4115 (Defining_Identifier
(Decl
), Loc
),
4116 Expression
=> New_Node
));
4119 Make_Attribute_Definition_Clause
(Loc
,
4120 Name
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
4121 Chars
=> Name_Alignment
,
4123 Make_Attribute_Reference
(Loc
,
4125 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4126 Attribute_Name
=> Name_Alignment
)));
4131 -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
4132 -- (OSD_Table => (1 => <value>,
4136 -- Iface_DT : Dispatch_Table (Nb_Prims) :=
4137 -- ([ Signature => <sig-value> ],
4138 -- Tag_Kind => <tag_kind-value>,
4139 -- Predef_Prims => Predef_Prims'Address,
4140 -- Offset_To_Top => 0,
4141 -- OSD => OSD'Address,
4142 -- Prims_Ptr => (prim-op-1'address,
4143 -- prim-op-2'address,
4145 -- prim-op-n'address));
4146 -- for Iface_DT'Alignment use Address'Alignment;
4148 -- Stage 3: Initialize the discriminant and the record components
4150 DT_Constr_List
:= New_List
;
4151 DT_Aggr_List
:= New_List
;
4155 Append_To
(DT_Constr_List
, Make_Integer_Literal
(Loc
, Nb_Prim
));
4156 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, Nb_Prim
));
4160 if RTE_Record_Component_Available
(RE_Signature
) then
4161 Append_To
(DT_Aggr_List
,
4162 New_Occurrence_Of
(RTE
(RE_Secondary_DT
), Loc
));
4167 if RTE_Record_Component_Available
(RE_Tag_Kind
) then
4168 Append_To
(DT_Aggr_List
, Tagged_Kind
(Typ
));
4173 Append_To
(DT_Aggr_List
,
4174 Make_Attribute_Reference
(Loc
,
4175 Prefix
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
4176 Attribute_Name
=> Name_Address
));
4178 -- If the location of the component that references this secondary
4179 -- dispatch table is variable then we have not declared the internal
4180 -- dummy object; the value of Offset_To_Top will be set by the init
4183 if No
(Dummy_Object
) then
4184 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
4187 Append_To
(DT_Aggr_List
,
4189 Make_Attribute_Reference
(Loc
,
4191 Make_Selected_Component
(Loc
,
4193 New_Occurrence_Of
(Dummy_Object
, Loc
),
4195 New_Occurrence_Of
(Iface_Comp
, Loc
)),
4196 Attribute_Name
=> Name_Position
)));
4199 -- Generate the Object Specific Data table required to dispatch calls
4200 -- through synchronized interfaces.
4203 or else Is_Abstract_Type
(Typ
)
4204 or else Is_Controlled
(Typ
)
4205 or else Restriction_Active
(No_Dispatching_Calls
)
4206 or else not Is_Limited_Type
(Typ
)
4207 or else not Has_Interfaces
(Typ
)
4208 or else not Build_Thunks
4209 or else not RTE_Record_Component_Available
(RE_OSD_Table
)
4211 -- No OSD table required
4213 Append_To
(DT_Aggr_List
,
4214 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
4217 OSD_Aggr_List
:= New_List
;
4220 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
4222 Prim_Alias
: Entity_Id
;
4223 Prim_Elmt
: Elmt_Id
;
4229 Prim_Table
:= (others => Empty
);
4230 Prim_Alias
:= Empty
;
4232 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4233 while Present
(Prim_Elmt
) loop
4234 Prim
:= Node
(Prim_Elmt
);
4236 if Present
(Interface_Alias
(Prim
))
4237 and then Find_Dispatching_Type
4238 (Interface_Alias
(Prim
)) = Iface
4240 Prim_Alias
:= Interface_Alias
(Prim
);
4241 E
:= Ultimate_Alias
(Prim
);
4242 Pos
:= UI_To_Int
(DT_Position
(Prim_Alias
));
4244 if Present
(Prim_Table
(Pos
)) then
4245 pragma Assert
(Prim_Table
(Pos
) = E
);
4249 Prim_Table
(Pos
) := E
;
4251 Append_To
(OSD_Aggr_List
,
4252 Make_Component_Association
(Loc
,
4253 Choices
=> New_List
(
4254 Make_Integer_Literal
(Loc
,
4255 DT_Position
(Prim_Alias
))),
4257 Make_Integer_Literal
(Loc
,
4258 DT_Position
(Alias
(Prim
)))));
4264 Next_Elmt
(Prim_Elmt
);
4266 pragma Assert
(Count
= Nb_Prim
);
4269 OSD
:= Make_Temporary
(Loc
, 'I');
4272 Make_Object_Declaration
(Loc
,
4273 Defining_Identifier
=> OSD
,
4274 Object_Definition
=>
4275 Make_Subtype_Indication
(Loc
,
4277 New_Occurrence_Of
(RTE
(RE_Object_Specific_Data
), Loc
),
4279 Make_Index_Or_Discriminant_Constraint
(Loc
,
4280 Constraints
=> New_List
(
4281 Make_Integer_Literal
(Loc
, Nb_Prim
)))),
4284 Make_Aggregate
(Loc
,
4285 Component_Associations
=> New_List
(
4286 Make_Component_Association
(Loc
,
4287 Choices
=> New_List
(
4289 (RTE_Record_Component
(RE_OSD_Num_Prims
), Loc
)),
4291 Make_Integer_Literal
(Loc
, Nb_Prim
)),
4293 Make_Component_Association
(Loc
,
4294 Choices
=> New_List
(
4296 (RTE_Record_Component
(RE_OSD_Table
), Loc
)),
4297 Expression
=> Make_Aggregate
(Loc
,
4298 Component_Associations
=> OSD_Aggr_List
))))));
4301 Make_Attribute_Definition_Clause
(Loc
,
4302 Name
=> New_Occurrence_Of
(OSD
, Loc
),
4303 Chars
=> Name_Alignment
,
4305 Make_Attribute_Reference
(Loc
,
4307 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4308 Attribute_Name
=> Name_Alignment
)));
4310 -- In secondary dispatch tables the Typeinfo component contains
4311 -- the address of the Object Specific Data (see a-tags.ads)
4313 Append_To
(DT_Aggr_List
,
4314 Make_Attribute_Reference
(Loc
,
4315 Prefix
=> New_Occurrence_Of
(OSD
, Loc
),
4316 Attribute_Name
=> Name_Address
));
4319 -- Initialize the table of primitive operations
4321 Prim_Ops_Aggr_List
:= New_List
;
4324 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
4326 elsif Is_Abstract_Type
(Typ
)
4327 or else not Building_Static_DT
(Typ
)
4329 for J
in 1 .. Nb_Prim
loop
4330 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
4335 CPP_Nb_Prims
: constant Nat
:= CPP_Num_Prims
(Typ
);
4338 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
4339 Thunk_Code
: Node_Id
;
4340 Thunk_Id
: Entity_Id
;
4343 Prim_Table
:= (others => Empty
);
4345 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4346 while Present
(Prim_Elmt
) loop
4347 Prim
:= Node
(Prim_Elmt
);
4348 E
:= Ultimate_Alias
(Prim
);
4349 Prim_Pos
:= UI_To_Int
(DT_Position
(E
));
4351 -- Do not reference predefined primitives because they are
4352 -- located in a separate dispatch table; skip abstract and
4353 -- eliminated primitives; skip primitives located in the C++
4354 -- part of the dispatch table because their slot is set by
4357 if not Is_Predefined_Dispatching_Operation
(Prim
)
4358 and then Present
(Interface_Alias
(Prim
))
4359 and then not Is_Abstract_Subprogram
(Alias
(Prim
))
4360 and then not Is_Eliminated
(Alias
(Prim
))
4361 and then (not Is_CPP_Class
(Root_Type
(Typ
))
4362 or else Prim_Pos
> CPP_Nb_Prims
)
4363 and then Find_Dispatching_Type
4364 (Interface_Alias
(Prim
)) = Iface
4366 -- Generate the code of the thunk only if the abstract
4367 -- interface type is not an immediate ancestor of
4368 -- Tagged_Type. Otherwise the DT associated with the
4369 -- interface is the primary DT.
4371 and then not Is_Ancestor
(Iface
, Typ
,
4372 Use_Full_View
=> True)
4374 if not Build_Thunks
then
4376 UI_To_Int
(DT_Position
(Interface_Alias
(Prim
)));
4377 Prim_Table
(Prim_Pos
) := Alias
(Prim
);
4380 Expand_Interface_Thunk
(Prim
, Thunk_Id
, Thunk_Code
);
4382 if Present
(Thunk_Id
) then
4384 UI_To_Int
(DT_Position
(Interface_Alias
(Prim
)));
4386 Prim_Table
(Prim_Pos
) := Thunk_Id
;
4387 Append_To
(Result
, Thunk_Code
);
4392 Next_Elmt
(Prim_Elmt
);
4395 for J
in Prim_Table
'Range loop
4396 if Present
(Prim_Table
(J
)) then
4398 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
4399 Make_Attribute_Reference
(Loc
,
4400 Prefix
=> New_Occurrence_Of
(Prim_Table
(J
), Loc
),
4401 Attribute_Name
=> Name_Unrestricted_Access
));
4404 New_Node
:= Make_Null
(Loc
);
4407 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
4413 Make_Aggregate
(Loc
,
4414 Expressions
=> Prim_Ops_Aggr_List
);
4416 Append_To
(DT_Aggr_List
, New_Node
);
4418 -- Remember aggregates initializing dispatch tables
4420 Append_Elmt
(New_Node
, DT_Aggr
);
4422 -- Note: Secondary dispatch tables are declared constant only if
4423 -- we can compute their offset field by means of the extra dummy
4424 -- object; otherwise they cannot be declared constant and the
4425 -- Offset_To_Top component is initialized by the IP routine.
4428 Make_Object_Declaration
(Loc
,
4429 Defining_Identifier
=> Iface_DT
,
4430 Aliased_Present
=> True,
4431 Constant_Present
=> Present
(Dummy_Object
),
4433 Object_Definition
=>
4434 Make_Subtype_Indication
(Loc
,
4435 Subtype_Mark
=> New_Occurrence_Of
4436 (RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
4437 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
4438 Constraints
=> DT_Constr_List
)),
4441 Make_Aggregate
(Loc
,
4442 Expressions
=> DT_Aggr_List
)));
4445 Make_Attribute_Definition_Clause
(Loc
,
4446 Name
=> New_Occurrence_Of
(Iface_DT
, Loc
),
4447 Chars
=> Name_Alignment
,
4450 Make_Attribute_Reference
(Loc
,
4452 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4453 Attribute_Name
=> Name_Alignment
)));
4455 if Exporting_Table
then
4456 Export_DT
(Typ
, Iface_DT
, Suffix_Index
);
4458 -- Generate code to create the pointer to the dispatch table
4460 -- Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address);
4462 -- Note: This declaration is not added here if the table is exported
4463 -- because in such case Make_Tags has already added this declaration.
4467 Make_Object_Declaration
(Loc
,
4468 Defining_Identifier
=> Iface_DT_Ptr
,
4469 Constant_Present
=> True,
4471 Object_Definition
=>
4472 New_Occurrence_Of
(RTE
(RE_Interface_Tag
), Loc
),
4475 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
4476 Make_Attribute_Reference
(Loc
,
4478 Make_Selected_Component
(Loc
,
4479 Prefix
=> New_Occurrence_Of
(Iface_DT
, Loc
),
4482 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
4483 Attribute_Name
=> Name_Address
))));
4487 Make_Object_Declaration
(Loc
,
4488 Defining_Identifier
=> Predef_Prims_Ptr
,
4489 Constant_Present
=> True,
4491 Object_Definition
=>
4492 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
4495 Make_Attribute_Reference
(Loc
,
4497 Make_Selected_Component
(Loc
,
4498 Prefix
=> New_Occurrence_Of
(Iface_DT
, Loc
),
4501 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
4502 Attribute_Name
=> Name_Address
)));
4504 -- Remember entities containing dispatch tables
4506 Append_Elmt
(Predef_Prims
, DT_Decl
);
4507 Append_Elmt
(Iface_DT
, DT_Decl
);
4508 end Make_Secondary_DT
;
4512 Elab_Code
: constant List_Id
:= New_List
;
4513 Result
: constant List_Id
:= New_List
;
4514 Tname
: constant Name_Id
:= Chars
(Typ
);
4516 -- When pragmas Discard_Names and No_Tagged_Streams simultaneously apply
4517 -- we initialize the Expanded_Name and the External_Tag of this tagged
4518 -- type with an empty string. This is useful to avoid exposing entity
4519 -- names at binary level. It can be done when both pragmas apply because
4520 -- (1) Discard_Names allows initializing Expanded_Name with an
4521 -- implementation defined value (Ada RM Section C.5 (7/2)).
4522 -- (2) External_Tag (combined with Internal_Tag) is used for object
4523 -- streaming and No_Tagged_Streams inhibits the generation of
4526 Discard_Names
: constant Boolean :=
4527 Present
(No_Tagged_Streams_Pragma
(Typ
))
4528 and then (Global_Discard_Names
4529 or else Einfo
.Discard_Names
(Typ
));
4531 -- The following name entries are used by Make_DT to generate a number
4532 -- of entities related to a tagged type. These entities may be generated
4533 -- in a scope other than that of the tagged type declaration, and if
4534 -- the entities for two tagged types with the same name happen to be
4535 -- generated in the same scope, we have to take care to use different
4536 -- names. This is achieved by means of a unique serial number appended
4537 -- to each generated entity name.
4539 Name_DT
: constant Name_Id
:=
4540 New_External_Name
(Tname
, 'T', Suffix_Index
=> -1);
4541 Name_Exname
: constant Name_Id
:=
4542 New_External_Name
(Tname
, 'E', Suffix_Index
=> -1);
4543 Name_HT_Link
: constant Name_Id
:=
4544 New_External_Name
(Tname
, 'H', Suffix_Index
=> -1);
4545 Name_Predef_Prims
: constant Name_Id
:=
4546 New_External_Name
(Tname
, 'R', Suffix_Index
=> -1);
4547 Name_SSD
: constant Name_Id
:=
4548 New_External_Name
(Tname
, 'S', Suffix_Index
=> -1);
4549 Name_TSD
: constant Name_Id
:=
4550 New_External_Name
(Tname
, 'B', Suffix_Index
=> -1);
4552 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
4553 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
4554 -- Save the Ghost-related attributes to restore on exit
4557 AI_Tag_Elmt
: Elmt_Id
;
4558 AI_Tag_Comp
: Elmt_Id
;
4560 DT_Aggr_List
: List_Id
;
4561 DT_Constr_List
: List_Id
;
4564 HT_Link
: Entity_Id
;
4567 Iface_Table_Node
: Node_Id
;
4568 Name_ITable
: Name_Id
;
4569 Nb_Predef_Prims
: Nat
:= 0;
4572 Num_Ifaces
: Nat
:= 0;
4573 Parent_Typ
: Entity_Id
;
4574 Predef_Prims
: Entity_Id
;
4576 Prim_Elmt
: Elmt_Id
;
4577 Prim_Ops_Aggr_List
: List_Id
;
4580 Typ_Comps
: Elist_Id
;
4581 Typ_Ifaces
: Elist_Id
;
4583 TSD_Aggr_List
: List_Id
;
4584 TSD_Tags_List
: List_Id
;
4586 -- Start of processing for Make_DT
4589 pragma Assert
(Is_Frozen
(Typ
));
4591 -- The tagged type being processed may be subject to pragma Ghost. Set
4592 -- the mode now to ensure that any nodes generated during dispatch table
4593 -- creation are properly marked as Ghost.
4595 Set_Ghost_Mode
(Typ
);
4597 -- Handle cases in which there is no need to build the dispatch table
4599 if Has_Dispatch_Table
(Typ
)
4600 or else No
(Access_Disp_Table
(Typ
))
4601 or else Is_CPP_Class
(Typ
)
4605 elsif No_Run_Time_Mode
then
4606 Error_Msg_CRT
("tagged types", Typ
);
4609 elsif not RTE_Available
(RE_Tag
) then
4611 Make_Object_Declaration
(Loc
,
4612 Defining_Identifier
=>
4613 Node
(First_Elmt
(Access_Disp_Table
(Typ
))),
4614 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
4615 Constant_Present
=> True,
4617 Unchecked_Convert_To
(RTE
(RE_Tag
),
4618 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
4620 Analyze_List
(Result
, Suppress
=> All_Checks
);
4621 Error_Msg_CRT
("tagged types", Typ
);
4625 -- Ensure that the value of Max_Predef_Prims defined in a-tags is
4626 -- correct. Valid values are 9 under configurable runtime or 15
4627 -- with full runtime.
4629 if RTE_Available
(RE_Interface_Data
) then
4630 if Max_Predef_Prims
/= 15 then
4631 Error_Msg_N
("run-time library configuration error", Typ
);
4635 if Max_Predef_Prims
/= 9 then
4636 Error_Msg_N
("run-time library configuration error", Typ
);
4637 Error_Msg_CRT
("tagged types", Typ
);
4642 DT
:= Make_Defining_Identifier
(Loc
, Name_DT
);
4643 Exname
:= Make_Defining_Identifier
(Loc
, Name_Exname
);
4644 HT_Link
:= Make_Defining_Identifier
(Loc
, Name_HT_Link
);
4645 Predef_Prims
:= Make_Defining_Identifier
(Loc
, Name_Predef_Prims
);
4646 SSD
:= Make_Defining_Identifier
(Loc
, Name_SSD
);
4647 TSD
:= Make_Defining_Identifier
(Loc
, Name_TSD
);
4649 -- Initialize Parent_Typ handling private types
4651 Parent_Typ
:= Etype
(Typ
);
4653 if Present
(Full_View
(Parent_Typ
)) then
4654 Parent_Typ
:= Full_View
(Parent_Typ
);
4657 -- Ensure that all the primitives are frozen. This is only required when
4658 -- building static dispatch tables --- the primitives must be frozen to
4659 -- be referenced (otherwise we have problems with the backend). It is
4660 -- not a requirement with nonstatic dispatch tables because in this case
4661 -- we generate now an empty dispatch table; the extra code required to
4662 -- register the primitives in the slots will be generated later --- when
4663 -- each primitive is frozen (see Freeze_Subprogram).
4665 if Building_Static_DT
(Typ
) then
4667 Saved_FLLTT
: constant Boolean :=
4668 Freezing_Library_Level_Tagged_Type
;
4673 Prim_Elmt
: Elmt_Id
;
4676 Freezing_Library_Level_Tagged_Type
:= True;
4678 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4679 while Present
(Prim_Elmt
) loop
4680 Prim
:= Node
(Prim_Elmt
);
4681 Frnodes
:= Freeze_Entity
(Prim
, Typ
);
4683 -- We disable this check for abstract subprograms, given that
4684 -- they cannot be called directly and thus the state of their
4685 -- untagged formals is of no concern. The RM is unclear in any
4686 -- case concerning the need for this check, and this topic may
4687 -- go back to the ARG.
4689 if not Is_Abstract_Subprogram
(Prim
) then
4690 Formal
:= First_Formal
(Prim
);
4691 while Present
(Formal
) loop
4692 Check_Premature_Freezing
(Prim
, Typ
, Etype
(Formal
));
4693 Next_Formal
(Formal
);
4696 Check_Premature_Freezing
(Prim
, Typ
, Etype
(Prim
));
4699 if Present
(Frnodes
) then
4700 Append_List_To
(Result
, Frnodes
);
4703 Next_Elmt
(Prim_Elmt
);
4706 Freezing_Library_Level_Tagged_Type
:= Saved_FLLTT
;
4710 if Building_Static_Secondary_DT
(Typ
) then
4712 Cannot_Have_Null_Disc
: Boolean := False;
4713 Name_Dummy_Object
: constant Name_Id
:=
4714 New_External_Name
(Tname
,
4715 'P', Suffix_Index
=> -1);
4717 Dummy_Object
:= Make_Defining_Identifier
(Loc
, Name_Dummy_Object
);
4719 -- Define the extra object imported and constant to avoid linker
4720 -- errors (since this object is never declared). Required because
4721 -- we implement RM 13.3(19) for exported and imported (variable)
4722 -- objects by making them volatile.
4724 Set_Is_Imported
(Dummy_Object
);
4725 Set_Ekind
(Dummy_Object
, E_Constant
);
4726 Set_Is_True_Constant
(Dummy_Object
);
4727 Set_Related_Type
(Dummy_Object
, Typ
);
4729 -- The scope must be set now to call Get_External_Name
4731 Set_Scope
(Dummy_Object
, Current_Scope
);
4733 Get_External_Name
(Dummy_Object
);
4734 Set_Interface_Name
(Dummy_Object
,
4735 Make_String_Literal
(Loc
, Strval
=> String_From_Name_Buffer
));
4737 -- Ensure proper Sprint output of this implicit importation
4739 Set_Is_Internal
(Dummy_Object
);
4741 if not Has_Discriminants
(Typ
) then
4743 Make_Object_Declaration
(Loc
,
4744 Defining_Identifier
=> Dummy_Object
,
4745 Constant_Present
=> True,
4746 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)));
4749 Constr_List
: constant List_Id
:= New_List
;
4753 Discrim
:= First_Discriminant
(Typ
);
4754 while Present
(Discrim
) loop
4755 if Is_Discrete_Type
(Etype
(Discrim
)) then
4756 Append_To
(Constr_List
,
4757 Make_Attribute_Reference
(Loc
,
4759 New_Occurrence_Of
(Etype
(Discrim
), Loc
),
4760 Attribute_Name
=> Name_First
));
4763 pragma Assert
(Is_Access_Type
(Etype
(Discrim
)));
4764 Cannot_Have_Null_Disc
:=
4765 Cannot_Have_Null_Disc
4766 or else Can_Never_Be_Null
(Etype
(Discrim
));
4767 Append_To
(Constr_List
, Make_Null
(Loc
));
4770 Next_Discriminant
(Discrim
);
4774 Make_Object_Declaration
(Loc
,
4775 Defining_Identifier
=> Dummy_Object
,
4776 Constant_Present
=> True,
4777 Object_Definition
=>
4778 Make_Subtype_Indication
(Loc
,
4779 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
4781 Make_Index_Or_Discriminant_Constraint
(Loc
,
4782 Constraints
=> Constr_List
))));
4786 -- Given that the dummy object will not be declared at run time,
4787 -- analyze its declaration with expansion disabled and warnings
4788 -- and error messages ignored.
4790 Expander_Mode_Save_And_Set
(False);
4791 Ignore_Errors_Enable
:= Ignore_Errors_Enable
+ 1;
4792 Analyze
(Last
(Result
), Suppress
=> All_Checks
);
4793 Ignore_Errors_Enable
:= Ignore_Errors_Enable
- 1;
4794 Expander_Mode_Restore
;
4798 -- Ada 2005 (AI-251): Build the secondary dispatch tables
4800 if Has_Interfaces
(Typ
) then
4801 Collect_Interface_Components
(Typ
, Typ_Comps
);
4803 -- Each secondary dispatch table is assigned an unique positive
4804 -- suffix index; such value also corresponds with the location of
4805 -- its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
4807 -- Note: This value must be kept sync with the Suffix_Index values
4808 -- generated by Make_Tags
4812 Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
4814 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
4815 while Present
(AI_Tag_Comp
) loop
4816 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'P'));
4818 -- Build the secondary table containing pointers to thunks
4823 Base_Type
(Related_Type
(Node
(AI_Tag_Comp
))),
4824 Iface_Comp
=> Node
(AI_Tag_Comp
),
4825 Suffix_Index
=> Suffix_Index
,
4827 UI_To_Int
(DT_Entry_Count
(Node
(AI_Tag_Comp
))),
4828 Iface_DT_Ptr
=> Node
(AI_Tag_Elmt
),
4829 Predef_Prims_Ptr
=> Node
(Next_Elmt
(AI_Tag_Elmt
)),
4830 Build_Thunks
=> True,
4833 -- Skip secondary dispatch table referencing thunks to predefined
4836 Next_Elmt
(AI_Tag_Elmt
);
4837 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'Y'));
4839 -- Secondary dispatch table referencing user-defined primitives
4840 -- covered by this interface.
4842 Next_Elmt
(AI_Tag_Elmt
);
4843 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'D'));
4845 -- Build the secondary table containing pointers to primitives
4846 -- (used to give support to Generic Dispatching Constructors).
4851 (Related_Type
(Node
(AI_Tag_Comp
))),
4852 Iface_Comp
=> Node
(AI_Tag_Comp
),
4854 Num_Iface_Prims
=> UI_To_Int
4855 (DT_Entry_Count
(Node
(AI_Tag_Comp
))),
4856 Iface_DT_Ptr
=> Node
(AI_Tag_Elmt
),
4857 Predef_Prims_Ptr
=> Node
(Next_Elmt
(AI_Tag_Elmt
)),
4858 Build_Thunks
=> False,
4861 -- Skip secondary dispatch table referencing predefined primitives
4863 Next_Elmt
(AI_Tag_Elmt
);
4864 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'Z'));
4866 Suffix_Index
:= Suffix_Index
+ 1;
4867 Next_Elmt
(AI_Tag_Elmt
);
4868 Next_Elmt
(AI_Tag_Comp
);
4872 -- Get the _tag entity and number of primitives of its dispatch table
4874 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
4875 Nb_Prim
:= UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Typ
)));
4877 if Generate_SCIL
then
4881 Set_Is_Statically_Allocated
(DT
, Is_Library_Level_Tagged_Type
(Typ
));
4882 Set_Is_Statically_Allocated
(SSD
, Is_Library_Level_Tagged_Type
(Typ
));
4883 Set_Is_Statically_Allocated
(TSD
, Is_Library_Level_Tagged_Type
(Typ
));
4884 Set_Is_Statically_Allocated
(Predef_Prims
,
4885 Is_Library_Level_Tagged_Type
(Typ
));
4887 -- In case of locally defined tagged type we declare the object
4888 -- containing the dispatch table by means of a variable. Its
4889 -- initialization is done later by means of an assignment. This is
4890 -- required to generate its External_Tag.
4892 if not Building_Static_DT
(Typ
) then
4895 -- DT : No_Dispatch_Table_Wrapper;
4896 -- for DT'Alignment use Address'Alignment;
4897 -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
4899 if not Has_DT
(Typ
) then
4901 Make_Object_Declaration
(Loc
,
4902 Defining_Identifier
=> DT
,
4903 Aliased_Present
=> True,
4904 Constant_Present
=> False,
4905 Object_Definition
=>
4907 (RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
)));
4910 Make_Attribute_Definition_Clause
(Loc
,
4911 Name
=> New_Occurrence_Of
(DT
, Loc
),
4912 Chars
=> Name_Alignment
,
4914 Make_Attribute_Reference
(Loc
,
4916 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4917 Attribute_Name
=> Name_Alignment
)));
4920 Make_Object_Declaration
(Loc
,
4921 Defining_Identifier
=> DT_Ptr
,
4922 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
4923 Constant_Present
=> True,
4925 Unchecked_Convert_To
(RTE
(RE_Tag
),
4926 Make_Attribute_Reference
(Loc
,
4928 Make_Selected_Component
(Loc
,
4929 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
4932 (RTE_Record_Component
(RE_NDT_Prims_Ptr
), Loc
)),
4933 Attribute_Name
=> Name_Address
))));
4935 Set_Is_Statically_Allocated
(DT_Ptr
,
4936 Is_Library_Level_Tagged_Type
(Typ
));
4938 -- Generate the SCIL node for the previous object declaration
4939 -- because it has a tag initialization.
4941 if Generate_SCIL
then
4943 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
4944 Set_SCIL_Entity
(New_Node
, Typ
);
4945 Set_SCIL_Node
(Last
(Result
), New_Node
);
4949 -- Gnat2scil has its own implementation of dispatch tables,
4950 -- different than what is being implemented here. Generating
4951 -- further dispatch table initialization code would just
4952 -- cause gnat2scil to generate useless Scil which CodePeer
4953 -- would waste time and space analyzing, so we skip it.
4957 -- DT : Dispatch_Table_Wrapper (Nb_Prim);
4958 -- for DT'Alignment use Address'Alignment;
4959 -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
4962 -- If the tagged type has no primitives we add a dummy slot
4963 -- whose address will be the tag of this type.
4967 New_List
(Make_Integer_Literal
(Loc
, 1));
4970 New_List
(Make_Integer_Literal
(Loc
, Nb_Prim
));
4974 Make_Object_Declaration
(Loc
,
4975 Defining_Identifier
=> DT
,
4976 Aliased_Present
=> True,
4977 Constant_Present
=> False,
4978 Object_Definition
=>
4979 Make_Subtype_Indication
(Loc
,
4981 New_Occurrence_Of
(RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
4983 Make_Index_Or_Discriminant_Constraint
(Loc
,
4984 Constraints
=> DT_Constr_List
))));
4987 Make_Attribute_Definition_Clause
(Loc
,
4988 Name
=> New_Occurrence_Of
(DT
, Loc
),
4989 Chars
=> Name_Alignment
,
4991 Make_Attribute_Reference
(Loc
,
4993 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4994 Attribute_Name
=> Name_Alignment
)));
4997 Make_Object_Declaration
(Loc
,
4998 Defining_Identifier
=> DT_Ptr
,
4999 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
5000 Constant_Present
=> True,
5002 Unchecked_Convert_To
(RTE
(RE_Tag
),
5003 Make_Attribute_Reference
(Loc
,
5005 Make_Selected_Component
(Loc
,
5006 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
5009 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
5010 Attribute_Name
=> Name_Address
))));
5012 Set_Is_Statically_Allocated
(DT_Ptr
,
5013 Is_Library_Level_Tagged_Type
(Typ
));
5015 -- Generate the SCIL node for the previous object declaration
5016 -- because it has a tag initialization.
5018 if Generate_SCIL
then
5020 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
5021 Set_SCIL_Entity
(New_Node
, Typ
);
5022 Set_SCIL_Node
(Last
(Result
), New_Node
);
5026 -- Gnat2scil has its own implementation of dispatch tables,
5027 -- different than what is being implemented here. Generating
5028 -- further dispatch table initialization code would just
5029 -- cause gnat2scil to generate useless Scil which CodePeer
5030 -- would waste time and space analyzing, so we skip it.
5034 Make_Object_Declaration
(Loc
,
5035 Defining_Identifier
=>
5036 Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
)))),
5037 Constant_Present
=> True,
5038 Object_Definition
=>
5039 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
5041 Make_Attribute_Reference
(Loc
,
5043 Make_Selected_Component
(Loc
,
5044 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
5047 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
5048 Attribute_Name
=> Name_Address
)));
5052 -- Generate: Expanded_Name : constant String := "";
5054 if Discard_Names
then
5056 Make_Object_Declaration
(Loc
,
5057 Defining_Identifier
=> Exname
,
5058 Constant_Present
=> True,
5059 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
5061 Make_String_Literal
(Loc
, "")));
5063 -- Generate: Exname : constant String := full_qualified_name (typ);
5064 -- The type itself may be an anonymous parent type, so use the first
5065 -- subtype to have a user-recognizable name.
5069 Make_Object_Declaration
(Loc
,
5070 Defining_Identifier
=> Exname
,
5071 Constant_Present
=> True,
5072 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
5074 Make_String_Literal
(Loc
,
5075 Fully_Qualified_Name_String
(First_Subtype
(Typ
)))));
5078 Set_Is_Statically_Allocated
(Exname
);
5079 Set_Is_True_Constant
(Exname
);
5081 -- Declare the object used by Ada.Tags.Register_Tag
5083 if RTE_Available
(RE_Register_Tag
) then
5085 Make_Object_Declaration
(Loc
,
5086 Defining_Identifier
=> HT_Link
,
5087 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
5088 Expression
=> New_Occurrence_Of
(RTE
(RE_No_Tag
), Loc
)));
5091 -- Generate code to create the storage for the type specific data object
5092 -- with enough space to store the tags of the ancestors plus the tags
5093 -- of all the implemented interfaces (as described in a-tags.adb).
5095 -- TSD : Type_Specific_Data (I_Depth) :=
5096 -- (Idepth => I_Depth,
5097 -- Access_Level => Type_Access_Level (Typ),
5098 -- Alignment => Typ'Alignment,
5099 -- Expanded_Name => Cstring_Ptr!(Exname'Address))
5100 -- External_Tag => Cstring_Ptr!(Exname'Address))
5101 -- HT_Link => HT_Link'Address,
5102 -- Transportable => <<boolean-value>>,
5103 -- Is_Abstract => <<boolean-value>>,
5104 -- Needs_Finalization => <<boolean-value>>,
5105 -- [ Size_Func => Size_Prim'Access, ]
5106 -- [ Interfaces_Table => <<access-value>>, ]
5107 -- [ SSD => SSD_Table'Address ]
5108 -- Tags_Table => (0 => null,
5111 -- for TSD'Alignment use Address'Alignment
5113 TSD_Aggr_List
:= New_List
;
5115 -- Idepth: Count ancestors to compute the inheritance depth. For private
5116 -- extensions, always go to the full view in order to compute the real
5117 -- inheritance depth.
5120 Current_Typ
: Entity_Id
;
5121 Parent_Typ
: Entity_Id
;
5127 Parent_Typ
:= Etype
(Current_Typ
);
5129 if Is_Private_Type
(Parent_Typ
) then
5130 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
5133 exit when Parent_Typ
= Current_Typ
;
5135 I_Depth
:= I_Depth
+ 1;
5136 Current_Typ
:= Parent_Typ
;
5140 Append_To
(TSD_Aggr_List
,
5141 Make_Integer_Literal
(Loc
, I_Depth
));
5145 Append_To
(TSD_Aggr_List
,
5146 Make_Integer_Literal
(Loc
, Type_Access_Level
(Typ
)));
5150 -- For CPP types we cannot rely on the value of 'Alignment provided
5151 -- by the backend to initialize this TSD field.
5153 if Convention
(Typ
) = Convention_CPP
5154 or else Is_CPP_Class
(Root_Type
(Typ
))
5156 Append_To
(TSD_Aggr_List
,
5157 Make_Integer_Literal
(Loc
, 0));
5159 Append_To
(TSD_Aggr_List
,
5160 Make_Attribute_Reference
(Loc
,
5161 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
5162 Attribute_Name
=> Name_Alignment
));
5167 Append_To
(TSD_Aggr_List
,
5168 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5169 Make_Attribute_Reference
(Loc
,
5170 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5171 Attribute_Name
=> Name_Address
)));
5173 -- External_Tag of a local tagged type
5175 -- <typ>A : constant String :=
5176 -- "Internal tag at 16#tag-addr#: <full-name-of-typ>";
5178 -- The reason we generate this strange name is that we do not want to
5179 -- enter local tagged types in the global hash table used to compute
5180 -- the Internal_Tag attribute for two reasons:
5182 -- 1. It is hard to avoid a tasking race condition for entering the
5183 -- entry into the hash table.
5185 -- 2. It would cause a storage leak, unless we rig up considerable
5186 -- mechanism to remove the entry from the hash table on exit.
5188 -- So what we do is to generate the above external tag name, where the
5189 -- hex address is the address of the local dispatch table (i.e. exactly
5190 -- the value we want if Internal_Tag is computed from this string).
5192 -- Of course this value will only be valid if the tagged type is still
5193 -- in scope, but it clearly must be erroneous to compute the internal
5194 -- tag of a tagged type that is out of scope.
5196 -- We don't do this processing if an explicit external tag has been
5197 -- specified. That's an odd case for which we have already issued a
5198 -- warning, where we will not be able to compute the internal tag.
5200 if not Discard_Names
5201 and then not Is_Library_Level_Entity
(Typ
)
5202 and then not Has_External_Tag_Rep_Clause
(Typ
)
5205 Exname
: constant Entity_Id
:=
5206 Make_Defining_Identifier
(Loc
,
5207 Chars
=> New_External_Name
(Tname
, 'A'));
5208 Full_Name
: constant String_Id
:=
5209 Fully_Qualified_Name_String
(First_Subtype
(Typ
));
5210 Str1_Id
: String_Id
;
5211 Str2_Id
: String_Id
;
5215 -- Str1 = "Internal tag at 16#";
5218 Store_String_Chars
("Internal tag at 16#");
5219 Str1_Id
:= End_String
;
5222 -- Str2 = "#: <type-full-name>";
5225 Store_String_Chars
("#: ");
5226 Store_String_Chars
(Full_Name
);
5227 Str2_Id
:= End_String
;
5230 -- Exname : constant String :=
5231 -- Str1 & Address_Image (Tag) & Str2;
5233 if RTE_Available
(RE_Address_Image
) then
5235 Make_Object_Declaration
(Loc
,
5236 Defining_Identifier
=> Exname
,
5237 Constant_Present
=> True,
5238 Object_Definition
=> New_Occurrence_Of
5239 (Standard_String
, Loc
),
5241 Make_Op_Concat
(Loc
,
5242 Left_Opnd
=> Make_String_Literal
(Loc
, Str1_Id
),
5244 Make_Op_Concat
(Loc
,
5246 Make_Function_Call
(Loc
,
5249 (RTE
(RE_Address_Image
), Loc
),
5250 Parameter_Associations
=> New_List
(
5251 Unchecked_Convert_To
(RTE
(RE_Address
),
5252 New_Occurrence_Of
(DT_Ptr
, Loc
)))),
5254 Make_String_Literal
(Loc
, Str2_Id
)))));
5257 -- Exname : constant String := Str1 & Str2;
5261 Make_Object_Declaration
(Loc
,
5262 Defining_Identifier
=> Exname
,
5263 Constant_Present
=> True,
5264 Object_Definition
=>
5265 New_Occurrence_Of
(Standard_String
, Loc
),
5267 Make_Op_Concat
(Loc
,
5268 Left_Opnd
=> Make_String_Literal
(Loc
, Str1_Id
),
5269 Right_Opnd
=> Make_String_Literal
(Loc
, Str2_Id
))));
5273 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5274 Make_Attribute_Reference
(Loc
,
5275 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5276 Attribute_Name
=> Name_Address
));
5279 -- External tag of a library-level tagged type: Check for a definition
5280 -- of External_Tag. The clause is considered only if it applies to this
5281 -- specific tagged type, as opposed to one of its ancestors.
5282 -- If the type is an unconstrained type extension, we are building the
5283 -- dispatch table of its anonymous base type, so the external tag, if
5284 -- any was specified, must be retrieved from the first subtype. Go to
5285 -- the full view in case the clause is in the private part.
5289 Def
: constant Node_Id
:= Get_Attribute_Definition_Clause
5290 (Underlying_Type
(First_Subtype
(Typ
)),
5291 Attribute_External_Tag
);
5293 Old_Val
: String_Id
;
5294 New_Val
: String_Id
;
5298 if not Present
(Def
)
5299 or else Entity
(Name
(Def
)) /= First_Subtype
(Typ
)
5302 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5303 Make_Attribute_Reference
(Loc
,
5304 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5305 Attribute_Name
=> Name_Address
));
5307 Old_Val
:= Strval
(Expr_Value_S
(Expression
(Def
)));
5309 -- For the rep clause "for <typ>'external_tag use y" generate:
5311 -- <typ>A : constant string := y;
5313 -- <typ>A'Address is used to set the External_Tag component
5316 -- Create a new nul terminated string if it is not already
5318 if String_Length
(Old_Val
) > 0
5320 Get_String_Char
(Old_Val
, String_Length
(Old_Val
)) = 0
5324 Start_String
(Old_Val
);
5325 Store_String_Char
(Get_Char_Code
(ASCII
.NUL
));
5326 New_Val
:= End_String
;
5329 E
:= Make_Defining_Identifier
(Loc
,
5330 New_External_Name
(Chars
(Typ
), 'A'));
5333 Make_Object_Declaration
(Loc
,
5334 Defining_Identifier
=> E
,
5335 Constant_Present
=> True,
5336 Object_Definition
=>
5337 New_Occurrence_Of
(Standard_String
, Loc
),
5339 Make_String_Literal
(Loc
, New_Val
)));
5342 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5343 Make_Attribute_Reference
(Loc
,
5344 Prefix
=> New_Occurrence_Of
(E
, Loc
),
5345 Attribute_Name
=> Name_Address
));
5350 Append_To
(TSD_Aggr_List
, New_Node
);
5354 if RTE_Available
(RE_Register_Tag
) then
5355 Append_To
(TSD_Aggr_List
,
5356 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
5357 Make_Attribute_Reference
(Loc
,
5358 Prefix
=> New_Occurrence_Of
(HT_Link
, Loc
),
5359 Attribute_Name
=> Name_Address
)));
5361 elsif RTE_Record_Component_Available
(RE_HT_Link
) then
5362 Append_To
(TSD_Aggr_List
,
5363 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
5364 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5367 -- Transportable: Set for types that can be used in remote calls
5368 -- with respect to E.4(18) legality rules.
5371 Transportable
: Entity_Id
;
5377 or else Is_Shared_Passive
(Typ
)
5379 ((Is_Remote_Types
(Typ
)
5380 or else Is_Remote_Call_Interface
(Typ
))
5381 and then Original_View_In_Visible_Part
(Typ
))
5382 or else not Comes_From_Source
(Typ
));
5384 Append_To
(TSD_Aggr_List
,
5385 New_Occurrence_Of
(Transportable
, Loc
));
5388 -- Is_Abstract (Ada 2012: AI05-0173). This functionality is not
5389 -- available in the HIE runtime.
5391 if RTE_Record_Component_Available
(RE_Is_Abstract
) then
5393 Is_Abstract
: Entity_Id
;
5395 Is_Abstract
:= Boolean_Literals
(Is_Abstract_Type
(Typ
));
5396 Append_To
(TSD_Aggr_List
,
5397 New_Occurrence_Of
(Is_Abstract
, Loc
));
5401 -- Needs_Finalization: Set if the type is controlled or has controlled
5405 Needs_Fin
: Entity_Id
;
5407 Needs_Fin
:= Boolean_Literals
(Needs_Finalization
(Typ
));
5408 Append_To
(TSD_Aggr_List
, New_Occurrence_Of
(Needs_Fin
, Loc
));
5413 if RTE_Record_Component_Available
(RE_Size_Func
) then
5415 -- Initialize this field to Null_Address if we are not building
5416 -- static dispatch tables static or if the size function is not
5417 -- available. In the former case we cannot initialize this field
5418 -- until the function is frozen and registered in the dispatch
5419 -- table (see Register_Primitive).
5421 if not Building_Static_DT
(Typ
) or else not Has_DT
(Typ
) then
5422 Append_To
(TSD_Aggr_List
,
5423 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5424 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5428 Prim_Elmt
: Elmt_Id
;
5430 Size_Comp
: Node_Id
:= Empty
;
5433 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5434 while Present
(Prim_Elmt
) loop
5435 Prim
:= Node
(Prim_Elmt
);
5437 if Chars
(Prim
) = Name_uSize
then
5438 Prim
:= Ultimate_Alias
(Prim
);
5440 if Is_Abstract_Subprogram
(Prim
) then
5442 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5443 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
5446 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5447 Make_Attribute_Reference
(Loc
,
5448 Prefix
=> New_Occurrence_Of
(Prim
, Loc
),
5449 Attribute_Name
=> Name_Unrestricted_Access
));
5455 Next_Elmt
(Prim_Elmt
);
5458 pragma Assert
(Present
(Size_Comp
));
5459 Append_To
(TSD_Aggr_List
, Size_Comp
);
5464 -- Interfaces_Table (required for AI-405)
5466 if RTE_Record_Component_Available
(RE_Interfaces_Table
) then
5468 -- Count the number of interface types implemented by Typ
5470 Collect_Interfaces
(Typ
, Typ_Ifaces
);
5472 AI
:= First_Elmt
(Typ_Ifaces
);
5473 while Present
(AI
) loop
5474 Num_Ifaces
:= Num_Ifaces
+ 1;
5478 if Num_Ifaces
= 0 then
5479 Iface_Table_Node
:= Make_Null
(Loc
);
5481 -- Generate the Interface_Table object
5485 TSD_Ifaces_List
: constant List_Id
:= New_List
;
5487 Ifaces_List
: Elist_Id
:= No_Elist
;
5488 Ifaces_Comp_List
: Elist_Id
:= No_Elist
;
5489 Ifaces_Tag_List
: Elist_Id
;
5490 Offset_To_Top
: Node_Id
;
5491 Sec_DT_Tag
: Node_Id
;
5494 -- Collect interfaces information if we need to compute the
5495 -- offset to the top using the dummy object.
5497 if Present
(Dummy_Object
) then
5498 Collect_Interfaces_Info
(Typ
,
5499 Ifaces_List
, Ifaces_Comp_List
, Ifaces_Tag_List
);
5502 AI
:= First_Elmt
(Typ_Ifaces
);
5503 while Present
(AI
) loop
5504 if Is_Ancestor
(Node
(AI
), Typ
, Use_Full_View
=> True) then
5505 Sec_DT_Tag
:= New_Occurrence_Of
(DT_Ptr
, Loc
);
5510 (Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
5511 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5513 while Is_Tag
(Node
(Elmt
))
5515 Is_Ancestor
(Node
(AI
), Related_Type
(Node
(Elmt
)),
5516 Use_Full_View
=> True)
5518 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5520 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5522 pragma Assert
(not Has_Thunks
(Node
(Elmt
)));
5524 pragma Assert
(not Has_Thunks
(Node
(Elmt
)));
5528 pragma Assert
(Ekind
(Node
(Elmt
)) = E_Constant
5530 Has_Thunks
(Node
(Next_Elmt
(Next_Elmt
(Elmt
)))));
5534 (Node
(Next_Elmt
(Next_Elmt
(Elmt
))), Loc
);
5537 -- For static dispatch tables compute Offset_To_Top using
5538 -- the dummy object.
5540 if Present
(Dummy_Object
) then
5542 Iface
: constant Node_Id
:= Node
(AI
);
5543 Iface_Comp
: Node_Id
:= Empty
;
5544 Iface_Comp_Elmt
: Elmt_Id
;
5545 Iface_Elmt
: Elmt_Id
;
5548 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
5549 Iface_Comp_Elmt
:= First_Elmt
(Ifaces_Comp_List
);
5551 while Present
(Iface_Elmt
) loop
5552 if Node
(Iface_Elmt
) = Iface
then
5553 Iface_Comp
:= Node
(Iface_Comp_Elmt
);
5557 Next_Elmt
(Iface_Elmt
);
5558 Next_Elmt
(Iface_Comp_Elmt
);
5561 pragma Assert
(Present
(Iface_Comp
));
5565 Make_Attribute_Reference
(Loc
,
5567 Make_Selected_Component
(Loc
,
5569 New_Occurrence_Of
(Dummy_Object
, Loc
),
5571 New_Occurrence_Of
(Iface_Comp
, Loc
)),
5572 Attribute_Name
=> Name_Position
));
5575 Offset_To_Top
:= Make_Integer_Literal
(Loc
, 0);
5578 Append_To
(TSD_Ifaces_List
,
5579 Make_Aggregate
(Loc
,
5580 Expressions
=> New_List
(
5584 Unchecked_Convert_To
(RTE
(RE_Tag
),
5586 (Node
(First_Elmt
(Access_Disp_Table
(Node
(AI
)))),
5589 -- Static_Offset_To_Top
5591 New_Occurrence_Of
(Standard_True
, Loc
),
5593 -- Offset_To_Top_Value
5597 -- Offset_To_Top_Func
5603 Unchecked_Convert_To
(RTE
(RE_Tag
), Sec_DT_Tag
))));
5608 Name_ITable
:= New_External_Name
(Tname
, 'I');
5609 ITable
:= Make_Defining_Identifier
(Loc
, Name_ITable
);
5610 Set_Is_Statically_Allocated
(ITable
,
5611 Is_Library_Level_Tagged_Type
(Typ
));
5613 -- The table of interfaces is constant if we are building a
5614 -- static dispatch table; otherwise is not constant because
5615 -- its slots are filled at run time by the IP routine.
5618 Make_Object_Declaration
(Loc
,
5619 Defining_Identifier
=> ITable
,
5620 Aliased_Present
=> True,
5621 Constant_Present
=> Present
(Dummy_Object
),
5622 Object_Definition
=>
5623 Make_Subtype_Indication
(Loc
,
5625 New_Occurrence_Of
(RTE
(RE_Interface_Data
), Loc
),
5627 Make_Index_Or_Discriminant_Constraint
(Loc
,
5628 Constraints
=> New_List
(
5629 Make_Integer_Literal
(Loc
, Num_Ifaces
)))),
5632 Make_Aggregate
(Loc
,
5633 Expressions
=> New_List
(
5634 Make_Integer_Literal
(Loc
, Num_Ifaces
),
5635 Make_Aggregate
(Loc
, TSD_Ifaces_List
)))));
5638 Make_Attribute_Definition_Clause
(Loc
,
5639 Name
=> New_Occurrence_Of
(ITable
, Loc
),
5640 Chars
=> Name_Alignment
,
5642 Make_Attribute_Reference
(Loc
,
5644 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5645 Attribute_Name
=> Name_Alignment
)));
5648 Make_Attribute_Reference
(Loc
,
5649 Prefix
=> New_Occurrence_Of
(ITable
, Loc
),
5650 Attribute_Name
=> Name_Unchecked_Access
);
5654 Append_To
(TSD_Aggr_List
, Iface_Table_Node
);
5657 -- Generate the Select Specific Data table for synchronized types that
5658 -- implement synchronized interfaces. The size of the table is
5659 -- constrained by the number of non-predefined primitive operations.
5661 if RTE_Record_Component_Available
(RE_SSD
) then
5662 if Ada_Version
>= Ada_2005
5663 and then Has_DT
(Typ
)
5664 and then Is_Concurrent_Record_Type
(Typ
)
5665 and then Has_Interfaces
(Typ
)
5666 and then Nb_Prim
> 0
5667 and then not Is_Abstract_Type
(Typ
)
5668 and then not Is_Controlled
(Typ
)
5669 and then not Restriction_Active
(No_Dispatching_Calls
)
5670 and then not Restriction_Active
(No_Select_Statements
)
5673 Make_Object_Declaration
(Loc
,
5674 Defining_Identifier
=> SSD
,
5675 Aliased_Present
=> True,
5676 Object_Definition
=>
5677 Make_Subtype_Indication
(Loc
,
5678 Subtype_Mark
=> New_Occurrence_Of
(
5679 RTE
(RE_Select_Specific_Data
), Loc
),
5681 Make_Index_Or_Discriminant_Constraint
(Loc
,
5682 Constraints
=> New_List
(
5683 Make_Integer_Literal
(Loc
, Nb_Prim
))))));
5686 Make_Attribute_Definition_Clause
(Loc
,
5687 Name
=> New_Occurrence_Of
(SSD
, Loc
),
5688 Chars
=> Name_Alignment
,
5690 Make_Attribute_Reference
(Loc
,
5692 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5693 Attribute_Name
=> Name_Alignment
)));
5695 -- This table is initialized by Make_Select_Specific_Data_Table,
5696 -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
5698 Append_To
(TSD_Aggr_List
,
5699 Make_Attribute_Reference
(Loc
,
5700 Prefix
=> New_Occurrence_Of
(SSD
, Loc
),
5701 Attribute_Name
=> Name_Unchecked_Access
));
5703 Append_To
(TSD_Aggr_List
, Make_Null
(Loc
));
5707 -- Initialize the table of ancestor tags. In case of interface types
5708 -- this table is not needed.
5710 TSD_Tags_List
:= New_List
;
5712 -- If we are not statically allocating the dispatch table then we must
5713 -- fill position 0 with null because we still have not generated the
5716 if not Building_Static_DT
(Typ
)
5717 or else Is_Interface
(Typ
)
5719 Append_To
(TSD_Tags_List
,
5720 Unchecked_Convert_To
(RTE
(RE_Tag
),
5721 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5723 -- Otherwise we can safely reference the tag
5726 Append_To
(TSD_Tags_List
,
5727 New_Occurrence_Of
(DT_Ptr
, Loc
));
5730 -- Fill the rest of the table with the tags of the ancestors
5733 Current_Typ
: Entity_Id
;
5734 Parent_Typ
: Entity_Id
;
5742 Parent_Typ
:= Etype
(Current_Typ
);
5744 if Is_Private_Type
(Parent_Typ
) then
5745 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
5748 exit when Parent_Typ
= Current_Typ
;
5750 if Is_CPP_Class
(Parent_Typ
) then
5752 -- The tags defined in the C++ side will be inherited when
5753 -- the object is constructed (Exp_Ch3.Build_Init_Procedure)
5755 Append_To
(TSD_Tags_List
,
5756 Unchecked_Convert_To
(RTE
(RE_Tag
),
5757 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5759 Append_To
(TSD_Tags_List
,
5761 (Node
(First_Elmt
(Access_Disp_Table
(Parent_Typ
))),
5766 Current_Typ
:= Parent_Typ
;
5769 pragma Assert
(Pos
= I_Depth
+ 1);
5772 Append_To
(TSD_Aggr_List
,
5773 Make_Aggregate
(Loc
,
5774 Expressions
=> TSD_Tags_List
));
5776 -- Build the TSD object
5779 Make_Object_Declaration
(Loc
,
5780 Defining_Identifier
=> TSD
,
5781 Aliased_Present
=> True,
5782 Constant_Present
=> Building_Static_DT
(Typ
),
5783 Object_Definition
=>
5784 Make_Subtype_Indication
(Loc
,
5785 Subtype_Mark
=> New_Occurrence_Of
(
5786 RTE
(RE_Type_Specific_Data
), Loc
),
5788 Make_Index_Or_Discriminant_Constraint
(Loc
,
5789 Constraints
=> New_List
(
5790 Make_Integer_Literal
(Loc
, I_Depth
)))),
5792 Expression
=> Make_Aggregate
(Loc
,
5793 Expressions
=> TSD_Aggr_List
)));
5795 Set_Is_True_Constant
(TSD
, Building_Static_DT
(Typ
));
5798 Make_Attribute_Definition_Clause
(Loc
,
5799 Name
=> New_Occurrence_Of
(TSD
, Loc
),
5800 Chars
=> Name_Alignment
,
5802 Make_Attribute_Reference
(Loc
,
5804 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5805 Attribute_Name
=> Name_Alignment
)));
5807 -- Initialize or declare the dispatch table object
5809 if not Has_DT
(Typ
) then
5810 DT_Constr_List
:= New_List
;
5811 DT_Aggr_List
:= New_List
;
5816 Make_Attribute_Reference
(Loc
,
5817 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
5818 Attribute_Name
=> Name_Address
);
5820 Append_To
(DT_Constr_List
, New_Node
);
5821 Append_To
(DT_Aggr_List
, New_Copy
(New_Node
));
5822 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
5824 -- In case of locally defined tagged types we have already declared
5825 -- and uninitialized object for the dispatch table, which is now
5826 -- initialized by means of the following assignment:
5828 -- DT := (TSD'Address, 0);
5830 if not Building_Static_DT
(Typ
) then
5832 Make_Assignment_Statement
(Loc
,
5833 Name
=> New_Occurrence_Of
(DT
, Loc
),
5834 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5836 -- In case of library level tagged types we declare and export now
5837 -- the constant object containing the dummy dispatch table. There
5838 -- is no need to declare the tag here because it has been previously
5839 -- declared by Make_Tags
5841 -- DT : aliased constant No_Dispatch_Table :=
5842 -- (NDT_TSD => TSD'Address;
5843 -- NDT_Prims_Ptr => 0);
5844 -- for DT'Alignment use Address'Alignment;
5848 Make_Object_Declaration
(Loc
,
5849 Defining_Identifier
=> DT
,
5850 Aliased_Present
=> True,
5851 Constant_Present
=> True,
5852 Object_Definition
=>
5853 New_Occurrence_Of
(RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
),
5854 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5857 Make_Attribute_Definition_Clause
(Loc
,
5858 Name
=> New_Occurrence_Of
(DT
, Loc
),
5859 Chars
=> Name_Alignment
,
5861 Make_Attribute_Reference
(Loc
,
5863 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5864 Attribute_Name
=> Name_Alignment
)));
5866 Export_DT
(Typ
, DT
);
5869 -- Common case: Typ has a dispatch table
5873 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
5874 -- (predef-prim-op-1'address,
5875 -- predef-prim-op-2'address,
5877 -- predef-prim-op-n'address);
5878 -- for Predef_Prims'Alignment use Address'Alignment
5880 -- DT : Dispatch_Table (Nb_Prims) :=
5881 -- (Signature => <sig-value>,
5882 -- Tag_Kind => <tag_kind-value>,
5883 -- Predef_Prims => Predef_Prims'First'Address,
5884 -- Offset_To_Top => 0,
5885 -- TSD => TSD'Address;
5886 -- Prims_Ptr => (prim-op-1'address,
5887 -- prim-op-2'address,
5889 -- prim-op-n'address));
5890 -- for DT'Alignment use Address'Alignment
5897 if not Building_Static_DT
(Typ
) then
5898 Nb_Predef_Prims
:= Max_Predef_Prims
;
5901 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5902 while Present
(Prim_Elmt
) loop
5903 Prim
:= Node
(Prim_Elmt
);
5905 if Is_Predefined_Dispatching_Operation
(Prim
)
5906 and then not Is_Abstract_Subprogram
(Prim
)
5908 Pos
:= UI_To_Int
(DT_Position
(Prim
));
5910 if Pos
> Nb_Predef_Prims
then
5911 Nb_Predef_Prims
:= Pos
;
5915 Next_Elmt
(Prim_Elmt
);
5921 (Nat
range 1 .. Nb_Predef_Prims
) of Entity_Id
;
5926 Prim_Ops_Aggr_List
:= New_List
;
5928 Prim_Table
:= (others => Empty
);
5930 if Building_Static_DT
(Typ
) then
5931 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5932 while Present
(Prim_Elmt
) loop
5933 Prim
:= Node
(Prim_Elmt
);
5935 if Is_Predefined_Dispatching_Operation
(Prim
)
5936 and then not Is_Abstract_Subprogram
(Prim
)
5937 and then not Is_Eliminated
(Prim
)
5938 and then not Present
(Prim_Table
5939 (UI_To_Int
(DT_Position
(Prim
))))
5941 E
:= Ultimate_Alias
(Prim
);
5942 pragma Assert
(not Is_Abstract_Subprogram
(E
));
5943 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) := E
;
5946 Next_Elmt
(Prim_Elmt
);
5950 for J
in Prim_Table
'Range loop
5951 if Present
(Prim_Table
(J
)) then
5953 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
5954 Make_Attribute_Reference
(Loc
,
5956 New_Occurrence_Of
(Prim_Table
(J
), Loc
),
5957 Attribute_Name
=> Name_Unrestricted_Access
));
5959 New_Node
:= Make_Null
(Loc
);
5962 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
5966 Make_Aggregate
(Loc
,
5967 Expressions
=> Prim_Ops_Aggr_List
);
5970 Make_Subtype_Declaration
(Loc
,
5971 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
5972 Subtype_Indication
=>
5973 New_Occurrence_Of
(RTE
(RE_Address_Array
), Loc
));
5975 Append_To
(Result
, Decl
);
5978 Make_Object_Declaration
(Loc
,
5979 Defining_Identifier
=> Predef_Prims
,
5980 Aliased_Present
=> True,
5981 Constant_Present
=> Building_Static_DT
(Typ
),
5982 Object_Definition
=>
5983 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
),
5984 Expression
=> New_Node
));
5986 -- Remember aggregates initializing dispatch tables
5988 Append_Elmt
(New_Node
, DT_Aggr
);
5991 Make_Attribute_Definition_Clause
(Loc
,
5992 Name
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
5993 Chars
=> Name_Alignment
,
5995 Make_Attribute_Reference
(Loc
,
5997 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5998 Attribute_Name
=> Name_Alignment
)));
6002 -- Stage 1: Initialize the discriminant and the record components
6004 DT_Constr_List
:= New_List
;
6005 DT_Aggr_List
:= New_List
;
6007 -- Num_Prims. If the tagged type has no primitives we add a dummy
6008 -- slot whose address will be the tag of this type.
6011 New_Node
:= Make_Integer_Literal
(Loc
, 1);
6013 New_Node
:= Make_Integer_Literal
(Loc
, Nb_Prim
);
6016 Append_To
(DT_Constr_List
, New_Node
);
6017 Append_To
(DT_Aggr_List
, New_Copy
(New_Node
));
6021 if RTE_Record_Component_Available
(RE_Signature
) then
6022 Append_To
(DT_Aggr_List
,
6023 New_Occurrence_Of
(RTE
(RE_Primary_DT
), Loc
));
6028 if RTE_Record_Component_Available
(RE_Tag_Kind
) then
6029 Append_To
(DT_Aggr_List
, Tagged_Kind
(Typ
));
6034 Append_To
(DT_Aggr_List
,
6035 Make_Attribute_Reference
(Loc
,
6036 Prefix
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
6037 Attribute_Name
=> Name_Address
));
6041 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
6045 Append_To
(DT_Aggr_List
,
6046 Make_Attribute_Reference
(Loc
,
6047 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6048 Attribute_Name
=> Name_Address
));
6050 -- Stage 2: Initialize the table of user-defined primitive operations
6052 Prim_Ops_Aggr_List
:= New_List
;
6055 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
6057 elsif not Building_Static_DT
(Typ
) then
6058 for J
in 1 .. Nb_Prim
loop
6059 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
6064 CPP_Nb_Prims
: constant Nat
:= CPP_Num_Prims
(Typ
);
6067 Prim_Elmt
: Elmt_Id
;
6069 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
6072 Prim_Table
:= (others => Empty
);
6074 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6075 while Present
(Prim_Elmt
) loop
6076 Prim
:= Node
(Prim_Elmt
);
6078 -- Retrieve the ultimate alias of the primitive for proper
6079 -- handling of renamings and eliminated primitives.
6081 E
:= Ultimate_Alias
(Prim
);
6083 -- If the alias is not a primitive operation then Prim does
6084 -- not rename another primitive, but rather an operation
6085 -- declared elsewhere (e.g. in another scope) and therefore
6086 -- Prim is a new primitive.
6088 if No
(Find_Dispatching_Type
(E
)) then
6092 Prim_Pos
:= UI_To_Int
(DT_Position
(E
));
6094 -- Skip predefined primitives because they are located in a
6095 -- separate dispatch table.
6097 if not Is_Predefined_Dispatching_Operation
(Prim
)
6098 and then not Is_Predefined_Dispatching_Operation
(E
)
6100 -- Skip entities with attribute Interface_Alias because
6101 -- those are only required to build secondary dispatch
6104 and then not Present
(Interface_Alias
(Prim
))
6106 -- Skip abstract and eliminated primitives
6108 and then not Is_Abstract_Subprogram
(E
)
6109 and then not Is_Eliminated
(E
)
6111 -- For derivations of CPP types skip primitives located in
6112 -- the C++ part of the dispatch table because their slots
6113 -- are initialized by the IC routine.
6115 and then (not Is_CPP_Class
(Root_Type
(Typ
))
6116 or else Prim_Pos
> CPP_Nb_Prims
)
6118 -- Skip ignored Ghost subprograms as those will be removed
6119 -- from the executable.
6121 and then not Is_Ignored_Ghost_Entity
(E
)
6124 (UI_To_Int
(DT_Position
(Prim
)) <= Nb_Prim
);
6126 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) := E
;
6129 Next_Elmt
(Prim_Elmt
);
6132 for J
in Prim_Table
'Range loop
6133 if Present
(Prim_Table
(J
)) then
6135 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
6136 Make_Attribute_Reference
(Loc
,
6138 New_Occurrence_Of
(Prim_Table
(J
), Loc
),
6139 Attribute_Name
=> Name_Unrestricted_Access
));
6141 New_Node
:= Make_Null
(Loc
);
6144 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
6150 Make_Aggregate
(Loc
,
6151 Expressions
=> Prim_Ops_Aggr_List
);
6153 Append_To
(DT_Aggr_List
, New_Node
);
6155 -- Remember aggregates initializing dispatch tables
6157 Append_Elmt
(New_Node
, DT_Aggr
);
6159 -- In case of locally defined tagged types we have already declared
6160 -- and uninitialized object for the dispatch table, which is now
6161 -- initialized by means of an assignment.
6163 if not Building_Static_DT
(Typ
) then
6165 Make_Assignment_Statement
(Loc
,
6166 Name
=> New_Occurrence_Of
(DT
, Loc
),
6167 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
6169 -- In case of library level tagged types we declare now and export
6170 -- the constant object containing the dispatch table.
6174 Make_Object_Declaration
(Loc
,
6175 Defining_Identifier
=> DT
,
6176 Aliased_Present
=> True,
6177 Constant_Present
=> True,
6178 Object_Definition
=>
6179 Make_Subtype_Indication
(Loc
,
6180 Subtype_Mark
=> New_Occurrence_Of
6181 (RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
6182 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
6183 Constraints
=> DT_Constr_List
)),
6184 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
6187 Make_Attribute_Definition_Clause
(Loc
,
6188 Name
=> New_Occurrence_Of
(DT
, Loc
),
6189 Chars
=> Name_Alignment
,
6191 Make_Attribute_Reference
(Loc
,
6193 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
6194 Attribute_Name
=> Name_Alignment
)));
6196 Export_DT
(Typ
, DT
);
6200 -- Initialize the table of ancestor tags if not building static
6203 if not Building_Static_DT
(Typ
)
6204 and then not Is_Interface
(Typ
)
6205 and then not Is_CPP_Class
(Typ
)
6208 Make_Assignment_Statement
(Loc
,
6210 Make_Indexed_Component
(Loc
,
6212 Make_Selected_Component
(Loc
,
6213 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6216 (RTE_Record_Component
(RE_Tags_Table
), Loc
)),
6218 New_List
(Make_Integer_Literal
(Loc
, 0))),
6222 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
)));
6225 -- Inherit the dispatch tables of the parent. There is no need to
6226 -- inherit anything from the parent when building static dispatch tables
6227 -- because the whole dispatch table (including inherited primitives) has
6228 -- been already built.
6230 if Building_Static_DT
(Typ
) then
6233 -- If the ancestor is a CPP_Class type we inherit the dispatch tables
6234 -- in the init proc, and we don't need to fill them in here.
6236 elsif Is_CPP_Class
(Parent_Typ
) then
6239 -- Otherwise we fill in the dispatch tables here
6242 if Typ
/= Parent_Typ
6243 and then not Is_Interface
(Typ
)
6244 and then not Restriction_Active
(No_Dispatching_Calls
)
6246 -- Inherit the dispatch table
6248 if not Is_Interface
(Typ
)
6249 and then not Is_Interface
(Parent_Typ
)
6250 and then not Is_CPP_Class
(Parent_Typ
)
6253 Nb_Prims
: constant Int
:=
6254 UI_To_Int
(DT_Entry_Count
6255 (First_Tag_Component
(Parent_Typ
)));
6258 Append_To
(Elab_Code
,
6259 Build_Inherit_Predefined_Prims
(Loc
,
6265 (Access_Disp_Table
(Parent_Typ
)))), Loc
),
6271 (Access_Disp_Table
(Typ
)))), Loc
)));
6273 if Nb_Prims
/= 0 then
6274 Append_To
(Elab_Code
,
6275 Build_Inherit_Prims
(Loc
,
6281 (Access_Disp_Table
(Parent_Typ
))), Loc
),
6282 New_Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
6283 Num_Prims
=> Nb_Prims
));
6288 -- Inherit the secondary dispatch tables of the ancestor
6290 if not Is_CPP_Class
(Parent_Typ
) then
6292 Sec_DT_Ancestor
: Elmt_Id
:=
6298 Sec_DT_Typ
: Elmt_Id
:=
6302 (Access_Disp_Table
(Typ
))));
6304 procedure Copy_Secondary_DTs
(Typ
: Entity_Id
);
6305 -- Local procedure required to climb through the ancestors
6306 -- and copy the contents of all their secondary dispatch
6309 ------------------------
6310 -- Copy_Secondary_DTs --
6311 ------------------------
6313 procedure Copy_Secondary_DTs
(Typ
: Entity_Id
) is
6318 -- Climb to the ancestor (if any) handling private types
6320 if Present
(Full_View
(Etype
(Typ
))) then
6321 if Full_View
(Etype
(Typ
)) /= Typ
then
6322 Copy_Secondary_DTs
(Full_View
(Etype
(Typ
)));
6325 elsif Etype
(Typ
) /= Typ
then
6326 Copy_Secondary_DTs
(Etype
(Typ
));
6329 if Present
(Interfaces
(Typ
))
6330 and then not Is_Empty_Elmt_List
(Interfaces
(Typ
))
6332 Iface
:= First_Elmt
(Interfaces
(Typ
));
6333 E
:= First_Entity
(Typ
);
6335 and then Present
(Node
(Sec_DT_Ancestor
))
6336 and then Ekind
(Node
(Sec_DT_Ancestor
)) = E_Constant
6338 if Is_Tag
(E
) and then Chars
(E
) /= Name_uTag
then
6340 Num_Prims
: constant Int
:=
6341 UI_To_Int
(DT_Entry_Count
(E
));
6344 if not Is_Interface
(Etype
(Typ
)) then
6346 -- Inherit first secondary dispatch table
6348 Append_To
(Elab_Code
,
6349 Build_Inherit_Predefined_Prims
(Loc
,
6351 Unchecked_Convert_To
(RTE
(RE_Tag
),
6354 (Next_Elmt
(Sec_DT_Ancestor
)),
6357 Unchecked_Convert_To
(RTE
(RE_Tag
),
6359 (Node
(Next_Elmt
(Sec_DT_Typ
)),
6362 if Num_Prims
/= 0 then
6363 Append_To
(Elab_Code
,
6364 Build_Inherit_Prims
(Loc
,
6365 Typ
=> Node
(Iface
),
6367 Unchecked_Convert_To
6370 (Node
(Sec_DT_Ancestor
),
6373 Unchecked_Convert_To
6376 (Node
(Sec_DT_Typ
), Loc
)),
6377 Num_Prims
=> Num_Prims
));
6381 Next_Elmt
(Sec_DT_Ancestor
);
6382 Next_Elmt
(Sec_DT_Typ
);
6384 -- Skip the secondary dispatch table of
6385 -- predefined primitives
6387 Next_Elmt
(Sec_DT_Ancestor
);
6388 Next_Elmt
(Sec_DT_Typ
);
6390 if not Is_Interface
(Etype
(Typ
)) then
6392 -- Inherit second secondary dispatch table
6394 Append_To
(Elab_Code
,
6395 Build_Inherit_Predefined_Prims
(Loc
,
6397 Unchecked_Convert_To
(RTE
(RE_Tag
),
6400 (Next_Elmt
(Sec_DT_Ancestor
)),
6403 Unchecked_Convert_To
(RTE
(RE_Tag
),
6405 (Node
(Next_Elmt
(Sec_DT_Typ
)),
6408 if Num_Prims
/= 0 then
6409 Append_To
(Elab_Code
,
6410 Build_Inherit_Prims
(Loc
,
6411 Typ
=> Node
(Iface
),
6413 Unchecked_Convert_To
6416 (Node
(Sec_DT_Ancestor
),
6419 Unchecked_Convert_To
6422 (Node
(Sec_DT_Typ
), Loc
)),
6423 Num_Prims
=> Num_Prims
));
6428 Next_Elmt
(Sec_DT_Ancestor
);
6429 Next_Elmt
(Sec_DT_Typ
);
6431 -- Skip the secondary dispatch table of
6432 -- predefined primitives
6434 Next_Elmt
(Sec_DT_Ancestor
);
6435 Next_Elmt
(Sec_DT_Typ
);
6443 end Copy_Secondary_DTs
;
6446 if Present
(Node
(Sec_DT_Ancestor
))
6447 and then Ekind
(Node
(Sec_DT_Ancestor
)) = E_Constant
6449 -- Handle private types
6451 if Present
(Full_View
(Typ
)) then
6452 Copy_Secondary_DTs
(Full_View
(Typ
));
6454 Copy_Secondary_DTs
(Typ
);
6462 -- Generate code to check if the external tag of this type is the same
6463 -- as the external tag of some other declaration.
6465 -- Check_TSD (TSD'Unrestricted_Access);
6467 -- This check is a consequence of AI05-0113-1/06, so it officially
6468 -- applies to Ada 2005 (and Ada 2012). It might be argued that it is
6469 -- a desirable check to add in Ada 95 mode, but we hesitate to make
6470 -- this change, as it would be incompatible, and could conceivably
6471 -- cause a problem in existing Ada 95 code.
6473 -- We check for No_Run_Time_Mode here, because we do not want to pick
6474 -- up the RE_Check_TSD entity and call it in No_Run_Time mode.
6476 -- We cannot perform this check if the generation of its expanded name
6479 if not No_Run_Time_Mode
6480 and then not Discard_Names
6481 and then Ada_Version
>= Ada_2005
6482 and then RTE_Available
(RE_Check_TSD
)
6483 and then not Duplicated_Tag_Checks_Suppressed
(Typ
)
6485 Append_To
(Elab_Code
,
6486 Make_Procedure_Call_Statement
(Loc
,
6488 New_Occurrence_Of
(RTE
(RE_Check_TSD
), Loc
),
6489 Parameter_Associations
=> New_List
(
6490 Make_Attribute_Reference
(Loc
,
6491 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6492 Attribute_Name
=> Name_Unchecked_Access
))));
6495 -- Generate code to register the Tag in the External_Tag hash table for
6496 -- the pure Ada type only.
6498 -- Register_Tag (Dt_Ptr);
6500 -- Skip this action in the following cases:
6501 -- 1) if Register_Tag is not available.
6502 -- 2) in No_Run_Time mode.
6503 -- 3) if Typ is not defined at the library level (this is required
6504 -- to avoid adding concurrency control to the hash table used
6505 -- by the run-time to register the tags).
6507 if not No_Run_Time_Mode
6508 and then Is_Library_Level_Entity
(Typ
)
6509 and then RTE_Available
(RE_Register_Tag
)
6511 Append_To
(Elab_Code
,
6512 Make_Procedure_Call_Statement
(Loc
,
6514 New_Occurrence_Of
(RTE
(RE_Register_Tag
), Loc
),
6515 Parameter_Associations
=>
6516 New_List
(New_Occurrence_Of
(DT_Ptr
, Loc
))));
6519 if not Is_Empty_List
(Elab_Code
) then
6520 Append_List_To
(Result
, Elab_Code
);
6523 -- Populate the two auxiliary tables used for dispatching asynchronous,
6524 -- conditional and timed selects for synchronized types that implement
6525 -- a limited interface. Skip this step in Ravenscar profile or when
6526 -- general dispatching is forbidden.
6528 if Ada_Version
>= Ada_2005
6529 and then Is_Concurrent_Record_Type
(Typ
)
6530 and then Has_Interfaces
(Typ
)
6531 and then not Restriction_Active
(No_Dispatching_Calls
)
6532 and then not Restriction_Active
(No_Select_Statements
)
6534 Append_List_To
(Result
,
6535 Make_Select_Specific_Data_Table
(Typ
));
6538 -- Remember entities containing dispatch tables
6540 Append_Elmt
(Predef_Prims
, DT_Decl
);
6541 Append_Elmt
(DT
, DT_Decl
);
6543 Analyze_List
(Result
, Suppress
=> All_Checks
);
6544 Set_Has_Dispatch_Table
(Typ
);
6546 -- Mark entities containing dispatch tables. Required by the backend to
6547 -- handle them properly.
6549 if Has_DT
(Typ
) then
6554 -- Object declarations
6556 Elmt
:= First_Elmt
(DT_Decl
);
6557 while Present
(Elmt
) loop
6558 Set_Is_Dispatch_Table_Entity
(Node
(Elmt
));
6559 pragma Assert
(Ekind
(Etype
(Node
(Elmt
))) = E_Array_Subtype
6560 or else Ekind
(Etype
(Node
(Elmt
))) = E_Record_Subtype
);
6561 Set_Is_Dispatch_Table_Entity
(Etype
(Node
(Elmt
)));
6565 -- Aggregates initializing dispatch tables
6567 Elmt
:= First_Elmt
(DT_Aggr
);
6568 while Present
(Elmt
) loop
6569 Set_Is_Dispatch_Table_Entity
(Etype
(Node
(Elmt
)));
6577 -- Register the tagged type in the call graph nodes table
6579 Register_CG_Node
(Typ
);
6582 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
6587 -------------------------------------
6588 -- Make_Select_Specific_Data_Table --
6589 -------------------------------------
6591 function Make_Select_Specific_Data_Table
6592 (Typ
: Entity_Id
) return List_Id
6594 Assignments
: constant List_Id
:= New_List
;
6595 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6597 Conc_Typ
: Entity_Id
;
6598 Decls
: List_Id
:= No_List
;
6600 Prim_Als
: Entity_Id
;
6601 Prim_Elmt
: Elmt_Id
;
6605 type Examined_Array
is array (Int
range <>) of Boolean;
6607 function Find_Entry_Index
(E
: Entity_Id
) return Uint
;
6608 -- Given an entry, find its index in the visible declarations of the
6609 -- corresponding concurrent type of Typ.
6611 ----------------------
6612 -- Find_Entry_Index --
6613 ----------------------
6615 function Find_Entry_Index
(E
: Entity_Id
) return Uint
is
6616 Index
: Uint
:= Uint_1
;
6617 Subp_Decl
: Entity_Id
;
6621 and then not Is_Empty_List
(Decls
)
6623 Subp_Decl
:= First
(Decls
);
6624 while Present
(Subp_Decl
) loop
6625 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
6626 if Defining_Identifier
(Subp_Decl
) = E
then
6638 end Find_Entry_Index
;
6644 -- Start of processing for Make_Select_Specific_Data_Table
6647 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
6649 if Present
(Corresponding_Concurrent_Type
(Typ
)) then
6650 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
6652 if Present
(Full_View
(Conc_Typ
)) then
6653 Conc_Typ
:= Full_View
(Conc_Typ
);
6656 if Ekind
(Conc_Typ
) = E_Protected_Type
then
6657 Decls
:= Visible_Declarations
(Protected_Definition
(
6658 Parent
(Conc_Typ
)));
6660 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
6661 Decls
:= Visible_Declarations
(Task_Definition
(
6662 Parent
(Conc_Typ
)));
6666 -- Count the non-predefined primitive operations
6668 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6669 while Present
(Prim_Elmt
) loop
6670 Prim
:= Node
(Prim_Elmt
);
6672 if not (Is_Predefined_Dispatching_Operation
(Prim
)
6673 or else Is_Predefined_Dispatching_Alias
(Prim
))
6675 Nb_Prim
:= Nb_Prim
+ 1;
6678 Next_Elmt
(Prim_Elmt
);
6682 Examined
: Examined_Array
(1 .. Nb_Prim
) := (others => False);
6685 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6686 while Present
(Prim_Elmt
) loop
6687 Prim
:= Node
(Prim_Elmt
);
6689 -- Look for primitive overriding an abstract interface subprogram
6691 if Present
(Interface_Alias
(Prim
))
6694 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
6695 Use_Full_View
=> True)
6696 and then not Examined
(UI_To_Int
(DT_Position
(Alias
(Prim
))))
6698 Prim_Pos
:= DT_Position
(Alias
(Prim
));
6699 pragma Assert
(UI_To_Int
(Prim_Pos
) <= Nb_Prim
);
6700 Examined
(UI_To_Int
(Prim_Pos
)) := True;
6702 -- Set the primitive operation kind regardless of subprogram
6704 -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
6706 if Tagged_Type_Expansion
then
6709 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
);
6713 Make_Attribute_Reference
(Loc
,
6714 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6715 Attribute_Name
=> Name_Tag
);
6718 Append_To
(Assignments
,
6719 Make_Procedure_Call_Statement
(Loc
,
6720 Name
=> New_Occurrence_Of
(RTE
(RE_Set_Prim_Op_Kind
), Loc
),
6721 Parameter_Associations
=> New_List
(
6723 Make_Integer_Literal
(Loc
, Prim_Pos
),
6724 Prim_Op_Kind
(Alias
(Prim
), Typ
))));
6726 -- Retrieve the root of the alias chain
6728 Prim_Als
:= Ultimate_Alias
(Prim
);
6730 -- In the case of an entry wrapper, set the entry index
6732 if Ekind
(Prim
) = E_Procedure
6733 and then Is_Primitive_Wrapper
(Prim_Als
)
6734 and then Ekind
(Wrapped_Entity
(Prim_Als
)) = E_Entry
6737 -- Ada.Tags.Set_Entry_Index
6738 -- (DT_Ptr, <position>, <index>);
6740 if Tagged_Type_Expansion
then
6743 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
);
6746 Make_Attribute_Reference
(Loc
,
6747 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6748 Attribute_Name
=> Name_Tag
);
6751 Append_To
(Assignments
,
6752 Make_Procedure_Call_Statement
(Loc
,
6754 New_Occurrence_Of
(RTE
(RE_Set_Entry_Index
), Loc
),
6755 Parameter_Associations
=> New_List
(
6757 Make_Integer_Literal
(Loc
, Prim_Pos
),
6758 Make_Integer_Literal
(Loc
,
6759 Find_Entry_Index
(Wrapped_Entity
(Prim_Als
))))));
6763 Next_Elmt
(Prim_Elmt
);
6768 end Make_Select_Specific_Data_Table
;
6774 function Make_Tags
(Typ
: Entity_Id
) return List_Id
is
6775 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6776 Result
: constant List_Id
:= New_List
;
6779 (Tag_Typ
: Entity_Id
;
6781 Is_Secondary_DT
: Boolean);
6782 -- Import the dispatch table DT of tagged type Tag_Typ. Required to
6783 -- generate forward references and statically allocate the table. For
6784 -- primary dispatch tables that require no dispatch table generate:
6786 -- DT : static aliased constant Non_Dispatch_Table_Wrapper;
6787 -- pragma Import (Ada, DT);
6789 -- Otherwise generate:
6791 -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
6792 -- pragma Import (Ada, DT);
6799 (Tag_Typ
: Entity_Id
;
6801 Is_Secondary_DT
: Boolean)
6803 DT_Constr_List
: List_Id
;
6807 Set_Is_Imported
(DT
);
6808 Set_Ekind
(DT
, E_Constant
);
6809 Set_Related_Type
(DT
, Typ
);
6811 -- The scope must be set now to call Get_External_Name
6813 Set_Scope
(DT
, Current_Scope
);
6815 Get_External_Name
(DT
);
6816 Set_Interface_Name
(DT
,
6817 Make_String_Literal
(Loc
, Strval
=> String_From_Name_Buffer
));
6819 -- Ensure proper Sprint output of this implicit importation
6821 Set_Is_Internal
(DT
);
6823 -- Save this entity to allow Make_DT to generate its exportation
6825 Append_Elmt
(DT
, Dispatch_Table_Wrappers
(Typ
));
6827 -- No dispatch table required
6829 if not Is_Secondary_DT
and then not Has_DT
(Tag_Typ
) then
6831 Make_Object_Declaration
(Loc
,
6832 Defining_Identifier
=> DT
,
6833 Aliased_Present
=> True,
6834 Constant_Present
=> True,
6835 Object_Definition
=>
6837 (RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
)));
6840 -- Calculate the number of primitives of the dispatch table and
6841 -- the size of the Type_Specific_Data record.
6844 UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Tag_Typ
)));
6846 -- If the tagged type has no primitives we add a dummy slot whose
6847 -- address will be the tag of this type.
6851 New_List
(Make_Integer_Literal
(Loc
, 1));
6854 New_List
(Make_Integer_Literal
(Loc
, Nb_Prim
));
6858 Make_Object_Declaration
(Loc
,
6859 Defining_Identifier
=> DT
,
6860 Aliased_Present
=> True,
6861 Constant_Present
=> True,
6862 Object_Definition
=>
6863 Make_Subtype_Indication
(Loc
,
6865 New_Occurrence_Of
(RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
6866 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
6867 Constraints
=> DT_Constr_List
))));
6873 Tname
: constant Name_Id
:= Chars
(Typ
);
6874 AI_Tag_Comp
: Elmt_Id
;
6875 DT
: Node_Id
:= Empty
;
6877 Predef_Prims_Ptr
: Node_Id
;
6878 Iface_DT
: Node_Id
:= Empty
;
6879 Iface_DT_Ptr
: Node_Id
;
6883 Typ_Comps
: Elist_Id
;
6885 -- Start of processing for Make_Tags
6888 pragma Assert
(No
(Access_Disp_Table
(Typ
)));
6889 Set_Access_Disp_Table
(Typ
, New_Elmt_List
);
6891 -- If the elaboration of this tagged type needs a boolean flag then
6892 -- define now its entity. It is initialized to True to indicate that
6893 -- elaboration is still pending; set to False by the IP routine.
6895 -- TypFxx : boolean := True;
6897 if Elab_Flag_Needed
(Typ
) then
6898 Set_Access_Disp_Table_Elab_Flag
(Typ
,
6899 Make_Defining_Identifier
(Loc
,
6900 Chars
=> New_External_Name
(Tname
, 'F')));
6903 Make_Object_Declaration
(Loc
,
6904 Defining_Identifier
=> Access_Disp_Table_Elab_Flag
(Typ
),
6905 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
6906 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
6909 -- 1) Generate the primary tag entities
6911 -- Primary dispatch table containing user-defined primitives
6913 DT_Ptr
:= Make_Defining_Identifier
(Loc
, New_External_Name
(Tname
, 'P'));
6914 Set_Etype
(DT_Ptr
, RTE
(RE_Tag
));
6915 Append_Elmt
(DT_Ptr
, Access_Disp_Table
(Typ
));
6917 -- Minimum decoration
6919 Set_Ekind
(DT_Ptr
, E_Variable
);
6920 Set_Related_Type
(DT_Ptr
, Typ
);
6922 -- Notify back end that the types are associated with a dispatch table
6924 Set_Is_Dispatch_Table_Entity
(RTE
(RE_Prim_Ptr
));
6925 Set_Is_Dispatch_Table_Entity
(RTE
(RE_Predef_Prims_Table_Ptr
));
6927 -- For CPP types there is no need to build the dispatch tables since
6928 -- they are imported from the C++ side. If the CPP type has an IP then
6929 -- we declare now the variable that will store the copy of the C++ tag.
6930 -- If the CPP type is an interface, we need the variable as well because
6931 -- it becomes the pointer to the corresponding secondary table.
6933 if Is_CPP_Class
(Typ
) then
6934 if Has_CPP_Constructors
(Typ
) or else Is_Interface
(Typ
) then
6936 Make_Object_Declaration
(Loc
,
6937 Defining_Identifier
=> DT_Ptr
,
6938 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
6940 Unchecked_Convert_To
(RTE
(RE_Tag
),
6941 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
6943 Set_Is_Statically_Allocated
(DT_Ptr
,
6944 Is_Library_Level_Tagged_Type
(Typ
));
6950 -- Primary dispatch table containing predefined primitives
6953 Make_Defining_Identifier
(Loc
,
6954 Chars
=> New_External_Name
(Tname
, 'Y'));
6955 Set_Etype
(Predef_Prims_Ptr
, RTE
(RE_Address
));
6956 Append_Elmt
(Predef_Prims_Ptr
, Access_Disp_Table
(Typ
));
6958 -- Import the forward declaration of the Dispatch Table wrapper
6959 -- record (Make_DT will take care of exporting it).
6961 if Building_Static_DT
(Typ
) then
6962 Set_Dispatch_Table_Wrappers
(Typ
, New_Elmt_List
);
6965 Make_Defining_Identifier
(Loc
,
6966 Chars
=> New_External_Name
(Tname
, 'T'));
6968 Import_DT
(Typ
, DT
, Is_Secondary_DT
=> False);
6970 if Has_DT
(Typ
) then
6972 Make_Object_Declaration
(Loc
,
6973 Defining_Identifier
=> DT_Ptr
,
6974 Constant_Present
=> True,
6975 Object_Definition
=>
6976 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
6978 Unchecked_Convert_To
(RTE
(RE_Tag
),
6979 Make_Attribute_Reference
(Loc
,
6981 Make_Selected_Component
(Loc
,
6982 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
6985 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
6986 Attribute_Name
=> Name_Address
))));
6988 -- Generate the SCIL node for the previous object declaration
6989 -- because it has a tag initialization.
6991 if Generate_SCIL
then
6993 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
6994 Set_SCIL_Entity
(New_Node
, Typ
);
6995 Set_SCIL_Node
(Last
(Result
), New_Node
);
6999 Make_Object_Declaration
(Loc
,
7000 Defining_Identifier
=> Predef_Prims_Ptr
,
7001 Constant_Present
=> True,
7002 Object_Definition
=>
7003 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
7005 Make_Attribute_Reference
(Loc
,
7007 Make_Selected_Component
(Loc
,
7008 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
7011 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
7012 Attribute_Name
=> Name_Address
)));
7014 -- No dispatch table required
7018 Make_Object_Declaration
(Loc
,
7019 Defining_Identifier
=> DT_Ptr
,
7020 Constant_Present
=> True,
7021 Object_Definition
=>
7022 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
7024 Unchecked_Convert_To
(RTE
(RE_Tag
),
7025 Make_Attribute_Reference
(Loc
,
7027 Make_Selected_Component
(Loc
,
7028 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
7031 (RTE_Record_Component
(RE_NDT_Prims_Ptr
),
7033 Attribute_Name
=> Name_Address
))));
7036 Set_Is_True_Constant
(DT_Ptr
);
7037 Set_Is_Statically_Allocated
(DT_Ptr
);
7041 -- 2) Generate the secondary tag entities
7043 -- Collect the components associated with secondary dispatch tables
7045 if Has_Interfaces
(Typ
) then
7046 Collect_Interface_Components
(Typ
, Typ_Comps
);
7048 -- For each interface type we build a unique external name associated
7049 -- with its secondary dispatch table. This name is used to declare an
7050 -- object that references this secondary dispatch table, whose value
7051 -- will be used for the elaboration of Typ objects, and also for the
7052 -- elaboration of objects of types derived from Typ that do not
7053 -- override the primitives of this interface type.
7057 -- Note: The value of Suffix_Index must be in sync with the values of
7058 -- Suffix_Index in secondary dispatch tables generated by Make_DT.
7060 if Is_CPP_Class
(Typ
) then
7061 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
7062 while Present
(AI_Tag_Comp
) loop
7063 Get_Secondary_DT_External_Name
7064 (Typ
, Related_Type
(Node
(AI_Tag_Comp
)), Suffix_Index
);
7065 Typ_Name
:= Name_Find
;
7067 -- Declare variables to store copy of the C++ secondary tags
7070 Make_Defining_Identifier
(Loc
,
7071 Chars
=> New_External_Name
(Typ_Name
, 'P'));
7072 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7073 Set_Ekind
(Iface_DT_Ptr
, E_Variable
);
7074 Set_Is_Tag
(Iface_DT_Ptr
);
7076 Set_Has_Thunks
(Iface_DT_Ptr
);
7078 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7079 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7082 Make_Object_Declaration
(Loc
,
7083 Defining_Identifier
=> Iface_DT_Ptr
,
7084 Object_Definition
=> New_Occurrence_Of
7085 (RTE
(RE_Interface_Tag
), Loc
),
7087 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
7088 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
7090 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7091 Is_Library_Level_Tagged_Type
(Typ
));
7093 Next_Elmt
(AI_Tag_Comp
);
7096 -- This is not a CPP_Class type
7099 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
7100 while Present
(AI_Tag_Comp
) loop
7101 Get_Secondary_DT_External_Name
7102 (Typ
, Related_Type
(Node
(AI_Tag_Comp
)), Suffix_Index
);
7103 Typ_Name
:= Name_Find
;
7105 if Building_Static_DT
(Typ
) then
7107 Make_Defining_Identifier
(Loc
,
7108 Chars
=> New_External_Name
(Typ_Name
, 'T'));
7110 (Tag_Typ
=> Related_Type
(Node
(AI_Tag_Comp
)),
7112 Is_Secondary_DT
=> True);
7115 -- Secondary dispatch table referencing thunks to user-defined
7116 -- primitives covered by this interface.
7119 Make_Defining_Identifier
(Loc
,
7120 Chars
=> New_External_Name
(Typ_Name
, 'P'));
7121 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7122 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
7123 Set_Is_Tag
(Iface_DT_Ptr
);
7124 Set_Has_Thunks
(Iface_DT_Ptr
);
7125 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7126 Is_Library_Level_Tagged_Type
(Typ
));
7127 Set_Is_True_Constant
(Iface_DT_Ptr
);
7129 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7130 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7132 if Building_Static_DT
(Typ
) then
7134 Make_Object_Declaration
(Loc
,
7135 Defining_Identifier
=> Iface_DT_Ptr
,
7136 Constant_Present
=> True,
7137 Object_Definition
=> New_Occurrence_Of
7138 (RTE
(RE_Interface_Tag
), Loc
),
7140 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
7141 Make_Attribute_Reference
(Loc
,
7143 Make_Selected_Component
(Loc
,
7145 New_Occurrence_Of
(Iface_DT
, Loc
),
7148 (RTE_Record_Component
(RE_Prims_Ptr
),
7150 Attribute_Name
=> Name_Address
))));
7153 -- Secondary dispatch table referencing thunks to predefined
7157 Make_Defining_Identifier
(Loc
,
7158 Chars
=> New_External_Name
(Typ_Name
, 'Y'));
7159 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Address
));
7160 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
7161 Set_Is_Tag
(Iface_DT_Ptr
);
7162 Set_Has_Thunks
(Iface_DT_Ptr
);
7163 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7164 Is_Library_Level_Tagged_Type
(Typ
));
7165 Set_Is_True_Constant
(Iface_DT_Ptr
);
7167 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7168 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7170 -- Secondary dispatch table referencing user-defined primitives
7171 -- covered by this interface.
7174 Make_Defining_Identifier
(Loc
,
7175 Chars
=> New_External_Name
(Typ_Name
, 'D'));
7176 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7177 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
7178 Set_Is_Tag
(Iface_DT_Ptr
);
7179 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7180 Is_Library_Level_Tagged_Type
(Typ
));
7181 Set_Is_True_Constant
(Iface_DT_Ptr
);
7183 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7184 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7186 -- Secondary dispatch table referencing predefined primitives
7189 Make_Defining_Identifier
(Loc
,
7190 Chars
=> New_External_Name
(Typ_Name
, 'Z'));
7191 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Address
));
7192 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
7193 Set_Is_Tag
(Iface_DT_Ptr
);
7194 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7195 Is_Library_Level_Tagged_Type
(Typ
));
7196 Set_Is_True_Constant
(Iface_DT_Ptr
);
7198 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7199 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7201 Next_Elmt
(AI_Tag_Comp
);
7206 -- 3) At the end of Access_Disp_Table, if the type has user-defined
7207 -- primitives, we add the entity of an access type declaration that
7208 -- is used by Build_Get_Prim_Op_Address to expand dispatching calls
7209 -- through the primary dispatch table.
7211 if UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Typ
))) = 0 then
7212 Analyze_List
(Result
);
7215 -- subtype Typ_DT is Address_Array (1 .. Nb_Prims);
7216 -- type Typ_DT_Acc is access Typ_DT;
7220 Name_DT_Prims
: constant Name_Id
:=
7221 New_External_Name
(Tname
, 'G');
7222 Name_DT_Prims_Acc
: constant Name_Id
:=
7223 New_External_Name
(Tname
, 'H');
7224 DT_Prims
: constant Entity_Id
:=
7225 Make_Defining_Identifier
(Loc
,
7227 DT_Prims_Acc
: constant Entity_Id
:=
7228 Make_Defining_Identifier
(Loc
,
7232 Make_Subtype_Declaration
(Loc
,
7233 Defining_Identifier
=> DT_Prims
,
7234 Subtype_Indication
=>
7235 Make_Subtype_Indication
(Loc
,
7237 New_Occurrence_Of
(RTE
(RE_Address_Array
), Loc
),
7239 Make_Index_Or_Discriminant_Constraint
(Loc
, New_List
(
7241 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
7243 Make_Integer_Literal
(Loc
,
7245 (First_Tag_Component
(Typ
)))))))));
7248 Make_Full_Type_Declaration
(Loc
,
7249 Defining_Identifier
=> DT_Prims_Acc
,
7251 Make_Access_To_Object_Definition
(Loc
,
7252 Subtype_Indication
=>
7253 New_Occurrence_Of
(DT_Prims
, Loc
))));
7255 Append_Elmt
(DT_Prims_Acc
, Access_Disp_Table
(Typ
));
7257 -- Analyze the resulting list and suppress the generation of the
7258 -- Init_Proc associated with the above array declaration because
7259 -- this type is never used in object declarations. It is only used
7260 -- to simplify the expansion associated with dispatching calls.
7262 Analyze_List
(Result
);
7263 Set_Suppress_Initialization
(Base_Type
(DT_Prims
));
7265 -- Disable backend optimizations based on assumptions about the
7266 -- aliasing status of objects designated by the access to the
7267 -- dispatch table. Required to handle dispatch tables imported
7270 Set_No_Strict_Aliasing
(Base_Type
(DT_Prims_Acc
));
7272 -- Add the freezing nodes of these declarations; required to avoid
7273 -- generating these freezing nodes in wrong scopes (for example in
7274 -- the IC routine of a derivation of Typ).
7276 -- What is an "IC routine"? Is "init_proc" meant here???
7278 Append_List_To
(Result
, Freeze_Entity
(DT_Prims
, Typ
));
7279 Append_List_To
(Result
, Freeze_Entity
(DT_Prims_Acc
, Typ
));
7281 -- Mark entity of dispatch table. Required by the back end to
7282 -- handle them properly.
7284 Set_Is_Dispatch_Table_Entity
(DT_Prims
);
7288 -- Mark entities of dispatch table. Required by the back end to handle
7291 if Present
(DT
) then
7292 Set_Is_Dispatch_Table_Entity
(DT
);
7293 Set_Is_Dispatch_Table_Entity
(Etype
(DT
));
7296 if Present
(Iface_DT
) then
7297 Set_Is_Dispatch_Table_Entity
(Iface_DT
);
7298 Set_Is_Dispatch_Table_Entity
(Etype
(Iface_DT
));
7301 if Is_CPP_Class
(Root_Type
(Typ
)) then
7302 Set_Ekind
(DT_Ptr
, E_Variable
);
7304 Set_Ekind
(DT_Ptr
, E_Constant
);
7307 Set_Is_Tag
(DT_Ptr
);
7308 Set_Related_Type
(DT_Ptr
, Typ
);
7317 function New_Value
(From
: Node_Id
) return Node_Id
is
7318 Res
: constant Node_Id
:= Duplicate_Subexpr
(From
);
7320 if Is_Access_Type
(Etype
(From
)) then
7321 return Make_Explicit_Dereference
(Sloc
(From
), Prefix
=> Res
);
7327 -----------------------------------
7328 -- Original_View_In_Visible_Part --
7329 -----------------------------------
7331 function Original_View_In_Visible_Part
(Typ
: Entity_Id
) return Boolean is
7332 Scop
: constant Entity_Id
:= Scope
(Typ
);
7335 -- The scope must be a package
7337 if not Is_Package_Or_Generic_Package
(Scop
) then
7341 -- A type with a private declaration has a private view declared in
7342 -- the visible part.
7344 if Has_Private_Declaration
(Typ
) then
7348 return List_Containing
(Parent
(Typ
)) =
7349 Visible_Declarations
(Package_Specification
(Scop
));
7350 end Original_View_In_Visible_Part
;
7356 function Prim_Op_Kind
7358 Typ
: Entity_Id
) return Node_Id
7360 Full_Typ
: Entity_Id
:= Typ
;
7361 Loc
: constant Source_Ptr
:= Sloc
(Prim
);
7362 Prim_Op
: Entity_Id
;
7365 -- Retrieve the original primitive operation
7367 Prim_Op
:= Ultimate_Alias
(Prim
);
7369 if Ekind
(Typ
) = E_Record_Type
7370 and then Present
(Corresponding_Concurrent_Type
(Typ
))
7372 Full_Typ
:= Corresponding_Concurrent_Type
(Typ
);
7375 -- When a private tagged type is completed by a concurrent type,
7376 -- retrieve the full view.
7378 if Is_Private_Type
(Full_Typ
) then
7379 Full_Typ
:= Full_View
(Full_Typ
);
7382 if Ekind
(Prim_Op
) = E_Function
then
7384 -- Protected function
7386 if Ekind
(Full_Typ
) = E_Protected_Type
then
7387 return New_Occurrence_Of
(RTE
(RE_POK_Protected_Function
), Loc
);
7391 elsif Ekind
(Full_Typ
) = E_Task_Type
then
7392 return New_Occurrence_Of
(RTE
(RE_POK_Task_Function
), Loc
);
7397 return New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
);
7401 pragma Assert
(Ekind
(Prim_Op
) = E_Procedure
);
7403 if Ekind
(Full_Typ
) = E_Protected_Type
then
7407 if Is_Primitive_Wrapper
(Prim_Op
)
7408 and then Ekind
(Wrapped_Entity
(Prim_Op
)) = E_Entry
7410 return New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
);
7412 -- Protected procedure
7416 New_Occurrence_Of
(RTE
(RE_POK_Protected_Procedure
), Loc
);
7419 elsif Ekind
(Full_Typ
) = E_Task_Type
then
7423 if Is_Primitive_Wrapper
(Prim_Op
)
7424 and then Ekind
(Wrapped_Entity
(Prim_Op
)) = E_Entry
7426 return New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
);
7428 -- Task "procedure". These are the internally Expander-generated
7429 -- procedures (task body for instance).
7432 return New_Occurrence_Of
(RTE
(RE_POK_Task_Procedure
), Loc
);
7435 -- Regular procedure
7438 return New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
);
7443 ------------------------
7444 -- Register_Primitive --
7445 ------------------------
7447 function Register_Primitive
7449 Prim
: Entity_Id
) return List_Id
7452 Iface_Prim
: Entity_Id
;
7453 Iface_Typ
: Entity_Id
;
7454 Iface_DT_Ptr
: Entity_Id
;
7455 Iface_DT_Elmt
: Elmt_Id
;
7456 L
: constant List_Id
:= New_List
;
7459 Tag_Typ
: Entity_Id
;
7460 Thunk_Id
: Entity_Id
;
7461 Thunk_Code
: Node_Id
;
7464 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
7466 -- Do not register in the dispatch table eliminated primitives
7468 if not RTE_Available
(RE_Tag
)
7469 or else Is_Eliminated
(Ultimate_Alias
(Prim
))
7470 or else Generate_SCIL
7475 if not Present
(Interface_Alias
(Prim
)) then
7476 Tag_Typ
:= Scope
(DTC_Entity
(Prim
));
7477 Pos
:= DT_Position
(Prim
);
7478 Tag
:= First_Tag_Component
(Tag_Typ
);
7480 if Is_Predefined_Dispatching_Operation
(Prim
)
7481 or else Is_Predefined_Dispatching_Alias
(Prim
)
7484 Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Tag_Typ
))));
7487 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7488 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7491 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7492 Make_Attribute_Reference
(Loc
,
7493 Prefix
=> New_Occurrence_Of
(Prim
, Loc
),
7494 Attribute_Name
=> Name_Unrestricted_Access
))));
7496 -- Register copy of the pointer to the 'size primitive in the TSD
7498 if Chars
(Prim
) = Name_uSize
7499 and then RTE_Record_Component_Available
(RE_Size_Func
)
7501 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Tag_Typ
)));
7503 Build_Set_Size_Function
(Loc
,
7504 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7505 Size_Func
=> Prim
));
7509 pragma Assert
(Pos
/= Uint_0
and then Pos
<= DT_Entry_Count
(Tag
));
7511 -- Skip registration of primitives located in the C++ part of the
7512 -- dispatch table. Their slot is set by the IC routine.
7514 if not Is_CPP_Class
(Root_Type
(Tag_Typ
))
7515 or else Pos
> CPP_Num_Prims
(Tag_Typ
)
7517 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Tag_Typ
)));
7519 Build_Set_Prim_Op_Address
(Loc
,
7521 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7524 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7525 Make_Attribute_Reference
(Loc
,
7526 Prefix
=> New_Occurrence_Of
(Prim
, Loc
),
7527 Attribute_Name
=> Name_Unrestricted_Access
))));
7531 -- Ada 2005 (AI-251): Primitive associated with an interface type
7533 -- Generate the code of the thunk only if the interface type is not an
7534 -- immediate ancestor of Typ; otherwise the dispatch table associated
7535 -- with the interface is the primary dispatch table and we have nothing
7539 Tag_Typ
:= Find_Dispatching_Type
(Alias
(Prim
));
7540 Iface_Typ
:= Find_Dispatching_Type
(Interface_Alias
(Prim
));
7542 pragma Assert
(Is_Interface
(Iface_Typ
));
7544 -- No action needed for interfaces that are ancestors of Typ because
7545 -- their primitives are located in the primary dispatch table.
7547 if Is_Ancestor
(Iface_Typ
, Tag_Typ
, Use_Full_View
=> True) then
7550 -- No action needed for primitives located in the C++ part of the
7551 -- dispatch table. Their slot is set by the IC routine.
7553 elsif Is_CPP_Class
(Root_Type
(Tag_Typ
))
7554 and then DT_Position
(Alias
(Prim
)) <= CPP_Num_Prims
(Tag_Typ
)
7555 and then not Is_Predefined_Dispatching_Operation
(Prim
)
7556 and then not Is_Predefined_Dispatching_Alias
(Prim
)
7561 Expand_Interface_Thunk
(Prim
, Thunk_Id
, Thunk_Code
);
7563 if not Is_Ancestor
(Iface_Typ
, Tag_Typ
, Use_Full_View
=> True)
7564 and then Present
(Thunk_Code
)
7566 -- Generate the code necessary to fill the appropriate entry of
7567 -- the secondary dispatch table of Prim's controlling type with
7568 -- Thunk_Id's address.
7570 Iface_DT_Elmt
:= Find_Interface_ADT
(Tag_Typ
, Iface_Typ
);
7571 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7572 pragma Assert
(Has_Thunks
(Iface_DT_Ptr
));
7574 Iface_Prim
:= Interface_Alias
(Prim
);
7575 Pos
:= DT_Position
(Iface_Prim
);
7576 Tag
:= First_Tag_Component
(Iface_Typ
);
7578 Prepend_To
(L
, Thunk_Code
);
7580 if Is_Predefined_Dispatching_Operation
(Prim
)
7581 or else Is_Predefined_Dispatching_Alias
(Prim
)
7584 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7586 New_Occurrence_Of
(Node
(Next_Elmt
(Iface_DT_Elmt
)), Loc
),
7589 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7590 Make_Attribute_Reference
(Loc
,
7591 Prefix
=> New_Occurrence_Of
(Thunk_Id
, Loc
),
7592 Attribute_Name
=> Name_Unrestricted_Access
))));
7594 Next_Elmt
(Iface_DT_Elmt
);
7595 Next_Elmt
(Iface_DT_Elmt
);
7596 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7597 pragma Assert
(not Has_Thunks
(Iface_DT_Ptr
));
7600 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7602 New_Occurrence_Of
(Node
(Next_Elmt
(Iface_DT_Elmt
)), Loc
),
7605 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7606 Make_Attribute_Reference
(Loc
,
7608 New_Occurrence_Of
(Alias
(Prim
), Loc
),
7609 Attribute_Name
=> Name_Unrestricted_Access
))));
7612 pragma Assert
(Pos
/= Uint_0
7613 and then Pos
<= DT_Entry_Count
(Tag
));
7616 Build_Set_Prim_Op_Address
(Loc
,
7618 Tag_Node
=> New_Occurrence_Of
(Iface_DT_Ptr
, Loc
),
7621 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7622 Make_Attribute_Reference
(Loc
,
7623 Prefix
=> New_Occurrence_Of
(Thunk_Id
, Loc
),
7624 Attribute_Name
=> Name_Unrestricted_Access
))));
7626 Next_Elmt
(Iface_DT_Elmt
);
7627 Next_Elmt
(Iface_DT_Elmt
);
7628 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7629 pragma Assert
(not Has_Thunks
(Iface_DT_Ptr
));
7632 Build_Set_Prim_Op_Address
(Loc
,
7634 Tag_Node
=> New_Occurrence_Of
(Iface_DT_Ptr
, Loc
),
7637 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7638 Make_Attribute_Reference
(Loc
,
7640 New_Occurrence_Of
(Alias
(Prim
), Loc
),
7641 Attribute_Name
=> Name_Unrestricted_Access
))));
7648 end Register_Primitive
;
7650 -------------------------
7651 -- Set_All_DT_Position --
7652 -------------------------
7654 procedure Set_All_DT_Position
(Typ
: Entity_Id
) is
7656 function In_Predef_Prims_DT
(Prim
: Entity_Id
) return Boolean;
7657 -- Returns True if Prim is located in the dispatch table of
7658 -- predefined primitives
7660 procedure Validate_Position
(Prim
: Entity_Id
);
7661 -- Check that position assigned to Prim is completely safe (it has not
7662 -- been assigned to a previously defined primitive operation of Typ).
7664 ------------------------
7665 -- In_Predef_Prims_DT --
7666 ------------------------
7668 function In_Predef_Prims_DT
(Prim
: Entity_Id
) return Boolean is
7670 -- Predefined primitives
7672 if Is_Predefined_Dispatching_Operation
(Prim
) then
7675 -- Renamings of predefined primitives
7677 elsif Present
(Alias
(Prim
))
7678 and then Is_Predefined_Dispatching_Operation
(Ultimate_Alias
(Prim
))
7680 if Chars
(Ultimate_Alias
(Prim
)) /= Name_Op_Eq
then
7683 -- An overriding operation that is a user-defined renaming of
7684 -- predefined equality inherits its slot from the overridden
7685 -- operation. Otherwise it is treated as a predefined op and
7686 -- occupies the same predefined slot as equality. A call to it is
7687 -- transformed into a call to its alias, which is the predefined
7688 -- equality op. A dispatching call thus uses the proper slot if
7689 -- operation is further inherited and called with class-wide
7694 not Comes_From_Source
(Prim
)
7695 or else No
(Overridden_Operation
(Prim
));
7698 -- User-defined primitives
7703 end In_Predef_Prims_DT
;
7705 -----------------------
7706 -- Validate_Position --
7707 -----------------------
7709 procedure Validate_Position
(Prim
: Entity_Id
) is
7714 -- Aliased primitives are safe
7716 if Present
(Alias
(Prim
)) then
7720 Op_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
7721 while Present
(Op_Elmt
) loop
7722 Op
:= Node
(Op_Elmt
);
7724 -- No need to check against itself
7729 -- Primitive operations covering abstract interfaces are
7732 elsif Present
(Interface_Alias
(Op
)) then
7735 -- Predefined dispatching operations are completely safe. They
7736 -- are allocated at fixed positions in a separate table.
7738 elsif Is_Predefined_Dispatching_Operation
(Op
)
7739 or else Is_Predefined_Dispatching_Alias
(Op
)
7743 -- Aliased subprograms are safe
7745 elsif Present
(Alias
(Op
)) then
7748 elsif DT_Position
(Op
) = DT_Position
(Prim
)
7749 and then not Is_Predefined_Dispatching_Operation
(Op
)
7750 and then not Is_Predefined_Dispatching_Operation
(Prim
)
7751 and then not Is_Predefined_Dispatching_Alias
(Op
)
7752 and then not Is_Predefined_Dispatching_Alias
(Prim
)
7754 -- Handle aliased subprograms
7763 if Present
(Overridden_Operation
(Op_1
)) then
7764 Op_1
:= Overridden_Operation
(Op_1
);
7765 elsif Present
(Alias
(Op_1
)) then
7766 Op_1
:= Alias
(Op_1
);
7774 if Present
(Overridden_Operation
(Op_2
)) then
7775 Op_2
:= Overridden_Operation
(Op_2
);
7776 elsif Present
(Alias
(Op_2
)) then
7777 Op_2
:= Alias
(Op_2
);
7783 if Op_1
/= Op_2
then
7784 raise Program_Error
;
7789 Next_Elmt
(Op_Elmt
);
7791 end Validate_Position
;
7795 Parent_Typ
: constant Entity_Id
:= Etype
(Typ
);
7796 First_Prim
: constant Elmt_Id
:= First_Elmt
(Primitive_Operations
(Typ
));
7797 The_Tag
: constant Entity_Id
:= First_Tag_Component
(Typ
);
7799 Adjusted
: Boolean := False;
7800 Finalized
: Boolean := False;
7806 Prim_Elmt
: Elmt_Id
;
7808 -- Start of processing for Set_All_DT_Position
7811 pragma Assert
(Present
(First_Tag_Component
(Typ
)));
7813 -- Set the DT_Position for each primitive operation. Perform some sanity
7814 -- checks to avoid building inconsistent dispatch tables.
7816 -- First stage: Set DTC entity of all the primitive operations. This is
7817 -- required to properly read the DT_Position attribute in latter stages.
7819 Prim_Elmt
:= First_Prim
;
7821 while Present
(Prim_Elmt
) loop
7822 Prim
:= Node
(Prim_Elmt
);
7824 -- Predefined primitives have a separate dispatch table
7826 if not In_Predef_Prims_DT
(Prim
) then
7827 Count_Prim
:= Count_Prim
+ 1;
7830 Set_DTC_Entity_Value
(Typ
, Prim
);
7832 -- Clear any previous value of the DT_Position attribute. In this
7833 -- way we ensure that the final position of all the primitives is
7834 -- established by the following stages of this algorithm.
7836 Set_DT_Position_Value
(Prim
, No_Uint
);
7838 Next_Elmt
(Prim_Elmt
);
7842 Fixed_Prim
: array (Int
range 0 .. Count_Prim
) of Boolean :=
7847 procedure Handle_Inherited_Private_Subprograms
(Typ
: Entity_Id
);
7848 -- Called if Typ is declared in a nested package or a public child
7849 -- package to handle inherited primitives that were inherited by Typ
7850 -- in the visible part, but whose declaration was deferred because
7851 -- the parent operation was private and not visible at that point.
7853 procedure Set_Fixed_Prim
(Pos
: Nat
);
7854 -- Sets to true an element of the Fixed_Prim table to indicate
7855 -- that this entry of the dispatch table of Typ is occupied.
7857 ------------------------------------------
7858 -- Handle_Inherited_Private_Subprograms --
7859 ------------------------------------------
7861 procedure Handle_Inherited_Private_Subprograms
(Typ
: Entity_Id
) is
7864 Op_Elmt_2
: Elmt_Id
;
7865 Prim_Op
: Entity_Id
;
7866 Parent_Subp
: Entity_Id
;
7869 Op_List
:= Primitive_Operations
(Typ
);
7871 Op_Elmt
:= First_Elmt
(Op_List
);
7872 while Present
(Op_Elmt
) loop
7873 Prim_Op
:= Node
(Op_Elmt
);
7875 -- Search primitives that are implicit operations with an
7876 -- internal name whose parent operation has a normal name.
7878 if Present
(Alias
(Prim_Op
))
7879 and then Find_Dispatching_Type
(Alias
(Prim_Op
)) /= Typ
7880 and then not Comes_From_Source
(Prim_Op
)
7881 and then Is_Internal_Name
(Chars
(Prim_Op
))
7882 and then not Is_Internal_Name
(Chars
(Alias
(Prim_Op
)))
7884 Parent_Subp
:= Alias
(Prim_Op
);
7886 -- Check if the type has an explicit overriding for this
7889 Op_Elmt_2
:= Next_Elmt
(Op_Elmt
);
7890 while Present
(Op_Elmt_2
) loop
7891 if Chars
(Node
(Op_Elmt_2
)) = Chars
(Parent_Subp
)
7892 and then Type_Conformant
(Prim_Op
, Node
(Op_Elmt_2
))
7894 Set_DT_Position_Value
(Prim_Op
,
7895 DT_Position
(Parent_Subp
));
7896 Set_DT_Position_Value
(Node
(Op_Elmt_2
),
7897 DT_Position
(Parent_Subp
));
7898 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(Prim_Op
)));
7900 goto Next_Primitive
;
7903 Next_Elmt
(Op_Elmt_2
);
7908 Next_Elmt
(Op_Elmt
);
7910 end Handle_Inherited_Private_Subprograms
;
7912 --------------------
7913 -- Set_Fixed_Prim --
7914 --------------------
7916 procedure Set_Fixed_Prim
(Pos
: Nat
) is
7918 pragma Assert
(Pos
<= Count_Prim
);
7919 Fixed_Prim
(Pos
) := True;
7921 when Constraint_Error
=>
7922 raise Program_Error
;
7926 -- In case of nested packages and public child package it may be
7927 -- necessary a special management on inherited subprograms so that
7928 -- the dispatch table is properly filled.
7930 if Ekind
(Scope
(Scope
(Typ
))) = E_Package
7931 and then Scope
(Scope
(Typ
)) /= Standard_Standard
7932 and then ((Is_Derived_Type
(Typ
) and then not Is_Private_Type
(Typ
))
7934 (Nkind
(Parent
(Typ
)) = N_Private_Extension_Declaration
7935 and then Is_Generic_Type
(Typ
)))
7936 and then In_Open_Scopes
(Scope
(Etype
(Typ
)))
7937 and then Is_Base_Type
(Typ
)
7939 Handle_Inherited_Private_Subprograms
(Typ
);
7942 -- Second stage: Register fixed entries
7945 Prim_Elmt
:= First_Prim
;
7946 while Present
(Prim_Elmt
) loop
7947 Prim
:= Node
(Prim_Elmt
);
7949 -- Predefined primitives have a separate table and all its
7950 -- entries are at predefined fixed positions.
7952 if In_Predef_Prims_DT
(Prim
) then
7953 if Is_Predefined_Dispatching_Operation
(Prim
) then
7954 Set_DT_Position_Value
(Prim
,
7955 Default_Prim_Op_Position
(Prim
));
7957 else pragma Assert
(Present
(Alias
(Prim
)));
7958 Set_DT_Position_Value
(Prim
,
7959 Default_Prim_Op_Position
(Ultimate_Alias
(Prim
)));
7962 -- Overriding primitives of ancestor abstract interfaces
7964 elsif Present
(Interface_Alias
(Prim
))
7965 and then Is_Ancestor
7966 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
7967 Use_Full_View
=> True)
7969 pragma Assert
(DT_Position
(Prim
) = No_Uint
7970 and then Present
(DTC_Entity
(Interface_Alias
(Prim
))));
7972 E
:= Interface_Alias
(Prim
);
7973 Set_DT_Position_Value
(Prim
, DT_Position
(E
));
7976 (DT_Position
(Alias
(Prim
)) = No_Uint
7977 or else DT_Position
(Alias
(Prim
)) = DT_Position
(E
));
7978 Set_DT_Position_Value
(Alias
(Prim
), DT_Position
(E
));
7979 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(Prim
)));
7981 -- Overriding primitives must use the same entry as the overridden
7982 -- primitive. Note that the Alias of the operation is set when the
7983 -- operation is declared by a renaming, in which case it is not
7984 -- overriding. If it renames another primitive it will use the
7985 -- same dispatch table slot, but if it renames an operation in a
7986 -- nested package it's a new primitive and will have its own slot.
7988 elsif not Present
(Interface_Alias
(Prim
))
7989 and then Present
(Alias
(Prim
))
7990 and then Chars
(Prim
) = Chars
(Alias
(Prim
))
7991 and then Nkind
(Unit_Declaration_Node
(Prim
)) /=
7992 N_Subprogram_Renaming_Declaration
7995 Par_Type
: constant Entity_Id
:=
7996 Find_Dispatching_Type
(Alias
(Prim
));
7999 if Present
(Par_Type
)
8000 and then Par_Type
/= Typ
8001 and then Is_Ancestor
(Par_Type
, Typ
, Use_Full_View
=> True)
8002 and then Present
(DTC_Entity
(Alias
(Prim
)))
8005 Set_DT_Position_Value
(Prim
, DT_Position
(E
));
8007 if not Is_Predefined_Dispatching_Alias
(E
) then
8008 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(E
)));
8014 Next_Elmt
(Prim_Elmt
);
8017 -- Third stage: Fix the position of all the new primitives. Entries
8018 -- associated with primitives covering interfaces are handled in a
8021 Prim_Elmt
:= First_Prim
;
8022 while Present
(Prim_Elmt
) loop
8023 Prim
:= Node
(Prim_Elmt
);
8025 -- Skip primitives previously set entries
8027 if DT_Position
(Prim
) /= No_Uint
then
8030 -- Primitives covering interface primitives are handled later
8032 elsif Present
(Interface_Alias
(Prim
)) then
8036 -- Take the next available position in the DT
8039 Nb_Prim
:= Nb_Prim
+ 1;
8040 pragma Assert
(Nb_Prim
<= Count_Prim
);
8041 exit when not Fixed_Prim
(Nb_Prim
);
8044 Set_DT_Position_Value
(Prim
, UI_From_Int
(Nb_Prim
));
8045 Set_Fixed_Prim
(Nb_Prim
);
8048 Next_Elmt
(Prim_Elmt
);
8052 -- Fourth stage: Complete the decoration of primitives covering
8053 -- interfaces (that is, propagate the DT_Position attribute from
8054 -- the aliased primitive)
8056 Prim_Elmt
:= First_Prim
;
8057 while Present
(Prim_Elmt
) loop
8058 Prim
:= Node
(Prim_Elmt
);
8060 if DT_Position
(Prim
) = No_Uint
8061 and then Present
(Interface_Alias
(Prim
))
8063 pragma Assert
(Present
(Alias
(Prim
))
8064 and then Find_Dispatching_Type
(Alias
(Prim
)) = Typ
);
8066 -- Check if this entry will be placed in the primary DT
8069 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
8070 Use_Full_View
=> True)
8072 pragma Assert
(DT_Position
(Alias
(Prim
)) /= No_Uint
);
8073 Set_DT_Position_Value
(Prim
, DT_Position
(Alias
(Prim
)));
8075 -- Otherwise it will be placed in the secondary DT
8079 (DT_Position
(Interface_Alias
(Prim
)) /= No_Uint
);
8080 Set_DT_Position_Value
(Prim
,
8081 DT_Position
(Interface_Alias
(Prim
)));
8085 Next_Elmt
(Prim_Elmt
);
8088 -- Generate listing showing the contents of the dispatch tables. This
8089 -- action is done before some further static checks because in case of
8090 -- critical errors caused by a wrong dispatch table we need to see the
8091 -- contents of such table.
8093 if Debug_Flag_ZZ
then
8097 -- Final stage: Ensure that the table is correct plus some further
8098 -- verifications concerning the primitives.
8100 Prim_Elmt
:= First_Prim
;
8102 while Present
(Prim_Elmt
) loop
8103 Prim
:= Node
(Prim_Elmt
);
8105 -- At this point all the primitives MUST have a position in the
8108 if DT_Position
(Prim
) = No_Uint
then
8109 raise Program_Error
;
8112 -- Calculate real size of the dispatch table
8114 if not In_Predef_Prims_DT
(Prim
)
8115 and then UI_To_Int
(DT_Position
(Prim
)) > DT_Length
8117 DT_Length
:= UI_To_Int
(DT_Position
(Prim
));
8120 -- Ensure that the assigned position to non-predefined dispatching
8121 -- operations in the dispatch table is correct.
8123 if not Is_Predefined_Dispatching_Operation
(Prim
)
8124 and then not Is_Predefined_Dispatching_Alias
(Prim
)
8126 Validate_Position
(Prim
);
8129 if Chars
(Prim
) = Name_Finalize
then
8133 if Chars
(Prim
) = Name_Adjust
then
8137 -- An abstract operation cannot be declared in the private part for a
8138 -- visible abstract type, because it can't be overridden outside this
8139 -- package hierarchy. For explicit declarations this is checked at
8140 -- the point of declaration, but for inherited operations it must be
8141 -- done when building the dispatch table.
8143 -- Ada 2005 (AI-251): Primitives associated with interfaces are
8144 -- excluded from this check because interfaces must be visible in
8145 -- the public and private part (RM 7.3 (7.3/2))
8147 -- We disable this check in Relaxed_RM_Semantics mode, to accommodate
8150 if not Relaxed_RM_Semantics
8151 and then Is_Abstract_Type
(Typ
)
8152 and then Is_Abstract_Subprogram
(Prim
)
8153 and then Present
(Alias
(Prim
))
8154 and then not Is_Interface
8155 (Find_Dispatching_Type
(Ultimate_Alias
(Prim
)))
8156 and then not Present
(Interface_Alias
(Prim
))
8157 and then Is_Derived_Type
(Typ
)
8158 and then In_Private_Part
(Current_Scope
)
8160 List_Containing
(Parent
(Prim
)) =
8161 Private_Declarations
(Package_Specification
(Current_Scope
))
8162 and then Original_View_In_Visible_Part
(Typ
)
8164 -- We exclude Input and Output stream operations because
8165 -- Limited_Controlled inherits useless Input and Output stream
8166 -- operations from Root_Controlled, which can never be overridden.
8168 if not Is_TSS
(Prim
, TSS_Stream_Input
)
8170 not Is_TSS
(Prim
, TSS_Stream_Output
)
8173 ("abstract inherited private operation&" &
8174 " must be overridden (RM 3.9.3(10))",
8175 Parent
(Typ
), Prim
);
8179 Next_Elmt
(Prim_Elmt
);
8184 if Is_Controlled
(Typ
) then
8185 if not Finalized
then
8187 ("controlled type has no explicit Finalize method??", Typ
);
8189 elsif not Adjusted
then
8191 ("controlled type has no explicit Adjust method??", Typ
);
8195 -- Set the final size of the Dispatch Table
8197 Set_DT_Entry_Count
(The_Tag
, UI_From_Int
(DT_Length
));
8199 -- The derived type must have at least as many components as its parent
8200 -- (for root types Etype points to itself and the test cannot fail).
8202 if DT_Entry_Count
(The_Tag
) <
8203 DT_Entry_Count
(First_Tag_Component
(Parent_Typ
))
8205 raise Program_Error
;
8207 end Set_All_DT_Position
;
8209 --------------------------
8210 -- Set_CPP_Constructors --
8211 --------------------------
8213 procedure Set_CPP_Constructors
(Typ
: Entity_Id
) is
8215 function Gen_Parameters_Profile
(E
: Entity_Id
) return List_Id
;
8216 -- Duplicate the parameters profile of the imported C++ constructor
8217 -- adding the "this" pointer to the object as the additional first
8218 -- parameter under the usual form _Init : in out Typ.
8220 ----------------------------
8221 -- Gen_Parameters_Profile --
8222 ----------------------------
8224 function Gen_Parameters_Profile
(E
: Entity_Id
) return List_Id
is
8225 Loc
: constant Source_Ptr
:= Sloc
(E
);
8232 Make_Parameter_Specification
(Loc
,
8233 Defining_Identifier
=>
8234 Make_Defining_Identifier
(Loc
, Name_uInit
),
8236 Out_Present
=> True,
8237 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
8239 if Present
(Parameter_Specifications
(Parent
(E
))) then
8240 P
:= First
(Parameter_Specifications
(Parent
(E
)));
8241 while Present
(P
) loop
8243 Make_Parameter_Specification
(Loc
,
8244 Defining_Identifier
=>
8245 Make_Defining_Identifier
(Loc
,
8246 Chars
=> Chars
(Defining_Identifier
(P
))),
8247 Parameter_Type
=> New_Copy_Tree
(Parameter_Type
(P
)),
8248 Expression
=> New_Copy_Tree
(Expression
(P
))));
8254 end Gen_Parameters_Profile
;
8260 Found
: Boolean := False;
8266 Covers_Default_Constructor
: Entity_Id
:= Empty
;
8268 -- Start of processing for Set_CPP_Constructor
8271 pragma Assert
(Is_CPP_Class
(Typ
));
8273 -- Look for the constructor entities
8275 E
:= Next_Entity
(Typ
);
8276 while Present
(E
) loop
8277 if Ekind
(E
) = E_Function
8278 and then Is_Constructor
(E
)
8282 Parms
:= Gen_Parameters_Profile
(E
);
8283 IP
:= Make_Defining_Identifier
(Loc
, Make_Init_Proc_Name
(Typ
));
8285 -- Case 1: Constructor of untagged type
8287 -- If the C++ class has no virtual methods then the matching Ada
8288 -- type is an untagged record type. In such case there is no need
8289 -- to generate a wrapper of the C++ constructor because the _tag
8290 -- component is not available.
8292 if not Is_Tagged_Type
(Typ
) then
8294 (Make_Subprogram_Declaration
(Loc
,
8296 Make_Procedure_Specification
(Loc
,
8297 Defining_Unit_Name
=> IP
,
8298 Parameter_Specifications
=> Parms
)));
8300 Set_Init_Proc
(Typ
, IP
);
8301 Set_Is_Imported
(IP
);
8302 Set_Is_Constructor
(IP
);
8303 Set_Interface_Name
(IP
, Interface_Name
(E
));
8304 Set_Convention
(IP
, Convention_CPP
);
8306 Set_Has_Completion
(IP
);
8308 -- Case 2: Constructor of a tagged type
8310 -- In this case we generate the IP routine as a wrapper of the
8311 -- C++ constructor because IP must also save a copy of the _tag
8312 -- generated in the C++ side. The copy of the _tag is used by
8313 -- Build_CPP_Init_Procedure to elaborate derivations of C++ types.
8316 -- procedure IP (_init : in out Typ; ...) is
8317 -- procedure ConstructorP (_init : in out Typ; ...);
8318 -- pragma Import (ConstructorP);
8320 -- ConstructorP (_init, ...);
8321 -- if Typ._tag = null then
8322 -- Typ._tag := _init._tag;
8328 Body_Stmts
: constant List_Id
:= New_List
;
8329 Constructor_Id
: Entity_Id
;
8330 Constructor_Decl_Node
: Node_Id
;
8331 Init_Tags_List
: List_Id
;
8334 Constructor_Id
:= Make_Temporary
(Loc
, 'P');
8336 Constructor_Decl_Node
:=
8337 Make_Subprogram_Declaration
(Loc
,
8338 Make_Procedure_Specification
(Loc
,
8339 Defining_Unit_Name
=> Constructor_Id
,
8340 Parameter_Specifications
=> Parms
));
8342 Set_Is_Imported
(Constructor_Id
);
8343 Set_Is_Constructor
(Constructor_Id
);
8344 Set_Interface_Name
(Constructor_Id
, Interface_Name
(E
));
8345 Set_Convention
(Constructor_Id
, Convention_CPP
);
8346 Set_Is_Public
(Constructor_Id
);
8347 Set_Has_Completion
(Constructor_Id
);
8349 -- Build the init procedure as a wrapper of this constructor
8351 Parms
:= Gen_Parameters_Profile
(E
);
8353 -- Invoke the C++ constructor
8356 Actuals
: constant List_Id
:= New_List
;
8360 while Present
(P
) loop
8362 New_Occurrence_Of
(Defining_Identifier
(P
), Loc
));
8366 Append_To
(Body_Stmts
,
8367 Make_Procedure_Call_Statement
(Loc
,
8368 Name
=> New_Occurrence_Of
(Constructor_Id
, Loc
),
8369 Parameter_Associations
=> Actuals
));
8372 -- Initialize copies of C++ primary and secondary tags
8374 Init_Tags_List
:= New_List
;
8381 Tag_Elmt
:= First_Elmt
(Access_Disp_Table
(Typ
));
8382 Tag_Comp
:= First_Tag_Component
(Typ
);
8384 while Present
(Tag_Elmt
)
8385 and then Is_Tag
(Node
(Tag_Elmt
))
8387 -- Skip the following assertion with primary tags
8388 -- because Related_Type is not set on primary tag
8392 (Tag_Comp
= First_Tag_Component
(Typ
)
8393 or else Related_Type
(Node
(Tag_Elmt
))
8394 = Related_Type
(Tag_Comp
));
8396 Append_To
(Init_Tags_List
,
8397 Make_Assignment_Statement
(Loc
,
8399 New_Occurrence_Of
(Node
(Tag_Elmt
), Loc
),
8401 Make_Selected_Component
(Loc
,
8403 Make_Identifier
(Loc
, Name_uInit
),
8405 New_Occurrence_Of
(Tag_Comp
, Loc
))));
8407 Tag_Comp
:= Next_Tag_Component
(Tag_Comp
);
8408 Next_Elmt
(Tag_Elmt
);
8412 Append_To
(Body_Stmts
,
8413 Make_If_Statement
(Loc
,
8418 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))),
8421 Unchecked_Convert_To
(RTE
(RE_Tag
),
8422 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))),
8423 Then_Statements
=> Init_Tags_List
));
8426 Make_Subprogram_Body
(Loc
,
8428 Make_Procedure_Specification
(Loc
,
8429 Defining_Unit_Name
=> IP
,
8430 Parameter_Specifications
=> Parms
),
8431 Declarations
=> New_List
(Constructor_Decl_Node
),
8432 Handled_Statement_Sequence
=>
8433 Make_Handled_Sequence_Of_Statements
(Loc
,
8434 Statements
=> Body_Stmts
,
8435 Exception_Handlers
=> No_List
));
8437 Discard_Node
(IP_Body
);
8438 Set_Init_Proc
(Typ
, IP
);
8442 -- If this constructor has parameters and all its parameters have
8443 -- defaults then it covers the default constructor. The semantic
8444 -- analyzer ensures that only one constructor with defaults covers
8445 -- the default constructor.
8447 if Present
(Parameter_Specifications
(Parent
(E
)))
8448 and then Needs_No_Actuals
(E
)
8450 Covers_Default_Constructor
:= IP
;
8457 -- If there are no constructors, mark the type as abstract since we
8458 -- won't be able to declare objects of that type.
8461 Set_Is_Abstract_Type
(Typ
);
8464 -- Handle constructor that has all its parameters with defaults and
8465 -- hence it covers the default constructor. We generate a wrapper IP
8466 -- which calls the covering constructor.
8468 if Present
(Covers_Default_Constructor
) then
8470 Body_Stmts
: List_Id
;
8473 Loc
:= Sloc
(Covers_Default_Constructor
);
8475 Body_Stmts
:= New_List
(
8476 Make_Procedure_Call_Statement
(Loc
,
8478 New_Occurrence_Of
(Covers_Default_Constructor
, Loc
),
8479 Parameter_Associations
=> New_List
(
8480 Make_Identifier
(Loc
, Name_uInit
))));
8482 IP
:= Make_Defining_Identifier
(Loc
, Make_Init_Proc_Name
(Typ
));
8485 Make_Subprogram_Body
(Loc
,
8487 Make_Procedure_Specification
(Loc
,
8488 Defining_Unit_Name
=> IP
,
8489 Parameter_Specifications
=> New_List
(
8490 Make_Parameter_Specification
(Loc
,
8491 Defining_Identifier
=>
8492 Make_Defining_Identifier
(Loc
, Name_uInit
),
8493 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)))),
8495 Declarations
=> No_List
,
8497 Handled_Statement_Sequence
=>
8498 Make_Handled_Sequence_Of_Statements
(Loc
,
8499 Statements
=> Body_Stmts
,
8500 Exception_Handlers
=> No_List
));
8502 Discard_Node
(IP_Body
);
8503 Set_Init_Proc
(Typ
, IP
);
8507 -- If the CPP type has constructors then it must import also the default
8508 -- C++ constructor. It is required for default initialization of objects
8509 -- of the type. It is also required to elaborate objects of Ada types
8510 -- that are defined as derivations of this CPP type.
8512 if Has_CPP_Constructors
(Typ
)
8513 and then No
(Init_Proc
(Typ
))
8515 Error_Msg_N
("??default constructor must be imported from C++", Typ
);
8517 end Set_CPP_Constructors
;
8519 ---------------------------
8520 -- Set_DT_Position_Value --
8521 ---------------------------
8523 procedure Set_DT_Position_Value
(Prim
: Entity_Id
; Value
: Uint
) is
8525 Set_DT_Position
(Prim
, Value
);
8527 -- Propagate the value to the wrapped subprogram (if one is present)
8529 if Ekind_In
(Prim
, E_Function
, E_Procedure
)
8530 and then Is_Primitive_Wrapper
(Prim
)
8531 and then Present
(Wrapped_Entity
(Prim
))
8532 and then Is_Dispatching_Operation
(Wrapped_Entity
(Prim
))
8534 Set_DT_Position
(Wrapped_Entity
(Prim
), Value
);
8536 end Set_DT_Position_Value
;
8538 --------------------------
8539 -- Set_DTC_Entity_Value --
8540 --------------------------
8542 procedure Set_DTC_Entity_Value
8543 (Tagged_Type
: Entity_Id
;
8547 if Present
(Interface_Alias
(Prim
))
8548 and then Is_Interface
8549 (Find_Dispatching_Type
(Interface_Alias
(Prim
)))
8551 Set_DTC_Entity
(Prim
,
8554 Iface
=> Find_Dispatching_Type
(Interface_Alias
(Prim
))));
8556 Set_DTC_Entity
(Prim
,
8557 First_Tag_Component
(Tagged_Type
));
8560 -- Propagate the value to the wrapped subprogram (if one is present)
8562 if Ekind_In
(Prim
, E_Function
, E_Procedure
)
8563 and then Is_Primitive_Wrapper
(Prim
)
8564 and then Present
(Wrapped_Entity
(Prim
))
8565 and then Is_Dispatching_Operation
(Wrapped_Entity
(Prim
))
8567 Set_DTC_Entity
(Wrapped_Entity
(Prim
), DTC_Entity
(Prim
));
8569 end Set_DTC_Entity_Value
;
8575 function Tagged_Kind
(T
: Entity_Id
) return Node_Id
is
8576 Conc_Typ
: Entity_Id
;
8577 Loc
: constant Source_Ptr
:= Sloc
(T
);
8581 (Is_Tagged_Type
(T
) and then RTE_Available
(RE_Tagged_Kind
));
8585 if Is_Abstract_Type
(T
) then
8586 if Is_Limited_Record
(T
) then
8587 return New_Occurrence_Of
8588 (RTE
(RE_TK_Abstract_Limited_Tagged
), Loc
);
8590 return New_Occurrence_Of
8591 (RTE
(RE_TK_Abstract_Tagged
), Loc
);
8596 elsif Is_Concurrent_Record_Type
(T
) then
8597 Conc_Typ
:= Corresponding_Concurrent_Type
(T
);
8599 if Present
(Full_View
(Conc_Typ
)) then
8600 Conc_Typ
:= Full_View
(Conc_Typ
);
8603 if Ekind
(Conc_Typ
) = E_Protected_Type
then
8604 return New_Occurrence_Of
(RTE
(RE_TK_Protected
), Loc
);
8606 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
8607 return New_Occurrence_Of
(RTE
(RE_TK_Task
), Loc
);
8610 -- Regular tagged kinds
8613 if Is_Limited_Record
(T
) then
8614 return New_Occurrence_Of
(RTE
(RE_TK_Limited_Tagged
), Loc
);
8616 return New_Occurrence_Of
(RTE
(RE_TK_Tagged
), Loc
);
8625 procedure Write_DT
(Typ
: Entity_Id
) is
8630 -- Protect this procedure against wrong usage. Required because it will
8631 -- be used directly from GDB
8633 if not (Typ
<= Last_Node_Id
)
8634 or else not Is_Tagged_Type
(Typ
)
8636 Write_Str
("wrong usage: Write_DT must be used with tagged types");
8641 Write_Int
(Int
(Typ
));
8643 Write_Name
(Chars
(Typ
));
8645 if Is_Interface
(Typ
) then
8646 Write_Str
(" is interface");
8651 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
8652 while Present
(Elmt
) loop
8653 Prim
:= Node
(Elmt
);
8656 -- Indicate if this primitive will be allocated in the primary
8657 -- dispatch table or in a secondary dispatch table associated
8658 -- with an abstract interface type
8660 if Present
(DTC_Entity
(Prim
)) then
8661 if Etype
(DTC_Entity
(Prim
)) = RTE
(RE_Tag
) then
8668 -- Output the node of this primitive operation and its name
8670 Write_Int
(Int
(Prim
));
8673 if Is_Predefined_Dispatching_Operation
(Prim
) then
8674 Write_Str
("(predefined) ");
8677 -- Prefix the name of the primitive with its corresponding tagged
8678 -- type to facilitate seeing inherited primitives.
8680 if Present
(Alias
(Prim
)) then
8682 (Chars
(Find_Dispatching_Type
(Ultimate_Alias
(Prim
))));
8684 Write_Name
(Chars
(Typ
));
8688 Write_Name
(Chars
(Prim
));
8690 -- Indicate if this primitive has an aliased primitive
8692 if Present
(Alias
(Prim
)) then
8693 Write_Str
(" (alias = ");
8694 Write_Int
(Int
(Alias
(Prim
)));
8696 -- If the DTC_Entity attribute is already set we can also output
8697 -- the name of the interface covered by this primitive (if any).
8699 if Ekind_In
(Alias
(Prim
), E_Function
, E_Procedure
)
8700 and then Present
(DTC_Entity
(Alias
(Prim
)))
8701 and then Is_Interface
(Scope
(DTC_Entity
(Alias
(Prim
))))
8703 Write_Str
(" from interface ");
8704 Write_Name
(Chars
(Scope
(DTC_Entity
(Alias
(Prim
)))));
8707 if Present
(Interface_Alias
(Prim
)) then
8708 Write_Str
(", AI_Alias of ");
8710 if Is_Null_Interface_Primitive
(Interface_Alias
(Prim
)) then
8711 Write_Str
("null primitive ");
8715 (Chars
(Find_Dispatching_Type
(Interface_Alias
(Prim
))));
8717 Write_Int
(Int
(Interface_Alias
(Prim
)));
8723 -- Display the final position of this primitive in its associated
8724 -- (primary or secondary) dispatch table.
8726 if Present
(DTC_Entity
(Prim
))
8727 and then DT_Position
(Prim
) /= No_Uint
8729 Write_Str
(" at #");
8730 Write_Int
(UI_To_Int
(DT_Position
(Prim
)));
8733 if Is_Abstract_Subprogram
(Prim
) then
8734 Write_Str
(" is abstract;");
8736 -- Check if this is a null primitive
8738 elsif Comes_From_Source
(Prim
)
8739 and then Ekind
(Prim
) = E_Procedure
8740 and then Null_Present
(Parent
(Prim
))
8742 Write_Str
(" is null;");
8745 if Is_Eliminated
(Ultimate_Alias
(Prim
)) then
8746 Write_Str
(" (eliminated)");
8749 if Is_Imported
(Prim
)
8750 and then Convention
(Prim
) = Convention_CPP
8752 Write_Str
(" (C++)");