1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, 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
393 N_Full_Type_Declaration | 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 elsif TSS_Name
= TSS_Put_Image
then
649 -- In VM targets unconditionally allow obtaining the position associated
650 -- with predefined interface primitives since in these platforms any
651 -- tagged type has these primitives.
653 elsif Ada_Version
>= Ada_2005
or else not Tagged_Type_Expansion
then
654 if Chars
(E
) = Name_uDisp_Asynchronous_Select
then
657 elsif Chars
(E
) = Name_uDisp_Conditional_Select
then
660 elsif Chars
(E
) = Name_uDisp_Get_Prim_Op_Kind
then
663 elsif Chars
(E
) = Name_uDisp_Get_Task_Id
then
666 elsif Chars
(E
) = Name_uDisp_Requeue
then
669 elsif Chars
(E
) = Name_uDisp_Timed_Select
then
675 end Default_Prim_Op_Position
;
677 ----------------------
678 -- Elab_Flag_Needed --
679 ----------------------
681 function Elab_Flag_Needed
(Typ
: Entity_Id
) return Boolean is
683 return Ada_Version
>= Ada_2005
684 and then not Is_Interface
(Typ
)
685 and then Has_Interfaces
(Typ
)
686 and then not Building_Static_DT
(Typ
);
687 end Elab_Flag_Needed
;
689 -----------------------------
690 -- Expand_Dispatching_Call --
691 -----------------------------
693 procedure Expand_Dispatching_Call
(Call_Node
: Node_Id
) is
694 Loc
: constant Source_Ptr
:= Sloc
(Call_Node
);
695 Call_Typ
: constant Entity_Id
:= Etype
(Call_Node
);
697 Ctrl_Arg
: constant Node_Id
:= Controlling_Argument
(Call_Node
);
698 Ctrl_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Ctrl_Arg
));
699 Param_List
: constant List_Id
:= Parameter_Associations
(Call_Node
);
704 New_Call_Name
: Node_Id
;
705 New_Params
: List_Id
:= No_List
;
708 Subp_Ptr_Typ
: Entity_Id
;
709 Subp_Typ
: Entity_Id
;
711 Eq_Prim_Op
: Entity_Id
:= Empty
;
712 Controlling_Tag
: Node_Id
;
714 procedure Build_Class_Wide_Check
;
715 -- If the denoted subprogram has a class-wide precondition, generate a
716 -- check using that precondition before the dispatching call, because
717 -- this is the only class-wide precondition that applies to the call.
719 function New_Value
(From
: Node_Id
) return Node_Id
;
720 -- From is the original Expression. New_Value is equivalent to a call
721 -- to Duplicate_Subexpr with an explicit dereference when From is an
724 ----------------------------
725 -- Build_Class_Wide_Check --
726 ----------------------------
728 procedure Build_Class_Wide_Check
is
729 function Replace_Formals
(N
: Node_Id
) return Traverse_Result
;
730 -- Replace occurrences of the formals of the subprogram by the
731 -- corresponding actuals in the call, given that this check is
732 -- performed outside of the body of the subprogram.
734 -- If the dispatching call appears in the same scope as the
735 -- declaration of the dispatching subprogram (for example in
736 -- the expression of a local expression function), the spec
737 -- has not been analyzed yet, in which case we use the Chars
738 -- field to recognize intended occurrences of the formals.
740 ---------------------
741 -- Replace_Formals --
742 ---------------------
744 function Replace_Formals
(N
: Node_Id
) return Traverse_Result
is
748 if Is_Entity_Name
(N
) then
749 F
:= First_Formal
(Subp
);
750 A
:= First_Actual
(Call_Node
);
752 if Present
(Entity
(N
)) and then Is_Formal
(Entity
(N
)) then
753 while Present
(F
) loop
754 if F
= Entity
(N
) then
755 Rewrite
(N
, New_Copy_Tree
(A
));
757 -- If the formal is class-wide, and thus not a
758 -- controlling argument, preserve its type because
759 -- it may appear in a nested call with a class-wide
762 if Is_Class_Wide_Type
(Etype
(F
)) then
763 Set_Etype
(N
, Etype
(F
));
765 -- Conversely, if this is a controlling argument
766 -- (in a dispatching call in the condition) that is a
767 -- dereference, the source is an access-to-class-wide
768 -- type, so preserve the dispatching nature of the
769 -- call in the rewritten condition.
771 elsif Nkind
(Parent
(N
)) = N_Explicit_Dereference
772 and then Is_Controlling_Actual
(Parent
(N
))
774 Set_Controlling_Argument
(Parent
(Parent
(N
)),
785 -- If the node is not analyzed, recognize occurrences of a
786 -- formal by name, as would be done when resolving the aspect
787 -- expression in the context of the subprogram.
789 elsif not Analyzed
(N
)
790 and then Nkind
(N
) = N_Identifier
791 and then No
(Entity
(N
))
793 while Present
(F
) loop
794 if Chars
(N
) = Chars
(F
) then
795 Rewrite
(N
, New_Copy_Tree
(A
));
808 procedure Update
is new Traverse_Proc
(Replace_Formals
);
812 Str_Loc
: constant String := Build_Location_String
(Loc
);
818 -- Start of processing for Build_Class_Wide_Check
822 -- Locate class-wide precondition, if any
824 if Present
(Contract
(Subp
))
825 and then Present
(Pre_Post_Conditions
(Contract
(Subp
)))
827 Prec
:= Pre_Post_Conditions
(Contract
(Subp
));
829 while Present
(Prec
) loop
830 exit when Pragma_Name
(Prec
) = Name_Precondition
831 and then Class_Present
(Prec
);
832 Prec
:= Next_Pragma
(Prec
);
835 if No
(Prec
) or else Is_Ignored
(Prec
) then
839 -- The expression for the precondition is analyzed within the
840 -- generated pragma. The message text is the last parameter of
841 -- the generated pragma, indicating source of precondition.
845 (Expression
(First
(Pragma_Argument_Associations
(Prec
))));
848 -- Build message indicating the failed precondition and the
849 -- dispatching call that caused it.
851 Msg
:= Expression
(Last
(Pragma_Argument_Associations
(Prec
)));
853 Append
(Global_Name_Buffer
, Strval
(Msg
));
854 Append
(Global_Name_Buffer
, " in dispatching call at ");
855 Append
(Global_Name_Buffer
, Str_Loc
);
856 Msg
:= Make_String_Literal
(Loc
, Name_Buffer
(1 .. Name_Len
));
858 Insert_Action
(Call_Node
,
859 Make_If_Statement
(Loc
,
860 Condition
=> Make_Op_Not
(Loc
, Cond
),
861 Then_Statements
=> New_List
(
862 Make_Procedure_Call_Statement
(Loc
,
864 New_Occurrence_Of
(RTE
(RE_Raise_Assert_Failure
), Loc
),
865 Parameter_Associations
=> New_List
(Msg
)))));
867 end Build_Class_Wide_Check
;
873 function New_Value
(From
: Node_Id
) return Node_Id
is
874 Res
: constant Node_Id
:= Duplicate_Subexpr
(From
);
876 if Is_Access_Type
(Etype
(From
)) then
878 Make_Explicit_Dereference
(Sloc
(From
),
888 SCIL_Node
: Node_Id
:= Empty
;
889 SCIL_Related_Node
: Node_Id
:= Call_Node
;
891 -- Start of processing for Expand_Dispatching_Call
894 if No_Run_Time_Mode
then
895 Error_Msg_CRT
("tagged types", Call_Node
);
899 -- Expand_Dispatching_Call is called directly from the semantics, so we
900 -- only proceed if the expander is active.
902 if not Expander_Active
904 -- And there is no need to expand the call if we are compiling under
905 -- restriction No_Dispatching_Calls; the semantic analyzer has
906 -- previously notified the violation of this restriction.
908 or else Restriction_Active
(No_Dispatching_Calls
)
910 -- No action needed if the dispatching call has been already expanded
912 or else Is_Expanded_Dispatching_Call
(Name
(Call_Node
))
917 -- Set subprogram. If this is an inherited operation that was
918 -- overridden, the body that is being called is its alias.
920 Subp
:= Entity
(Name
(Call_Node
));
922 if Present
(Alias
(Subp
))
923 and then Is_Inherited_Operation
(Subp
)
924 and then No
(DTC_Entity
(Subp
))
926 Subp
:= Alias
(Subp
);
929 Build_Class_Wide_Check
;
931 -- Definition of the class-wide type and the tagged type
933 -- If the controlling argument is itself a tag rather than a tagged
934 -- object, then use the class-wide type associated with the subprogram's
935 -- controlling type. This case can occur when a call to an inherited
936 -- primitive has an actual that originated from a default parameter
937 -- given by a tag-indeterminate call and when there is no other
938 -- controlling argument providing the tag (AI-239 requires dispatching).
939 -- This capability of dispatching directly by tag is also needed by the
940 -- implementation of AI-260 (for the generic dispatching constructors).
942 if Ctrl_Typ
= RTE
(RE_Tag
)
943 or else (RTE_Available
(RE_Interface_Tag
)
944 and then Ctrl_Typ
= RTE
(RE_Interface_Tag
))
946 CW_Typ
:= Class_Wide_Type
(Find_Dispatching_Type
(Subp
));
948 -- Class_Wide_Type is applied to the expressions used to initialize
949 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
950 -- there are cases where the controlling type is resolved to a specific
951 -- type (such as for designated types of arguments such as CW'Access).
953 elsif Is_Access_Type
(Ctrl_Typ
) then
954 CW_Typ
:= Class_Wide_Type
(Designated_Type
(Ctrl_Typ
));
957 CW_Typ
:= Class_Wide_Type
(Ctrl_Typ
);
960 Typ
:= Find_Specific_Type
(CW_Typ
);
962 if not Is_Limited_Type
(Typ
) then
963 Eq_Prim_Op
:= Find_Prim_Op
(Typ
, Name_Op_Eq
);
966 -- Dispatching call to C++ primitive. Create a new parameter list
967 -- with no tag checks.
969 New_Params
:= New_List
;
971 if Is_CPP_Class
(Typ
) then
972 Param
:= First_Actual
(Call_Node
);
973 while Present
(Param
) loop
974 Append_To
(New_Params
, Relocate_Node
(Param
));
978 -- Dispatching call to Ada primitive
980 elsif Present
(Param_List
) then
981 Apply_Tag_Checks
(Call_Node
);
983 Param
:= First_Actual
(Call_Node
);
984 while Present
(Param
) loop
986 -- Cases in which we may have generated run-time checks. Note that
987 -- we strip any qualification from Param before comparing with the
988 -- already-stripped controlling argument.
990 if Unqualify
(Param
) = Ctrl_Arg
or else Subp
= Eq_Prim_Op
then
991 Append_To
(New_Params
,
992 Duplicate_Subexpr_Move_Checks
(Param
));
994 elsif Nkind
(Parent
(Param
)) /= N_Parameter_Association
995 or else not Is_Accessibility_Actual
(Parent
(Param
))
997 Append_To
(New_Params
, Relocate_Node
(Param
));
1000 Next_Actual
(Param
);
1004 -- Generate the appropriate subprogram pointer type
1006 if Etype
(Subp
) = Typ
then
1009 Res_Typ
:= Etype
(Subp
);
1012 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, Call_Node
);
1013 Subp_Ptr_Typ
:= Create_Itype
(E_Access_Subprogram_Type
, Call_Node
);
1014 Set_Etype
(Subp_Typ
, Res_Typ
);
1015 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
1016 Set_Convention
(Subp_Typ
, Convention
(Subp
));
1018 -- Notify gigi that the designated type is a dispatching primitive
1020 Set_Is_Dispatch_Table_Entity
(Subp_Typ
);
1022 -- Create a new list of parameters which is a copy of the old formal
1023 -- list including the creation of a new set of matching entities.
1026 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
1027 New_Formal
: Entity_Id
;
1028 Last_Formal
: Entity_Id
:= Empty
;
1031 if Present
(Old_Formal
) then
1032 New_Formal
:= New_Copy
(Old_Formal
);
1033 Set_First_Entity
(Subp_Typ
, New_Formal
);
1034 Param
:= First_Actual
(Call_Node
);
1037 Set_Scope
(New_Formal
, Subp_Typ
);
1039 -- Change all the controlling argument types to be class-wide
1040 -- to avoid a recursion in dispatching.
1042 if Is_Controlling_Formal
(New_Formal
) then
1043 Set_Etype
(New_Formal
, Etype
(Param
));
1046 -- If the type of the formal is an itype, there was code here
1047 -- introduced in 1998 in revision 1.46, to create a new itype
1048 -- by copy. This seems useless, and in fact leads to semantic
1049 -- errors when the itype is the completion of a type derived
1050 -- from a private type.
1052 Last_Formal
:= New_Formal
;
1053 Next_Formal
(Old_Formal
);
1054 exit when No
(Old_Formal
);
1056 Link_Entities
(New_Formal
, New_Copy
(Old_Formal
));
1057 Next_Entity
(New_Formal
);
1058 Next_Actual
(Param
);
1061 Unlink_Next_Entity
(New_Formal
);
1062 Set_Last_Entity
(Subp_Typ
, Last_Formal
);
1065 -- Now that the explicit formals have been duplicated, any extra
1066 -- formals needed by the subprogram must be duplicated; we know
1067 -- that extra formals are available because they were added when
1068 -- the tagged type was frozen (see Expand_Freeze_Record_Type).
1070 pragma Assert
(Is_Frozen
(Typ
));
1072 -- Warning: The addition of the extra formals cannot be performed
1073 -- here invoking Create_Extra_Formals since we must ensure that all
1074 -- the extra formals of the pointer type and the target subprogram
1075 -- match (and for functions that return a tagged type the profile of
1076 -- the built subprogram type always returns a class-wide type, which
1077 -- may affect the addition of some extra formals).
1079 if Present
(Last_Formal
)
1080 and then Present
(Extra_Formal
(Last_Formal
))
1082 Old_Formal
:= Extra_Formal
(Last_Formal
);
1083 New_Formal
:= New_Copy
(Old_Formal
);
1084 Set_Scope
(New_Formal
, Subp_Typ
);
1086 Set_Extra_Formal
(Last_Formal
, New_Formal
);
1087 Set_Extra_Formals
(Subp_Typ
, New_Formal
);
1089 if Ekind
(Subp
) = E_Function
1090 and then Present
(Extra_Accessibility_Of_Result
(Subp
))
1091 and then Extra_Accessibility_Of_Result
(Subp
) = Old_Formal
1093 Set_Extra_Accessibility_Of_Result
(Subp_Typ
, New_Formal
);
1096 Old_Formal
:= Extra_Formal
(Old_Formal
);
1097 while Present
(Old_Formal
) loop
1098 Set_Extra_Formal
(New_Formal
, New_Copy
(Old_Formal
));
1099 New_Formal
:= Extra_Formal
(New_Formal
);
1100 Set_Scope
(New_Formal
, Subp_Typ
);
1102 if Ekind
(Subp
) = E_Function
1103 and then Present
(Extra_Accessibility_Of_Result
(Subp
))
1104 and then Extra_Accessibility_Of_Result
(Subp
) = Old_Formal
1106 Set_Extra_Accessibility_Of_Result
(Subp_Typ
, New_Formal
);
1109 Old_Formal
:= Extra_Formal
(Old_Formal
);
1114 -- Complete description of pointer type, including size information, as
1115 -- must be done with itypes to prevent order-of-elaboration anomalies
1118 Set_Etype
(Subp_Ptr_Typ
, Subp_Ptr_Typ
);
1119 Set_Directly_Designated_Type
(Subp_Ptr_Typ
, Subp_Typ
);
1120 Set_Convention
(Subp_Ptr_Typ
, Convention
(Subp_Typ
));
1121 Layout_Type
(Subp_Ptr_Typ
);
1123 -- If the controlling argument is a value of type Ada.Tag or an abstract
1124 -- interface class-wide type then use it directly. Otherwise, the tag
1125 -- must be extracted from the controlling object.
1127 if Ctrl_Typ
= RTE
(RE_Tag
)
1128 or else (RTE_Available
(RE_Interface_Tag
)
1129 and then Ctrl_Typ
= RTE
(RE_Interface_Tag
))
1131 Controlling_Tag
:= Duplicate_Subexpr
(Ctrl_Arg
);
1133 -- Extract the tag from an unchecked type conversion. Done to avoid
1134 -- the expansion of additional code just to obtain the value of such
1135 -- tag because the current management of interface type conversions
1136 -- generates in some cases this unchecked type conversion with the
1137 -- tag of the object (see Expand_Interface_Conversion).
1139 elsif Nkind
(Ctrl_Arg
) = N_Unchecked_Type_Conversion
1141 (Etype
(Expression
(Ctrl_Arg
)) = RTE
(RE_Tag
)
1143 (RTE_Available
(RE_Interface_Tag
)
1145 Etype
(Expression
(Ctrl_Arg
)) = RTE
(RE_Interface_Tag
)))
1147 Controlling_Tag
:= Duplicate_Subexpr
(Expression
(Ctrl_Arg
));
1149 -- Ada 2005 (AI-251): Abstract interface class-wide type
1151 elsif Is_Interface
(Ctrl_Typ
)
1152 and then Is_Class_Wide_Type
(Ctrl_Typ
)
1154 Controlling_Tag
:= Duplicate_Subexpr
(Ctrl_Arg
);
1156 elsif Is_Access_Type
(Ctrl_Typ
) then
1158 Make_Selected_Component
(Loc
,
1160 Make_Explicit_Dereference
(Loc
,
1161 Duplicate_Subexpr_Move_Checks
(Ctrl_Arg
)),
1162 Selector_Name
=> New_Occurrence_Of
(DTC_Entity
(Subp
), Loc
));
1166 Make_Selected_Component
(Loc
,
1167 Prefix
=> Duplicate_Subexpr_Move_Checks
(Ctrl_Arg
),
1168 Selector_Name
=> New_Occurrence_Of
(DTC_Entity
(Subp
), Loc
));
1171 -- Handle dispatching calls to predefined primitives
1173 if Is_Predefined_Dispatching_Operation
(Subp
)
1174 or else Is_Predefined_Dispatching_Alias
(Subp
)
1176 Build_Get_Predefined_Prim_Op_Address
(Loc
,
1177 Tag_Node
=> Controlling_Tag
,
1178 Position
=> DT_Position
(Subp
),
1179 New_Node
=> New_Node
);
1181 -- Handle dispatching calls to user-defined primitives
1184 Build_Get_Prim_Op_Address
(Loc
,
1185 Typ
=> Underlying_Type
(Find_Dispatching_Type
(Subp
)),
1186 Tag_Node
=> Controlling_Tag
,
1187 Position
=> DT_Position
(Subp
),
1188 New_Node
=> New_Node
);
1192 Unchecked_Convert_To
(Subp_Ptr_Typ
, New_Node
);
1194 -- Generate the SCIL node for this dispatching call. Done now because
1195 -- attribute SCIL_Controlling_Tag must be set after the new call name
1196 -- is built to reference the nodes that will see the SCIL backend
1197 -- (because Build_Get_Prim_Op_Address generates an unchecked type
1198 -- conversion which relocates the controlling tag node).
1200 if Generate_SCIL
then
1201 SCIL_Node
:= Make_SCIL_Dispatching_Call
(Sloc
(Call_Node
));
1202 Set_SCIL_Entity
(SCIL_Node
, Typ
);
1203 Set_SCIL_Target_Prim
(SCIL_Node
, Subp
);
1205 -- Common case: the controlling tag is the tag of an object
1206 -- (for example, obj.tag)
1208 if Nkind
(Controlling_Tag
) = N_Selected_Component
then
1209 Set_SCIL_Controlling_Tag
(SCIL_Node
, Controlling_Tag
);
1211 -- Handle renaming of selected component
1213 elsif Nkind
(Controlling_Tag
) = N_Identifier
1214 and then Nkind
(Parent
(Entity
(Controlling_Tag
))) =
1215 N_Object_Renaming_Declaration
1216 and then Nkind
(Name
(Parent
(Entity
(Controlling_Tag
)))) =
1217 N_Selected_Component
1219 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1220 Name
(Parent
(Entity
(Controlling_Tag
))));
1222 -- If the controlling tag is an identifier, the SCIL node references
1223 -- the corresponding object or parameter declaration
1225 elsif Nkind
(Controlling_Tag
) = N_Identifier
1226 and then Nkind
(Parent
(Entity
(Controlling_Tag
))) in
1227 N_Object_Declaration | N_Parameter_Specification
1229 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1230 Parent
(Entity
(Controlling_Tag
)));
1232 -- If the controlling tag is a dereference, the SCIL node references
1233 -- the corresponding object or parameter declaration
1235 elsif Nkind
(Controlling_Tag
) = N_Explicit_Dereference
1236 and then Nkind
(Prefix
(Controlling_Tag
)) = N_Identifier
1237 and then Nkind
(Parent
(Entity
(Prefix
(Controlling_Tag
)))) in
1238 N_Object_Declaration | N_Parameter_Specification
1240 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1241 Parent
(Entity
(Prefix
(Controlling_Tag
))));
1243 -- For a direct reference of the tag of the type the SCIL node
1244 -- references the internal object declaration containing the tag
1247 elsif Nkind
(Controlling_Tag
) = N_Attribute_Reference
1248 and then Attribute_Name
(Controlling_Tag
) = Name_Tag
1250 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1254 (Access_Disp_Table
(Entity
(Prefix
(Controlling_Tag
)))))));
1256 -- Interfaces are not supported. For now we leave the SCIL node
1257 -- decorated with the Controlling_Tag. More work needed here???
1259 elsif Is_Interface
(Etype
(Controlling_Tag
)) then
1260 Set_SCIL_Controlling_Tag
(SCIL_Node
, Controlling_Tag
);
1263 pragma Assert
(False);
1268 if Nkind
(Call_Node
) = N_Function_Call
then
1270 Make_Function_Call
(Loc
,
1271 Name
=> New_Call_Name
,
1272 Parameter_Associations
=> New_Params
);
1274 -- If this is a dispatching "=", we must first compare the tags so
1275 -- we generate: x.tag = y.tag and then x = y
1277 if Subp
= Eq_Prim_Op
then
1278 Param
:= First_Actual
(Call_Node
);
1284 Make_Selected_Component
(Loc
,
1285 Prefix
=> New_Value
(Param
),
1287 New_Occurrence_Of
(First_Tag_Component
(Typ
),
1291 Make_Selected_Component
(Loc
,
1293 Unchecked_Convert_To
(Typ
,
1294 New_Value
(Next_Actual
(Param
))),
1297 (First_Tag_Component
(Typ
), Loc
))),
1298 Right_Opnd
=> New_Call
);
1300 SCIL_Related_Node
:= Right_Opnd
(New_Call
);
1305 Make_Procedure_Call_Statement
(Loc
,
1306 Name
=> New_Call_Name
,
1307 Parameter_Associations
=> New_Params
);
1310 -- Register the dispatching call in the call graph nodes table
1312 Register_CG_Node
(Call_Node
);
1314 Rewrite
(Call_Node
, New_Call
);
1316 -- Associate the SCIL node of this dispatching call
1318 if Generate_SCIL
then
1319 Set_SCIL_Node
(SCIL_Related_Node
, SCIL_Node
);
1322 -- Suppress all checks during the analysis of the expanded code to avoid
1323 -- the generation of spurious warnings under ZFP run-time.
1325 Analyze_And_Resolve
(Call_Node
, Call_Typ
, Suppress
=> All_Checks
);
1326 end Expand_Dispatching_Call
;
1328 ---------------------------------
1329 -- Expand_Interface_Conversion --
1330 ---------------------------------
1332 procedure Expand_Interface_Conversion
(N
: Node_Id
) is
1333 function Underlying_Record_Type
(Typ
: Entity_Id
) return Entity_Id
;
1334 -- Return the underlying record type of Typ
1336 ----------------------------
1337 -- Underlying_Record_Type --
1338 ----------------------------
1340 function Underlying_Record_Type
(Typ
: Entity_Id
) return Entity_Id
is
1341 E
: Entity_Id
:= Typ
;
1344 -- Handle access types
1346 if Is_Access_Type
(E
) then
1347 E
:= Directly_Designated_Type
(E
);
1350 -- Handle class-wide types. This conversion can appear explicitly in
1351 -- the source code. Example: I'Class (Obj)
1353 if Is_Class_Wide_Type
(E
) then
1357 -- If the target type is a tagged synchronized type, the dispatch
1358 -- table info is in the corresponding record type.
1360 if Is_Concurrent_Type
(E
) then
1361 E
:= Corresponding_Record_Type
(E
);
1364 -- Handle private types
1366 E
:= Underlying_Type
(E
);
1370 return Base_Type
(E
);
1371 end Underlying_Record_Type
;
1375 Loc
: constant Source_Ptr
:= Sloc
(N
);
1376 Etyp
: constant Entity_Id
:= Etype
(N
);
1377 Operand
: constant Node_Id
:= Expression
(N
);
1378 Operand_Typ
: Entity_Id
:= Etype
(Operand
);
1380 Iface_Typ
: constant Entity_Id
:= Underlying_Record_Type
(Etype
(N
));
1381 Iface_Tag
: Entity_Id
;
1382 Is_Static
: Boolean;
1384 -- Start of processing for Expand_Interface_Conversion
1387 -- Freeze the entity associated with the target interface to have
1388 -- available the attribute Access_Disp_Table.
1390 Freeze_Before
(N
, Iface_Typ
);
1392 -- Ada 2005 (AI-345): Handle synchronized interface type derivations
1394 if Is_Concurrent_Type
(Operand_Typ
) then
1395 Operand_Typ
:= Base_Type
(Corresponding_Record_Type
(Operand_Typ
));
1398 -- No displacement of the pointer to the object needed when the type of
1399 -- the operand is not an interface type and the interface is one of
1400 -- its parent types (since they share the primary dispatch table).
1403 Opnd
: Entity_Id
:= Operand_Typ
;
1406 if Is_Access_Type
(Opnd
) then
1407 Opnd
:= Designated_Type
(Opnd
);
1410 Opnd
:= Underlying_Record_Type
(Opnd
);
1412 if not Is_Interface
(Opnd
)
1413 and then Is_Ancestor
(Iface_Typ
, Opnd
, Use_Full_View
=> True)
1418 -- When the type of the operand and the target interface type match,
1419 -- it is generally safe to skip generating code to displace the
1420 -- pointer to the object to reference the secondary dispatch table
1421 -- associated with the target interface type. The exception to this
1422 -- general rule is when the underlying object of the type conversion
1423 -- is an object built by means of a dispatching constructor (since in
1424 -- such case the expansion of the constructor call is a direct call
1425 -- to an object primitive, i.e. without thunks, and the expansion of
1426 -- the constructor call adds an explicit conversion to the target
1427 -- interface type to force the displacement of the pointer to the
1428 -- object to reference the corresponding secondary dispatch table
1429 -- (cf. Make_DT and Expand_Dispatching_Constructor_Call)).
1431 -- At this stage we cannot identify whether the underlying object is
1432 -- a BIP object and hence we cannot skip generating the code to try
1433 -- displacing the pointer to the object. However, under configurable
1434 -- runtime it is safe to skip generating code to displace the pointer
1435 -- to the object, because generic dispatching constructors are not
1438 if Opnd
= Iface_Typ
and then not RTE_Available
(RE_Displace
) then
1443 -- Evaluate if we can statically displace the pointer to the object
1446 Opnd_Typ
: constant Node_Id
:= Underlying_Record_Type
(Operand_Typ
);
1450 not Is_Interface
(Opnd_Typ
)
1451 and then Interface_Present_In_Ancestor
1454 and then (Etype
(Opnd_Typ
) = Opnd_Typ
1456 Is_Variable_Size_Record
(Etype
(Opnd_Typ
)));
1459 if not Tagged_Type_Expansion
then
1462 -- A static conversion to an interface type that is not class-wide is
1463 -- curious but legal if the interface operation is a null procedure.
1464 -- If the operation is abstract it will be rejected later.
1467 and then Is_Interface
(Etype
(N
))
1468 and then not Is_Class_Wide_Type
(Etype
(N
))
1469 and then Comes_From_Source
(N
)
1471 Rewrite
(N
, Unchecked_Convert_To
(Etype
(N
), N
));
1476 if not Is_Static
then
1478 -- Give error if configurable run-time and Displace not available
1480 if not RTE_Available
(RE_Displace
) then
1481 Error_Msg_CRT
("dynamic interface conversion", N
);
1485 -- Handle conversion of access-to-class-wide interface types. Target
1486 -- can be an access to an object or an access to another class-wide
1487 -- interface (see -1- and -2- in the following example):
1489 -- type Iface1_Ref is access all Iface1'Class;
1490 -- type Iface2_Ref is access all Iface1'Class;
1492 -- Acc1 : Iface1_Ref := new ...
1493 -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1
1494 -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
1496 if Is_Access_Type
(Operand_Typ
) then
1498 Unchecked_Convert_To
(Etype
(N
),
1499 Make_Function_Call
(Loc
,
1500 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
1501 Parameter_Associations
=> New_List
(
1503 Unchecked_Convert_To
(RTE
(RE_Address
),
1504 Relocate_Node
(Expression
(N
))),
1507 (Node
(First_Elmt
(Access_Disp_Table
(Iface_Typ
))),
1515 Make_Function_Call
(Loc
,
1516 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
1517 Parameter_Associations
=> New_List
(
1518 Make_Attribute_Reference
(Loc
,
1519 Prefix
=> Relocate_Node
(Expression
(N
)),
1520 Attribute_Name
=> Name_Address
),
1523 (Node
(First_Elmt
(Access_Disp_Table
(Iface_Typ
))),
1528 -- If target is a class-wide interface, change the type of the data
1529 -- returned by IW_Convert to indicate this is a dispatching call.
1532 New_Itype
: Entity_Id
;
1535 New_Itype
:= Create_Itype
(E_Anonymous_Access_Type
, N
);
1536 Set_Etype
(New_Itype
, New_Itype
);
1537 Set_Directly_Designated_Type
(New_Itype
, Etyp
);
1540 Make_Explicit_Dereference
(Loc
,
1542 Unchecked_Convert_To
(New_Itype
, Relocate_Node
(N
))));
1544 Freeze_Itype
(New_Itype
, N
);
1550 Iface_Tag
:= Find_Interface_Tag
(Operand_Typ
, Iface_Typ
);
1551 pragma Assert
(Present
(Iface_Tag
));
1553 -- Keep separate access types to interfaces because one internal
1554 -- function is used to handle the null value (see following comments)
1556 if not Is_Access_Type
(Etype
(N
)) then
1558 -- Statically displace the pointer to the object to reference the
1559 -- component containing the secondary dispatch table.
1562 Convert_Tag_To_Interface
(Class_Wide_Type
(Iface_Typ
),
1563 Make_Selected_Component
(Loc
,
1564 Prefix
=> Relocate_Node
(Expression
(N
)),
1565 Selector_Name
=> New_Occurrence_Of
(Iface_Tag
, Loc
))));
1568 -- Build internal function to handle the case in which the actual is
1569 -- null. If the actual is null returns null because no displacement
1570 -- is required; otherwise performs a type conversion that will be
1571 -- expanded in the code that returns the value of the displaced
1574 -- function Func (O : Address) return Iface_Typ is
1575 -- type Op_Typ is access all Operand_Typ;
1576 -- Aux : Op_Typ := To_Op_Typ (O);
1578 -- if O = Null_Address then
1581 -- return Iface_Typ!(Aux.Iface_Tag'Address);
1586 Desig_Typ
: Entity_Id
;
1588 New_Typ_Decl
: Node_Id
;
1592 Desig_Typ
:= Etype
(Expression
(N
));
1594 if Is_Access_Type
(Desig_Typ
) then
1596 Available_View
(Directly_Designated_Type
(Desig_Typ
));
1599 if Is_Concurrent_Type
(Desig_Typ
) then
1600 Desig_Typ
:= Base_Type
(Corresponding_Record_Type
(Desig_Typ
));
1604 Make_Full_Type_Declaration
(Loc
,
1605 Defining_Identifier
=> Make_Temporary
(Loc
, 'T'),
1607 Make_Access_To_Object_Definition
(Loc
,
1608 All_Present
=> True,
1609 Null_Exclusion_Present
=> False,
1610 Constant_Present
=> False,
1611 Subtype_Indication
=>
1612 New_Occurrence_Of
(Desig_Typ
, Loc
)));
1615 Make_Simple_Return_Statement
(Loc
,
1616 Unchecked_Convert_To
(Etype
(N
),
1617 Make_Attribute_Reference
(Loc
,
1619 Make_Selected_Component
(Loc
,
1621 Unchecked_Convert_To
1622 (Defining_Identifier
(New_Typ_Decl
),
1623 Make_Identifier
(Loc
, Name_uO
)),
1625 New_Occurrence_Of
(Iface_Tag
, Loc
)),
1626 Attribute_Name
=> Name_Address
))));
1628 -- If the type is null-excluding, no need for the null branch.
1629 -- Otherwise we need to check for it and return null.
1631 if not Can_Never_Be_Null
(Etype
(N
)) then
1633 Make_If_Statement
(Loc
,
1636 Left_Opnd
=> Make_Identifier
(Loc
, Name_uO
),
1637 Right_Opnd
=> New_Occurrence_Of
1638 (RTE
(RE_Null_Address
), Loc
)),
1640 Then_Statements
=> New_List
(
1641 Make_Simple_Return_Statement
(Loc
, Make_Null
(Loc
))),
1642 Else_Statements
=> Stats
));
1645 Fent
:= Make_Temporary
(Loc
, 'F');
1647 Make_Subprogram_Body
(Loc
,
1649 Make_Function_Specification
(Loc
,
1650 Defining_Unit_Name
=> Fent
,
1652 Parameter_Specifications
=> New_List
(
1653 Make_Parameter_Specification
(Loc
,
1654 Defining_Identifier
=>
1655 Make_Defining_Identifier
(Loc
, Name_uO
),
1657 New_Occurrence_Of
(RTE
(RE_Address
), Loc
))),
1659 Result_Definition
=>
1660 New_Occurrence_Of
(Etype
(N
), Loc
)),
1662 Declarations
=> New_List
(New_Typ_Decl
),
1664 Handled_Statement_Sequence
=>
1665 Make_Handled_Sequence_Of_Statements
(Loc
, Stats
));
1667 -- Place function body before the expression containing the
1668 -- conversion. We suppress all checks because the body of the
1669 -- internally generated function already takes care of the case
1670 -- in which the actual is null; therefore there is no need to
1671 -- double check that the pointer is not null when the program
1672 -- executes the alternative that performs the type conversion).
1674 Insert_Action
(N
, Func
, Suppress
=> All_Checks
);
1676 if Is_Access_Type
(Etype
(Expression
(N
))) then
1678 -- Generate: Func (Address!(Expression))
1681 Make_Function_Call
(Loc
,
1682 Name
=> New_Occurrence_Of
(Fent
, Loc
),
1683 Parameter_Associations
=> New_List
(
1684 Unchecked_Convert_To
(RTE
(RE_Address
),
1685 Relocate_Node
(Expression
(N
))))));
1688 -- Generate: Func (Operand_Typ!(Expression)'Address)
1691 Make_Function_Call
(Loc
,
1692 Name
=> New_Occurrence_Of
(Fent
, Loc
),
1693 Parameter_Associations
=> New_List
(
1694 Make_Attribute_Reference
(Loc
,
1695 Prefix
=> Unchecked_Convert_To
(Operand_Typ
,
1696 Relocate_Node
(Expression
(N
))),
1697 Attribute_Name
=> Name_Address
))));
1703 end Expand_Interface_Conversion
;
1705 ------------------------------
1706 -- Expand_Interface_Actuals --
1707 ------------------------------
1709 procedure Expand_Interface_Actuals
(Call_Node
: Node_Id
) is
1711 Actual_Dup
: Node_Id
;
1712 Actual_Typ
: Entity_Id
;
1714 Conversion
: Node_Id
;
1716 Formal_Typ
: Entity_Id
;
1718 Formal_DDT
: Entity_Id
:= Empty
; -- initialize to prevent warning
1719 Actual_DDT
: Entity_Id
:= Empty
; -- initialize to prevent warning
1722 -- This subprogram is called directly from the semantics, so we need a
1723 -- check to see whether expansion is active before proceeding.
1725 if not Expander_Active
then
1729 -- Call using access to subprogram with explicit dereference
1731 if Nkind
(Name
(Call_Node
)) = N_Explicit_Dereference
then
1732 Subp
:= Etype
(Name
(Call_Node
));
1734 -- Call using selected component
1736 elsif Nkind
(Name
(Call_Node
)) = N_Selected_Component
then
1737 Subp
:= Entity
(Selector_Name
(Name
(Call_Node
)));
1739 -- Call using direct name
1742 Subp
:= Entity
(Name
(Call_Node
));
1745 -- Ada 2005 (AI-251): Look for interface type formals to force "this"
1748 Formal
:= First_Formal
(Subp
);
1749 Actual
:= First_Actual
(Call_Node
);
1750 while Present
(Formal
) loop
1751 Formal_Typ
:= Etype
(Formal
);
1753 if Has_Non_Limited_View
(Formal_Typ
) then
1754 Formal_Typ
:= Non_Limited_View
(Formal_Typ
);
1757 if Ekind
(Formal_Typ
) = E_Record_Type_With_Private
then
1758 Formal_Typ
:= Full_View
(Formal_Typ
);
1761 if Is_Access_Type
(Formal_Typ
) then
1762 Formal_DDT
:= Directly_Designated_Type
(Formal_Typ
);
1764 if Has_Non_Limited_View
(Formal_DDT
) then
1765 Formal_DDT
:= Non_Limited_View
(Formal_DDT
);
1769 Actual_Typ
:= Etype
(Actual
);
1771 if Has_Non_Limited_View
(Actual_Typ
) then
1772 Actual_Typ
:= Non_Limited_View
(Actual_Typ
);
1775 if Is_Access_Type
(Actual_Typ
) then
1776 Actual_DDT
:= Directly_Designated_Type
(Actual_Typ
);
1778 if Has_Non_Limited_View
(Actual_DDT
) then
1779 Actual_DDT
:= Non_Limited_View
(Actual_DDT
);
1783 if Is_Interface
(Formal_Typ
)
1784 and then Is_Class_Wide_Type
(Formal_Typ
)
1786 -- No need to displace the pointer if the type of the actual
1787 -- coincides with the type of the formal.
1789 if Actual_Typ
= Formal_Typ
then
1792 -- No need to displace the pointer if the interface type is a
1793 -- parent of the type of the actual because in this case the
1794 -- interface primitives are located in the primary dispatch table.
1796 elsif Is_Ancestor
(Formal_Typ
, Actual_Typ
,
1797 Use_Full_View
=> True)
1801 -- Implicit conversion to the class-wide formal type to force the
1802 -- displacement of the pointer.
1805 -- Normally, expansion of actuals for calls to build-in-place
1806 -- functions happens as part of Expand_Actuals, but in this
1807 -- case the call will be wrapped in a conversion and soon after
1808 -- expanded further to handle the displacement for a class-wide
1809 -- interface conversion, so if this is a BIP call then we need
1810 -- to handle it now.
1812 if Is_Build_In_Place_Function_Call
(Actual
) then
1813 Make_Build_In_Place_Call_In_Anonymous_Context
(Actual
);
1816 Conversion
:= Convert_To
(Formal_Typ
, Relocate_Node
(Actual
));
1817 Rewrite
(Actual
, Conversion
);
1818 Analyze_And_Resolve
(Actual
, Formal_Typ
);
1821 -- Access to class-wide interface type
1823 elsif Is_Access_Type
(Formal_Typ
)
1824 and then Is_Interface
(Formal_DDT
)
1825 and then Is_Class_Wide_Type
(Formal_DDT
)
1826 and then Interface_Present_In_Ancestor
1828 Iface
=> Etype
(Formal_DDT
))
1830 -- Handle attributes 'Access and 'Unchecked_Access
1832 if Nkind
(Actual
) = N_Attribute_Reference
1834 (Attribute_Name
(Actual
) = Name_Access
1835 or else Attribute_Name
(Actual
) = Name_Unchecked_Access
)
1837 -- This case must have been handled by the analysis and
1838 -- expansion of 'Access. The only exception is when types
1839 -- match and no further expansion is required.
1841 pragma Assert
(Base_Type
(Etype
(Prefix
(Actual
)))
1842 = Base_Type
(Formal_DDT
));
1845 -- No need to displace the pointer if the type of the actual
1846 -- coincides with the type of the formal.
1848 elsif Actual_DDT
= Formal_DDT
then
1851 -- No need to displace the pointer if the interface type is
1852 -- a parent of the type of the actual because in this case the
1853 -- interface primitives are located in the primary dispatch table.
1855 elsif Is_Ancestor
(Formal_DDT
, Actual_DDT
,
1856 Use_Full_View
=> True)
1861 Actual_Dup
:= Relocate_Node
(Actual
);
1863 if From_Limited_With
(Actual_Typ
) then
1865 -- If the type of the actual parameter comes from a limited
1866 -- with_clause and the nonlimited view is already available,
1867 -- we replace the anonymous access type by a duplicate
1868 -- declaration whose designated type is the nonlimited view.
1870 if Has_Non_Limited_View
(Actual_DDT
) then
1871 Anon
:= New_Copy
(Actual_Typ
);
1873 if Is_Itype
(Anon
) then
1874 Set_Scope
(Anon
, Current_Scope
);
1877 Set_Directly_Designated_Type
1878 (Anon
, Non_Limited_View
(Actual_DDT
));
1879 Set_Etype
(Actual_Dup
, Anon
);
1883 Conversion
:= Convert_To
(Formal_Typ
, Actual_Dup
);
1884 Rewrite
(Actual
, Conversion
);
1885 Analyze_And_Resolve
(Actual
, Formal_Typ
);
1889 Next_Actual
(Actual
);
1890 Next_Formal
(Formal
);
1892 end Expand_Interface_Actuals
;
1894 ----------------------------
1895 -- Expand_Interface_Thunk --
1896 ----------------------------
1898 procedure Expand_Interface_Thunk
1900 Thunk_Id
: out Entity_Id
;
1901 Thunk_Code
: out Node_Id
;
1904 Loc
: constant Source_Ptr
:= Sloc
(Prim
);
1905 Actuals
: constant List_Id
:= New_List
;
1906 Decl
: constant List_Id
:= New_List
;
1907 Formals
: constant List_Id
:= New_List
;
1908 Target
: constant Entity_Id
:= Ultimate_Alias
(Prim
);
1915 Iface_Formal
: Node_Id
:= Empty
; -- initialize to prevent warning
1916 Is_Predef_Op
: constant Boolean :=
1917 Is_Predefined_Dispatching_Operation
(Prim
)
1918 or else Is_Predefined_Dispatching_Operation
(Target
);
1920 Offset_To_Top
: Node_Id
;
1921 Target_Formal
: Entity_Id
;
1925 Thunk_Code
:= Empty
;
1927 -- No thunk needed if the primitive has been eliminated
1929 if Is_Eliminated
(Target
) then
1932 -- In case of primitives that are functions without formals and a
1933 -- controlling result there is no need to build the thunk.
1935 elsif not Present
(First_Formal
(Target
)) then
1936 pragma Assert
(Ekind
(Target
) = E_Function
1937 and then Has_Controlling_Result
(Target
));
1941 -- Duplicate the formals of the Target primitive. In the thunk, the type
1942 -- of the controlling formal is the covered interface type (instead of
1943 -- the target tagged type). Done to avoid problems with discriminated
1944 -- tagged types because, if the controlling type has discriminants with
1945 -- default values, then the type conversions done inside the body of
1946 -- the thunk (after the displacement of the pointer to the base of the
1947 -- actual object) generate code that modify its contents.
1949 -- Note: This special management is not done for predefined primitives
1950 -- because they don't have available the Interface_Alias attribute (see
1951 -- Sem_Ch3.Add_Internal_Interface_Entities).
1953 if not Is_Predef_Op
then
1954 Iface_Formal
:= First_Formal
(Interface_Alias
(Prim
));
1957 Formal
:= First_Formal
(Target
);
1958 while Present
(Formal
) loop
1959 Ftyp
:= Etype
(Formal
);
1961 -- Use the interface type as the type of the controlling formal (see
1964 if not Is_Controlling_Formal
(Formal
) then
1965 Ftyp
:= Etype
(Formal
);
1966 Expr
:= New_Copy_Tree
(Expression
(Parent
(Formal
)));
1968 -- For predefined primitives the controlling type of the thunk is
1969 -- the interface type passed by the caller (since they don't have
1970 -- available the Interface_Alias attribute; see comment above).
1972 elsif Is_Predef_Op
then
1977 Ftyp
:= Etype
(Iface_Formal
);
1980 -- Sanity check performed to ensure the proper controlling type
1981 -- when the thunk has exactly one controlling parameter and it
1982 -- comes first. In such case the GCC backend reuses the C++
1983 -- thunks machinery which perform a computation equivalent to
1984 -- the code generated by the expander; for other cases the GCC
1985 -- backend translates the expanded code unmodified. However, as
1986 -- a generalization, the check is performed for all controlling
1989 if Is_Access_Type
(Ftyp
) then
1990 pragma Assert
(Base_Type
(Designated_Type
(Ftyp
)) = Iface
);
1993 Ftyp
:= Base_Type
(Ftyp
);
1994 pragma Assert
(Ftyp
= Iface
);
1999 Make_Parameter_Specification
(Loc
,
2000 Defining_Identifier
=>
2001 Make_Defining_Identifier
(Sloc
(Formal
),
2002 Chars
=> Chars
(Formal
)),
2003 In_Present
=> In_Present
(Parent
(Formal
)),
2004 Out_Present
=> Out_Present
(Parent
(Formal
)),
2005 Parameter_Type
=> New_Occurrence_Of
(Ftyp
, Loc
),
2006 Expression
=> Expr
));
2008 if not Is_Predef_Op
then
2009 Next_Formal
(Iface_Formal
);
2012 Next_Formal
(Formal
);
2015 Target_Formal
:= First_Formal
(Target
);
2016 Formal
:= First
(Formals
);
2017 while Present
(Formal
) loop
2019 -- If the parent is a constrained discriminated type, then the
2020 -- primitive operation will have been defined on a first subtype.
2021 -- For proper matching with controlling type, use base type.
2023 if Ekind
(Target_Formal
) = E_In_Parameter
2024 and then Ekind
(Etype
(Target_Formal
)) = E_Anonymous_Access_Type
2027 Base_Type
(Directly_Designated_Type
(Etype
(Target_Formal
)));
2029 Ftyp
:= Base_Type
(Etype
(Target_Formal
));
2032 -- For concurrent types, the relevant information is found in the
2033 -- Corresponding_Record_Type, rather than the type entity itself.
2035 if Is_Concurrent_Type
(Ftyp
) then
2036 Ftyp
:= Corresponding_Record_Type
(Ftyp
);
2039 if Ekind
(Target_Formal
) = E_In_Parameter
2040 and then Ekind
(Etype
(Target_Formal
)) = E_Anonymous_Access_Type
2041 and then Is_Controlling_Formal
(Target_Formal
)
2044 -- type T is access all <<type of the target formal>>
2045 -- S : Storage_Offset := Storage_Offset!(Formal)
2046 -- + Offset_To_Top (address!(Formal))
2049 Make_Full_Type_Declaration
(Loc
,
2050 Defining_Identifier
=> Make_Temporary
(Loc
, 'T'),
2052 Make_Access_To_Object_Definition
(Loc
,
2053 All_Present
=> True,
2054 Null_Exclusion_Present
=> False,
2055 Constant_Present
=> False,
2056 Subtype_Indication
=>
2057 New_Occurrence_Of
(Ftyp
, Loc
)));
2060 Unchecked_Convert_To
(RTE
(RE_Address
),
2061 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
2063 if not RTE_Available
(RE_Offset_To_Top
) then
2065 Build_Offset_To_Top
(Loc
, New_Arg
);
2068 Make_Function_Call
(Loc
,
2069 Name
=> New_Occurrence_Of
(RTE
(RE_Offset_To_Top
), Loc
),
2070 Parameter_Associations
=> New_List
(New_Arg
));
2074 Make_Object_Declaration
(Loc
,
2075 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
2076 Constant_Present
=> True,
2077 Object_Definition
=>
2078 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
2082 Unchecked_Convert_To
2083 (RTE
(RE_Storage_Offset
),
2085 (Defining_Identifier
(Formal
), Loc
)),
2089 Append_To
(Decl
, Decl_2
);
2090 Append_To
(Decl
, Decl_1
);
2092 -- Reference the new actual. Generate:
2096 Unchecked_Convert_To
2097 (Defining_Identifier
(Decl_2
),
2098 New_Occurrence_Of
(Defining_Identifier
(Decl_1
), Loc
)));
2100 elsif Is_Controlling_Formal
(Target_Formal
) then
2103 -- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
2104 -- + Offset_To_Top (Formal'Address)
2105 -- S2 : Addr_Ptr := Addr_Ptr!(S1)
2108 Make_Attribute_Reference
(Loc
,
2110 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
),
2114 if not RTE_Available
(RE_Offset_To_Top
) then
2116 Build_Offset_To_Top
(Loc
, New_Arg
);
2119 Make_Function_Call
(Loc
,
2120 Name
=> New_Occurrence_Of
(RTE
(RE_Offset_To_Top
), Loc
),
2121 Parameter_Associations
=> New_List
(New_Arg
));
2125 Make_Object_Declaration
(Loc
,
2126 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
2127 Constant_Present
=> True,
2128 Object_Definition
=>
2129 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
2133 Unchecked_Convert_To
2134 (RTE
(RE_Storage_Offset
),
2135 Make_Attribute_Reference
(Loc
,
2138 (Defining_Identifier
(Formal
), Loc
),
2139 Attribute_Name
=> Name_Address
)),
2144 Make_Object_Declaration
(Loc
,
2145 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
2146 Constant_Present
=> True,
2147 Object_Definition
=>
2148 New_Occurrence_Of
(RTE
(RE_Addr_Ptr
), Loc
),
2150 Unchecked_Convert_To
2152 New_Occurrence_Of
(Defining_Identifier
(Decl_1
), Loc
)));
2154 Append_To
(Decl
, Decl_1
);
2155 Append_To
(Decl
, Decl_2
);
2157 -- Reference the new actual, generate:
2158 -- Target_Formal (S2.all)
2161 Unchecked_Convert_To
(Ftyp
,
2162 Make_Explicit_Dereference
(Loc
,
2163 New_Occurrence_Of
(Defining_Identifier
(Decl_2
), Loc
))));
2165 -- Ensure proper matching of access types. Required to avoid
2166 -- reporting spurious errors.
2168 elsif Is_Access_Type
(Etype
(Target_Formal
)) then
2170 Unchecked_Convert_To
(Base_Type
(Etype
(Target_Formal
)),
2171 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
)));
2173 -- No special management required for this actual
2177 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
2180 Next_Formal
(Target_Formal
);
2184 Thunk_Id
:= Make_Temporary
(Loc
, 'T');
2186 -- Note: any change to this symbol name needs to be coordinated
2187 -- with GNATcoverage, as that tool relies on it to identify
2188 -- thunks and exclude them from source coverage analysis.
2190 Set_Ekind
(Thunk_Id
, Ekind
(Prim
));
2191 Set_Is_Thunk
(Thunk_Id
);
2192 Set_Convention
(Thunk_Id
, Convention
(Prim
));
2193 Set_Needs_Debug_Info
(Thunk_Id
, Needs_Debug_Info
(Target
));
2194 Set_Thunk_Entity
(Thunk_Id
, Target
);
2198 if Ekind
(Target
) = E_Procedure
then
2200 Make_Subprogram_Body
(Loc
,
2202 Make_Procedure_Specification
(Loc
,
2203 Defining_Unit_Name
=> Thunk_Id
,
2204 Parameter_Specifications
=> Formals
),
2205 Declarations
=> Decl
,
2206 Handled_Statement_Sequence
=>
2207 Make_Handled_Sequence_Of_Statements
(Loc
,
2208 Statements
=> New_List
(
2209 Make_Procedure_Call_Statement
(Loc
,
2210 Name
=> New_Occurrence_Of
(Target
, Loc
),
2211 Parameter_Associations
=> Actuals
))));
2215 else pragma Assert
(Ekind
(Target
) = E_Function
);
2217 Result_Def
: Node_Id
;
2218 Call_Node
: Node_Id
;
2222 Make_Function_Call
(Loc
,
2223 Name
=> New_Occurrence_Of
(Target
, Loc
),
2224 Parameter_Associations
=> Actuals
);
2226 if not Is_Interface
(Etype
(Prim
)) then
2227 Result_Def
:= New_Copy
(Result_Definition
(Parent
(Target
)));
2229 -- Thunk of function returning a class-wide interface object. No
2230 -- extra displacement needed since the displacement is generated
2231 -- in the return statement of Prim. Example:
2233 -- type Iface is interface ...
2234 -- function F (O : Iface) return Iface'Class;
2236 -- type T is new ... and Iface with ...
2237 -- function F (O : T) return Iface'Class;
2239 elsif Is_Class_Wide_Type
(Etype
(Prim
)) then
2240 Result_Def
:= New_Occurrence_Of
(Etype
(Prim
), Loc
);
2242 -- Thunk of function returning an interface object. Displacement
2245 -- type Iface is interface ...
2246 -- function F (O : Iface) return Iface;
2248 -- type T is new ... and Iface with ...
2249 -- function F (O : T) return T;
2253 New_Occurrence_Of
(Class_Wide_Type
(Etype
(Prim
)), Loc
);
2255 -- Adding implicit conversion to force the displacement of
2256 -- the pointer to the object to reference the corresponding
2257 -- secondary dispatch table.
2260 Make_Type_Conversion
(Loc
,
2262 New_Occurrence_Of
(Class_Wide_Type
(Etype
(Prim
)), Loc
),
2263 Expression
=> Relocate_Node
(Call_Node
));
2267 Make_Subprogram_Body
(Loc
,
2269 Make_Function_Specification
(Loc
,
2270 Defining_Unit_Name
=> Thunk_Id
,
2271 Parameter_Specifications
=> Formals
,
2272 Result_Definition
=> Result_Def
),
2273 Declarations
=> Decl
,
2274 Handled_Statement_Sequence
=>
2275 Make_Handled_Sequence_Of_Statements
(Loc
,
2276 Statements
=> New_List
(
2277 Make_Simple_Return_Statement
(Loc
, Call_Node
))));
2280 end Expand_Interface_Thunk
;
2282 --------------------------
2283 -- Has_CPP_Constructors --
2284 --------------------------
2286 function Has_CPP_Constructors
(Typ
: Entity_Id
) return Boolean is
2290 -- Look for the constructor entities
2292 E
:= Next_Entity
(Typ
);
2293 while Present
(E
) loop
2294 if Ekind
(E
) = E_Function
and then Is_Constructor
(E
) then
2302 end Has_CPP_Constructors
;
2308 function Has_DT
(Typ
: Entity_Id
) return Boolean is
2310 return not Is_Interface
(Typ
)
2311 and then not Restriction_Active
(No_Dispatching_Calls
);
2314 ----------------------------------
2315 -- Is_Expanded_Dispatching_Call --
2316 ----------------------------------
2318 function Is_Expanded_Dispatching_Call
(N
: Node_Id
) return Boolean is
2320 return Nkind
(N
) in N_Subprogram_Call
2321 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
2322 and then Is_Dispatch_Table_Entity
(Etype
(Name
(N
)));
2323 end Is_Expanded_Dispatching_Call
;
2325 -------------------------------------
2326 -- Is_Predefined_Dispatching_Alias --
2327 -------------------------------------
2329 function Is_Predefined_Dispatching_Alias
(Prim
: Entity_Id
) return Boolean
2332 return not Is_Predefined_Dispatching_Operation
(Prim
)
2333 and then Present
(Alias
(Prim
))
2334 and then Is_Predefined_Dispatching_Operation
(Ultimate_Alias
(Prim
));
2335 end Is_Predefined_Dispatching_Alias
;
2337 ----------------------------------------
2338 -- Make_Disp_Asynchronous_Select_Body --
2339 ----------------------------------------
2341 -- For interface types, generate:
2343 -- procedure _Disp_Asynchronous_Select
2344 -- (T : in out <Typ>;
2346 -- P : System.Address;
2347 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2352 -- C := Ada.Tags.POK_Function;
2353 -- end _Disp_Asynchronous_Select;
2355 -- For protected types, generate:
2357 -- procedure _Disp_Asynchronous_Select
2358 -- (T : in out <Typ>;
2360 -- P : System.Address;
2361 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2365 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2366 -- Bnn : System.Tasking.Protected_Objects.Operations.
2367 -- Communication_Block;
2369 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2370 -- (T._object'Access,
2371 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2373 -- System.Tasking.Asynchronous_Call,
2375 -- B := System.Storage_Elements.Dummy_Communication_Block (Bnn);
2376 -- end _Disp_Asynchronous_Select;
2378 -- For task types, generate:
2380 -- procedure _Disp_Asynchronous_Select
2381 -- (T : in out <Typ>;
2383 -- P : System.Address;
2384 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2388 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2390 -- System.Tasking.Rendezvous.Task_Entry_Call
2392 -- System.Tasking.Task_Entry_Index (I),
2394 -- System.Tasking.Asynchronous_Call,
2396 -- end _Disp_Asynchronous_Select;
2398 function Make_Disp_Asynchronous_Select_Body
2399 (Typ
: Entity_Id
) return Node_Id
2401 Com_Block
: Entity_Id
;
2402 Conc_Typ
: Entity_Id
:= Empty
;
2403 Decls
: constant List_Id
:= New_List
;
2404 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2406 Stmts
: constant List_Id
:= New_List
;
2410 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2412 -- Null body is generated for interface types
2414 if Is_Interface
(Typ
) then
2416 Make_Subprogram_Body
(Loc
,
2418 Make_Disp_Asynchronous_Select_Spec
(Typ
),
2419 Declarations
=> New_List
,
2420 Handled_Statement_Sequence
=>
2421 Make_Handled_Sequence_Of_Statements
(Loc
,
2423 Make_Assignment_Statement
(Loc
,
2424 Name
=> Make_Identifier
(Loc
, Name_uF
),
2425 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
2428 if Is_Concurrent_Record_Type
(Typ
) then
2429 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
2433 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2435 -- where I will be used to capture the entry index of the primitive
2436 -- wrapper at position S.
2438 if Tagged_Type_Expansion
then
2440 Unchecked_Convert_To
(RTE
(RE_Tag
),
2442 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
2445 Make_Attribute_Reference
(Loc
,
2446 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
2447 Attribute_Name
=> Name_Tag
);
2451 Make_Object_Declaration
(Loc
,
2452 Defining_Identifier
=>
2453 Make_Defining_Identifier
(Loc
, Name_uI
),
2454 Object_Definition
=>
2455 New_Occurrence_Of
(Standard_Integer
, Loc
),
2457 Make_Function_Call
(Loc
,
2459 New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
2460 Parameter_Associations
=>
2461 New_List
(Tag_Node
, Make_Identifier
(Loc
, Name_uS
)))));
2463 if Ekind
(Conc_Typ
) = E_Protected_Type
then
2466 -- Bnn : Communication_Block;
2468 Com_Block
:= Make_Temporary
(Loc
, 'B');
2470 Make_Object_Declaration
(Loc
,
2471 Defining_Identifier
=> Com_Block
,
2472 Object_Definition
=>
2473 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
2475 -- Build T._object'Access for calls below
2478 Make_Attribute_Reference
(Loc
,
2479 Attribute_Name
=> Name_Unchecked_Access
,
2481 Make_Selected_Component
(Loc
,
2482 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2483 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
2485 case Corresponding_Runtime_Package
(Conc_Typ
) is
2486 when System_Tasking_Protected_Objects_Entries
=>
2489 -- Protected_Entry_Call
2490 -- (T._object'Access, -- Object
2491 -- Protected_Entry_Index! (I), -- E
2492 -- P, -- Uninterpreted_Data
2493 -- Asynchronous_Call, -- Mode
2494 -- Bnn); -- Communication_Block
2496 -- where T is the protected object, I is the entry index, P
2497 -- is the wrapped parameters and B is the name of the
2498 -- communication block.
2501 Make_Procedure_Call_Statement
(Loc
,
2503 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
2504 Parameter_Associations
=>
2508 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2511 (RTE
(RE_Protected_Entry_Index
), Loc
),
2512 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2514 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2515 New_Occurrence_Of
-- Asynchronous_Call
2516 (RTE
(RE_Asynchronous_Call
), Loc
),
2517 New_Occurrence_Of
-- comm block
2518 (Com_Block
, Loc
))));
2521 raise Program_Error
;
2525 -- B := Dummy_Communication_Block (Bnn);
2528 Make_Assignment_Statement
(Loc
,
2529 Name
=> Make_Identifier
(Loc
, Name_uB
),
2531 Make_Unchecked_Type_Conversion
(Loc
,
2534 (RTE
(RE_Dummy_Communication_Block
), Loc
),
2535 Expression
=> New_Occurrence_Of
(Com_Block
, Loc
))));
2541 Make_Assignment_Statement
(Loc
,
2542 Name
=> Make_Identifier
(Loc
, Name_uF
),
2543 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
2546 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
2550 -- (T._task_id, -- Acceptor
2551 -- Task_Entry_Index! (I), -- E
2552 -- P, -- Uninterpreted_Data
2553 -- Asynchronous_Call, -- Mode
2554 -- F); -- Rendezvous_Successful
2556 -- where T is the task object, I is the entry index, P is the
2557 -- wrapped parameters and F is the status flag.
2560 Make_Procedure_Call_Statement
(Loc
,
2562 New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
2563 Parameter_Associations
=>
2565 Make_Selected_Component
(Loc
, -- T._task_id
2566 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2567 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
2569 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2571 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
2572 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2574 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2575 New_Occurrence_Of
-- Asynchronous_Call
2576 (RTE
(RE_Asynchronous_Call
), Loc
),
2577 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
2581 -- Ensure that the statements list is non-empty
2584 Make_Assignment_Statement
(Loc
,
2585 Name
=> Make_Identifier
(Loc
, Name_uF
),
2586 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
2590 Make_Subprogram_Body
(Loc
,
2592 Make_Disp_Asynchronous_Select_Spec
(Typ
),
2593 Declarations
=> Decls
,
2594 Handled_Statement_Sequence
=>
2595 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
2596 end Make_Disp_Asynchronous_Select_Body
;
2598 ----------------------------------------
2599 -- Make_Disp_Asynchronous_Select_Spec --
2600 ----------------------------------------
2602 function Make_Disp_Asynchronous_Select_Spec
2603 (Typ
: Entity_Id
) return Node_Id
2605 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2606 B_Id
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
2607 Def_Id
: constant Entity_Id
:=
2608 Make_Defining_Identifier
(Loc
,
2609 Name_uDisp_Asynchronous_Select
);
2610 Params
: constant List_Id
:= New_List
;
2613 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2615 -- T : in out Typ; -- Object parameter
2616 -- S : Integer; -- Primitive operation slot
2617 -- P : Address; -- Wrapped parameters
2618 -- B : out Dummy_Communication_Block; -- Communication block dummy
2619 -- F : out Boolean; -- Status flag
2621 -- The B parameter may be left uninitialized
2623 Set_Warnings_Off
(B_Id
);
2625 Append_List_To
(Params
, New_List
(
2627 Make_Parameter_Specification
(Loc
,
2628 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
2629 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
2631 Out_Present
=> True),
2633 Make_Parameter_Specification
(Loc
,
2634 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
2635 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
2637 Make_Parameter_Specification
(Loc
,
2638 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
2639 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2641 Make_Parameter_Specification
(Loc
,
2642 Defining_Identifier
=> B_Id
,
2644 New_Occurrence_Of
(RTE
(RE_Dummy_Communication_Block
), Loc
),
2645 Out_Present
=> True),
2647 Make_Parameter_Specification
(Loc
,
2648 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
2649 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
2650 Out_Present
=> True)));
2653 Make_Procedure_Specification
(Loc
,
2654 Defining_Unit_Name
=> Def_Id
,
2655 Parameter_Specifications
=> Params
);
2656 end Make_Disp_Asynchronous_Select_Spec
;
2658 ---------------------------------------
2659 -- Make_Disp_Conditional_Select_Body --
2660 ---------------------------------------
2662 -- For interface types, generate:
2664 -- procedure _Disp_Conditional_Select
2665 -- (T : in out <Typ>;
2667 -- P : System.Address;
2668 -- C : out Ada.Tags.Prim_Op_Kind;
2673 -- C := Ada.Tags.POK_Function;
2674 -- end _Disp_Conditional_Select;
2676 -- For protected types, generate:
2678 -- procedure _Disp_Conditional_Select
2679 -- (T : in out <Typ>;
2681 -- P : System.Address;
2682 -- C : out Ada.Tags.Prim_Op_Kind;
2686 -- Bnn : System.Tasking.Protected_Objects.Operations.
2687 -- Communication_Block;
2690 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S));
2692 -- if C = Ada.Tags.POK_Procedure
2693 -- or else C = Ada.Tags.POK_Protected_Procedure
2694 -- or else C = Ada.Tags.POK_Task_Procedure
2700 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2701 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2702 -- (T.object'Access,
2703 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2705 -- System.Tasking.Conditional_Call,
2707 -- F := not Cancelled (Bnn);
2708 -- end _Disp_Conditional_Select;
2710 -- For task types, generate:
2712 -- procedure _Disp_Conditional_Select
2713 -- (T : in out <Typ>;
2715 -- P : System.Address;
2716 -- C : out Ada.Tags.Prim_Op_Kind;
2722 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2723 -- System.Tasking.Rendezvous.Task_Entry_Call
2725 -- System.Tasking.Task_Entry_Index (I),
2727 -- System.Tasking.Conditional_Call,
2729 -- end _Disp_Conditional_Select;
2731 function Make_Disp_Conditional_Select_Body
2732 (Typ
: Entity_Id
) return Node_Id
2734 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2735 Blk_Nam
: Entity_Id
;
2736 Conc_Typ
: Entity_Id
:= Empty
;
2737 Decls
: constant List_Id
:= New_List
;
2739 Stmts
: constant List_Id
:= New_List
;
2743 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2745 -- Null body is generated for interface types
2747 if Is_Interface
(Typ
) then
2749 Make_Subprogram_Body
(Loc
,
2751 Make_Disp_Conditional_Select_Spec
(Typ
),
2752 Declarations
=> No_List
,
2753 Handled_Statement_Sequence
=>
2754 Make_Handled_Sequence_Of_Statements
(Loc
,
2755 New_List
(Make_Assignment_Statement
(Loc
,
2756 Name
=> Make_Identifier
(Loc
, Name_uF
),
2757 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
2760 if Is_Concurrent_Record_Type
(Typ
) then
2761 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
2766 -- where I will be used to capture the entry index of the primitive
2767 -- wrapper at position S.
2770 Make_Object_Declaration
(Loc
,
2771 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uI
),
2772 Object_Definition
=>
2773 New_Occurrence_Of
(Standard_Integer
, Loc
)));
2776 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S);
2778 -- if C = POK_Procedure
2779 -- or else C = POK_Protected_Procedure
2780 -- or else C = POK_Task_Procedure;
2786 Build_Common_Dispatching_Select_Statements
(Typ
, Stmts
);
2789 -- Bnn : Communication_Block;
2791 -- where Bnn is the name of the communication block used in the
2792 -- call to Protected_Entry_Call.
2794 Blk_Nam
:= Make_Temporary
(Loc
, 'B');
2796 Make_Object_Declaration
(Loc
,
2797 Defining_Identifier
=> Blk_Nam
,
2798 Object_Definition
=>
2799 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
2802 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2804 -- I is the entry index and S is the dispatch table slot
2806 if Tagged_Type_Expansion
then
2808 Unchecked_Convert_To
(RTE
(RE_Tag
),
2810 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
2814 Make_Attribute_Reference
(Loc
,
2815 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
2816 Attribute_Name
=> Name_Tag
);
2820 Make_Assignment_Statement
(Loc
,
2821 Name
=> Make_Identifier
(Loc
, Name_uI
),
2823 Make_Function_Call
(Loc
,
2825 New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
2826 Parameter_Associations
=> New_List
(
2828 Make_Identifier
(Loc
, Name_uS
)))));
2830 if Ekind
(Conc_Typ
) = E_Protected_Type
then
2832 Obj_Ref
:= -- T._object'Access
2833 Make_Attribute_Reference
(Loc
,
2834 Attribute_Name
=> Name_Unchecked_Access
,
2836 Make_Selected_Component
(Loc
,
2837 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2838 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
2840 case Corresponding_Runtime_Package
(Conc_Typ
) is
2841 when System_Tasking_Protected_Objects_Entries
=>
2844 -- Protected_Entry_Call
2845 -- (T._object'Access, -- Object
2846 -- Protected_Entry_Index! (I), -- E
2847 -- P, -- Uninterpreted_Data
2848 -- Conditional_Call, -- Mode
2851 -- where T is the protected object, I is the entry index, P
2852 -- are the wrapped parameters and Bnn is the name of the
2853 -- communication block.
2856 Make_Procedure_Call_Statement
(Loc
,
2858 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
2859 Parameter_Associations
=> New_List
(
2862 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2865 (RTE
(RE_Protected_Entry_Index
), Loc
),
2866 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2868 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2870 New_Occurrence_Of
-- Conditional_Call
2871 (RTE
(RE_Conditional_Call
), Loc
),
2872 New_Occurrence_Of
-- Bnn
2875 when System_Tasking_Protected_Objects_Single_Entry
=>
2877 -- If we are compiling for a restricted run-time, the call
2878 -- uses the simpler form.
2881 Make_Procedure_Call_Statement
(Loc
,
2884 (RTE
(RE_Protected_Single_Entry_Call
), Loc
),
2885 Parameter_Associations
=> New_List
(
2888 Make_Attribute_Reference
(Loc
,
2889 Prefix
=> Make_Identifier
(Loc
, Name_uP
),
2890 Attribute_Name
=> Name_Address
),
2893 (RTE
(RE_Conditional_Call
), Loc
))));
2895 raise Program_Error
;
2899 -- F := not Cancelled (Bnn);
2901 -- where F is the success flag. The status of Cancelled is negated
2902 -- in order to match the behavior of the version for task types.
2905 Make_Assignment_Statement
(Loc
,
2906 Name
=> Make_Identifier
(Loc
, Name_uF
),
2910 Make_Function_Call
(Loc
,
2912 New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
2913 Parameter_Associations
=> New_List
(
2914 New_Occurrence_Of
(Blk_Nam
, Loc
))))));
2916 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
2920 -- (T._task_id, -- Acceptor
2921 -- Task_Entry_Index! (I), -- E
2922 -- P, -- Uninterpreted_Data
2923 -- Conditional_Call, -- Mode
2924 -- F); -- Rendezvous_Successful
2926 -- where T is the task object, I is the entry index, P are the
2927 -- wrapped parameters and F is the status flag.
2930 Make_Procedure_Call_Statement
(Loc
,
2932 New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
2933 Parameter_Associations
=> New_List
(
2935 Make_Selected_Component
(Loc
, -- T._task_id
2936 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2937 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
2939 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2941 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
2942 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2944 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2945 New_Occurrence_Of
-- Conditional_Call
2946 (RTE
(RE_Conditional_Call
), Loc
),
2947 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
2951 -- Initialize out parameters
2954 Make_Assignment_Statement
(Loc
,
2955 Name
=> Make_Identifier
(Loc
, Name_uF
),
2956 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
2958 Make_Assignment_Statement
(Loc
,
2959 Name
=> Make_Identifier
(Loc
, Name_uC
),
2960 Expression
=> New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
)));
2964 Make_Subprogram_Body
(Loc
,
2966 Make_Disp_Conditional_Select_Spec
(Typ
),
2967 Declarations
=> Decls
,
2968 Handled_Statement_Sequence
=>
2969 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
2970 end Make_Disp_Conditional_Select_Body
;
2972 ---------------------------------------
2973 -- Make_Disp_Conditional_Select_Spec --
2974 ---------------------------------------
2976 function Make_Disp_Conditional_Select_Spec
2977 (Typ
: Entity_Id
) return Node_Id
2979 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2980 Def_Id
: constant Node_Id
:=
2981 Make_Defining_Identifier
(Loc
,
2982 Name_uDisp_Conditional_Select
);
2983 Params
: constant List_Id
:= New_List
;
2986 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2988 -- T : in out Typ; -- Object parameter
2989 -- S : Integer; -- Primitive operation slot
2990 -- P : Address; -- Wrapped parameters
2991 -- C : out Prim_Op_Kind; -- Call kind
2992 -- F : out Boolean; -- Status flag
2994 Append_List_To
(Params
, New_List
(
2996 Make_Parameter_Specification
(Loc
,
2997 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
2998 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
3000 Out_Present
=> True),
3002 Make_Parameter_Specification
(Loc
,
3003 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
3004 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3006 Make_Parameter_Specification
(Loc
,
3007 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
3008 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3010 Make_Parameter_Specification
(Loc
,
3011 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
3013 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
3014 Out_Present
=> True),
3016 Make_Parameter_Specification
(Loc
,
3017 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
3018 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3019 Out_Present
=> True)));
3022 Make_Procedure_Specification
(Loc
,
3023 Defining_Unit_Name
=> Def_Id
,
3024 Parameter_Specifications
=> Params
);
3025 end Make_Disp_Conditional_Select_Spec
;
3027 -------------------------------------
3028 -- Make_Disp_Get_Prim_Op_Kind_Body --
3029 -------------------------------------
3031 function Make_Disp_Get_Prim_Op_Kind_Body
(Typ
: Entity_Id
) return Node_Id
is
3032 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3036 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3038 if Is_Interface
(Typ
) then
3040 Make_Subprogram_Body
(Loc
,
3042 Make_Disp_Get_Prim_Op_Kind_Spec
(Typ
),
3043 Declarations
=> New_List
,
3044 Handled_Statement_Sequence
=>
3045 Make_Handled_Sequence_Of_Statements
(Loc
,
3046 New_List
(Make_Null_Statement
(Loc
))));
3050 -- C := get_prim_op_kind (tag! (<type>VP), S);
3052 -- where C is the out parameter capturing the call kind and S is the
3053 -- dispatch table slot number.
3055 if Tagged_Type_Expansion
then
3057 Unchecked_Convert_To
(RTE
(RE_Tag
),
3059 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
3063 Make_Attribute_Reference
(Loc
,
3064 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
3065 Attribute_Name
=> Name_Tag
);
3069 Make_Subprogram_Body
(Loc
,
3071 Make_Disp_Get_Prim_Op_Kind_Spec
(Typ
),
3072 Declarations
=> New_List
,
3073 Handled_Statement_Sequence
=>
3074 Make_Handled_Sequence_Of_Statements
(Loc
,
3076 Make_Assignment_Statement
(Loc
,
3077 Name
=> Make_Identifier
(Loc
, Name_uC
),
3079 Make_Function_Call
(Loc
,
3081 New_Occurrence_Of
(RTE
(RE_Get_Prim_Op_Kind
), Loc
),
3082 Parameter_Associations
=> New_List
(
3084 Make_Identifier
(Loc
, Name_uS
)))))));
3085 end Make_Disp_Get_Prim_Op_Kind_Body
;
3087 -------------------------------------
3088 -- Make_Disp_Get_Prim_Op_Kind_Spec --
3089 -------------------------------------
3091 function Make_Disp_Get_Prim_Op_Kind_Spec
3092 (Typ
: Entity_Id
) return Node_Id
3094 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3095 Def_Id
: constant Node_Id
:=
3096 Make_Defining_Identifier
(Loc
, Name_uDisp_Get_Prim_Op_Kind
);
3097 Params
: constant List_Id
:= New_List
;
3100 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3102 -- T : in out Typ; -- Object parameter
3103 -- S : Integer; -- Primitive operation slot
3104 -- C : out Prim_Op_Kind; -- Call kind
3106 Append_List_To
(Params
, New_List
(
3108 Make_Parameter_Specification
(Loc
,
3109 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
3110 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
3112 Out_Present
=> True),
3114 Make_Parameter_Specification
(Loc
,
3115 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
3116 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3118 Make_Parameter_Specification
(Loc
,
3119 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
3121 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
3122 Out_Present
=> True)));
3125 Make_Procedure_Specification
(Loc
,
3126 Defining_Unit_Name
=> Def_Id
,
3127 Parameter_Specifications
=> Params
);
3128 end Make_Disp_Get_Prim_Op_Kind_Spec
;
3130 --------------------------------
3131 -- Make_Disp_Get_Task_Id_Body --
3132 --------------------------------
3134 function Make_Disp_Get_Task_Id_Body
3135 (Typ
: Entity_Id
) return Node_Id
3137 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3141 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3143 if Is_Concurrent_Record_Type
(Typ
)
3144 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) = E_Task_Type
3147 -- return To_Address (_T._task_id);
3150 Make_Simple_Return_Statement
(Loc
,
3152 Make_Unchecked_Type_Conversion
(Loc
,
3153 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
3155 Make_Selected_Component
(Loc
,
3156 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
3157 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
))));
3159 -- A null body is constructed for non-task types
3163 -- return Null_Address;
3166 Make_Simple_Return_Statement
(Loc
,
3167 Expression
=> New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
3171 Make_Subprogram_Body
(Loc
,
3172 Specification
=> Make_Disp_Get_Task_Id_Spec
(Typ
),
3173 Declarations
=> New_List
,
3174 Handled_Statement_Sequence
=>
3175 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Ret
)));
3176 end Make_Disp_Get_Task_Id_Body
;
3178 --------------------------------
3179 -- Make_Disp_Get_Task_Id_Spec --
3180 --------------------------------
3182 function Make_Disp_Get_Task_Id_Spec
3183 (Typ
: Entity_Id
) return Node_Id
3185 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3188 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3191 Make_Function_Specification
(Loc
,
3192 Defining_Unit_Name
=>
3193 Make_Defining_Identifier
(Loc
, Name_uDisp_Get_Task_Id
),
3194 Parameter_Specifications
=> New_List
(
3195 Make_Parameter_Specification
(Loc
,
3196 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
3197 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
3198 Result_Definition
=>
3199 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
3200 end Make_Disp_Get_Task_Id_Spec
;
3202 ----------------------------
3203 -- Make_Disp_Requeue_Body --
3204 ----------------------------
3206 function Make_Disp_Requeue_Body
3207 (Typ
: Entity_Id
) return Node_Id
3209 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3210 Conc_Typ
: Entity_Id
:= Empty
;
3211 Stmts
: constant List_Id
:= New_List
;
3214 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3216 -- Null body is generated for interface types and non-concurrent
3219 if Is_Interface
(Typ
)
3220 or else not Is_Concurrent_Record_Type
(Typ
)
3223 Make_Subprogram_Body
(Loc
,
3224 Specification
=> Make_Disp_Requeue_Spec
(Typ
),
3225 Declarations
=> No_List
,
3226 Handled_Statement_Sequence
=>
3227 Make_Handled_Sequence_Of_Statements
(Loc
,
3228 New_List
(Make_Null_Statement
(Loc
))));
3231 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
3233 if Ekind
(Conc_Typ
) = E_Protected_Type
then
3235 -- Generate statements:
3237 -- System.Tasking.Protected_Objects.Operations.
3238 -- Requeue_Protected_Entry
3239 -- (Protection_Entries_Access (P),
3240 -- O._object'Unchecked_Access,
3241 -- Protected_Entry_Index (I),
3244 -- System.Tasking.Protected_Objects.Operations.
3245 -- Requeue_Task_To_Protected_Entry
3246 -- (O._object'Unchecked_Access,
3247 -- Protected_Entry_Index (I),
3251 if Restriction_Active
(No_Entry_Queue
) then
3252 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
3255 Make_If_Statement
(Loc
,
3256 Condition
=> Make_Identifier
(Loc
, Name_uF
),
3261 -- Call to Requeue_Protected_Entry
3263 Make_Procedure_Call_Statement
(Loc
,
3266 (RTE
(RE_Requeue_Protected_Entry
), Loc
),
3267 Parameter_Associations
=>
3270 Make_Unchecked_Type_Conversion
(Loc
, -- PEA (P)
3273 RTE
(RE_Protection_Entries_Access
), Loc
),
3275 Make_Identifier
(Loc
, Name_uP
)),
3277 Make_Attribute_Reference
(Loc
, -- O._object'Acc
3279 Name_Unchecked_Access
,
3281 Make_Selected_Component
(Loc
,
3283 Make_Identifier
(Loc
, Name_uO
),
3285 Make_Identifier
(Loc
, Name_uObject
))),
3287 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3290 (RTE
(RE_Protected_Entry_Index
), Loc
),
3291 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3293 Make_Identifier
(Loc
, Name_uA
)))), -- abort status
3298 -- Call to Requeue_Task_To_Protected_Entry
3300 Make_Procedure_Call_Statement
(Loc
,
3303 (RTE
(RE_Requeue_Task_To_Protected_Entry
), Loc
),
3304 Parameter_Associations
=>
3307 Make_Attribute_Reference
(Loc
, -- O._object'Acc
3308 Attribute_Name
=> Name_Unchecked_Access
,
3310 Make_Selected_Component
(Loc
,
3312 Make_Identifier
(Loc
, Name_uO
),
3314 Make_Identifier
(Loc
, Name_uObject
))),
3316 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3319 (RTE
(RE_Protected_Entry_Index
), Loc
),
3320 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3322 Make_Identifier
(Loc
, Name_uA
)))))); -- abort status
3326 pragma Assert
(Is_Task_Type
(Conc_Typ
));
3330 -- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry
3331 -- (Protection_Entries_Access (P),
3333 -- Task_Entry_Index (I),
3336 -- System.Tasking.Rendezvous.Requeue_Task_Entry
3338 -- Task_Entry_Index (I),
3343 Make_If_Statement
(Loc
,
3344 Condition
=> Make_Identifier
(Loc
, Name_uF
),
3346 Then_Statements
=> New_List
(
3348 -- Call to Requeue_Protected_To_Task_Entry
3350 Make_Procedure_Call_Statement
(Loc
,
3353 (RTE
(RE_Requeue_Protected_To_Task_Entry
), Loc
),
3355 Parameter_Associations
=> New_List
(
3357 Make_Unchecked_Type_Conversion
(Loc
, -- PEA (P)
3360 (RTE
(RE_Protection_Entries_Access
), Loc
),
3361 Expression
=> Make_Identifier
(Loc
, Name_uP
)),
3363 Make_Selected_Component
(Loc
, -- O._task_id
3364 Prefix
=> Make_Identifier
(Loc
, Name_uO
),
3365 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3367 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3369 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
3370 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3372 Make_Identifier
(Loc
, Name_uA
)))), -- abort status
3374 Else_Statements
=> New_List
(
3376 -- Call to Requeue_Task_Entry
3378 Make_Procedure_Call_Statement
(Loc
,
3380 New_Occurrence_Of
(RTE
(RE_Requeue_Task_Entry
), Loc
),
3382 Parameter_Associations
=> New_List
(
3384 Make_Selected_Component
(Loc
, -- O._task_id
3385 Prefix
=> Make_Identifier
(Loc
, Name_uO
),
3386 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3388 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3390 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
3391 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3393 Make_Identifier
(Loc
, Name_uA
)))))); -- abort status
3396 -- Even though no declarations are needed in both cases, we allocate
3397 -- a list for entities added by Freeze.
3400 Make_Subprogram_Body
(Loc
,
3401 Specification
=> Make_Disp_Requeue_Spec
(Typ
),
3402 Declarations
=> New_List
,
3403 Handled_Statement_Sequence
=>
3404 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
3405 end Make_Disp_Requeue_Body
;
3407 ----------------------------
3408 -- Make_Disp_Requeue_Spec --
3409 ----------------------------
3411 function Make_Disp_Requeue_Spec
3412 (Typ
: Entity_Id
) return Node_Id
3414 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3417 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3419 -- O : in out Typ; - Object parameter
3420 -- F : Boolean; - Protected (True) / task (False) flag
3421 -- P : Address; - Protection_Entries_Access value
3422 -- I : Entry_Index - Index of entry call
3423 -- A : Boolean - Abort flag
3425 -- Note that the Protection_Entries_Access value is represented as a
3426 -- System.Address in order to avoid dragging in the tasking runtime
3427 -- when compiling sources without tasking constructs.
3430 Make_Procedure_Specification
(Loc
,
3431 Defining_Unit_Name
=>
3432 Make_Defining_Identifier
(Loc
, Name_uDisp_Requeue
),
3434 Parameter_Specifications
=> New_List
(
3436 Make_Parameter_Specification
(Loc
, -- O
3437 Defining_Identifier
=>
3438 Make_Defining_Identifier
(Loc
, Name_uO
),
3440 New_Occurrence_Of
(Typ
, Loc
),
3442 Out_Present
=> True),
3444 Make_Parameter_Specification
(Loc
, -- F
3445 Defining_Identifier
=>
3446 Make_Defining_Identifier
(Loc
, Name_uF
),
3448 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
3450 Make_Parameter_Specification
(Loc
, -- P
3451 Defining_Identifier
=>
3452 Make_Defining_Identifier
(Loc
, Name_uP
),
3454 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3456 Make_Parameter_Specification
(Loc
, -- I
3457 Defining_Identifier
=>
3458 Make_Defining_Identifier
(Loc
, Name_uI
),
3460 New_Occurrence_Of
(Standard_Integer
, Loc
)),
3462 Make_Parameter_Specification
(Loc
, -- A
3463 Defining_Identifier
=>
3464 Make_Defining_Identifier
(Loc
, Name_uA
),
3466 New_Occurrence_Of
(Standard_Boolean
, Loc
))));
3467 end Make_Disp_Requeue_Spec
;
3469 ---------------------------------
3470 -- Make_Disp_Timed_Select_Body --
3471 ---------------------------------
3473 -- For interface types, generate:
3475 -- procedure _Disp_Timed_Select
3476 -- (T : in out <Typ>;
3478 -- P : System.Address;
3481 -- C : out Ada.Tags.Prim_Op_Kind;
3486 -- C := Ada.Tags.POK_Function;
3487 -- end _Disp_Timed_Select;
3489 -- For protected types, generate:
3491 -- procedure _Disp_Timed_Select
3492 -- (T : in out <Typ>;
3494 -- P : System.Address;
3497 -- C : out Ada.Tags.Prim_Op_Kind;
3503 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S);
3505 -- if C = Ada.Tags.POK_Procedure
3506 -- or else C = Ada.Tags.POK_Protected_Procedure
3507 -- or else C = Ada.Tags.POK_Task_Procedure
3513 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3514 -- System.Tasking.Protected_Objects.Operations.
3515 -- Timed_Protected_Entry_Call
3516 -- (T._object'Access,
3517 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
3522 -- end _Disp_Timed_Select;
3524 -- For task types, generate:
3526 -- procedure _Disp_Timed_Select
3527 -- (T : in out <Typ>;
3529 -- P : System.Address;
3532 -- C : out Ada.Tags.Prim_Op_Kind;
3538 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3539 -- System.Tasking.Rendezvous.Timed_Task_Entry_Call
3541 -- System.Tasking.Task_Entry_Index (I),
3546 -- end _Disp_Time_Select;
3548 function Make_Disp_Timed_Select_Body
3549 (Typ
: Entity_Id
) return Node_Id
3551 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3552 Conc_Typ
: Entity_Id
:= Empty
;
3553 Decls
: constant List_Id
:= New_List
;
3555 Stmts
: constant List_Id
:= New_List
;
3559 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3561 -- Null body is generated for interface types
3563 if Is_Interface
(Typ
) then
3565 Make_Subprogram_Body
(Loc
,
3566 Specification
=> Make_Disp_Timed_Select_Spec
(Typ
),
3567 Declarations
=> New_List
,
3568 Handled_Statement_Sequence
=>
3569 Make_Handled_Sequence_Of_Statements
(Loc
,
3571 Make_Assignment_Statement
(Loc
,
3572 Name
=> Make_Identifier
(Loc
, Name_uF
),
3573 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
3576 if Is_Concurrent_Record_Type
(Typ
) then
3577 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
3582 -- where I will be used to capture the entry index of the primitive
3583 -- wrapper at position S.
3586 Make_Object_Declaration
(Loc
,
3587 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uI
),
3588 Object_Definition
=>
3589 New_Occurrence_Of
(Standard_Integer
, Loc
)));
3592 -- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
3594 -- if C = POK_Procedure
3595 -- or else C = POK_Protected_Procedure
3596 -- or else C = POK_Task_Procedure;
3602 Build_Common_Dispatching_Select_Statements
(Typ
, Stmts
);
3605 -- I := Get_Entry_Index (tag! (<type>VP), S);
3607 -- I is the entry index and S is the dispatch table slot
3609 if Tagged_Type_Expansion
then
3611 Unchecked_Convert_To
(RTE
(RE_Tag
),
3613 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
3617 Make_Attribute_Reference
(Loc
,
3618 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
3619 Attribute_Name
=> Name_Tag
);
3623 Make_Assignment_Statement
(Loc
,
3624 Name
=> Make_Identifier
(Loc
, Name_uI
),
3626 Make_Function_Call
(Loc
,
3627 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
3628 Parameter_Associations
=> New_List
(
3630 Make_Identifier
(Loc
, Name_uS
)))));
3634 if Ekind
(Conc_Typ
) = E_Protected_Type
then
3636 -- Build T._object'Access
3639 Make_Attribute_Reference
(Loc
,
3640 Attribute_Name
=> Name_Unchecked_Access
,
3642 Make_Selected_Component
(Loc
,
3643 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
3644 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
3646 -- Normal case, No_Entry_Queue restriction not active. In this
3647 -- case we generate:
3649 -- Timed_Protected_Entry_Call
3650 -- (T._object'access,
3651 -- Protected_Entry_Index! (I),
3654 -- where T is the protected object, I is the entry index, P are
3655 -- the wrapped parameters, D is the delay amount, M is the delay
3656 -- mode and F is the status flag.
3658 -- Historically, there was also an implementation for single
3659 -- entry protected types (in s-tposen). However, it was removed
3660 -- by also testing for no No_Select_Statements restriction in
3661 -- Exp_Utils.Corresponding_Runtime_Package. This simplified the
3662 -- implementation of s-tposen.adb and provided consistency between
3663 -- all versions of System.Tasking.Protected_Objects.Single_Entry
3666 case Corresponding_Runtime_Package
(Conc_Typ
) is
3667 when System_Tasking_Protected_Objects_Entries
=>
3669 Make_Procedure_Call_Statement
(Loc
,
3672 (RTE
(RE_Timed_Protected_Entry_Call
), Loc
),
3673 Parameter_Associations
=> New_List
(
3676 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3679 (RTE
(RE_Protected_Entry_Index
), Loc
),
3680 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3682 Make_Identifier
(Loc
, Name_uP
), -- parameter block
3683 Make_Identifier
(Loc
, Name_uD
), -- delay
3684 Make_Identifier
(Loc
, Name_uM
), -- delay mode
3685 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
3688 raise Program_Error
;
3694 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
3697 -- Timed_Task_Entry_Call (
3699 -- Task_Entry_Index! (I),
3705 -- where T is the task object, I is the entry index, P are the
3706 -- wrapped parameters, D is the delay amount, M is the delay
3707 -- mode and F is the status flag.
3710 Make_Procedure_Call_Statement
(Loc
,
3712 New_Occurrence_Of
(RTE
(RE_Timed_Task_Entry_Call
), Loc
),
3714 Parameter_Associations
=> New_List
(
3715 Make_Selected_Component
(Loc
, -- T._task_id
3716 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
3717 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3719 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3721 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
3722 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3724 Make_Identifier
(Loc
, Name_uP
), -- parameter block
3725 Make_Identifier
(Loc
, Name_uD
), -- delay
3726 Make_Identifier
(Loc
, Name_uM
), -- delay mode
3727 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
3731 -- Initialize out parameters
3734 Make_Assignment_Statement
(Loc
,
3735 Name
=> Make_Identifier
(Loc
, Name_uF
),
3736 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3738 Make_Assignment_Statement
(Loc
,
3739 Name
=> Make_Identifier
(Loc
, Name_uC
),
3740 Expression
=> New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
)));
3744 Make_Subprogram_Body
(Loc
,
3745 Specification
=> Make_Disp_Timed_Select_Spec
(Typ
),
3746 Declarations
=> Decls
,
3747 Handled_Statement_Sequence
=>
3748 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
3749 end Make_Disp_Timed_Select_Body
;
3751 ---------------------------------
3752 -- Make_Disp_Timed_Select_Spec --
3753 ---------------------------------
3755 function Make_Disp_Timed_Select_Spec
3756 (Typ
: Entity_Id
) return Node_Id
3758 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3759 Def_Id
: constant Node_Id
:=
3760 Make_Defining_Identifier
(Loc
,
3761 Name_uDisp_Timed_Select
);
3762 Params
: constant List_Id
:= New_List
;
3765 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3767 -- T : in out Typ; -- Object parameter
3768 -- S : Integer; -- Primitive operation slot
3769 -- P : Address; -- Wrapped parameters
3770 -- D : Duration; -- Delay
3771 -- M : Integer; -- Delay Mode
3772 -- C : out Prim_Op_Kind; -- Call kind
3773 -- F : out Boolean; -- Status flag
3775 Append_List_To
(Params
, New_List
(
3777 Make_Parameter_Specification
(Loc
,
3778 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
3779 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
3781 Out_Present
=> True),
3783 Make_Parameter_Specification
(Loc
,
3784 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
3785 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3787 Make_Parameter_Specification
(Loc
,
3788 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
3789 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3791 Make_Parameter_Specification
(Loc
,
3792 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uD
),
3793 Parameter_Type
=> New_Occurrence_Of
(Standard_Duration
, Loc
)),
3795 Make_Parameter_Specification
(Loc
,
3796 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uM
),
3797 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3799 Make_Parameter_Specification
(Loc
,
3800 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
3802 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
3803 Out_Present
=> True)));
3806 Make_Parameter_Specification
(Loc
,
3807 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
3808 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3809 Out_Present
=> True));
3812 Make_Procedure_Specification
(Loc
,
3813 Defining_Unit_Name
=> Def_Id
,
3814 Parameter_Specifications
=> Params
);
3815 end Make_Disp_Timed_Select_Spec
;
3821 -- The frontend supports two models for expanding dispatch tables
3822 -- associated with library-level defined tagged types: statically and
3823 -- non-statically allocated dispatch tables. In the former case the object
3824 -- containing the dispatch table is constant and it is initialized by means
3825 -- of a positional aggregate. In the latter case, the object containing
3826 -- the dispatch table is a variable which is initialized by means of
3829 -- In case of locally defined tagged types, the object containing the
3830 -- object containing the dispatch table is always a variable (instead of a
3831 -- constant). This is currently required to give support to late overriding
3832 -- of primitives. For example:
3834 -- procedure Example is
3836 -- type T1 is tagged null record;
3837 -- procedure Prim (O : T1);
3840 -- type T2 is new Pkg.T1 with null record;
3841 -- procedure Prim (X : T2) is -- late overriding
3847 -- WARNING: This routine manages Ghost regions. Return statements must be
3848 -- replaced by gotos which jump to the end of the routine and restore the
3851 function Make_DT
(Typ
: Entity_Id
; N
: Node_Id
:= Empty
) return List_Id
is
3852 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3854 Max_Predef_Prims
: constant Int
:=
3858 (Parent
(RTE
(RE_Max_Predef_Prims
)))));
3860 DT_Decl
: constant Elist_Id
:= New_Elmt_List
;
3861 DT_Aggr
: constant Elist_Id
:= New_Elmt_List
;
3862 -- Entities marked with attribute Is_Dispatch_Table_Entity
3864 Dummy_Object
: Entity_Id
:= Empty
;
3865 -- Extra nonexistent object of type Typ internally used to compute the
3866 -- offset to the components that reference secondary dispatch tables.
3867 -- Used to compute the offset of components located at fixed position.
3869 procedure Check_Premature_Freezing
3871 Tagged_Type
: Entity_Id
;
3873 -- Verify that all untagged types in the profile of a subprogram are
3874 -- frozen at the point the subprogram is frozen. This enforces the rule
3875 -- on RM 13.14 (14) as modified by AI05-019. At the point a subprogram
3876 -- is frozen, enough must be known about it to build the activation
3877 -- record for it, which requires at least that the size of all
3878 -- parameters be known. Controlling arguments are by-reference,
3879 -- and therefore the rule only applies to untagged types. Typical
3880 -- violation of the rule involves an object declaration that freezes a
3881 -- tagged type, when one of its primitive operations has a type in its
3882 -- profile whose full view has not been analyzed yet. More complex cases
3883 -- involve composite types that have one private unfrozen subcomponent.
3884 -- Move this check to sem???
3886 procedure Export_DT
(Typ
: Entity_Id
; DT
: Entity_Id
; Index
: Nat
:= 0);
3887 -- Export the dispatch table DT of tagged type Typ. Required to generate
3888 -- forward references and statically allocate the table. For primary
3889 -- dispatch tables Index is 0; for secondary dispatch tables the value
3890 -- of index must match the Suffix_Index value assigned to the table by
3891 -- Make_Tags when generating its unique external name, and it is used to
3892 -- retrieve from the Dispatch_Table_Wrappers list associated with Typ
3893 -- the external name generated by Import_DT.
3895 procedure Make_Secondary_DT
3898 Iface_Comp
: Node_Id
;
3900 Num_Iface_Prims
: Nat
;
3901 Iface_DT_Ptr
: Entity_Id
;
3902 Predef_Prims_Ptr
: Entity_Id
;
3903 Build_Thunks
: Boolean;
3905 -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch
3906 -- Table of Typ associated with Iface. Each abstract interface of Typ
3907 -- has two secondary dispatch tables: one containing pointers to thunks
3908 -- and another containing pointers to the primitives covering the
3909 -- interface primitives. The former secondary table is generated when
3910 -- Build_Thunks is True, and provides common support for dispatching
3911 -- calls through interface types; the latter secondary table is
3912 -- generated when Build_Thunks is False, and provides support for
3913 -- Generic Dispatching Constructors that dispatch calls through
3914 -- interface types. When constructing this latter table the value of
3915 -- Suffix_Index is -1 to indicate that there is no need to export such
3916 -- table when building statically allocated dispatch tables; a positive
3917 -- value of Suffix_Index must match the Suffix_Index value assigned to
3918 -- this secondary dispatch table by Make_Tags when its unique external
3919 -- name was generated.
3921 function Number_Of_Predefined_Prims
(Typ
: Entity_Id
) return Nat
;
3922 -- Returns the number of predefined primitives of Typ
3924 ------------------------------
3925 -- Check_Premature_Freezing --
3926 ------------------------------
3928 procedure Check_Premature_Freezing
3930 Tagged_Type
: Entity_Id
;
3935 function Is_Actual_For_Formal_Incomplete_Type
3936 (T
: Entity_Id
) return Boolean;
3937 -- In Ada 2012, if a nested generic has an incomplete formal type,
3938 -- the actual may be (and usually is) a private type whose completion
3939 -- appears later. It is safe to build the dispatch table in this
3940 -- case, gigi will have full views available.
3942 ------------------------------------------
3943 -- Is_Actual_For_Formal_Incomplete_Type --
3944 ------------------------------------------
3946 function Is_Actual_For_Formal_Incomplete_Type
3947 (T
: Entity_Id
) return Boolean
3949 Gen_Par
: Entity_Id
;
3953 if not Is_Generic_Instance
(Current_Scope
)
3954 or else not Used_As_Generic_Actual
(T
)
3958 Gen_Par
:= Generic_Parent
(Parent
(Current_Scope
));
3963 (Generic_Formal_Declarations
3964 (Unit_Declaration_Node
(Gen_Par
)));
3965 while Present
(F
) loop
3966 if Ekind
(Defining_Identifier
(F
)) = E_Incomplete_Type
then
3974 end Is_Actual_For_Formal_Incomplete_Type
;
3976 -- Start of processing for Check_Premature_Freezing
3979 -- Note that if the type is a (subtype of) a generic actual, the
3980 -- actual will have been frozen by the instantiation.
3983 and then Is_Private_Type
(Typ
)
3984 and then No
(Full_View
(Typ
))
3985 and then not Is_Generic_Type
(Typ
)
3986 and then not Is_Tagged_Type
(Typ
)
3987 and then not Is_Frozen
(Typ
)
3988 and then not Is_Generic_Actual_Type
(Typ
)
3990 Error_Msg_Sloc
:= Sloc
(Subp
);
3992 ("declaration must appear after completion of type &", N
, Typ
);
3994 ("\which is an untagged type in the profile of "
3995 & "primitive operation & declared#", N
, Subp
);
3998 Comp
:= Private_Component
(Typ
);
4000 if not Is_Tagged_Type
(Typ
)
4001 and then Present
(Comp
)
4002 and then not Is_Frozen
(Comp
)
4003 and then not Is_Actual_For_Formal_Incomplete_Type
(Comp
)
4005 Error_Msg_Sloc
:= Sloc
(Subp
);
4006 Error_Msg_Node_2
:= Subp
;
4007 Error_Msg_Name_1
:= Chars
(Tagged_Type
);
4009 ("declaration must appear after completion of type &",
4012 ("\which is a component of untagged type& in the profile "
4013 & "of primitive & of type % that is frozen by the "
4014 & "declaration ", N
, Typ
);
4017 end Check_Premature_Freezing
;
4023 procedure Export_DT
(Typ
: Entity_Id
; DT
: Entity_Id
; Index
: Nat
:= 0)
4029 Set_Is_Statically_Allocated
(DT
);
4030 Set_Is_True_Constant
(DT
);
4031 Set_Is_Exported
(DT
);
4034 Elmt
:= First_Elmt
(Dispatch_Table_Wrappers
(Typ
));
4035 while Count
/= Index
loop
4040 pragma Assert
(Related_Type
(Node
(Elmt
)) = Typ
);
4042 Get_External_Name
(Node
(Elmt
));
4043 Set_Interface_Name
(DT
,
4044 Make_String_Literal
(Loc
,
4045 Strval
=> String_From_Name_Buffer
));
4047 -- Ensure proper Sprint output of this implicit importation
4049 Set_Is_Internal
(DT
);
4053 -----------------------
4054 -- Make_Secondary_DT --
4055 -----------------------
4057 procedure Make_Secondary_DT
4060 Iface_Comp
: Node_Id
;
4062 Num_Iface_Prims
: Nat
;
4063 Iface_DT_Ptr
: Entity_Id
;
4064 Predef_Prims_Ptr
: Entity_Id
;
4065 Build_Thunks
: Boolean;
4068 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
4069 Exporting_Table
: constant Boolean :=
4070 Building_Static_DT
(Typ
)
4071 and then Suffix_Index
> 0;
4072 Iface_DT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
4073 Predef_Prims
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
4074 DT_Constr_List
: List_Id
;
4075 DT_Aggr_List
: List_Id
;
4076 Empty_DT
: Boolean := False;
4080 OSD_Aggr_List
: List_Id
;
4082 Prim_Elmt
: Elmt_Id
;
4083 Prim_Ops_Aggr_List
: List_Id
;
4086 -- Handle cases in which we do not generate statically allocated
4089 if not Building_Static_DT
(Typ
) then
4090 Set_Ekind
(Predef_Prims
, E_Variable
);
4091 Set_Ekind
(Iface_DT
, E_Variable
);
4093 -- Statically allocated dispatch tables and related entities are
4097 Set_Ekind
(Predef_Prims
, E_Constant
);
4098 Set_Is_Statically_Allocated
(Predef_Prims
);
4099 Set_Is_True_Constant
(Predef_Prims
);
4101 Set_Ekind
(Iface_DT
, E_Constant
);
4102 Set_Is_Statically_Allocated
(Iface_DT
);
4103 Set_Is_True_Constant
(Iface_DT
);
4106 -- Calculate the number of slots of the dispatch table. If the number
4107 -- of primitives of Typ is 0 we reserve a dummy single entry for its
4108 -- DT because at run time the pointer to this dummy entry will be
4111 if Num_Iface_Prims
= 0 then
4115 Nb_Prim
:= Num_Iface_Prims
;
4120 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
4121 -- (predef-prim-op-thunk-1'address,
4122 -- predef-prim-op-thunk-2'address,
4124 -- predef-prim-op-thunk-n'address);
4126 -- Create the thunks associated with the predefined primitives and
4127 -- save their entity to fill the aggregate.
4130 Nb_P_Prims
: constant Nat
:= Number_Of_Predefined_Prims
(Typ
);
4131 Prim_Table
: array (Nat
range 1 .. Nb_P_Prims
) of Entity_Id
;
4133 Thunk_Id
: Entity_Id
;
4134 Thunk_Code
: Node_Id
;
4137 Prim_Ops_Aggr_List
:= New_List
;
4138 Prim_Table
:= (others => Empty
);
4140 if Building_Static_DT
(Typ
) then
4141 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4142 while Present
(Prim_Elmt
) loop
4143 Prim
:= Node
(Prim_Elmt
);
4145 if Is_Predefined_Dispatching_Operation
(Prim
)
4146 and then not Is_Abstract_Subprogram
(Prim
)
4147 and then not Is_Eliminated
(Prim
)
4148 and then not Generate_SCIL
4149 and then not Present
(Prim_Table
4150 (UI_To_Int
(DT_Position
(Prim
))))
4152 if not Build_Thunks
then
4153 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) :=
4157 Expand_Interface_Thunk
4158 (Prim
, Thunk_Id
, Thunk_Code
, Iface
);
4160 if Present
(Thunk_Id
) then
4161 Append_To
(Result
, Thunk_Code
);
4162 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) :=
4168 Next_Elmt
(Prim_Elmt
);
4172 for J
in Prim_Table
'Range loop
4173 if Present
(Prim_Table
(J
)) then
4175 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
4176 Make_Attribute_Reference
(Loc
,
4177 Prefix
=> New_Occurrence_Of
(Prim_Table
(J
), Loc
),
4178 Attribute_Name
=> Name_Unrestricted_Access
));
4180 New_Node
:= Make_Null
(Loc
);
4183 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
4187 Make_Aggregate
(Loc
, Expressions
=> Prim_Ops_Aggr_List
);
4189 -- Remember aggregates initializing dispatch tables
4191 Append_Elmt
(New_Node
, DT_Aggr
);
4194 Make_Subtype_Declaration
(Loc
,
4195 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
4196 Subtype_Indication
=>
4197 New_Occurrence_Of
(RTE
(RE_Address_Array
), Loc
));
4199 Append_To
(Result
, Decl
);
4202 Make_Object_Declaration
(Loc
,
4203 Defining_Identifier
=> Predef_Prims
,
4204 Constant_Present
=> Building_Static_DT
(Typ
),
4205 Aliased_Present
=> True,
4206 Object_Definition
=> New_Occurrence_Of
4207 (Defining_Identifier
(Decl
), Loc
),
4208 Expression
=> New_Node
));
4213 -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
4214 -- (OSD_Table => (1 => <value>,
4217 -- for OSD'Alignment use Address'Alignment;
4219 -- Iface_DT : Dispatch_Table (Nb_Prims) :=
4220 -- ([ Signature => <sig-value> ],
4221 -- Tag_Kind => <tag_kind-value>,
4222 -- Predef_Prims => Predef_Prims'Address,
4223 -- Offset_To_Top => 0,
4224 -- OSD => OSD'Address,
4225 -- Prims_Ptr => (prim-op-1'address,
4226 -- prim-op-2'address,
4228 -- prim-op-n'address));
4230 -- Stage 3: Initialize the discriminant and the record components
4232 DT_Constr_List
:= New_List
;
4233 DT_Aggr_List
:= New_List
;
4237 Append_To
(DT_Constr_List
, Make_Integer_Literal
(Loc
, Nb_Prim
));
4238 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, Nb_Prim
));
4242 if RTE_Record_Component_Available
(RE_Signature
) then
4243 Append_To
(DT_Aggr_List
,
4244 New_Occurrence_Of
(RTE
(RE_Secondary_DT
), Loc
));
4249 if RTE_Record_Component_Available
(RE_Tag_Kind
) then
4250 Append_To
(DT_Aggr_List
, Tagged_Kind
(Typ
));
4255 Append_To
(DT_Aggr_List
,
4256 Make_Attribute_Reference
(Loc
,
4257 Prefix
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
4258 Attribute_Name
=> Name_Address
));
4260 -- Interface component located at variable offset; the value of
4261 -- Offset_To_Top will be set by the init subprogram.
4263 if No
(Dummy_Object
)
4264 or else Is_Variable_Size_Record
(Etype
(Scope
(Iface_Comp
)))
4266 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
4268 -- Interface component located at fixed offset
4271 Append_To
(DT_Aggr_List
,
4273 Make_Attribute_Reference
(Loc
,
4275 Make_Selected_Component
(Loc
,
4277 New_Occurrence_Of
(Dummy_Object
, Loc
),
4279 New_Occurrence_Of
(Iface_Comp
, Loc
)),
4280 Attribute_Name
=> Name_Position
)));
4283 -- Generate the Object Specific Data table required to dispatch calls
4284 -- through synchronized interfaces.
4287 or else Is_Abstract_Type
(Typ
)
4288 or else Is_Controlled
(Typ
)
4289 or else Restriction_Active
(No_Dispatching_Calls
)
4290 or else not Is_Limited_Type
(Typ
)
4291 or else not Has_Interfaces
(Typ
)
4292 or else not Build_Thunks
4293 or else not RTE_Record_Component_Available
(RE_OSD_Table
)
4295 -- No OSD table required
4297 Append_To
(DT_Aggr_List
,
4298 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
4301 OSD_Aggr_List
:= New_List
;
4304 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
4306 Prim_Alias
: Entity_Id
;
4307 Prim_Elmt
: Elmt_Id
;
4313 Prim_Table
:= (others => Empty
);
4314 Prim_Alias
:= Empty
;
4316 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4317 while Present
(Prim_Elmt
) loop
4318 Prim
:= Node
(Prim_Elmt
);
4320 if Present
(Interface_Alias
(Prim
))
4321 and then Find_Dispatching_Type
4322 (Interface_Alias
(Prim
)) = Iface
4324 Prim_Alias
:= Interface_Alias
(Prim
);
4325 E
:= Ultimate_Alias
(Prim
);
4326 Pos
:= UI_To_Int
(DT_Position
(Prim_Alias
));
4328 if Present
(Prim_Table
(Pos
)) then
4329 pragma Assert
(Prim_Table
(Pos
) = E
);
4333 Prim_Table
(Pos
) := E
;
4335 Append_To
(OSD_Aggr_List
,
4336 Make_Component_Association
(Loc
,
4337 Choices
=> New_List
(
4338 Make_Integer_Literal
(Loc
,
4339 DT_Position
(Prim_Alias
))),
4341 Make_Integer_Literal
(Loc
,
4342 DT_Position
(Alias
(Prim
)))));
4348 Next_Elmt
(Prim_Elmt
);
4350 pragma Assert
(Count
= Nb_Prim
);
4353 OSD
:= Make_Temporary
(Loc
, 'I');
4356 Make_Object_Declaration
(Loc
,
4357 Defining_Identifier
=> OSD
,
4358 Constant_Present
=> True,
4359 Object_Definition
=>
4360 Make_Subtype_Indication
(Loc
,
4362 New_Occurrence_Of
(RTE
(RE_Object_Specific_Data
), Loc
),
4364 Make_Index_Or_Discriminant_Constraint
(Loc
,
4365 Constraints
=> New_List
(
4366 Make_Integer_Literal
(Loc
, Nb_Prim
)))),
4369 Make_Aggregate
(Loc
,
4370 Component_Associations
=> New_List
(
4371 Make_Component_Association
(Loc
,
4372 Choices
=> New_List
(
4374 (RTE_Record_Component
(RE_OSD_Num_Prims
), Loc
)),
4376 Make_Integer_Literal
(Loc
, Nb_Prim
)),
4378 Make_Component_Association
(Loc
,
4379 Choices
=> New_List
(
4381 (RTE_Record_Component
(RE_OSD_Table
), Loc
)),
4382 Expression
=> Make_Aggregate
(Loc
,
4383 Component_Associations
=> OSD_Aggr_List
))))));
4386 Make_Attribute_Definition_Clause
(Loc
,
4387 Name
=> New_Occurrence_Of
(OSD
, Loc
),
4388 Chars
=> Name_Alignment
,
4390 Make_Attribute_Reference
(Loc
,
4392 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4393 Attribute_Name
=> Name_Alignment
)));
4395 -- In secondary dispatch tables the Typeinfo component contains
4396 -- the address of the Object Specific Data (see a-tags.ads).
4398 Append_To
(DT_Aggr_List
,
4399 Make_Attribute_Reference
(Loc
,
4400 Prefix
=> New_Occurrence_Of
(OSD
, Loc
),
4401 Attribute_Name
=> Name_Address
));
4404 -- Initialize the table of primitive operations
4406 Prim_Ops_Aggr_List
:= New_List
;
4409 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
4411 elsif Is_Abstract_Type
(Typ
)
4412 or else not Building_Static_DT
(Typ
)
4414 for J
in 1 .. Nb_Prim
loop
4415 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
4420 CPP_Nb_Prims
: constant Nat
:= CPP_Num_Prims
(Typ
);
4423 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
4424 Thunk_Code
: Node_Id
;
4425 Thunk_Id
: Entity_Id
;
4428 Prim_Table
:= (others => Empty
);
4430 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4431 while Present
(Prim_Elmt
) loop
4432 Prim
:= Node
(Prim_Elmt
);
4433 E
:= Ultimate_Alias
(Prim
);
4434 Prim_Pos
:= UI_To_Int
(DT_Position
(E
));
4436 -- Do not reference predefined primitives because they are
4437 -- located in a separate dispatch table; skip abstract and
4438 -- eliminated primitives; skip primitives located in the C++
4439 -- part of the dispatch table because their slot is set by
4442 if not Is_Predefined_Dispatching_Operation
(Prim
)
4443 and then Present
(Interface_Alias
(Prim
))
4444 and then not Is_Abstract_Subprogram
(Alias
(Prim
))
4445 and then not Is_Eliminated
(Alias
(Prim
))
4446 and then (not Is_CPP_Class
(Root_Type
(Typ
))
4447 or else Prim_Pos
> CPP_Nb_Prims
)
4448 and then Find_Dispatching_Type
4449 (Interface_Alias
(Prim
)) = Iface
4451 -- Generate the code of the thunk only if the abstract
4452 -- interface type is not an immediate ancestor of
4453 -- Tagged_Type. Otherwise the DT associated with the
4454 -- interface is the primary DT.
4456 and then not Is_Ancestor
(Iface
, Typ
,
4457 Use_Full_View
=> True)
4459 if not Build_Thunks
then
4461 UI_To_Int
(DT_Position
(Interface_Alias
(Prim
)));
4462 Prim_Table
(Prim_Pos
) := Alias
(Prim
);
4465 Expand_Interface_Thunk
4466 (Prim
, Thunk_Id
, Thunk_Code
, Iface
);
4468 if Present
(Thunk_Id
) then
4470 UI_To_Int
(DT_Position
(Interface_Alias
(Prim
)));
4472 Prim_Table
(Prim_Pos
) := Thunk_Id
;
4473 Append_To
(Result
, Thunk_Code
);
4478 Next_Elmt
(Prim_Elmt
);
4481 for J
in Prim_Table
'Range loop
4482 if Present
(Prim_Table
(J
)) then
4484 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
4485 Make_Attribute_Reference
(Loc
,
4486 Prefix
=> New_Occurrence_Of
(Prim_Table
(J
), Loc
),
4487 Attribute_Name
=> Name_Unrestricted_Access
));
4490 New_Node
:= Make_Null
(Loc
);
4493 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
4499 Make_Aggregate
(Loc
,
4500 Expressions
=> Prim_Ops_Aggr_List
);
4502 Append_To
(DT_Aggr_List
, New_Node
);
4504 -- Remember aggregates initializing dispatch tables
4506 Append_Elmt
(New_Node
, DT_Aggr
);
4508 -- Note: Secondary dispatch tables are declared constant only if
4509 -- we can compute their offset field by means of the extra dummy
4510 -- object; otherwise they cannot be declared constant and the
4511 -- Offset_To_Top component is initialized by the IP routine.
4514 Make_Object_Declaration
(Loc
,
4515 Defining_Identifier
=> Iface_DT
,
4516 Aliased_Present
=> True,
4517 Constant_Present
=> Building_Static_Secondary_DT
(Typ
),
4519 Object_Definition
=>
4520 Make_Subtype_Indication
(Loc
,
4521 Subtype_Mark
=> New_Occurrence_Of
4522 (RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
4523 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
4524 Constraints
=> DT_Constr_List
)),
4527 Make_Aggregate
(Loc
,
4528 Expressions
=> DT_Aggr_List
)));
4530 if Exporting_Table
then
4531 Export_DT
(Typ
, Iface_DT
, Suffix_Index
);
4533 -- Generate code to create the pointer to the dispatch table
4535 -- Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address);
4537 -- Note: This declaration is not added here if the table is exported
4538 -- because in such case Make_Tags has already added this declaration.
4542 Make_Object_Declaration
(Loc
,
4543 Defining_Identifier
=> Iface_DT_Ptr
,
4544 Constant_Present
=> True,
4546 Object_Definition
=>
4547 New_Occurrence_Of
(RTE
(RE_Interface_Tag
), Loc
),
4550 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
4551 Make_Attribute_Reference
(Loc
,
4553 Make_Selected_Component
(Loc
,
4554 Prefix
=> New_Occurrence_Of
(Iface_DT
, Loc
),
4557 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
4558 Attribute_Name
=> Name_Address
))));
4562 Make_Object_Declaration
(Loc
,
4563 Defining_Identifier
=> Predef_Prims_Ptr
,
4564 Constant_Present
=> True,
4566 Object_Definition
=>
4567 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
4570 Make_Attribute_Reference
(Loc
,
4572 Make_Selected_Component
(Loc
,
4573 Prefix
=> New_Occurrence_Of
(Iface_DT
, Loc
),
4576 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
4577 Attribute_Name
=> Name_Address
)));
4579 -- Remember entities containing dispatch tables
4581 Append_Elmt
(Predef_Prims
, DT_Decl
);
4582 Append_Elmt
(Iface_DT
, DT_Decl
);
4583 end Make_Secondary_DT
;
4585 --------------------------------
4586 -- Number_Of_Predefined_Prims --
4587 --------------------------------
4589 function Number_Of_Predefined_Prims
(Typ
: Entity_Id
) return Nat
is
4590 Nb_Predef_Prims
: Nat
:= 0;
4593 if not Generate_SCIL
then
4596 Prim_Elmt
: Elmt_Id
;
4600 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4601 while Present
(Prim_Elmt
) loop
4602 Prim
:= Node
(Prim_Elmt
);
4604 if Is_Predefined_Dispatching_Operation
(Prim
)
4605 and then not Is_Abstract_Subprogram
(Prim
)
4607 Pos
:= UI_To_Int
(DT_Position
(Prim
));
4609 if Pos
> Nb_Predef_Prims
then
4610 Nb_Predef_Prims
:= Pos
;
4614 Next_Elmt
(Prim_Elmt
);
4619 pragma Assert
(Nb_Predef_Prims
<= Max_Predef_Prims
);
4620 return Nb_Predef_Prims
;
4621 end Number_Of_Predefined_Prims
;
4625 Elab_Code
: constant List_Id
:= New_List
;
4626 Result
: constant List_Id
:= New_List
;
4627 Tname
: constant Name_Id
:= Chars
(Typ
);
4629 -- When pragmas Discard_Names and No_Tagged_Streams simultaneously apply
4630 -- we initialize the Expanded_Name and the External_Tag of this tagged
4631 -- type with an empty string. This is useful to avoid exposing entity
4632 -- names at binary level. It can be done when both pragmas apply because
4633 -- (1) Discard_Names allows initializing Expanded_Name with an
4634 -- implementation defined value (Ada RM Section C.5 (7/2)).
4635 -- (2) External_Tag (combined with Internal_Tag) is used for object
4636 -- streaming and No_Tagged_Streams inhibits the generation of
4639 Discard_Names
: constant Boolean :=
4640 Present
(No_Tagged_Streams_Pragma
(Typ
))
4641 and then (Global_Discard_Names
4642 or else Einfo
.Discard_Names
(Typ
));
4644 -- The following name entries are used by Make_DT to generate a number
4645 -- of entities related to a tagged type. These entities may be generated
4646 -- in a scope other than that of the tagged type declaration, and if
4647 -- the entities for two tagged types with the same name happen to be
4648 -- generated in the same scope, we have to take care to use different
4649 -- names. This is achieved by means of a unique serial number appended
4650 -- to each generated entity name.
4652 Name_DT
: constant Name_Id
:=
4653 New_External_Name
(Tname
, 'T', Suffix_Index
=> -1);
4654 Name_Exname
: constant Name_Id
:=
4655 New_External_Name
(Tname
, 'E', Suffix_Index
=> -1);
4656 Name_HT_Link
: constant Name_Id
:=
4657 New_External_Name
(Tname
, 'H', Suffix_Index
=> -1);
4658 Name_Predef_Prims
: constant Name_Id
:=
4659 New_External_Name
(Tname
, 'R', Suffix_Index
=> -1);
4660 Name_SSD
: constant Name_Id
:=
4661 New_External_Name
(Tname
, 'S', Suffix_Index
=> -1);
4662 Name_TSD
: constant Name_Id
:=
4663 New_External_Name
(Tname
, 'B', Suffix_Index
=> -1);
4665 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
4666 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
4667 -- Save the Ghost-related attributes to restore on exit
4670 AI_Tag_Elmt
: Elmt_Id
;
4671 AI_Tag_Comp
: Elmt_Id
;
4673 DT_Aggr_List
: List_Id
;
4674 DT_Constr_List
: List_Id
;
4677 HT_Link
: Entity_Id
;
4680 Iface_Table_Node
: Node_Id
;
4681 Name_ITable
: Name_Id
;
4684 Num_Ifaces
: Nat
:= 0;
4685 Parent_Typ
: Entity_Id
;
4686 Predef_Prims
: Entity_Id
;
4688 Prim_Elmt
: Elmt_Id
;
4689 Prim_Ops_Aggr_List
: List_Id
;
4692 Typ_Comps
: Elist_Id
;
4693 Typ_Ifaces
: Elist_Id
;
4695 TSD_Aggr_List
: List_Id
;
4696 TSD_Tags_List
: List_Id
;
4698 -- Start of processing for Make_DT
4701 pragma Assert
(Is_Frozen
(Typ
));
4703 -- The tagged type being processed may be subject to pragma Ghost. Set
4704 -- the mode now to ensure that any nodes generated during dispatch table
4705 -- creation are properly marked as Ghost.
4707 Set_Ghost_Mode
(Typ
);
4709 -- Handle cases in which there is no need to build the dispatch table
4711 if Has_Dispatch_Table
(Typ
)
4712 or else No
(Access_Disp_Table
(Typ
))
4713 or else Is_CPP_Class
(Typ
)
4717 elsif No_Run_Time_Mode
then
4718 Error_Msg_CRT
("tagged types", Typ
);
4721 elsif not RTE_Available
(RE_Tag
) then
4723 Make_Object_Declaration
(Loc
,
4724 Defining_Identifier
=>
4725 Node
(First_Elmt
(Access_Disp_Table
(Typ
))),
4726 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
4727 Constant_Present
=> True,
4729 Unchecked_Convert_To
(RTE
(RE_Tag
),
4730 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
4732 Analyze_List
(Result
, Suppress
=> All_Checks
);
4733 Error_Msg_CRT
("tagged types", Typ
);
4737 -- Ensure that the value of Max_Predef_Prims defined in a-tags is
4738 -- correct. Valid values are 10 under configurable runtime or 16
4739 -- with full runtime.
4741 if RTE_Available
(RE_Interface_Data
) then
4742 if Max_Predef_Prims
/= 16 then
4743 Error_Msg_N
("run-time library configuration error", Typ
);
4747 if Max_Predef_Prims
/= 10 then
4748 Error_Msg_N
("run-time library configuration error", Typ
);
4749 Error_Msg_CRT
("tagged types", Typ
);
4754 DT
:= Make_Defining_Identifier
(Loc
, Name_DT
);
4755 Exname
:= Make_Defining_Identifier
(Loc
, Name_Exname
);
4756 HT_Link
:= Make_Defining_Identifier
(Loc
, Name_HT_Link
);
4757 Predef_Prims
:= Make_Defining_Identifier
(Loc
, Name_Predef_Prims
);
4758 SSD
:= Make_Defining_Identifier
(Loc
, Name_SSD
);
4759 TSD
:= Make_Defining_Identifier
(Loc
, Name_TSD
);
4761 -- Initialize Parent_Typ handling private types
4763 Parent_Typ
:= Etype
(Typ
);
4765 if Present
(Full_View
(Parent_Typ
)) then
4766 Parent_Typ
:= Full_View
(Parent_Typ
);
4769 -- Ensure that all the primitives are frozen. This is only required when
4770 -- building static dispatch tables --- the primitives must be frozen to
4771 -- be referenced (otherwise we have problems with the backend). It is
4772 -- not a requirement with nonstatic dispatch tables because in this case
4773 -- we generate now an empty dispatch table; the extra code required to
4774 -- register the primitives in the slots will be generated later --- when
4775 -- each primitive is frozen (see Freeze_Subprogram).
4777 if Building_Static_DT
(Typ
) then
4779 Saved_FLLTT
: constant Boolean :=
4780 Freezing_Library_Level_Tagged_Type
;
4785 Prim_Elmt
: Elmt_Id
;
4788 Freezing_Library_Level_Tagged_Type
:= True;
4790 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4791 while Present
(Prim_Elmt
) loop
4792 Prim
:= Node
(Prim_Elmt
);
4793 Frnodes
:= Freeze_Entity
(Prim
, Typ
);
4795 -- We disable this check for abstract subprograms, given that
4796 -- they cannot be called directly and thus the state of their
4797 -- untagged formals is of no concern. The RM is unclear in any
4798 -- case concerning the need for this check, and this topic may
4799 -- go back to the ARG.
4801 if not Is_Abstract_Subprogram
(Prim
) then
4802 Formal
:= First_Formal
(Prim
);
4803 while Present
(Formal
) loop
4804 Check_Premature_Freezing
(Prim
, Typ
, Etype
(Formal
));
4805 Next_Formal
(Formal
);
4808 Check_Premature_Freezing
(Prim
, Typ
, Etype
(Prim
));
4811 if Present
(Frnodes
) then
4812 Append_List_To
(Result
, Frnodes
);
4815 Next_Elmt
(Prim_Elmt
);
4818 Freezing_Library_Level_Tagged_Type
:= Saved_FLLTT
;
4822 if not Is_Interface
(Typ
) and then Has_Interfaces
(Typ
) then
4824 Cannot_Have_Null_Disc
: Boolean := False;
4825 Dummy_Object_Typ
: constant Entity_Id
:= Typ
;
4826 Name_Dummy_Object
: constant Name_Id
:=
4827 New_External_Name
(Tname
,
4828 'P', Suffix_Index
=> -1);
4830 Dummy_Object
:= Make_Defining_Identifier
(Loc
, Name_Dummy_Object
);
4832 -- Define the extra object imported and constant to avoid linker
4833 -- errors (since this object is never declared). Required because
4834 -- we implement RM 13.3(19) for exported and imported (variable)
4835 -- objects by making them volatile.
4837 Set_Is_Imported
(Dummy_Object
);
4838 Set_Ekind
(Dummy_Object
, E_Constant
);
4839 Set_Is_True_Constant
(Dummy_Object
);
4840 Set_Related_Type
(Dummy_Object
, Typ
);
4842 -- The scope must be set now to call Get_External_Name
4844 Set_Scope
(Dummy_Object
, Current_Scope
);
4846 Get_External_Name
(Dummy_Object
);
4847 Set_Interface_Name
(Dummy_Object
,
4848 Make_String_Literal
(Loc
, Strval
=> String_From_Name_Buffer
));
4850 -- Ensure proper Sprint output of this implicit importation
4852 Set_Is_Internal
(Dummy_Object
);
4854 if not Has_Discriminants
(Dummy_Object_Typ
) then
4856 Make_Object_Declaration
(Loc
,
4857 Defining_Identifier
=> Dummy_Object
,
4858 Constant_Present
=> True,
4859 Object_Definition
=> New_Occurrence_Of
4860 (Dummy_Object_Typ
, Loc
)));
4863 Constr_List
: constant List_Id
:= New_List
;
4867 Discrim
:= First_Discriminant
(Dummy_Object_Typ
);
4868 while Present
(Discrim
) loop
4869 if Is_Discrete_Type
(Etype
(Discrim
)) then
4870 Append_To
(Constr_List
,
4871 Make_Attribute_Reference
(Loc
,
4873 New_Occurrence_Of
(Etype
(Discrim
), Loc
),
4874 Attribute_Name
=> Name_First
));
4877 pragma Assert
(Is_Access_Type
(Etype
(Discrim
)));
4878 Cannot_Have_Null_Disc
:=
4879 Cannot_Have_Null_Disc
4880 or else Can_Never_Be_Null
(Etype
(Discrim
));
4881 Append_To
(Constr_List
, Make_Null
(Loc
));
4884 Next_Discriminant
(Discrim
);
4888 Make_Object_Declaration
(Loc
,
4889 Defining_Identifier
=> Dummy_Object
,
4890 Constant_Present
=> True,
4891 Object_Definition
=>
4892 Make_Subtype_Indication
(Loc
,
4894 New_Occurrence_Of
(Dummy_Object_Typ
, Loc
),
4896 Make_Index_Or_Discriminant_Constraint
(Loc
,
4897 Constraints
=> Constr_List
))));
4901 -- Given that the dummy object will not be declared at run time,
4902 -- analyze its declaration with expansion disabled and warnings
4903 -- and error messages ignored.
4905 Expander_Mode_Save_And_Set
(False);
4906 Ignore_Errors_Enable
:= Ignore_Errors_Enable
+ 1;
4907 Analyze
(Last
(Result
), Suppress
=> All_Checks
);
4908 Ignore_Errors_Enable
:= Ignore_Errors_Enable
- 1;
4909 Expander_Mode_Restore
;
4913 -- Ada 2005 (AI-251): Build the secondary dispatch tables
4915 if Has_Interfaces
(Typ
) then
4916 Collect_Interface_Components
(Typ
, Typ_Comps
);
4918 -- Each secondary dispatch table is assigned an unique positive
4919 -- suffix index; such value also corresponds with the location of
4920 -- its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
4922 -- Note: This value must be kept sync with the Suffix_Index values
4923 -- generated by Make_Tags
4927 Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
4929 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
4930 while Present
(AI_Tag_Comp
) loop
4931 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'P'));
4933 -- Build the secondary table containing pointers to thunks
4938 Base_Type
(Related_Type
(Node
(AI_Tag_Comp
))),
4939 Iface_Comp
=> Node
(AI_Tag_Comp
),
4940 Suffix_Index
=> Suffix_Index
,
4942 UI_To_Int
(DT_Entry_Count
(Node
(AI_Tag_Comp
))),
4943 Iface_DT_Ptr
=> Node
(AI_Tag_Elmt
),
4944 Predef_Prims_Ptr
=> Node
(Next_Elmt
(AI_Tag_Elmt
)),
4945 Build_Thunks
=> True,
4948 -- Skip secondary dispatch table referencing thunks to predefined
4951 Next_Elmt
(AI_Tag_Elmt
);
4952 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'Y'));
4954 -- Secondary dispatch table referencing user-defined primitives
4955 -- covered by this interface.
4957 Next_Elmt
(AI_Tag_Elmt
);
4958 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'D'));
4960 -- Build the secondary table containing pointers to primitives
4961 -- (used to give support to Generic Dispatching Constructors).
4966 (Related_Type
(Node
(AI_Tag_Comp
))),
4967 Iface_Comp
=> Node
(AI_Tag_Comp
),
4969 Num_Iface_Prims
=> UI_To_Int
4970 (DT_Entry_Count
(Node
(AI_Tag_Comp
))),
4971 Iface_DT_Ptr
=> Node
(AI_Tag_Elmt
),
4972 Predef_Prims_Ptr
=> Node
(Next_Elmt
(AI_Tag_Elmt
)),
4973 Build_Thunks
=> False,
4976 -- Skip secondary dispatch table referencing predefined primitives
4978 Next_Elmt
(AI_Tag_Elmt
);
4979 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'Z'));
4981 Suffix_Index
:= Suffix_Index
+ 1;
4982 Next_Elmt
(AI_Tag_Elmt
);
4983 Next_Elmt
(AI_Tag_Comp
);
4987 -- Get the _tag entity and number of primitives of its dispatch table
4989 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
4990 Nb_Prim
:= UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Typ
)));
4992 if Generate_SCIL
then
4996 Set_Is_Statically_Allocated
(DT
, Is_Library_Level_Tagged_Type
(Typ
));
4997 Set_Is_Statically_Allocated
(SSD
, Is_Library_Level_Tagged_Type
(Typ
));
4998 Set_Is_Statically_Allocated
(TSD
, Is_Library_Level_Tagged_Type
(Typ
));
4999 Set_Is_Statically_Allocated
(Predef_Prims
,
5000 Is_Library_Level_Tagged_Type
(Typ
));
5002 -- In case of locally defined tagged type we declare the object
5003 -- containing the dispatch table by means of a variable. Its
5004 -- initialization is done later by means of an assignment. This is
5005 -- required to generate its External_Tag.
5007 if not Building_Static_DT
(Typ
) then
5010 -- DT : No_Dispatch_Table_Wrapper;
5011 -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
5013 if not Has_DT
(Typ
) then
5015 Make_Object_Declaration
(Loc
,
5016 Defining_Identifier
=> DT
,
5017 Aliased_Present
=> True,
5018 Constant_Present
=> False,
5019 Object_Definition
=>
5021 (RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
)));
5024 Make_Object_Declaration
(Loc
,
5025 Defining_Identifier
=> DT_Ptr
,
5026 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
5027 Constant_Present
=> True,
5029 Unchecked_Convert_To
(RTE
(RE_Tag
),
5030 Make_Attribute_Reference
(Loc
,
5032 Make_Selected_Component
(Loc
,
5033 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
5036 (RTE_Record_Component
(RE_NDT_Prims_Ptr
), Loc
)),
5037 Attribute_Name
=> Name_Address
))));
5039 Set_Is_Statically_Allocated
(DT_Ptr
,
5040 Is_Library_Level_Tagged_Type
(Typ
));
5042 -- Generate the SCIL node for the previous object declaration
5043 -- because it has a tag initialization.
5045 if Generate_SCIL
then
5047 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
5048 Set_SCIL_Entity
(New_Node
, Typ
);
5049 Set_SCIL_Node
(Last
(Result
), New_Node
);
5053 -- Gnat2scil has its own implementation of dispatch tables,
5054 -- different than what is being implemented here. Generating
5055 -- further dispatch table initialization code would just
5056 -- cause gnat2scil to generate useless Scil which CodePeer
5057 -- would waste time and space analyzing, so we skip it.
5061 -- DT : Dispatch_Table_Wrapper (Nb_Prim);
5062 -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
5065 -- If the tagged type has no primitives we add a dummy slot
5066 -- whose address will be the tag of this type.
5070 New_List
(Make_Integer_Literal
(Loc
, 1));
5073 New_List
(Make_Integer_Literal
(Loc
, Nb_Prim
));
5077 Make_Object_Declaration
(Loc
,
5078 Defining_Identifier
=> DT
,
5079 Aliased_Present
=> True,
5080 Constant_Present
=> False,
5081 Object_Definition
=>
5082 Make_Subtype_Indication
(Loc
,
5084 New_Occurrence_Of
(RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
5086 Make_Index_Or_Discriminant_Constraint
(Loc
,
5087 Constraints
=> DT_Constr_List
))));
5090 Make_Object_Declaration
(Loc
,
5091 Defining_Identifier
=> DT_Ptr
,
5092 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
5093 Constant_Present
=> True,
5095 Unchecked_Convert_To
(RTE
(RE_Tag
),
5096 Make_Attribute_Reference
(Loc
,
5098 Make_Selected_Component
(Loc
,
5099 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
5102 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
5103 Attribute_Name
=> Name_Address
))));
5105 Set_Is_Statically_Allocated
(DT_Ptr
,
5106 Is_Library_Level_Tagged_Type
(Typ
));
5108 -- Generate the SCIL node for the previous object declaration
5109 -- because it has a tag initialization.
5111 if Generate_SCIL
then
5113 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
5114 Set_SCIL_Entity
(New_Node
, Typ
);
5115 Set_SCIL_Node
(Last
(Result
), New_Node
);
5119 -- Gnat2scil has its own implementation of dispatch tables,
5120 -- different than what is being implemented here. Generating
5121 -- further dispatch table initialization code would just
5122 -- cause gnat2scil to generate useless Scil which CodePeer
5123 -- would waste time and space analyzing, so we skip it.
5127 Make_Object_Declaration
(Loc
,
5128 Defining_Identifier
=>
5129 Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
)))),
5130 Constant_Present
=> True,
5131 Object_Definition
=>
5132 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
5134 Make_Attribute_Reference
(Loc
,
5136 Make_Selected_Component
(Loc
,
5137 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
5140 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
5141 Attribute_Name
=> Name_Address
)));
5145 -- Generate: Expanded_Name : constant String := "";
5147 if Discard_Names
then
5149 Make_Object_Declaration
(Loc
,
5150 Defining_Identifier
=> Exname
,
5151 Constant_Present
=> True,
5152 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
5154 Make_String_Literal
(Loc
, "")));
5156 -- Generate: Exname : constant String := full_qualified_name (typ);
5157 -- The type itself may be an anonymous parent type, so use the first
5158 -- subtype to have a user-recognizable name.
5162 Make_Object_Declaration
(Loc
,
5163 Defining_Identifier
=> Exname
,
5164 Constant_Present
=> True,
5165 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
5167 Make_String_Literal
(Loc
,
5168 Fully_Qualified_Name_String
(First_Subtype
(Typ
)))));
5171 Set_Is_Statically_Allocated
(Exname
);
5172 Set_Is_True_Constant
(Exname
);
5174 -- Declare the object used by Ada.Tags.Register_Tag
5176 if RTE_Available
(RE_Register_Tag
) then
5178 Make_Object_Declaration
(Loc
,
5179 Defining_Identifier
=> HT_Link
,
5180 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
5181 Expression
=> New_Occurrence_Of
(RTE
(RE_No_Tag
), Loc
)));
5184 -- Generate code to create the storage for the type specific data object
5185 -- with enough space to store the tags of the ancestors plus the tags
5186 -- of all the implemented interfaces (as described in a-tags.adb).
5188 -- TSD : Type_Specific_Data (I_Depth) :=
5189 -- (Idepth => I_Depth,
5190 -- Access_Level => Type_Access_Level (Typ),
5191 -- Alignment => Typ'Alignment,
5192 -- Expanded_Name => Cstring_Ptr!(Exname'Address))
5193 -- External_Tag => Cstring_Ptr!(Exname'Address))
5194 -- HT_Link => HT_Link'Address,
5195 -- Transportable => <<boolean-value>>,
5196 -- Is_Abstract => <<boolean-value>>,
5197 -- Needs_Finalization => <<boolean-value>>,
5198 -- [ Size_Func => Size_Prim'Access, ]
5199 -- [ Interfaces_Table => <<access-value>>, ]
5200 -- [ SSD => SSD_Table'Address ]
5201 -- Tags_Table => (0 => null,
5205 TSD_Aggr_List
:= New_List
;
5207 -- Idepth: Count ancestors to compute the inheritance depth. For private
5208 -- extensions, always go to the full view in order to compute the real
5209 -- inheritance depth.
5212 Current_Typ
: Entity_Id
;
5213 Parent_Typ
: Entity_Id
;
5219 Parent_Typ
:= Etype
(Current_Typ
);
5221 if Is_Private_Type
(Parent_Typ
) then
5222 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
5225 exit when Parent_Typ
= Current_Typ
;
5227 I_Depth
:= I_Depth
+ 1;
5228 Current_Typ
:= Parent_Typ
;
5232 Append_To
(TSD_Aggr_List
,
5233 Make_Integer_Literal
(Loc
, I_Depth
));
5237 Append_To
(TSD_Aggr_List
,
5238 Make_Integer_Literal
(Loc
, Type_Access_Level
(Typ
)));
5242 -- For CPP types we cannot rely on the value of 'Alignment provided
5243 -- by the backend to initialize this TSD field.
5245 if Convention
(Typ
) = Convention_CPP
5246 or else Is_CPP_Class
(Root_Type
(Typ
))
5248 Append_To
(TSD_Aggr_List
,
5249 Make_Integer_Literal
(Loc
, 0));
5251 Append_To
(TSD_Aggr_List
,
5252 Make_Attribute_Reference
(Loc
,
5253 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
5254 Attribute_Name
=> Name_Alignment
));
5259 Append_To
(TSD_Aggr_List
,
5260 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5261 Make_Attribute_Reference
(Loc
,
5262 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5263 Attribute_Name
=> Name_Address
)));
5265 -- External_Tag of a local tagged type
5267 -- <typ>A : constant String :=
5268 -- "Internal tag at 16#tag-addr#: <full-name-of-typ>";
5270 -- The reason we generate this strange name is that we do not want to
5271 -- enter local tagged types in the global hash table used to compute
5272 -- the Internal_Tag attribute for two reasons:
5274 -- 1. It is hard to avoid a tasking race condition for entering the
5275 -- entry into the hash table.
5277 -- 2. It would cause a storage leak, unless we rig up considerable
5278 -- mechanism to remove the entry from the hash table on exit.
5280 -- So what we do is to generate the above external tag name, where the
5281 -- hex address is the address of the local dispatch table (i.e. exactly
5282 -- the value we want if Internal_Tag is computed from this string).
5284 -- Of course this value will only be valid if the tagged type is still
5285 -- in scope, but it clearly must be erroneous to compute the internal
5286 -- tag of a tagged type that is out of scope.
5288 -- We don't do this processing if an explicit external tag has been
5289 -- specified. That's an odd case for which we have already issued a
5290 -- warning, where we will not be able to compute the internal tag.
5292 if not Discard_Names
5293 and then not Is_Library_Level_Entity
(Typ
)
5294 and then not Has_External_Tag_Rep_Clause
(Typ
)
5297 Exname
: constant Entity_Id
:=
5298 Make_Defining_Identifier
(Loc
,
5299 Chars
=> New_External_Name
(Tname
, 'A'));
5300 Full_Name
: constant String_Id
:=
5301 Fully_Qualified_Name_String
(First_Subtype
(Typ
));
5302 Str1_Id
: String_Id
;
5303 Str2_Id
: String_Id
;
5307 -- Str1 = "Internal tag at 16#";
5310 Store_String_Chars
("Internal tag at 16#");
5311 Str1_Id
:= End_String
;
5314 -- Str2 = "#: <type-full-name>";
5317 Store_String_Chars
("#: ");
5318 Store_String_Chars
(Full_Name
);
5319 Str2_Id
:= End_String
;
5322 -- Exname : constant String :=
5323 -- Str1 & Address_Image (Tag) & Str2;
5325 if RTE_Available
(RE_Address_Image
) then
5327 Make_Object_Declaration
(Loc
,
5328 Defining_Identifier
=> Exname
,
5329 Constant_Present
=> True,
5330 Object_Definition
=> New_Occurrence_Of
5331 (Standard_String
, Loc
),
5333 Make_Op_Concat
(Loc
,
5334 Left_Opnd
=> Make_String_Literal
(Loc
, Str1_Id
),
5336 Make_Op_Concat
(Loc
,
5338 Make_Function_Call
(Loc
,
5341 (RTE
(RE_Address_Image
), Loc
),
5342 Parameter_Associations
=> New_List
(
5343 Unchecked_Convert_To
(RTE
(RE_Address
),
5344 New_Occurrence_Of
(DT_Ptr
, Loc
)))),
5346 Make_String_Literal
(Loc
, Str2_Id
)))));
5349 -- Exname : constant String := Str1 & Str2;
5353 Make_Object_Declaration
(Loc
,
5354 Defining_Identifier
=> Exname
,
5355 Constant_Present
=> True,
5356 Object_Definition
=>
5357 New_Occurrence_Of
(Standard_String
, Loc
),
5359 Make_Op_Concat
(Loc
,
5360 Left_Opnd
=> Make_String_Literal
(Loc
, Str1_Id
),
5361 Right_Opnd
=> Make_String_Literal
(Loc
, Str2_Id
))));
5365 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5366 Make_Attribute_Reference
(Loc
,
5367 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5368 Attribute_Name
=> Name_Address
));
5371 -- External tag of a library-level tagged type: Check for a definition
5372 -- of External_Tag. The clause is considered only if it applies to this
5373 -- specific tagged type, as opposed to one of its ancestors.
5374 -- If the type is an unconstrained type extension, we are building the
5375 -- dispatch table of its anonymous base type, so the external tag, if
5376 -- any was specified, must be retrieved from the first subtype. Go to
5377 -- the full view in case the clause is in the private part.
5381 Def
: constant Node_Id
:= Get_Attribute_Definition_Clause
5382 (Underlying_Type
(First_Subtype
(Typ
)),
5383 Attribute_External_Tag
);
5385 Old_Val
: String_Id
;
5386 New_Val
: String_Id
;
5390 if not Present
(Def
)
5391 or else Entity
(Name
(Def
)) /= First_Subtype
(Typ
)
5394 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5395 Make_Attribute_Reference
(Loc
,
5396 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5397 Attribute_Name
=> Name_Address
));
5399 Old_Val
:= Strval
(Expr_Value_S
(Expression
(Def
)));
5401 -- For the rep clause "for <typ>'external_tag use y" generate:
5403 -- <typ>A : constant string := y;
5405 -- <typ>A'Address is used to set the External_Tag component
5408 -- Create a new nul terminated string if it is not already
5410 if String_Length
(Old_Val
) > 0
5412 Get_String_Char
(Old_Val
, String_Length
(Old_Val
)) = 0
5416 Start_String
(Old_Val
);
5417 Store_String_Char
(Get_Char_Code
(ASCII
.NUL
));
5418 New_Val
:= End_String
;
5421 E
:= Make_Defining_Identifier
(Loc
,
5422 New_External_Name
(Chars
(Typ
), 'A'));
5425 Make_Object_Declaration
(Loc
,
5426 Defining_Identifier
=> E
,
5427 Constant_Present
=> True,
5428 Object_Definition
=>
5429 New_Occurrence_Of
(Standard_String
, Loc
),
5431 Make_String_Literal
(Loc
, New_Val
)));
5434 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5435 Make_Attribute_Reference
(Loc
,
5436 Prefix
=> New_Occurrence_Of
(E
, Loc
),
5437 Attribute_Name
=> Name_Address
));
5442 Append_To
(TSD_Aggr_List
, New_Node
);
5446 if RTE_Available
(RE_Register_Tag
) then
5447 Append_To
(TSD_Aggr_List
,
5448 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
5449 Make_Attribute_Reference
(Loc
,
5450 Prefix
=> New_Occurrence_Of
(HT_Link
, Loc
),
5451 Attribute_Name
=> Name_Address
)));
5453 elsif RTE_Record_Component_Available
(RE_HT_Link
) then
5454 Append_To
(TSD_Aggr_List
,
5455 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
5456 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5459 -- Transportable: Set for types that can be used in remote calls
5460 -- with respect to E.4(18) legality rules.
5463 Transportable
: Entity_Id
;
5469 or else Is_Shared_Passive
(Typ
)
5471 ((Is_Remote_Types
(Typ
)
5472 or else Is_Remote_Call_Interface
(Typ
))
5473 and then Original_View_In_Visible_Part
(Typ
))
5474 or else not Comes_From_Source
(Typ
));
5476 Append_To
(TSD_Aggr_List
,
5477 New_Occurrence_Of
(Transportable
, Loc
));
5480 -- Is_Abstract (Ada 2012: AI05-0173). This functionality is not
5481 -- available in the HIE runtime.
5483 if RTE_Record_Component_Available
(RE_Is_Abstract
) then
5485 Is_Abstract
: Entity_Id
;
5487 Is_Abstract
:= Boolean_Literals
(Is_Abstract_Type
(Typ
));
5488 Append_To
(TSD_Aggr_List
,
5489 New_Occurrence_Of
(Is_Abstract
, Loc
));
5493 -- Needs_Finalization: Set if the type is controlled or has controlled
5497 Needs_Fin
: Entity_Id
;
5499 Needs_Fin
:= Boolean_Literals
(Needs_Finalization
(Typ
));
5500 Append_To
(TSD_Aggr_List
, New_Occurrence_Of
(Needs_Fin
, Loc
));
5505 if RTE_Record_Component_Available
(RE_Size_Func
) then
5507 -- Initialize this field to Null_Address if we are not building
5508 -- static dispatch tables static or if the size function is not
5509 -- available. In the former case we cannot initialize this field
5510 -- until the function is frozen and registered in the dispatch
5511 -- table (see Register_Primitive).
5513 if not Building_Static_DT
(Typ
) or else not Has_DT
(Typ
) then
5514 Append_To
(TSD_Aggr_List
,
5515 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5516 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5520 Prim_Elmt
: Elmt_Id
;
5522 Size_Comp
: Node_Id
:= Empty
;
5525 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5526 while Present
(Prim_Elmt
) loop
5527 Prim
:= Node
(Prim_Elmt
);
5529 if Chars
(Prim
) = Name_uSize
then
5530 Prim
:= Ultimate_Alias
(Prim
);
5532 if Is_Abstract_Subprogram
(Prim
) then
5534 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5535 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
5538 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5539 Make_Attribute_Reference
(Loc
,
5540 Prefix
=> New_Occurrence_Of
(Prim
, Loc
),
5541 Attribute_Name
=> Name_Unrestricted_Access
));
5547 Next_Elmt
(Prim_Elmt
);
5550 pragma Assert
(Present
(Size_Comp
));
5551 Append_To
(TSD_Aggr_List
, Size_Comp
);
5556 -- Interfaces_Table (required for AI-405)
5558 if RTE_Record_Component_Available
(RE_Interfaces_Table
) then
5560 -- Count the number of interface types implemented by Typ
5562 Collect_Interfaces
(Typ
, Typ_Ifaces
);
5564 AI
:= First_Elmt
(Typ_Ifaces
);
5565 while Present
(AI
) loop
5566 Num_Ifaces
:= Num_Ifaces
+ 1;
5570 if Num_Ifaces
= 0 then
5571 Iface_Table_Node
:= Make_Null
(Loc
);
5573 -- Generate the Interface_Table object
5577 TSD_Ifaces_List
: constant List_Id
:= New_List
;
5579 Offset_To_Top
: Node_Id
;
5580 Sec_DT_Tag
: Node_Id
;
5582 Dummy_Object_Ifaces_List
: Elist_Id
:= No_Elist
;
5583 Dummy_Object_Ifaces_Comp_List
: Elist_Id
:= No_Elist
;
5584 Dummy_Object_Ifaces_Tag_List
: Elist_Id
:= No_Elist
;
5585 -- Interfaces information of the dummy object
5588 -- Collect interfaces information if we need to compute the
5589 -- offset to the top using the dummy object.
5591 if Present
(Dummy_Object
) then
5592 Collect_Interfaces_Info
(Typ
,
5593 Ifaces_List
=> Dummy_Object_Ifaces_List
,
5594 Components_List
=> Dummy_Object_Ifaces_Comp_List
,
5595 Tags_List
=> Dummy_Object_Ifaces_Tag_List
);
5598 AI
:= First_Elmt
(Typ_Ifaces
);
5599 while Present
(AI
) loop
5600 if Is_Ancestor
(Node
(AI
), Typ
, Use_Full_View
=> True) then
5601 Sec_DT_Tag
:= New_Occurrence_Of
(DT_Ptr
, Loc
);
5606 (Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
5607 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5609 while Is_Tag
(Node
(Elmt
))
5611 Is_Ancestor
(Node
(AI
), Related_Type
(Node
(Elmt
)),
5612 Use_Full_View
=> True)
5614 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5616 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5618 pragma Assert
(not Has_Thunks
(Node
(Elmt
)));
5620 pragma Assert
(not Has_Thunks
(Node
(Elmt
)));
5624 pragma Assert
(Ekind
(Node
(Elmt
)) = E_Constant
5626 Has_Thunks
(Node
(Next_Elmt
(Next_Elmt
(Elmt
)))));
5630 (Node
(Next_Elmt
(Next_Elmt
(Elmt
))), Loc
);
5633 -- Use the dummy object to compute Offset_To_Top of
5634 -- components located at fixed position.
5636 if Present
(Dummy_Object
) then
5638 Iface
: constant Node_Id
:= Node
(AI
);
5639 Iface_Comp
: Node_Id
:= Empty
;
5640 Iface_Comp_Elmt
: Elmt_Id
;
5641 Iface_Elmt
: Elmt_Id
;
5645 First_Elmt
(Dummy_Object_Ifaces_List
);
5647 First_Elmt
(Dummy_Object_Ifaces_Comp_List
);
5649 while Present
(Iface_Elmt
) loop
5650 if Node
(Iface_Elmt
) = Iface
then
5651 Iface_Comp
:= Node
(Iface_Comp_Elmt
);
5655 Next_Elmt
(Iface_Elmt
);
5656 Next_Elmt
(Iface_Comp_Elmt
);
5659 pragma Assert
(Present
(Iface_Comp
));
5662 Is_Variable_Size_Record
(Etype
(Scope
(Iface_Comp
)))
5666 Make_Attribute_Reference
(Loc
,
5668 Make_Selected_Component
(Loc
,
5670 New_Occurrence_Of
(Dummy_Object
, Loc
),
5672 New_Occurrence_Of
(Iface_Comp
, Loc
)),
5673 Attribute_Name
=> Name_Position
));
5675 Offset_To_Top
:= Make_Integer_Literal
(Loc
, 0);
5679 Offset_To_Top
:= Make_Integer_Literal
(Loc
, 0);
5682 Append_To
(TSD_Ifaces_List
,
5683 Make_Aggregate
(Loc
,
5684 Expressions
=> New_List
(
5688 Unchecked_Convert_To
(RTE
(RE_Tag
),
5690 (Node
(First_Elmt
(Access_Disp_Table
(Node
(AI
)))),
5693 -- Static_Offset_To_Top
5695 New_Occurrence_Of
(Standard_True
, Loc
),
5697 -- Offset_To_Top_Value
5701 -- Offset_To_Top_Func
5707 Unchecked_Convert_To
(RTE
(RE_Tag
), Sec_DT_Tag
))));
5712 Name_ITable
:= New_External_Name
(Tname
, 'I');
5713 ITable
:= Make_Defining_Identifier
(Loc
, Name_ITable
);
5714 Set_Is_Statically_Allocated
(ITable
,
5715 Is_Library_Level_Tagged_Type
(Typ
));
5717 -- The table of interfaces is constant if we are building a
5718 -- static dispatch table; otherwise is not constant because
5719 -- its slots are filled at run time by the IP routine.
5722 Make_Object_Declaration
(Loc
,
5723 Defining_Identifier
=> ITable
,
5724 Aliased_Present
=> True,
5725 Constant_Present
=> Building_Static_Secondary_DT
(Typ
),
5726 Object_Definition
=>
5727 Make_Subtype_Indication
(Loc
,
5729 New_Occurrence_Of
(RTE
(RE_Interface_Data
), Loc
),
5731 Make_Index_Or_Discriminant_Constraint
(Loc
,
5732 Constraints
=> New_List
(
5733 Make_Integer_Literal
(Loc
, Num_Ifaces
)))),
5736 Make_Aggregate
(Loc
,
5737 Expressions
=> New_List
(
5738 Make_Integer_Literal
(Loc
, Num_Ifaces
),
5739 Make_Aggregate
(Loc
, TSD_Ifaces_List
)))));
5742 Make_Attribute_Reference
(Loc
,
5743 Prefix
=> New_Occurrence_Of
(ITable
, Loc
),
5744 Attribute_Name
=> Name_Unchecked_Access
);
5748 Append_To
(TSD_Aggr_List
, Iface_Table_Node
);
5751 -- Generate the Select Specific Data table for synchronized types that
5752 -- implement synchronized interfaces. The size of the table is
5753 -- constrained by the number of non-predefined primitive operations.
5755 if RTE_Record_Component_Available
(RE_SSD
) then
5756 if Ada_Version
>= Ada_2005
5757 and then Has_DT
(Typ
)
5758 and then Is_Concurrent_Record_Type
(Typ
)
5759 and then Has_Interfaces
(Typ
)
5760 and then Nb_Prim
> 0
5761 and then not Is_Abstract_Type
(Typ
)
5762 and then not Is_Controlled
(Typ
)
5763 and then not Restriction_Active
(No_Dispatching_Calls
)
5764 and then not Restriction_Active
(No_Select_Statements
)
5767 Make_Object_Declaration
(Loc
,
5768 Defining_Identifier
=> SSD
,
5769 Aliased_Present
=> True,
5770 Object_Definition
=>
5771 Make_Subtype_Indication
(Loc
,
5772 Subtype_Mark
=> New_Occurrence_Of
(
5773 RTE
(RE_Select_Specific_Data
), Loc
),
5775 Make_Index_Or_Discriminant_Constraint
(Loc
,
5776 Constraints
=> New_List
(
5777 Make_Integer_Literal
(Loc
, Nb_Prim
))))));
5780 Make_Attribute_Definition_Clause
(Loc
,
5781 Name
=> New_Occurrence_Of
(SSD
, Loc
),
5782 Chars
=> Name_Alignment
,
5784 Make_Attribute_Reference
(Loc
,
5786 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5787 Attribute_Name
=> Name_Alignment
)));
5789 -- This table is initialized by Make_Select_Specific_Data_Table,
5790 -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
5792 Append_To
(TSD_Aggr_List
,
5793 Make_Attribute_Reference
(Loc
,
5794 Prefix
=> New_Occurrence_Of
(SSD
, Loc
),
5795 Attribute_Name
=> Name_Unchecked_Access
));
5797 Append_To
(TSD_Aggr_List
, Make_Null
(Loc
));
5801 -- Initialize the table of ancestor tags. In case of interface types
5802 -- this table is not needed.
5804 TSD_Tags_List
:= New_List
;
5806 -- If we are not statically allocating the dispatch table then we must
5807 -- fill position 0 with null because we still have not generated the
5810 if not Building_Static_DT
(Typ
)
5811 or else Is_Interface
(Typ
)
5813 Append_To
(TSD_Tags_List
,
5814 Unchecked_Convert_To
(RTE
(RE_Tag
),
5815 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5817 -- Otherwise we can safely reference the tag
5820 Append_To
(TSD_Tags_List
,
5821 New_Occurrence_Of
(DT_Ptr
, Loc
));
5824 -- Fill the rest of the table with the tags of the ancestors
5827 Current_Typ
: Entity_Id
;
5828 Parent_Typ
: Entity_Id
;
5836 Parent_Typ
:= Etype
(Current_Typ
);
5838 if Is_Private_Type
(Parent_Typ
) then
5839 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
5842 exit when Parent_Typ
= Current_Typ
;
5844 if Is_CPP_Class
(Parent_Typ
) then
5846 -- The tags defined in the C++ side will be inherited when
5847 -- the object is constructed (Exp_Ch3.Build_Init_Procedure)
5849 Append_To
(TSD_Tags_List
,
5850 Unchecked_Convert_To
(RTE
(RE_Tag
),
5851 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5853 Append_To
(TSD_Tags_List
,
5855 (Node
(First_Elmt
(Access_Disp_Table
(Parent_Typ
))),
5860 Current_Typ
:= Parent_Typ
;
5863 pragma Assert
(Pos
= I_Depth
+ 1);
5866 Append_To
(TSD_Aggr_List
,
5867 Make_Aggregate
(Loc
,
5868 Expressions
=> TSD_Tags_List
));
5870 -- Build the TSD object
5873 Make_Object_Declaration
(Loc
,
5874 Defining_Identifier
=> TSD
,
5875 Aliased_Present
=> True,
5876 Constant_Present
=> Building_Static_DT
(Typ
),
5877 Object_Definition
=>
5878 Make_Subtype_Indication
(Loc
,
5879 Subtype_Mark
=> New_Occurrence_Of
(
5880 RTE
(RE_Type_Specific_Data
), Loc
),
5882 Make_Index_Or_Discriminant_Constraint
(Loc
,
5883 Constraints
=> New_List
(
5884 Make_Integer_Literal
(Loc
, I_Depth
)))),
5886 Expression
=> Make_Aggregate
(Loc
,
5887 Expressions
=> TSD_Aggr_List
)));
5889 Set_Is_True_Constant
(TSD
, Building_Static_DT
(Typ
));
5891 -- Initialize or declare the dispatch table object
5893 if not Has_DT
(Typ
) then
5894 DT_Constr_List
:= New_List
;
5895 DT_Aggr_List
:= New_List
;
5900 Make_Attribute_Reference
(Loc
,
5901 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
5902 Attribute_Name
=> Name_Address
);
5904 Append_To
(DT_Constr_List
, New_Node
);
5905 Append_To
(DT_Aggr_List
, New_Copy
(New_Node
));
5906 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
5908 -- In case of locally defined tagged types we have already declared
5909 -- and uninitialized object for the dispatch table, which is now
5910 -- initialized by means of the following assignment:
5912 -- DT := (TSD'Address, 0);
5914 if not Building_Static_DT
(Typ
) then
5916 Make_Assignment_Statement
(Loc
,
5917 Name
=> New_Occurrence_Of
(DT
, Loc
),
5918 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5920 -- In case of library level tagged types we declare and export now
5921 -- the constant object containing the dummy dispatch table. There
5922 -- is no need to declare the tag here because it has been previously
5923 -- declared by Make_Tags
5925 -- DT : aliased constant No_Dispatch_Table :=
5926 -- (NDT_TSD => TSD'Address;
5927 -- NDT_Prims_Ptr => 0);
5931 Make_Object_Declaration
(Loc
,
5932 Defining_Identifier
=> DT
,
5933 Aliased_Present
=> True,
5934 Constant_Present
=> True,
5935 Object_Definition
=>
5936 New_Occurrence_Of
(RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
),
5937 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5939 Export_DT
(Typ
, DT
);
5942 -- Common case: Typ has a dispatch table
5946 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
5947 -- (predef-prim-op-1'address,
5948 -- predef-prim-op-2'address,
5950 -- predef-prim-op-n'address);
5952 -- DT : Dispatch_Table (Nb_Prims) :=
5953 -- (Signature => <sig-value>,
5954 -- Tag_Kind => <tag_kind-value>,
5955 -- Predef_Prims => Predef_Prims'First'Address,
5956 -- Offset_To_Top => 0,
5957 -- TSD => TSD'Address;
5958 -- Prims_Ptr => (prim-op-1'address,
5959 -- prim-op-2'address,
5961 -- prim-op-n'address));
5962 -- for DT'Alignment use Address'Alignment
5966 Nb_P_Prims
: constant Nat
:= Number_Of_Predefined_Prims
(Typ
);
5967 Prim_Table
: array (Nat
range 1 .. Nb_P_Prims
) of Entity_Id
;
5972 Prim_Ops_Aggr_List
:= New_List
;
5973 Prim_Table
:= (others => Empty
);
5975 if Building_Static_DT
(Typ
) then
5976 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5977 while Present
(Prim_Elmt
) loop
5978 Prim
:= Node
(Prim_Elmt
);
5980 if Is_Predefined_Dispatching_Operation
(Prim
)
5981 and then not Is_Abstract_Subprogram
(Prim
)
5982 and then not Is_Eliminated
(Prim
)
5983 and then not Generate_SCIL
5984 and then not Present
(Prim_Table
5985 (UI_To_Int
(DT_Position
(Prim
))))
5987 E
:= Ultimate_Alias
(Prim
);
5988 pragma Assert
(not Is_Abstract_Subprogram
(E
));
5989 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) := E
;
5992 Next_Elmt
(Prim_Elmt
);
5996 for J
in Prim_Table
'Range loop
5997 if Present
(Prim_Table
(J
)) then
5999 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
6000 Make_Attribute_Reference
(Loc
,
6002 New_Occurrence_Of
(Prim_Table
(J
), Loc
),
6003 Attribute_Name
=> Name_Unrestricted_Access
));
6005 New_Node
:= Make_Null
(Loc
);
6008 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
6012 Make_Aggregate
(Loc
,
6013 Expressions
=> Prim_Ops_Aggr_List
);
6016 Make_Subtype_Declaration
(Loc
,
6017 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
6018 Subtype_Indication
=>
6019 New_Occurrence_Of
(RTE
(RE_Address_Array
), Loc
));
6021 Append_To
(Result
, Decl
);
6024 Make_Object_Declaration
(Loc
,
6025 Defining_Identifier
=> Predef_Prims
,
6026 Aliased_Present
=> True,
6027 Constant_Present
=> Building_Static_DT
(Typ
),
6028 Object_Definition
=>
6029 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
),
6030 Expression
=> New_Node
));
6032 -- Remember aggregates initializing dispatch tables
6034 Append_Elmt
(New_Node
, DT_Aggr
);
6037 -- Stage 1: Initialize the discriminant and the record components
6039 DT_Constr_List
:= New_List
;
6040 DT_Aggr_List
:= New_List
;
6042 -- Num_Prims. If the tagged type has no primitives we add a dummy
6043 -- slot whose address will be the tag of this type.
6046 New_Node
:= Make_Integer_Literal
(Loc
, 1);
6048 New_Node
:= Make_Integer_Literal
(Loc
, Nb_Prim
);
6051 Append_To
(DT_Constr_List
, New_Node
);
6052 Append_To
(DT_Aggr_List
, New_Copy
(New_Node
));
6056 if RTE_Record_Component_Available
(RE_Signature
) then
6057 Append_To
(DT_Aggr_List
,
6058 New_Occurrence_Of
(RTE
(RE_Primary_DT
), Loc
));
6063 if RTE_Record_Component_Available
(RE_Tag_Kind
) then
6064 Append_To
(DT_Aggr_List
, Tagged_Kind
(Typ
));
6069 Append_To
(DT_Aggr_List
,
6070 Make_Attribute_Reference
(Loc
,
6071 Prefix
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
6072 Attribute_Name
=> Name_Address
));
6076 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
6080 Append_To
(DT_Aggr_List
,
6081 Make_Attribute_Reference
(Loc
,
6082 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6083 Attribute_Name
=> Name_Address
));
6085 -- Stage 2: Initialize the table of user-defined primitive operations
6087 Prim_Ops_Aggr_List
:= New_List
;
6090 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
6092 elsif not Building_Static_DT
(Typ
) then
6093 for J
in 1 .. Nb_Prim
loop
6094 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
6099 CPP_Nb_Prims
: constant Nat
:= CPP_Num_Prims
(Typ
);
6102 Prim_Elmt
: Elmt_Id
;
6104 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
6107 Prim_Table
:= (others => Empty
);
6109 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6110 while Present
(Prim_Elmt
) loop
6111 Prim
:= Node
(Prim_Elmt
);
6113 -- Retrieve the ultimate alias of the primitive for proper
6114 -- handling of renamings and eliminated primitives.
6116 E
:= Ultimate_Alias
(Prim
);
6118 -- If the alias is not a primitive operation then Prim does
6119 -- not rename another primitive, but rather an operation
6120 -- declared elsewhere (e.g. in another scope) and therefore
6121 -- Prim is a new primitive.
6123 if No
(Find_Dispatching_Type
(E
)) then
6127 Prim_Pos
:= UI_To_Int
(DT_Position
(E
));
6129 -- Skip predefined primitives because they are located in a
6130 -- separate dispatch table.
6132 if not Is_Predefined_Dispatching_Operation
(Prim
)
6133 and then not Is_Predefined_Dispatching_Operation
(E
)
6135 -- Skip entities with attribute Interface_Alias because
6136 -- those are only required to build secondary dispatch
6139 and then not Present
(Interface_Alias
(Prim
))
6141 -- Skip abstract and eliminated primitives
6143 and then not Is_Abstract_Subprogram
(E
)
6144 and then not Is_Eliminated
(E
)
6146 -- For derivations of CPP types skip primitives located in
6147 -- the C++ part of the dispatch table because their slots
6148 -- are initialized by the IC routine.
6150 and then (not Is_CPP_Class
(Root_Type
(Typ
))
6151 or else Prim_Pos
> CPP_Nb_Prims
)
6153 -- Skip ignored Ghost subprograms as those will be removed
6154 -- from the executable.
6156 and then not Is_Ignored_Ghost_Entity
(E
)
6159 (UI_To_Int
(DT_Position
(Prim
)) <= Nb_Prim
);
6161 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) := E
;
6164 Next_Elmt
(Prim_Elmt
);
6167 for J
in Prim_Table
'Range loop
6168 if Present
(Prim_Table
(J
)) then
6170 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
6171 Make_Attribute_Reference
(Loc
,
6173 New_Occurrence_Of
(Prim_Table
(J
), Loc
),
6174 Attribute_Name
=> Name_Unrestricted_Access
));
6176 New_Node
:= Make_Null
(Loc
);
6179 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
6185 Make_Aggregate
(Loc
,
6186 Expressions
=> Prim_Ops_Aggr_List
);
6188 Append_To
(DT_Aggr_List
, New_Node
);
6190 -- Remember aggregates initializing dispatch tables
6192 Append_Elmt
(New_Node
, DT_Aggr
);
6194 -- In case of locally defined tagged types we have already declared
6195 -- and uninitialized object for the dispatch table, which is now
6196 -- initialized by means of an assignment.
6198 if not Building_Static_DT
(Typ
) then
6200 Make_Assignment_Statement
(Loc
,
6201 Name
=> New_Occurrence_Of
(DT
, Loc
),
6202 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
6204 -- In case of library level tagged types we declare now and export
6205 -- the constant object containing the dispatch table.
6209 Make_Object_Declaration
(Loc
,
6210 Defining_Identifier
=> DT
,
6211 Aliased_Present
=> True,
6212 Constant_Present
=> True,
6213 Object_Definition
=>
6214 Make_Subtype_Indication
(Loc
,
6215 Subtype_Mark
=> New_Occurrence_Of
6216 (RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
6217 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
6218 Constraints
=> DT_Constr_List
)),
6219 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
6221 Export_DT
(Typ
, DT
);
6225 -- Initialize the table of ancestor tags if not building static
6228 if not Building_Static_DT
(Typ
)
6229 and then not Is_Interface
(Typ
)
6230 and then not Is_CPP_Class
(Typ
)
6233 Make_Assignment_Statement
(Loc
,
6235 Make_Indexed_Component
(Loc
,
6237 Make_Selected_Component
(Loc
,
6238 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6241 (RTE_Record_Component
(RE_Tags_Table
), Loc
)),
6243 New_List
(Make_Integer_Literal
(Loc
, 0))),
6247 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
)));
6250 -- Inherit the dispatch tables of the parent. There is no need to
6251 -- inherit anything from the parent when building static dispatch tables
6252 -- because the whole dispatch table (including inherited primitives) has
6253 -- been already built.
6255 if Building_Static_DT
(Typ
) then
6258 -- If the ancestor is a CPP_Class type we inherit the dispatch tables
6259 -- in the init proc, and we don't need to fill them in here.
6261 elsif Is_CPP_Class
(Parent_Typ
) then
6264 -- Otherwise we fill in the dispatch tables here
6267 if Typ
/= Parent_Typ
6268 and then not Is_Interface
(Typ
)
6269 and then not Restriction_Active
(No_Dispatching_Calls
)
6271 -- Inherit the dispatch table
6273 if not Is_Interface
(Typ
)
6274 and then not Is_Interface
(Parent_Typ
)
6275 and then not Is_CPP_Class
(Parent_Typ
)
6278 Nb_Prims
: constant Int
:=
6279 UI_To_Int
(DT_Entry_Count
6280 (First_Tag_Component
(Parent_Typ
)));
6283 Append_To
(Elab_Code
,
6284 Build_Inherit_Predefined_Prims
(Loc
,
6290 (Access_Disp_Table
(Parent_Typ
)))), Loc
),
6296 (Access_Disp_Table
(Typ
)))), Loc
),
6298 Number_Of_Predefined_Prims
(Parent_Typ
)));
6300 if Nb_Prims
/= 0 then
6301 Append_To
(Elab_Code
,
6302 Build_Inherit_Prims
(Loc
,
6308 (Access_Disp_Table
(Parent_Typ
))), Loc
),
6309 New_Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
6310 Num_Prims
=> Nb_Prims
));
6315 -- Inherit the secondary dispatch tables of the ancestor
6317 if not Is_CPP_Class
(Parent_Typ
) then
6319 Sec_DT_Ancestor
: Elmt_Id
:=
6325 Sec_DT_Typ
: Elmt_Id
:=
6329 (Access_Disp_Table
(Typ
))));
6331 procedure Copy_Secondary_DTs
(Typ
: Entity_Id
);
6332 -- Local procedure required to climb through the ancestors
6333 -- and copy the contents of all their secondary dispatch
6336 ------------------------
6337 -- Copy_Secondary_DTs --
6338 ------------------------
6340 procedure Copy_Secondary_DTs
(Typ
: Entity_Id
) is
6345 -- Climb to the ancestor (if any) handling private types
6347 if Present
(Full_View
(Etype
(Typ
))) then
6348 if Full_View
(Etype
(Typ
)) /= Typ
then
6349 Copy_Secondary_DTs
(Full_View
(Etype
(Typ
)));
6352 elsif Etype
(Typ
) /= Typ
then
6353 Copy_Secondary_DTs
(Etype
(Typ
));
6356 if Present
(Interfaces
(Typ
))
6357 and then not Is_Empty_Elmt_List
(Interfaces
(Typ
))
6359 Iface
:= First_Elmt
(Interfaces
(Typ
));
6360 E
:= First_Entity
(Typ
);
6362 and then Present
(Node
(Sec_DT_Ancestor
))
6363 and then Ekind
(Node
(Sec_DT_Ancestor
)) = E_Constant
6365 if Is_Tag
(E
) and then Chars
(E
) /= Name_uTag
then
6367 Num_Prims
: constant Int
:=
6368 UI_To_Int
(DT_Entry_Count
(E
));
6371 if not Is_Interface
(Etype
(Typ
)) then
6373 -- Inherit first secondary dispatch table
6375 Append_To
(Elab_Code
,
6376 Build_Inherit_Predefined_Prims
(Loc
,
6378 Unchecked_Convert_To
(RTE
(RE_Tag
),
6381 (Next_Elmt
(Sec_DT_Ancestor
)),
6384 Unchecked_Convert_To
(RTE
(RE_Tag
),
6386 (Node
(Next_Elmt
(Sec_DT_Typ
)),
6389 Number_Of_Predefined_Prims
6392 if Num_Prims
/= 0 then
6393 Append_To
(Elab_Code
,
6394 Build_Inherit_Prims
(Loc
,
6395 Typ
=> Node
(Iface
),
6397 Unchecked_Convert_To
6400 (Node
(Sec_DT_Ancestor
),
6403 Unchecked_Convert_To
6406 (Node
(Sec_DT_Typ
), Loc
)),
6407 Num_Prims
=> Num_Prims
));
6411 Next_Elmt
(Sec_DT_Ancestor
);
6412 Next_Elmt
(Sec_DT_Typ
);
6414 -- Skip the secondary dispatch table of
6415 -- predefined primitives
6417 Next_Elmt
(Sec_DT_Ancestor
);
6418 Next_Elmt
(Sec_DT_Typ
);
6420 if not Is_Interface
(Etype
(Typ
)) then
6422 -- Inherit second secondary dispatch table
6424 Append_To
(Elab_Code
,
6425 Build_Inherit_Predefined_Prims
(Loc
,
6427 Unchecked_Convert_To
(RTE
(RE_Tag
),
6430 (Next_Elmt
(Sec_DT_Ancestor
)),
6433 Unchecked_Convert_To
(RTE
(RE_Tag
),
6435 (Node
(Next_Elmt
(Sec_DT_Typ
)),
6438 Number_Of_Predefined_Prims
6441 if Num_Prims
/= 0 then
6442 Append_To
(Elab_Code
,
6443 Build_Inherit_Prims
(Loc
,
6444 Typ
=> Node
(Iface
),
6446 Unchecked_Convert_To
6449 (Node
(Sec_DT_Ancestor
),
6452 Unchecked_Convert_To
6455 (Node
(Sec_DT_Typ
), Loc
)),
6456 Num_Prims
=> Num_Prims
));
6461 Next_Elmt
(Sec_DT_Ancestor
);
6462 Next_Elmt
(Sec_DT_Typ
);
6464 -- Skip the secondary dispatch table of
6465 -- predefined primitives
6467 Next_Elmt
(Sec_DT_Ancestor
);
6468 Next_Elmt
(Sec_DT_Typ
);
6476 end Copy_Secondary_DTs
;
6479 if Present
(Node
(Sec_DT_Ancestor
))
6480 and then Ekind
(Node
(Sec_DT_Ancestor
)) = E_Constant
6482 -- Handle private types
6484 if Present
(Full_View
(Typ
)) then
6485 Copy_Secondary_DTs
(Full_View
(Typ
));
6487 Copy_Secondary_DTs
(Typ
);
6495 -- Generate code to check if the external tag of this type is the same
6496 -- as the external tag of some other declaration.
6498 -- Check_TSD (TSD'Unrestricted_Access);
6500 -- This check is a consequence of AI05-0113-1/06, so it officially
6501 -- applies to Ada 2005 (and Ada 2012). It might be argued that it is
6502 -- a desirable check to add in Ada 95 mode, but we hesitate to make
6503 -- this change, as it would be incompatible, and could conceivably
6504 -- cause a problem in existing Ada 95 code.
6506 -- We check for No_Run_Time_Mode here, because we do not want to pick
6507 -- up the RE_Check_TSD entity and call it in No_Run_Time mode.
6509 -- We cannot perform this check if the generation of its expanded name
6512 if not No_Run_Time_Mode
6513 and then not Discard_Names
6514 and then Ada_Version
>= Ada_2005
6515 and then RTE_Available
(RE_Check_TSD
)
6516 and then not Duplicated_Tag_Checks_Suppressed
(Typ
)
6518 Append_To
(Elab_Code
,
6519 Make_Procedure_Call_Statement
(Loc
,
6521 New_Occurrence_Of
(RTE
(RE_Check_TSD
), Loc
),
6522 Parameter_Associations
=> New_List
(
6523 Make_Attribute_Reference
(Loc
,
6524 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6525 Attribute_Name
=> Name_Unchecked_Access
))));
6528 -- Generate code to register the Tag in the External_Tag hash table for
6529 -- the pure Ada type only.
6531 -- Register_Tag (Dt_Ptr);
6533 -- Skip this action in the following cases:
6534 -- 1) if Register_Tag is not available.
6535 -- 2) in No_Run_Time mode.
6536 -- 3) if Typ is not defined at the library level (this is required
6537 -- to avoid adding concurrency control to the hash table used
6538 -- by the run-time to register the tags).
6540 if not No_Run_Time_Mode
6541 and then Is_Library_Level_Entity
(Typ
)
6542 and then RTE_Available
(RE_Register_Tag
)
6544 Append_To
(Elab_Code
,
6545 Make_Procedure_Call_Statement
(Loc
,
6547 New_Occurrence_Of
(RTE
(RE_Register_Tag
), Loc
),
6548 Parameter_Associations
=>
6549 New_List
(New_Occurrence_Of
(DT_Ptr
, Loc
))));
6552 if not Is_Empty_List
(Elab_Code
) then
6553 Append_List_To
(Result
, Elab_Code
);
6556 -- Populate the two auxiliary tables used for dispatching asynchronous,
6557 -- conditional and timed selects for synchronized types that implement
6558 -- a limited interface. Skip this step in Ravenscar profile or when
6559 -- general dispatching is forbidden.
6561 if Ada_Version
>= Ada_2005
6562 and then Is_Concurrent_Record_Type
(Typ
)
6563 and then Has_Interfaces
(Typ
)
6564 and then not Restriction_Active
(No_Dispatching_Calls
)
6565 and then not Restriction_Active
(No_Select_Statements
)
6567 Append_List_To
(Result
,
6568 Make_Select_Specific_Data_Table
(Typ
));
6571 -- Remember entities containing dispatch tables
6573 Append_Elmt
(Predef_Prims
, DT_Decl
);
6574 Append_Elmt
(DT
, DT_Decl
);
6576 Analyze_List
(Result
, Suppress
=> All_Checks
);
6577 Set_Has_Dispatch_Table
(Typ
);
6579 -- Mark entities containing dispatch tables. Required by the backend to
6580 -- handle them properly.
6582 if Has_DT
(Typ
) then
6587 -- Object declarations
6589 Elmt
:= First_Elmt
(DT_Decl
);
6590 while Present
(Elmt
) loop
6591 Set_Is_Dispatch_Table_Entity
(Node
(Elmt
));
6592 pragma Assert
(Ekind
(Etype
(Node
(Elmt
))) = E_Array_Subtype
6593 or else Ekind
(Etype
(Node
(Elmt
))) = E_Record_Subtype
);
6594 Set_Is_Dispatch_Table_Entity
(Etype
(Node
(Elmt
)));
6598 -- Aggregates initializing dispatch tables
6600 Elmt
:= First_Elmt
(DT_Aggr
);
6601 while Present
(Elmt
) loop
6602 Set_Is_Dispatch_Table_Entity
(Etype
(Node
(Elmt
)));
6610 -- Register the tagged type in the call graph nodes table
6612 Register_CG_Node
(Typ
);
6615 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
6620 -------------------------------------
6621 -- Make_Select_Specific_Data_Table --
6622 -------------------------------------
6624 function Make_Select_Specific_Data_Table
6625 (Typ
: Entity_Id
) return List_Id
6627 Assignments
: constant List_Id
:= New_List
;
6628 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6630 Conc_Typ
: Entity_Id
;
6631 Decls
: List_Id
:= No_List
;
6633 Prim_Als
: Entity_Id
;
6634 Prim_Elmt
: Elmt_Id
;
6638 type Examined_Array
is array (Int
range <>) of Boolean;
6640 function Find_Entry_Index
(E
: Entity_Id
) return Uint
;
6641 -- Given an entry, find its index in the visible declarations of the
6642 -- corresponding concurrent type of Typ.
6644 ----------------------
6645 -- Find_Entry_Index --
6646 ----------------------
6648 function Find_Entry_Index
(E
: Entity_Id
) return Uint
is
6649 Index
: Uint
:= Uint_1
;
6650 Subp_Decl
: Entity_Id
;
6654 and then not Is_Empty_List
(Decls
)
6656 Subp_Decl
:= First
(Decls
);
6657 while Present
(Subp_Decl
) loop
6658 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
6659 if Defining_Identifier
(Subp_Decl
) = E
then
6671 end Find_Entry_Index
;
6677 -- Start of processing for Make_Select_Specific_Data_Table
6680 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
6682 if Present
(Corresponding_Concurrent_Type
(Typ
)) then
6683 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
6685 if Present
(Full_View
(Conc_Typ
)) then
6686 Conc_Typ
:= Full_View
(Conc_Typ
);
6689 if Ekind
(Conc_Typ
) = E_Protected_Type
then
6690 Decls
:= Visible_Declarations
(Protected_Definition
(
6691 Parent
(Conc_Typ
)));
6693 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
6694 Decls
:= Visible_Declarations
(Task_Definition
(
6695 Parent
(Conc_Typ
)));
6699 -- Count the non-predefined primitive operations
6701 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6702 while Present
(Prim_Elmt
) loop
6703 Prim
:= Node
(Prim_Elmt
);
6705 if not (Is_Predefined_Dispatching_Operation
(Prim
)
6706 or else Is_Predefined_Dispatching_Alias
(Prim
))
6708 Nb_Prim
:= Nb_Prim
+ 1;
6711 Next_Elmt
(Prim_Elmt
);
6715 Examined
: Examined_Array
(1 .. Nb_Prim
) := (others => False);
6718 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6719 while Present
(Prim_Elmt
) loop
6720 Prim
:= Node
(Prim_Elmt
);
6722 -- Look for primitive overriding an abstract interface subprogram
6724 if Present
(Interface_Alias
(Prim
))
6727 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
6728 Use_Full_View
=> True)
6729 and then not Examined
(UI_To_Int
(DT_Position
(Alias
(Prim
))))
6731 Prim_Pos
:= DT_Position
(Alias
(Prim
));
6732 pragma Assert
(UI_To_Int
(Prim_Pos
) <= Nb_Prim
);
6733 Examined
(UI_To_Int
(Prim_Pos
)) := True;
6735 -- Set the primitive operation kind regardless of subprogram
6737 -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
6739 if Tagged_Type_Expansion
then
6742 (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
,
6753 Name
=> New_Occurrence_Of
(RTE
(RE_Set_Prim_Op_Kind
), Loc
),
6754 Parameter_Associations
=> New_List
(
6756 Make_Integer_Literal
(Loc
, Prim_Pos
),
6757 Prim_Op_Kind
(Alias
(Prim
), Typ
))));
6759 -- Retrieve the root of the alias chain
6761 Prim_Als
:= Ultimate_Alias
(Prim
);
6763 -- In the case of an entry wrapper, set the entry index
6765 if Ekind
(Prim
) = E_Procedure
6766 and then Is_Primitive_Wrapper
(Prim_Als
)
6767 and then Ekind
(Wrapped_Entity
(Prim_Als
)) = E_Entry
6770 -- Ada.Tags.Set_Entry_Index
6771 -- (DT_Ptr, <position>, <index>);
6773 if Tagged_Type_Expansion
then
6776 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
);
6779 Make_Attribute_Reference
(Loc
,
6780 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6781 Attribute_Name
=> Name_Tag
);
6784 Append_To
(Assignments
,
6785 Make_Procedure_Call_Statement
(Loc
,
6787 New_Occurrence_Of
(RTE
(RE_Set_Entry_Index
), Loc
),
6788 Parameter_Associations
=> New_List
(
6790 Make_Integer_Literal
(Loc
, Prim_Pos
),
6791 Make_Integer_Literal
(Loc
,
6792 Find_Entry_Index
(Wrapped_Entity
(Prim_Als
))))));
6796 Next_Elmt
(Prim_Elmt
);
6801 end Make_Select_Specific_Data_Table
;
6807 function Make_Tags
(Typ
: Entity_Id
) return List_Id
is
6808 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6809 Result
: constant List_Id
:= New_List
;
6812 (Tag_Typ
: Entity_Id
;
6814 Is_Secondary_DT
: Boolean);
6815 -- Import the dispatch table DT of tagged type Tag_Typ. Required to
6816 -- generate forward references and statically allocate the table. For
6817 -- primary dispatch tables that require no dispatch table generate:
6819 -- DT : static aliased constant Non_Dispatch_Table_Wrapper;
6820 -- pragma Import (Ada, DT);
6822 -- Otherwise generate:
6824 -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
6825 -- pragma Import (Ada, DT);
6832 (Tag_Typ
: Entity_Id
;
6834 Is_Secondary_DT
: Boolean)
6836 DT_Constr_List
: List_Id
;
6840 Set_Is_Imported
(DT
);
6841 Set_Ekind
(DT
, E_Constant
);
6842 Set_Related_Type
(DT
, Typ
);
6844 -- The scope must be set now to call Get_External_Name
6846 Set_Scope
(DT
, Current_Scope
);
6848 Get_External_Name
(DT
);
6849 Set_Interface_Name
(DT
,
6850 Make_String_Literal
(Loc
, Strval
=> String_From_Name_Buffer
));
6852 -- Ensure proper Sprint output of this implicit importation
6854 Set_Is_Internal
(DT
);
6856 -- Save this entity to allow Make_DT to generate its exportation
6858 Append_Elmt
(DT
, Dispatch_Table_Wrappers
(Typ
));
6860 -- No dispatch table required
6862 if not Is_Secondary_DT
and then not Has_DT
(Tag_Typ
) then
6864 Make_Object_Declaration
(Loc
,
6865 Defining_Identifier
=> DT
,
6866 Aliased_Present
=> True,
6867 Constant_Present
=> True,
6868 Object_Definition
=>
6870 (RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
)));
6873 -- Calculate the number of primitives of the dispatch table and
6874 -- the size of the Type_Specific_Data record.
6877 UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Tag_Typ
)));
6879 -- If the tagged type has no primitives we add a dummy slot whose
6880 -- address will be the tag of this type.
6884 New_List
(Make_Integer_Literal
(Loc
, 1));
6887 New_List
(Make_Integer_Literal
(Loc
, Nb_Prim
));
6891 Make_Object_Declaration
(Loc
,
6892 Defining_Identifier
=> DT
,
6893 Aliased_Present
=> True,
6894 Constant_Present
=> True,
6895 Object_Definition
=>
6896 Make_Subtype_Indication
(Loc
,
6898 New_Occurrence_Of
(RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
6899 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
6900 Constraints
=> DT_Constr_List
))));
6906 Tname
: constant Name_Id
:= Chars
(Typ
);
6907 AI_Tag_Comp
: Elmt_Id
;
6908 DT
: Node_Id
:= Empty
;
6910 Predef_Prims_Ptr
: Node_Id
;
6911 Iface_DT
: Node_Id
:= Empty
;
6912 Iface_DT_Ptr
: Node_Id
;
6916 Typ_Comps
: Elist_Id
;
6918 -- Start of processing for Make_Tags
6921 pragma Assert
(No
(Access_Disp_Table
(Typ
)));
6922 Set_Access_Disp_Table
(Typ
, New_Elmt_List
);
6924 -- If the elaboration of this tagged type needs a boolean flag then
6925 -- define now its entity. It is initialized to True to indicate that
6926 -- elaboration is still pending; set to False by the IP routine.
6928 -- TypFxx : boolean := True;
6930 if Elab_Flag_Needed
(Typ
) then
6931 Set_Access_Disp_Table_Elab_Flag
(Typ
,
6932 Make_Defining_Identifier
(Loc
,
6933 Chars
=> New_External_Name
(Tname
, 'F')));
6936 Make_Object_Declaration
(Loc
,
6937 Defining_Identifier
=> Access_Disp_Table_Elab_Flag
(Typ
),
6938 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
6939 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
6942 -- 1) Generate the primary tag entities
6944 -- Primary dispatch table containing user-defined primitives
6946 DT_Ptr
:= Make_Defining_Identifier
(Loc
, New_External_Name
(Tname
, 'P'));
6947 Set_Etype
(DT_Ptr
, RTE
(RE_Tag
));
6948 Append_Elmt
(DT_Ptr
, Access_Disp_Table
(Typ
));
6950 -- Minimum decoration
6952 Set_Ekind
(DT_Ptr
, E_Variable
);
6953 Set_Related_Type
(DT_Ptr
, Typ
);
6955 -- Notify back end that the types are associated with a dispatch table
6957 Set_Is_Dispatch_Table_Entity
(RTE
(RE_Prim_Ptr
));
6958 Set_Is_Dispatch_Table_Entity
(RTE
(RE_Predef_Prims_Table_Ptr
));
6960 -- For CPP types there is no need to build the dispatch tables since
6961 -- they are imported from the C++ side. If the CPP type has an IP then
6962 -- we declare now the variable that will store the copy of the C++ tag.
6963 -- If the CPP type is an interface, we need the variable as well because
6964 -- it becomes the pointer to the corresponding secondary table.
6966 if Is_CPP_Class
(Typ
) then
6967 if Has_CPP_Constructors
(Typ
) or else Is_Interface
(Typ
) then
6969 Make_Object_Declaration
(Loc
,
6970 Defining_Identifier
=> DT_Ptr
,
6971 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
6973 Unchecked_Convert_To
(RTE
(RE_Tag
),
6974 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
6976 Set_Is_Statically_Allocated
(DT_Ptr
,
6977 Is_Library_Level_Tagged_Type
(Typ
));
6983 -- Primary dispatch table containing predefined primitives
6986 Make_Defining_Identifier
(Loc
,
6987 Chars
=> New_External_Name
(Tname
, 'Y'));
6988 Set_Etype
(Predef_Prims_Ptr
, RTE
(RE_Address
));
6989 Append_Elmt
(Predef_Prims_Ptr
, Access_Disp_Table
(Typ
));
6991 -- Import the forward declaration of the Dispatch Table wrapper
6992 -- record (Make_DT will take care of exporting it).
6994 if Building_Static_DT
(Typ
) then
6995 Set_Dispatch_Table_Wrappers
(Typ
, New_Elmt_List
);
6998 Make_Defining_Identifier
(Loc
,
6999 Chars
=> New_External_Name
(Tname
, 'T'));
7001 Import_DT
(Typ
, DT
, Is_Secondary_DT
=> False);
7003 if Has_DT
(Typ
) then
7005 Make_Object_Declaration
(Loc
,
7006 Defining_Identifier
=> DT_Ptr
,
7007 Constant_Present
=> True,
7008 Object_Definition
=>
7009 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
7011 Unchecked_Convert_To
(RTE
(RE_Tag
),
7012 Make_Attribute_Reference
(Loc
,
7014 Make_Selected_Component
(Loc
,
7015 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
7018 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
7019 Attribute_Name
=> Name_Address
))));
7021 -- Generate the SCIL node for the previous object declaration
7022 -- because it has a tag initialization.
7024 if Generate_SCIL
then
7026 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
7027 Set_SCIL_Entity
(New_Node
, Typ
);
7028 Set_SCIL_Node
(Last
(Result
), New_Node
);
7032 Make_Object_Declaration
(Loc
,
7033 Defining_Identifier
=> Predef_Prims_Ptr
,
7034 Constant_Present
=> True,
7035 Object_Definition
=>
7036 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
7038 Make_Attribute_Reference
(Loc
,
7040 Make_Selected_Component
(Loc
,
7041 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
7044 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
7045 Attribute_Name
=> Name_Address
)));
7047 -- No dispatch table required
7051 Make_Object_Declaration
(Loc
,
7052 Defining_Identifier
=> DT_Ptr
,
7053 Constant_Present
=> True,
7054 Object_Definition
=>
7055 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
7057 Unchecked_Convert_To
(RTE
(RE_Tag
),
7058 Make_Attribute_Reference
(Loc
,
7060 Make_Selected_Component
(Loc
,
7061 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
7064 (RTE_Record_Component
(RE_NDT_Prims_Ptr
),
7066 Attribute_Name
=> Name_Address
))));
7069 Set_Is_True_Constant
(DT_Ptr
);
7070 Set_Is_Statically_Allocated
(DT_Ptr
);
7074 -- 2) Generate the secondary tag entities
7076 -- Collect the components associated with secondary dispatch tables
7078 if Has_Interfaces
(Typ
) then
7079 Collect_Interface_Components
(Typ
, Typ_Comps
);
7081 -- For each interface type we build a unique external name associated
7082 -- with its secondary dispatch table. This name is used to declare an
7083 -- object that references this secondary dispatch table, whose value
7084 -- will be used for the elaboration of Typ objects, and also for the
7085 -- elaboration of objects of types derived from Typ that do not
7086 -- override the primitives of this interface type.
7090 -- Note: The value of Suffix_Index must be in sync with the values of
7091 -- Suffix_Index in secondary dispatch tables generated by Make_DT.
7093 if Is_CPP_Class
(Typ
) then
7094 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
7095 while Present
(AI_Tag_Comp
) loop
7096 Get_Secondary_DT_External_Name
7097 (Typ
, Related_Type
(Node
(AI_Tag_Comp
)), Suffix_Index
);
7098 Typ_Name
:= Name_Find
;
7100 -- Declare variables to store copy of the C++ secondary tags
7103 Make_Defining_Identifier
(Loc
,
7104 Chars
=> New_External_Name
(Typ_Name
, 'P'));
7105 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7106 Set_Ekind
(Iface_DT_Ptr
, E_Variable
);
7107 Set_Is_Tag
(Iface_DT_Ptr
);
7109 Set_Has_Thunks
(Iface_DT_Ptr
);
7111 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7112 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7115 Make_Object_Declaration
(Loc
,
7116 Defining_Identifier
=> Iface_DT_Ptr
,
7117 Object_Definition
=> New_Occurrence_Of
7118 (RTE
(RE_Interface_Tag
), Loc
),
7120 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
7121 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
7123 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7124 Is_Library_Level_Tagged_Type
(Typ
));
7126 Next_Elmt
(AI_Tag_Comp
);
7129 -- This is not a CPP_Class type
7132 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
7133 while Present
(AI_Tag_Comp
) loop
7134 Get_Secondary_DT_External_Name
7135 (Typ
, Related_Type
(Node
(AI_Tag_Comp
)), Suffix_Index
);
7136 Typ_Name
:= Name_Find
;
7138 if Building_Static_DT
(Typ
) then
7140 Make_Defining_Identifier
(Loc
,
7141 Chars
=> New_External_Name
(Typ_Name
, 'T'));
7143 (Tag_Typ
=> Related_Type
(Node
(AI_Tag_Comp
)),
7145 Is_Secondary_DT
=> True);
7148 -- Secondary dispatch table referencing thunks to user-defined
7149 -- primitives covered by this interface.
7152 Make_Defining_Identifier
(Loc
,
7153 Chars
=> New_External_Name
(Typ_Name
, 'P'));
7154 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7155 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
7156 Set_Is_Tag
(Iface_DT_Ptr
);
7157 Set_Has_Thunks
(Iface_DT_Ptr
);
7158 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7159 Is_Library_Level_Tagged_Type
(Typ
));
7160 Set_Is_True_Constant
(Iface_DT_Ptr
);
7162 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7163 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7165 if Building_Static_DT
(Typ
) then
7167 Make_Object_Declaration
(Loc
,
7168 Defining_Identifier
=> Iface_DT_Ptr
,
7169 Constant_Present
=> True,
7170 Object_Definition
=> New_Occurrence_Of
7171 (RTE
(RE_Interface_Tag
), Loc
),
7173 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
7174 Make_Attribute_Reference
(Loc
,
7176 Make_Selected_Component
(Loc
,
7178 New_Occurrence_Of
(Iface_DT
, Loc
),
7181 (RTE_Record_Component
(RE_Prims_Ptr
),
7183 Attribute_Name
=> Name_Address
))));
7186 -- Secondary dispatch table referencing thunks to predefined
7190 Make_Defining_Identifier
(Loc
,
7191 Chars
=> New_External_Name
(Typ_Name
, 'Y'));
7192 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Address
));
7193 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
7194 Set_Is_Tag
(Iface_DT_Ptr
);
7195 Set_Has_Thunks
(Iface_DT_Ptr
);
7196 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7197 Is_Library_Level_Tagged_Type
(Typ
));
7198 Set_Is_True_Constant
(Iface_DT_Ptr
);
7200 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7201 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7203 -- Secondary dispatch table referencing user-defined primitives
7204 -- covered by this interface.
7207 Make_Defining_Identifier
(Loc
,
7208 Chars
=> New_External_Name
(Typ_Name
, 'D'));
7209 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7210 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
7211 Set_Is_Tag
(Iface_DT_Ptr
);
7212 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7213 Is_Library_Level_Tagged_Type
(Typ
));
7214 Set_Is_True_Constant
(Iface_DT_Ptr
);
7216 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7217 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7219 -- Secondary dispatch table referencing predefined primitives
7222 Make_Defining_Identifier
(Loc
,
7223 Chars
=> New_External_Name
(Typ_Name
, 'Z'));
7224 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Address
));
7225 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
7226 Set_Is_Tag
(Iface_DT_Ptr
);
7227 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7228 Is_Library_Level_Tagged_Type
(Typ
));
7229 Set_Is_True_Constant
(Iface_DT_Ptr
);
7231 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7232 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7234 Next_Elmt
(AI_Tag_Comp
);
7239 -- 3) At the end of Access_Disp_Table, if the type has user-defined
7240 -- primitives, we add the entity of an access type declaration that
7241 -- is used by Build_Get_Prim_Op_Address to expand dispatching calls
7242 -- through the primary dispatch table.
7244 if DT_Entry_Count
(First_Tag_Component
(Typ
)) = 0 then
7245 Analyze_List
(Result
);
7248 -- subtype Typ_DT is Address_Array (1 .. Nb_Prims);
7249 -- type Typ_DT_Acc is access Typ_DT;
7253 Name_DT_Prims
: constant Name_Id
:=
7254 New_External_Name
(Tname
, 'G');
7255 Name_DT_Prims_Acc
: constant Name_Id
:=
7256 New_External_Name
(Tname
, 'H');
7257 DT_Prims
: constant Entity_Id
:=
7258 Make_Defining_Identifier
(Loc
,
7260 DT_Prims_Acc
: constant Entity_Id
:=
7261 Make_Defining_Identifier
(Loc
,
7265 Make_Subtype_Declaration
(Loc
,
7266 Defining_Identifier
=> DT_Prims
,
7267 Subtype_Indication
=>
7268 Make_Subtype_Indication
(Loc
,
7270 New_Occurrence_Of
(RTE
(RE_Address_Array
), Loc
),
7272 Make_Index_Or_Discriminant_Constraint
(Loc
, New_List
(
7274 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
7276 Make_Integer_Literal
(Loc
,
7278 (First_Tag_Component
(Typ
)))))))));
7281 Make_Full_Type_Declaration
(Loc
,
7282 Defining_Identifier
=> DT_Prims_Acc
,
7284 Make_Access_To_Object_Definition
(Loc
,
7285 Subtype_Indication
=>
7286 New_Occurrence_Of
(DT_Prims
, Loc
))));
7288 Append_Elmt
(DT_Prims_Acc
, Access_Disp_Table
(Typ
));
7290 -- Analyze the resulting list and suppress the generation of the
7291 -- Init_Proc associated with the above array declaration because
7292 -- this type is never used in object declarations. It is only used
7293 -- to simplify the expansion associated with dispatching calls.
7295 Analyze_List
(Result
);
7296 Set_Suppress_Initialization
(Base_Type
(DT_Prims
));
7298 -- Disable backend optimizations based on assumptions about the
7299 -- aliasing status of objects designated by the access to the
7300 -- dispatch table. Required to handle dispatch tables imported
7303 Set_No_Strict_Aliasing
(Base_Type
(DT_Prims_Acc
));
7305 -- Add the freezing nodes of these declarations; required to avoid
7306 -- generating these freezing nodes in wrong scopes (for example in
7307 -- the IC routine of a derivation of Typ).
7309 -- What is an "IC routine"? Is "init_proc" meant here???
7311 Append_List_To
(Result
, Freeze_Entity
(DT_Prims
, Typ
));
7312 Append_List_To
(Result
, Freeze_Entity
(DT_Prims_Acc
, Typ
));
7314 -- Mark entity of dispatch table. Required by the back end to
7315 -- handle them properly.
7317 Set_Is_Dispatch_Table_Entity
(DT_Prims
);
7321 -- Mark entities of dispatch table. Required by the back end to handle
7324 if Present
(DT
) then
7325 Set_Is_Dispatch_Table_Entity
(DT
);
7326 Set_Is_Dispatch_Table_Entity
(Etype
(DT
));
7329 if Present
(Iface_DT
) then
7330 Set_Is_Dispatch_Table_Entity
(Iface_DT
);
7331 Set_Is_Dispatch_Table_Entity
(Etype
(Iface_DT
));
7334 if Is_CPP_Class
(Root_Type
(Typ
)) then
7335 Set_Ekind
(DT_Ptr
, E_Variable
);
7337 Set_Ekind
(DT_Ptr
, E_Constant
);
7340 Set_Is_Tag
(DT_Ptr
);
7341 Set_Related_Type
(DT_Ptr
, Typ
);
7350 function New_Value
(From
: Node_Id
) return Node_Id
is
7351 Res
: constant Node_Id
:= Duplicate_Subexpr
(From
);
7353 if Is_Access_Type
(Etype
(From
)) then
7354 return Make_Explicit_Dereference
(Sloc
(From
), Prefix
=> Res
);
7360 -----------------------------------
7361 -- Original_View_In_Visible_Part --
7362 -----------------------------------
7364 function Original_View_In_Visible_Part
(Typ
: Entity_Id
) return Boolean is
7365 Scop
: constant Entity_Id
:= Scope
(Typ
);
7368 -- The scope must be a package
7370 if not Is_Package_Or_Generic_Package
(Scop
) then
7374 -- A type with a private declaration has a private view declared in
7375 -- the visible part.
7377 if Has_Private_Declaration
(Typ
) then
7381 return List_Containing
(Parent
(Typ
)) =
7382 Visible_Declarations
(Package_Specification
(Scop
));
7383 end Original_View_In_Visible_Part
;
7389 function Prim_Op_Kind
7391 Typ
: Entity_Id
) return Node_Id
7393 Full_Typ
: Entity_Id
:= Typ
;
7394 Loc
: constant Source_Ptr
:= Sloc
(Prim
);
7395 Prim_Op
: Entity_Id
;
7398 -- Retrieve the original primitive operation
7400 Prim_Op
:= Ultimate_Alias
(Prim
);
7402 if Ekind
(Typ
) = E_Record_Type
7403 and then Present
(Corresponding_Concurrent_Type
(Typ
))
7405 Full_Typ
:= Corresponding_Concurrent_Type
(Typ
);
7408 -- When a private tagged type is completed by a concurrent type,
7409 -- retrieve the full view.
7411 if Is_Private_Type
(Full_Typ
) then
7412 Full_Typ
:= Full_View
(Full_Typ
);
7415 if Ekind
(Prim_Op
) = E_Function
then
7417 -- Protected function
7419 if Ekind
(Full_Typ
) = E_Protected_Type
then
7420 return New_Occurrence_Of
(RTE
(RE_POK_Protected_Function
), Loc
);
7424 elsif Ekind
(Full_Typ
) = E_Task_Type
then
7425 return New_Occurrence_Of
(RTE
(RE_POK_Task_Function
), Loc
);
7430 return New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
);
7434 pragma Assert
(Ekind
(Prim_Op
) = E_Procedure
);
7436 if Ekind
(Full_Typ
) = E_Protected_Type
then
7440 if Is_Primitive_Wrapper
(Prim_Op
)
7441 and then Ekind
(Wrapped_Entity
(Prim_Op
)) = E_Entry
7443 return New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
);
7445 -- Protected procedure
7449 New_Occurrence_Of
(RTE
(RE_POK_Protected_Procedure
), Loc
);
7452 elsif Ekind
(Full_Typ
) = E_Task_Type
then
7456 if Is_Primitive_Wrapper
(Prim_Op
)
7457 and then Ekind
(Wrapped_Entity
(Prim_Op
)) = E_Entry
7459 return New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
);
7461 -- Task "procedure". These are the internally Expander-generated
7462 -- procedures (task body for instance).
7465 return New_Occurrence_Of
(RTE
(RE_POK_Task_Procedure
), Loc
);
7468 -- Regular procedure
7471 return New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
);
7476 ------------------------
7477 -- Register_Primitive --
7478 ------------------------
7480 function Register_Primitive
7482 Prim
: Entity_Id
) return List_Id
7485 Iface_Prim
: Entity_Id
;
7486 Iface_Typ
: Entity_Id
;
7487 Iface_DT_Ptr
: Entity_Id
;
7488 Iface_DT_Elmt
: Elmt_Id
;
7489 L
: constant List_Id
:= New_List
;
7492 Tag_Typ
: Entity_Id
;
7493 Thunk_Id
: Entity_Id
;
7494 Thunk_Code
: Node_Id
;
7497 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
7499 -- Do not register in the dispatch table eliminated primitives
7501 if not RTE_Available
(RE_Tag
)
7502 or else Is_Eliminated
(Ultimate_Alias
(Prim
))
7503 or else Generate_SCIL
7508 if not Present
(Interface_Alias
(Prim
)) then
7509 Tag_Typ
:= Scope
(DTC_Entity
(Prim
));
7510 Pos
:= DT_Position
(Prim
);
7511 Tag
:= First_Tag_Component
(Tag_Typ
);
7513 if Is_Predefined_Dispatching_Operation
(Prim
)
7514 or else Is_Predefined_Dispatching_Alias
(Prim
)
7517 Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Tag_Typ
))));
7520 Build_Set_Predefined_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
))));
7529 -- Register copy of the pointer to the 'size primitive in the TSD
7531 if Chars
(Prim
) = Name_uSize
7532 and then RTE_Record_Component_Available
(RE_Size_Func
)
7534 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Tag_Typ
)));
7536 Build_Set_Size_Function
(Loc
,
7537 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7538 Size_Func
=> Prim
));
7542 pragma Assert
(Pos
/= Uint_0
and then Pos
<= DT_Entry_Count
(Tag
));
7544 -- Skip registration of primitives located in the C++ part of the
7545 -- dispatch table. Their slot is set by the IC routine.
7547 if not Is_CPP_Class
(Root_Type
(Tag_Typ
))
7548 or else Pos
> CPP_Num_Prims
(Tag_Typ
)
7550 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Tag_Typ
)));
7552 Build_Set_Prim_Op_Address
(Loc
,
7554 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7557 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7558 Make_Attribute_Reference
(Loc
,
7559 Prefix
=> New_Occurrence_Of
(Prim
, Loc
),
7560 Attribute_Name
=> Name_Unrestricted_Access
))));
7564 -- Ada 2005 (AI-251): Primitive associated with an interface type
7566 -- Generate the code of the thunk only if the interface type is not an
7567 -- immediate ancestor of Typ; otherwise the dispatch table associated
7568 -- with the interface is the primary dispatch table and we have nothing
7572 Tag_Typ
:= Find_Dispatching_Type
(Alias
(Prim
));
7573 Iface_Typ
:= Find_Dispatching_Type
(Interface_Alias
(Prim
));
7575 pragma Assert
(Is_Interface
(Iface_Typ
));
7577 -- No action needed for interfaces that are ancestors of Typ because
7578 -- their primitives are located in the primary dispatch table.
7580 if Is_Ancestor
(Iface_Typ
, Tag_Typ
, Use_Full_View
=> True) then
7583 -- No action needed for primitives located in the C++ part of the
7584 -- dispatch table. Their slot is set by the IC routine.
7586 elsif Is_CPP_Class
(Root_Type
(Tag_Typ
))
7587 and then DT_Position
(Alias
(Prim
)) <= CPP_Num_Prims
(Tag_Typ
)
7588 and then not Is_Predefined_Dispatching_Operation
(Prim
)
7589 and then not Is_Predefined_Dispatching_Alias
(Prim
)
7594 Expand_Interface_Thunk
(Prim
, Thunk_Id
, Thunk_Code
, Iface_Typ
);
7596 if not Is_Ancestor
(Iface_Typ
, Tag_Typ
, Use_Full_View
=> True)
7597 and then Present
(Thunk_Code
)
7599 -- Generate the code necessary to fill the appropriate entry of
7600 -- the secondary dispatch table of Prim's controlling type with
7601 -- Thunk_Id's address.
7603 Iface_DT_Elmt
:= Find_Interface_ADT
(Tag_Typ
, Iface_Typ
);
7604 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7605 pragma Assert
(Has_Thunks
(Iface_DT_Ptr
));
7607 Iface_Prim
:= Interface_Alias
(Prim
);
7608 Pos
:= DT_Position
(Iface_Prim
);
7609 Tag
:= First_Tag_Component
(Iface_Typ
);
7611 Prepend_To
(L
, Thunk_Code
);
7613 if Is_Predefined_Dispatching_Operation
(Prim
)
7614 or else Is_Predefined_Dispatching_Alias
(Prim
)
7617 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7619 New_Occurrence_Of
(Node
(Next_Elmt
(Iface_DT_Elmt
)), Loc
),
7622 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7623 Make_Attribute_Reference
(Loc
,
7624 Prefix
=> New_Occurrence_Of
(Thunk_Id
, Loc
),
7625 Attribute_Name
=> Name_Unrestricted_Access
))));
7627 Next_Elmt
(Iface_DT_Elmt
);
7628 Next_Elmt
(Iface_DT_Elmt
);
7629 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7630 pragma Assert
(not Has_Thunks
(Iface_DT_Ptr
));
7633 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7635 New_Occurrence_Of
(Node
(Next_Elmt
(Iface_DT_Elmt
)), Loc
),
7638 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7639 Make_Attribute_Reference
(Loc
,
7641 New_Occurrence_Of
(Alias
(Prim
), Loc
),
7642 Attribute_Name
=> Name_Unrestricted_Access
))));
7645 pragma Assert
(Pos
/= Uint_0
7646 and then Pos
<= DT_Entry_Count
(Tag
));
7649 Build_Set_Prim_Op_Address
(Loc
,
7651 Tag_Node
=> New_Occurrence_Of
(Iface_DT_Ptr
, Loc
),
7654 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7655 Make_Attribute_Reference
(Loc
,
7656 Prefix
=> New_Occurrence_Of
(Thunk_Id
, Loc
),
7657 Attribute_Name
=> Name_Unrestricted_Access
))));
7659 Next_Elmt
(Iface_DT_Elmt
);
7660 Next_Elmt
(Iface_DT_Elmt
);
7661 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7662 pragma Assert
(not Has_Thunks
(Iface_DT_Ptr
));
7665 Build_Set_Prim_Op_Address
(Loc
,
7667 Tag_Node
=> New_Occurrence_Of
(Iface_DT_Ptr
, Loc
),
7670 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7671 Make_Attribute_Reference
(Loc
,
7673 New_Occurrence_Of
(Ultimate_Alias
(Prim
), Loc
),
7674 Attribute_Name
=> Name_Unrestricted_Access
))));
7681 end Register_Primitive
;
7683 -------------------------
7684 -- Set_All_DT_Position --
7685 -------------------------
7687 procedure Set_All_DT_Position
(Typ
: Entity_Id
) is
7689 function In_Predef_Prims_DT
(Prim
: Entity_Id
) return Boolean;
7690 -- Returns True if Prim is located in the dispatch table of
7691 -- predefined primitives
7693 procedure Validate_Position
(Prim
: Entity_Id
);
7694 -- Check that position assigned to Prim is completely safe (it has not
7695 -- been assigned to a previously defined primitive operation of Typ).
7697 ------------------------
7698 -- In_Predef_Prims_DT --
7699 ------------------------
7701 function In_Predef_Prims_DT
(Prim
: Entity_Id
) return Boolean is
7703 -- Predefined primitives
7705 if Is_Predefined_Dispatching_Operation
(Prim
) then
7708 -- Renamings of predefined primitives
7710 elsif Present
(Alias
(Prim
))
7711 and then Is_Predefined_Dispatching_Operation
(Ultimate_Alias
(Prim
))
7713 if Chars
(Ultimate_Alias
(Prim
)) /= Name_Op_Eq
then
7716 -- An overriding operation that is a user-defined renaming of
7717 -- predefined equality inherits its slot from the overridden
7718 -- operation. Otherwise it is treated as a predefined op and
7719 -- occupies the same predefined slot as equality. A call to it is
7720 -- transformed into a call to its alias, which is the predefined
7721 -- equality op. A dispatching call thus uses the proper slot if
7722 -- operation is further inherited and called with class-wide
7727 not Comes_From_Source
(Prim
)
7728 or else No
(Overridden_Operation
(Prim
));
7731 -- User-defined primitives
7736 end In_Predef_Prims_DT
;
7738 -----------------------
7739 -- Validate_Position --
7740 -----------------------
7742 procedure Validate_Position
(Prim
: Entity_Id
) is
7747 -- Aliased primitives are safe
7749 if Present
(Alias
(Prim
)) then
7753 Op_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
7754 while Present
(Op_Elmt
) loop
7755 Op
:= Node
(Op_Elmt
);
7757 -- No need to check against itself
7762 -- Primitive operations covering abstract interfaces are
7765 elsif Present
(Interface_Alias
(Op
)) then
7768 -- Predefined dispatching operations are completely safe. They
7769 -- are allocated at fixed positions in a separate table.
7771 elsif Is_Predefined_Dispatching_Operation
(Op
)
7772 or else Is_Predefined_Dispatching_Alias
(Op
)
7776 -- Aliased subprograms are safe
7778 elsif Present
(Alias
(Op
)) then
7781 elsif DT_Position
(Op
) = DT_Position
(Prim
)
7782 and then not Is_Predefined_Dispatching_Operation
(Op
)
7783 and then not Is_Predefined_Dispatching_Operation
(Prim
)
7784 and then not Is_Predefined_Dispatching_Alias
(Op
)
7785 and then not Is_Predefined_Dispatching_Alias
(Prim
)
7787 -- Handle aliased subprograms
7796 if Present
(Overridden_Operation
(Op_1
)) then
7797 Op_1
:= Overridden_Operation
(Op_1
);
7798 elsif Present
(Alias
(Op_1
)) then
7799 Op_1
:= Alias
(Op_1
);
7807 if Present
(Overridden_Operation
(Op_2
)) then
7808 Op_2
:= Overridden_Operation
(Op_2
);
7809 elsif Present
(Alias
(Op_2
)) then
7810 Op_2
:= Alias
(Op_2
);
7816 if Op_1
/= Op_2
then
7817 raise Program_Error
;
7822 Next_Elmt
(Op_Elmt
);
7824 end Validate_Position
;
7828 Parent_Typ
: constant Entity_Id
:= Etype
(Typ
);
7829 First_Prim
: constant Elmt_Id
:= First_Elmt
(Primitive_Operations
(Typ
));
7830 The_Tag
: constant Entity_Id
:= First_Tag_Component
(Typ
);
7832 Adjusted
: Boolean := False;
7833 Finalized
: Boolean := False;
7839 Prim_Elmt
: Elmt_Id
;
7841 -- Start of processing for Set_All_DT_Position
7844 pragma Assert
(Present
(First_Tag_Component
(Typ
)));
7846 -- Set the DT_Position for each primitive operation. Perform some sanity
7847 -- checks to avoid building inconsistent dispatch tables.
7849 -- First stage: Set DTC entity of all the primitive operations. This is
7850 -- required to properly read the DT_Position attribute in latter stages.
7852 Prim_Elmt
:= First_Prim
;
7854 while Present
(Prim_Elmt
) loop
7855 Prim
:= Node
(Prim_Elmt
);
7857 -- Predefined primitives have a separate dispatch table
7859 if not In_Predef_Prims_DT
(Prim
) then
7860 Count_Prim
:= Count_Prim
+ 1;
7863 Set_DTC_Entity_Value
(Typ
, Prim
);
7865 -- Clear any previous value of the DT_Position attribute. In this
7866 -- way we ensure that the final position of all the primitives is
7867 -- established by the following stages of this algorithm.
7869 Set_DT_Position_Value
(Prim
, No_Uint
);
7871 Next_Elmt
(Prim_Elmt
);
7875 Fixed_Prim
: array (Int
range 0 .. Count_Prim
) of Boolean :=
7880 procedure Handle_Inherited_Private_Subprograms
(Typ
: Entity_Id
);
7881 -- Called if Typ is declared in a nested package or a public child
7882 -- package to handle inherited primitives that were inherited by Typ
7883 -- in the visible part, but whose declaration was deferred because
7884 -- the parent operation was private and not visible at that point.
7886 procedure Set_Fixed_Prim
(Pos
: Nat
);
7887 -- Sets to true an element of the Fixed_Prim table to indicate
7888 -- that this entry of the dispatch table of Typ is occupied.
7890 ------------------------------------------
7891 -- Handle_Inherited_Private_Subprograms --
7892 ------------------------------------------
7894 procedure Handle_Inherited_Private_Subprograms
(Typ
: Entity_Id
) is
7897 Op_Elmt_2
: Elmt_Id
;
7898 Prim_Op
: Entity_Id
;
7899 Parent_Subp
: Entity_Id
;
7902 Op_List
:= Primitive_Operations
(Typ
);
7904 Op_Elmt
:= First_Elmt
(Op_List
);
7905 while Present
(Op_Elmt
) loop
7906 Prim_Op
:= Node
(Op_Elmt
);
7908 -- Search primitives that are implicit operations with an
7909 -- internal name whose parent operation has a normal name.
7911 if Present
(Alias
(Prim_Op
))
7912 and then Find_Dispatching_Type
(Alias
(Prim_Op
)) /= Typ
7913 and then not Comes_From_Source
(Prim_Op
)
7914 and then Is_Internal_Name
(Chars
(Prim_Op
))
7915 and then not Is_Internal_Name
(Chars
(Alias
(Prim_Op
)))
7917 Parent_Subp
:= Alias
(Prim_Op
);
7919 -- Check if the type has an explicit overriding for this
7922 Op_Elmt_2
:= Next_Elmt
(Op_Elmt
);
7923 while Present
(Op_Elmt_2
) loop
7924 if Chars
(Node
(Op_Elmt_2
)) = Chars
(Parent_Subp
)
7925 and then Type_Conformant
(Prim_Op
, Node
(Op_Elmt_2
))
7927 Set_DT_Position_Value
(Prim_Op
,
7928 DT_Position
(Parent_Subp
));
7929 Set_DT_Position_Value
(Node
(Op_Elmt_2
),
7930 DT_Position
(Parent_Subp
));
7931 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(Prim_Op
)));
7933 goto Next_Primitive
;
7936 Next_Elmt
(Op_Elmt_2
);
7941 Next_Elmt
(Op_Elmt
);
7943 end Handle_Inherited_Private_Subprograms
;
7945 --------------------
7946 -- Set_Fixed_Prim --
7947 --------------------
7949 procedure Set_Fixed_Prim
(Pos
: Nat
) is
7951 pragma Assert
(Pos
<= Count_Prim
);
7952 Fixed_Prim
(Pos
) := True;
7954 when Constraint_Error
=>
7955 raise Program_Error
;
7959 -- In case of nested packages and public child package it may be
7960 -- necessary a special management on inherited subprograms so that
7961 -- the dispatch table is properly filled.
7963 if Ekind
(Scope
(Scope
(Typ
))) = E_Package
7964 and then Scope
(Scope
(Typ
)) /= Standard_Standard
7965 and then ((Is_Derived_Type
(Typ
) and then not Is_Private_Type
(Typ
))
7967 (Nkind
(Parent
(Typ
)) = N_Private_Extension_Declaration
7968 and then Is_Generic_Type
(Typ
)))
7969 and then In_Open_Scopes
(Scope
(Etype
(Typ
)))
7970 and then Is_Base_Type
(Typ
)
7972 Handle_Inherited_Private_Subprograms
(Typ
);
7975 -- Second stage: Register fixed entries
7978 Prim_Elmt
:= First_Prim
;
7979 while Present
(Prim_Elmt
) loop
7980 Prim
:= Node
(Prim_Elmt
);
7982 -- Predefined primitives have a separate table and all its
7983 -- entries are at predefined fixed positions.
7985 if In_Predef_Prims_DT
(Prim
) then
7986 if Is_Predefined_Dispatching_Operation
(Prim
) then
7987 Set_DT_Position_Value
(Prim
,
7988 Default_Prim_Op_Position
(Prim
));
7990 else pragma Assert
(Present
(Alias
(Prim
)));
7991 Set_DT_Position_Value
(Prim
,
7992 Default_Prim_Op_Position
(Ultimate_Alias
(Prim
)));
7995 -- Overriding primitives of ancestor abstract interfaces
7997 elsif Present
(Interface_Alias
(Prim
))
7998 and then Is_Ancestor
7999 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
8000 Use_Full_View
=> True)
8002 pragma Assert
(DT_Position
(Prim
) = No_Uint
8003 and then Present
(DTC_Entity
(Interface_Alias
(Prim
))));
8005 E
:= Interface_Alias
(Prim
);
8006 Set_DT_Position_Value
(Prim
, DT_Position
(E
));
8009 (DT_Position
(Alias
(Prim
)) = No_Uint
8010 or else DT_Position
(Alias
(Prim
)) = DT_Position
(E
));
8011 Set_DT_Position_Value
(Alias
(Prim
), DT_Position
(E
));
8012 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(Prim
)));
8014 -- Overriding primitives must use the same entry as the overridden
8015 -- primitive. Note that the Alias of the operation is set when the
8016 -- operation is declared by a renaming, in which case it is not
8017 -- overriding. If it renames another primitive it will use the
8018 -- same dispatch table slot, but if it renames an operation in a
8019 -- nested package it's a new primitive and will have its own slot.
8021 elsif not Present
(Interface_Alias
(Prim
))
8022 and then Present
(Alias
(Prim
))
8023 and then Chars
(Prim
) = Chars
(Alias
(Prim
))
8024 and then Nkind
(Unit_Declaration_Node
(Prim
)) /=
8025 N_Subprogram_Renaming_Declaration
8028 Par_Type
: constant Entity_Id
:=
8029 Find_Dispatching_Type
(Alias
(Prim
));
8032 if Present
(Par_Type
)
8033 and then Par_Type
/= Typ
8034 and then Is_Ancestor
(Par_Type
, Typ
, Use_Full_View
=> True)
8035 and then Present
(DTC_Entity
(Alias
(Prim
)))
8038 Set_DT_Position_Value
(Prim
, DT_Position
(E
));
8040 if not Is_Predefined_Dispatching_Alias
(E
) then
8041 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(E
)));
8047 Next_Elmt
(Prim_Elmt
);
8050 -- Third stage: Fix the position of all the new primitives. Entries
8051 -- associated with primitives covering interfaces are handled in a
8054 Prim_Elmt
:= First_Prim
;
8055 while Present
(Prim_Elmt
) loop
8056 Prim
:= Node
(Prim_Elmt
);
8058 -- Skip primitives previously set entries
8060 if DT_Position
(Prim
) /= No_Uint
then
8063 -- Primitives covering interface primitives are handled later
8065 elsif Present
(Interface_Alias
(Prim
)) then
8069 -- Take the next available position in the DT
8072 Nb_Prim
:= Nb_Prim
+ 1;
8073 pragma Assert
(Nb_Prim
<= Count_Prim
);
8074 exit when not Fixed_Prim
(Nb_Prim
);
8077 Set_DT_Position_Value
(Prim
, UI_From_Int
(Nb_Prim
));
8078 Set_Fixed_Prim
(Nb_Prim
);
8081 Next_Elmt
(Prim_Elmt
);
8085 -- Fourth stage: Complete the decoration of primitives covering
8086 -- interfaces (that is, propagate the DT_Position attribute from
8087 -- the aliased primitive)
8089 Prim_Elmt
:= First_Prim
;
8090 while Present
(Prim_Elmt
) loop
8091 Prim
:= Node
(Prim_Elmt
);
8093 if DT_Position
(Prim
) = No_Uint
8094 and then Present
(Interface_Alias
(Prim
))
8096 pragma Assert
(Present
(Alias
(Prim
))
8097 and then Find_Dispatching_Type
(Alias
(Prim
)) = Typ
);
8099 -- Check if this entry will be placed in the primary DT
8102 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
8103 Use_Full_View
=> True)
8105 pragma Assert
(DT_Position
(Alias
(Prim
)) /= No_Uint
);
8106 Set_DT_Position_Value
(Prim
, DT_Position
(Alias
(Prim
)));
8108 -- Otherwise it will be placed in the secondary DT
8112 (DT_Position
(Interface_Alias
(Prim
)) /= No_Uint
);
8113 Set_DT_Position_Value
(Prim
,
8114 DT_Position
(Interface_Alias
(Prim
)));
8118 Next_Elmt
(Prim_Elmt
);
8121 -- Generate listing showing the contents of the dispatch tables. This
8122 -- action is done before some further static checks because in case of
8123 -- critical errors caused by a wrong dispatch table we need to see the
8124 -- contents of such table.
8126 if Debug_Flag_ZZ
then
8130 -- Final stage: Ensure that the table is correct plus some further
8131 -- verifications concerning the primitives.
8133 Prim_Elmt
:= First_Prim
;
8135 while Present
(Prim_Elmt
) loop
8136 Prim
:= Node
(Prim_Elmt
);
8138 -- At this point all the primitives MUST have a position in the
8141 if DT_Position
(Prim
) = No_Uint
then
8142 raise Program_Error
;
8145 -- Calculate real size of the dispatch table
8147 if not In_Predef_Prims_DT
(Prim
)
8148 and then UI_To_Int
(DT_Position
(Prim
)) > DT_Length
8150 DT_Length
:= UI_To_Int
(DT_Position
(Prim
));
8153 -- Ensure that the assigned position to non-predefined dispatching
8154 -- operations in the dispatch table is correct.
8156 if not Is_Predefined_Dispatching_Operation
(Prim
)
8157 and then not Is_Predefined_Dispatching_Alias
(Prim
)
8159 Validate_Position
(Prim
);
8162 if Chars
(Prim
) = Name_Finalize
then
8166 if Chars
(Prim
) = Name_Adjust
then
8170 -- An abstract operation cannot be declared in the private part for a
8171 -- visible abstract type, because it can't be overridden outside this
8172 -- package hierarchy. For explicit declarations this is checked at
8173 -- the point of declaration, but for inherited operations it must be
8174 -- done when building the dispatch table.
8176 -- Ada 2005 (AI-251): Primitives associated with interfaces are
8177 -- excluded from this check because interfaces must be visible in
8178 -- the public and private part (RM 7.3 (7.3/2))
8180 -- We disable this check in Relaxed_RM_Semantics mode, to accommodate
8183 if not Relaxed_RM_Semantics
8184 and then Is_Abstract_Type
(Typ
)
8185 and then Is_Abstract_Subprogram
(Prim
)
8186 and then Present
(Alias
(Prim
))
8187 and then not Is_Interface
8188 (Find_Dispatching_Type
(Ultimate_Alias
(Prim
)))
8189 and then not Present
(Interface_Alias
(Prim
))
8190 and then Is_Derived_Type
(Typ
)
8191 and then In_Private_Part
(Current_Scope
)
8193 List_Containing
(Parent
(Prim
)) =
8194 Private_Declarations
(Package_Specification
(Current_Scope
))
8195 and then Original_View_In_Visible_Part
(Typ
)
8197 -- We exclude Input and Output stream operations because
8198 -- Limited_Controlled inherits useless Input and Output stream
8199 -- operations from Root_Controlled, which can never be overridden.
8200 -- Move this check to sem???
8202 if not Is_TSS
(Prim
, TSS_Stream_Input
)
8204 not Is_TSS
(Prim
, TSS_Stream_Output
)
8207 ("abstract inherited private operation&" &
8208 " must be overridden (RM 3.9.3(10))",
8209 Parent
(Typ
), Prim
);
8213 Next_Elmt
(Prim_Elmt
);
8218 if Is_Controlled
(Typ
) then
8219 if not Finalized
then
8221 ("controlled type has no explicit Finalize method??", Typ
);
8223 elsif not Adjusted
then
8225 ("controlled type has no explicit Adjust method??", Typ
);
8229 -- Set the final size of the Dispatch Table
8231 Set_DT_Entry_Count
(The_Tag
, UI_From_Int
(DT_Length
));
8233 -- The derived type must have at least as many components as its parent
8234 -- (for root types Etype points to itself and the test cannot fail).
8236 if DT_Entry_Count
(The_Tag
) <
8237 DT_Entry_Count
(First_Tag_Component
(Parent_Typ
))
8239 raise Program_Error
;
8241 end Set_All_DT_Position
;
8243 --------------------------
8244 -- Set_CPP_Constructors --
8245 --------------------------
8247 procedure Set_CPP_Constructors
(Typ
: Entity_Id
) is
8249 function Gen_Parameters_Profile
(E
: Entity_Id
) return List_Id
;
8250 -- Duplicate the parameters profile of the imported C++ constructor
8251 -- adding the "this" pointer to the object as the additional first
8252 -- parameter under the usual form _Init : in out Typ.
8254 ----------------------------
8255 -- Gen_Parameters_Profile --
8256 ----------------------------
8258 function Gen_Parameters_Profile
(E
: Entity_Id
) return List_Id
is
8259 Loc
: constant Source_Ptr
:= Sloc
(E
);
8266 Make_Parameter_Specification
(Loc
,
8267 Defining_Identifier
=>
8268 Make_Defining_Identifier
(Loc
, Name_uInit
),
8270 Out_Present
=> True,
8271 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
8273 if Present
(Parameter_Specifications
(Parent
(E
))) then
8274 P
:= First
(Parameter_Specifications
(Parent
(E
)));
8275 while Present
(P
) loop
8277 Make_Parameter_Specification
(Loc
,
8278 Defining_Identifier
=>
8279 Make_Defining_Identifier
(Loc
,
8280 Chars
=> Chars
(Defining_Identifier
(P
))),
8281 Parameter_Type
=> New_Copy_Tree
(Parameter_Type
(P
)),
8282 Expression
=> New_Copy_Tree
(Expression
(P
))));
8288 end Gen_Parameters_Profile
;
8294 Found
: Boolean := False;
8300 Covers_Default_Constructor
: Entity_Id
:= Empty
;
8302 -- Start of processing for Set_CPP_Constructor
8305 pragma Assert
(Is_CPP_Class
(Typ
));
8307 -- Look for the constructor entities
8309 E
:= Next_Entity
(Typ
);
8310 while Present
(E
) loop
8311 if Ekind
(E
) = E_Function
8312 and then Is_Constructor
(E
)
8316 Parms
:= Gen_Parameters_Profile
(E
);
8317 IP
:= Make_Defining_Identifier
(Loc
, Make_Init_Proc_Name
(Typ
));
8319 -- Case 1: Constructor of untagged type
8321 -- If the C++ class has no virtual methods then the matching Ada
8322 -- type is an untagged record type. In such case there is no need
8323 -- to generate a wrapper of the C++ constructor because the _tag
8324 -- component is not available.
8326 if not Is_Tagged_Type
(Typ
) then
8328 (Make_Subprogram_Declaration
(Loc
,
8330 Make_Procedure_Specification
(Loc
,
8331 Defining_Unit_Name
=> IP
,
8332 Parameter_Specifications
=> Parms
)));
8334 Set_Init_Proc
(Typ
, IP
);
8335 Set_Is_Imported
(IP
);
8336 Set_Is_Constructor
(IP
);
8337 Set_Interface_Name
(IP
, Interface_Name
(E
));
8338 Set_Convention
(IP
, Convention_CPP
);
8340 Set_Has_Completion
(IP
);
8342 -- Case 2: Constructor of a tagged type
8344 -- In this case we generate the IP routine as a wrapper of the
8345 -- C++ constructor because IP must also save a copy of the _tag
8346 -- generated in the C++ side. The copy of the _tag is used by
8347 -- Build_CPP_Init_Procedure to elaborate derivations of C++ types.
8350 -- procedure IP (_init : in out Typ; ...) is
8351 -- procedure ConstructorP (_init : in out Typ; ...);
8352 -- pragma Import (ConstructorP);
8354 -- ConstructorP (_init, ...);
8355 -- if Typ._tag = null then
8356 -- Typ._tag := _init._tag;
8362 Body_Stmts
: constant List_Id
:= New_List
;
8363 Constructor_Id
: Entity_Id
;
8364 Constructor_Decl_Node
: Node_Id
;
8365 Init_Tags_List
: List_Id
;
8368 Constructor_Id
:= Make_Temporary
(Loc
, 'P');
8370 Constructor_Decl_Node
:=
8371 Make_Subprogram_Declaration
(Loc
,
8372 Make_Procedure_Specification
(Loc
,
8373 Defining_Unit_Name
=> Constructor_Id
,
8374 Parameter_Specifications
=> Parms
));
8376 Set_Is_Imported
(Constructor_Id
);
8377 Set_Is_Constructor
(Constructor_Id
);
8378 Set_Interface_Name
(Constructor_Id
, Interface_Name
(E
));
8379 Set_Convention
(Constructor_Id
, Convention_CPP
);
8380 Set_Is_Public
(Constructor_Id
);
8381 Set_Has_Completion
(Constructor_Id
);
8383 -- Build the init procedure as a wrapper of this constructor
8385 Parms
:= Gen_Parameters_Profile
(E
);
8387 -- Invoke the C++ constructor
8390 Actuals
: constant List_Id
:= New_List
;
8394 while Present
(P
) loop
8396 New_Occurrence_Of
(Defining_Identifier
(P
), Loc
));
8400 Append_To
(Body_Stmts
,
8401 Make_Procedure_Call_Statement
(Loc
,
8402 Name
=> New_Occurrence_Of
(Constructor_Id
, Loc
),
8403 Parameter_Associations
=> Actuals
));
8406 -- Initialize copies of C++ primary and secondary tags
8408 Init_Tags_List
:= New_List
;
8415 Tag_Elmt
:= First_Elmt
(Access_Disp_Table
(Typ
));
8416 Tag_Comp
:= First_Tag_Component
(Typ
);
8418 while Present
(Tag_Elmt
)
8419 and then Is_Tag
(Node
(Tag_Elmt
))
8421 -- Skip the following assertion with primary tags
8422 -- because Related_Type is not set on primary tag
8426 (Tag_Comp
= First_Tag_Component
(Typ
)
8427 or else Related_Type
(Node
(Tag_Elmt
))
8428 = Related_Type
(Tag_Comp
));
8430 Append_To
(Init_Tags_List
,
8431 Make_Assignment_Statement
(Loc
,
8433 New_Occurrence_Of
(Node
(Tag_Elmt
), Loc
),
8435 Make_Selected_Component
(Loc
,
8437 Make_Identifier
(Loc
, Name_uInit
),
8439 New_Occurrence_Of
(Tag_Comp
, Loc
))));
8441 Tag_Comp
:= Next_Tag_Component
(Tag_Comp
);
8442 Next_Elmt
(Tag_Elmt
);
8446 Append_To
(Body_Stmts
,
8447 Make_If_Statement
(Loc
,
8452 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))),
8455 Unchecked_Convert_To
(RTE
(RE_Tag
),
8456 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))),
8457 Then_Statements
=> Init_Tags_List
));
8460 Make_Subprogram_Body
(Loc
,
8462 Make_Procedure_Specification
(Loc
,
8463 Defining_Unit_Name
=> IP
,
8464 Parameter_Specifications
=> Parms
),
8465 Declarations
=> New_List
(Constructor_Decl_Node
),
8466 Handled_Statement_Sequence
=>
8467 Make_Handled_Sequence_Of_Statements
(Loc
,
8468 Statements
=> Body_Stmts
,
8469 Exception_Handlers
=> No_List
));
8471 Discard_Node
(IP_Body
);
8472 Set_Init_Proc
(Typ
, IP
);
8476 -- If this constructor has parameters and all its parameters have
8477 -- defaults then it covers the default constructor. The semantic
8478 -- analyzer ensures that only one constructor with defaults covers
8479 -- the default constructor.
8481 if Present
(Parameter_Specifications
(Parent
(E
)))
8482 and then Needs_No_Actuals
(E
)
8484 Covers_Default_Constructor
:= IP
;
8491 -- If there are no constructors, mark the type as abstract since we
8492 -- won't be able to declare objects of that type.
8495 Set_Is_Abstract_Type
(Typ
);
8498 -- Handle constructor that has all its parameters with defaults and
8499 -- hence it covers the default constructor. We generate a wrapper IP
8500 -- which calls the covering constructor.
8502 if Present
(Covers_Default_Constructor
) then
8504 Body_Stmts
: List_Id
;
8507 Loc
:= Sloc
(Covers_Default_Constructor
);
8509 Body_Stmts
:= New_List
(
8510 Make_Procedure_Call_Statement
(Loc
,
8512 New_Occurrence_Of
(Covers_Default_Constructor
, Loc
),
8513 Parameter_Associations
=> New_List
(
8514 Make_Identifier
(Loc
, Name_uInit
))));
8516 IP
:= Make_Defining_Identifier
(Loc
, Make_Init_Proc_Name
(Typ
));
8519 Make_Subprogram_Body
(Loc
,
8521 Make_Procedure_Specification
(Loc
,
8522 Defining_Unit_Name
=> IP
,
8523 Parameter_Specifications
=> New_List
(
8524 Make_Parameter_Specification
(Loc
,
8525 Defining_Identifier
=>
8526 Make_Defining_Identifier
(Loc
, Name_uInit
),
8527 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)))),
8529 Declarations
=> No_List
,
8531 Handled_Statement_Sequence
=>
8532 Make_Handled_Sequence_Of_Statements
(Loc
,
8533 Statements
=> Body_Stmts
,
8534 Exception_Handlers
=> No_List
));
8536 Discard_Node
(IP_Body
);
8537 Set_Init_Proc
(Typ
, IP
);
8541 -- If the CPP type has constructors then it must import also the default
8542 -- C++ constructor. It is required for default initialization of objects
8543 -- of the type. It is also required to elaborate objects of Ada types
8544 -- that are defined as derivations of this CPP type.
8546 if Has_CPP_Constructors
(Typ
)
8547 and then No
(Init_Proc
(Typ
))
8549 Error_Msg_N
("??default constructor must be imported from C++", Typ
);
8551 end Set_CPP_Constructors
;
8553 ---------------------------
8554 -- Set_DT_Position_Value --
8555 ---------------------------
8557 procedure Set_DT_Position_Value
(Prim
: Entity_Id
; Value
: Uint
) is
8559 Set_DT_Position
(Prim
, Value
);
8561 -- Propagate the value to the wrapped subprogram (if one is present)
8563 if Ekind
(Prim
) in E_Function | E_Procedure
8564 and then Is_Primitive_Wrapper
(Prim
)
8565 and then Present
(Wrapped_Entity
(Prim
))
8566 and then Is_Dispatching_Operation
(Wrapped_Entity
(Prim
))
8568 Set_DT_Position
(Wrapped_Entity
(Prim
), Value
);
8570 end Set_DT_Position_Value
;
8572 --------------------------
8573 -- Set_DTC_Entity_Value --
8574 --------------------------
8576 procedure Set_DTC_Entity_Value
8577 (Tagged_Type
: Entity_Id
;
8581 if Present
(Interface_Alias
(Prim
))
8582 and then Is_Interface
8583 (Find_Dispatching_Type
(Interface_Alias
(Prim
)))
8585 Set_DTC_Entity
(Prim
,
8588 Iface
=> Find_Dispatching_Type
(Interface_Alias
(Prim
))));
8590 Set_DTC_Entity
(Prim
,
8591 First_Tag_Component
(Tagged_Type
));
8594 -- Propagate the value to the wrapped subprogram (if one is present)
8596 if Ekind
(Prim
) in E_Function | E_Procedure
8597 and then Is_Primitive_Wrapper
(Prim
)
8598 and then Present
(Wrapped_Entity
(Prim
))
8599 and then Is_Dispatching_Operation
(Wrapped_Entity
(Prim
))
8601 Set_DTC_Entity
(Wrapped_Entity
(Prim
), DTC_Entity
(Prim
));
8603 end Set_DTC_Entity_Value
;
8609 function Tagged_Kind
(T
: Entity_Id
) return Node_Id
is
8610 Conc_Typ
: Entity_Id
;
8611 Loc
: constant Source_Ptr
:= Sloc
(T
);
8615 (Is_Tagged_Type
(T
) and then RTE_Available
(RE_Tagged_Kind
));
8619 if Is_Abstract_Type
(T
) then
8620 if Is_Limited_Record
(T
) then
8621 return New_Occurrence_Of
8622 (RTE
(RE_TK_Abstract_Limited_Tagged
), Loc
);
8624 return New_Occurrence_Of
8625 (RTE
(RE_TK_Abstract_Tagged
), Loc
);
8630 elsif Is_Concurrent_Record_Type
(T
) then
8631 Conc_Typ
:= Corresponding_Concurrent_Type
(T
);
8633 if Present
(Full_View
(Conc_Typ
)) then
8634 Conc_Typ
:= Full_View
(Conc_Typ
);
8637 if Ekind
(Conc_Typ
) = E_Protected_Type
then
8638 return New_Occurrence_Of
(RTE
(RE_TK_Protected
), Loc
);
8640 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
8641 return New_Occurrence_Of
(RTE
(RE_TK_Task
), Loc
);
8644 -- Regular tagged kinds
8647 if Is_Limited_Record
(T
) then
8648 return New_Occurrence_Of
(RTE
(RE_TK_Limited_Tagged
), Loc
);
8650 return New_Occurrence_Of
(RTE
(RE_TK_Tagged
), Loc
);
8659 procedure Write_DT
(Typ
: Entity_Id
) is
8664 -- Protect this procedure against wrong usage. Required because it will
8665 -- be used directly from GDB
8667 if not (Typ
<= Last_Node_Id
)
8668 or else not Is_Tagged_Type
(Typ
)
8670 Write_Str
("wrong usage: Write_DT must be used with tagged types");
8675 Write_Int
(Int
(Typ
));
8677 Write_Name
(Chars
(Typ
));
8679 if Is_Interface
(Typ
) then
8680 Write_Str
(" is interface");
8685 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
8686 while Present
(Elmt
) loop
8687 Prim
:= Node
(Elmt
);
8690 -- Indicate if this primitive will be allocated in the primary
8691 -- dispatch table or in a secondary dispatch table associated
8692 -- with an abstract interface type
8694 if Present
(DTC_Entity
(Prim
)) then
8695 if Etype
(DTC_Entity
(Prim
)) = RTE
(RE_Tag
) then
8702 -- Output the node of this primitive operation and its name
8704 Write_Int
(Int
(Prim
));
8707 if Is_Predefined_Dispatching_Operation
(Prim
) then
8708 Write_Str
("(predefined) ");
8711 -- Prefix the name of the primitive with its corresponding tagged
8712 -- type to facilitate seeing inherited primitives.
8714 if Present
(Alias
(Prim
)) then
8716 (Chars
(Find_Dispatching_Type
(Ultimate_Alias
(Prim
))));
8718 Write_Name
(Chars
(Typ
));
8722 Write_Name
(Chars
(Prim
));
8724 -- Indicate if this primitive has an aliased primitive
8726 if Present
(Alias
(Prim
)) then
8727 Write_Str
(" (alias = ");
8728 Write_Int
(Int
(Alias
(Prim
)));
8730 -- If the DTC_Entity attribute is already set we can also output
8731 -- the name of the interface covered by this primitive (if any).
8733 if Ekind
(Alias
(Prim
)) in E_Function | E_Procedure
8734 and then Present
(DTC_Entity
(Alias
(Prim
)))
8735 and then Is_Interface
(Scope
(DTC_Entity
(Alias
(Prim
))))
8737 Write_Str
(" from interface ");
8738 Write_Name
(Chars
(Scope
(DTC_Entity
(Alias
(Prim
)))));
8741 if Present
(Interface_Alias
(Prim
)) then
8742 Write_Str
(", AI_Alias of ");
8744 if Is_Null_Interface_Primitive
(Interface_Alias
(Prim
)) then
8745 Write_Str
("null primitive ");
8749 (Chars
(Find_Dispatching_Type
(Interface_Alias
(Prim
))));
8751 Write_Int
(Int
(Interface_Alias
(Prim
)));
8757 -- Display the final position of this primitive in its associated
8758 -- (primary or secondary) dispatch table.
8760 if Present
(DTC_Entity
(Prim
))
8761 and then DT_Position
(Prim
) /= No_Uint
8763 Write_Str
(" at #");
8764 Write_Int
(UI_To_Int
(DT_Position
(Prim
)));
8767 if Is_Abstract_Subprogram
(Prim
) then
8768 Write_Str
(" is abstract;");
8770 -- Check if this is a null primitive
8772 elsif Comes_From_Source
(Prim
)
8773 and then Ekind
(Prim
) = E_Procedure
8774 and then Null_Present
(Parent
(Prim
))
8776 Write_Str
(" is null;");
8779 if Is_Eliminated
(Ultimate_Alias
(Prim
)) then
8780 Write_Str
(" (eliminated)");
8783 if Is_Imported
(Prim
)
8784 and then Convention
(Prim
) = Convention_CPP
8786 Write_Str
(" (C++)");