1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Expander
; use Expander
;
33 with Exp_Atag
; use Exp_Atag
;
34 with Exp_Ch6
; use Exp_Ch6
;
35 with Exp_CG
; use Exp_CG
;
36 with Exp_Dbug
; use Exp_Dbug
;
37 with Exp_Tss
; use Exp_Tss
;
38 with Exp_Util
; use Exp_Util
;
39 with Freeze
; use Freeze
;
40 with Ghost
; use Ghost
;
41 with Itypes
; use Itypes
;
42 with Layout
; use Layout
;
43 with Nlists
; use Nlists
;
44 with Nmake
; use Nmake
;
45 with Namet
; use Namet
;
47 with Output
; use Output
;
48 with Restrict
; use Restrict
;
49 with Rident
; use Rident
;
50 with Rtsfind
; use Rtsfind
;
52 with Sem_Aux
; use Sem_Aux
;
53 with Sem_Ch6
; use Sem_Ch6
;
54 with Sem_Ch7
; use Sem_Ch7
;
55 with Sem_Ch8
; use Sem_Ch8
;
56 with Sem_Disp
; use Sem_Disp
;
57 with Sem_Eval
; use Sem_Eval
;
58 with Sem_Res
; use Sem_Res
;
59 with Sem_Type
; use Sem_Type
;
60 with Sem_Util
; use Sem_Util
;
61 with Sinfo
; use Sinfo
;
62 with Sinput
; use Sinput
;
63 with Snames
; use Snames
;
64 with Stand
; use Stand
;
65 with Stringt
; use Stringt
;
66 with SCIL_LL
; use SCIL_LL
;
67 with Tbuild
; use Tbuild
;
69 package body Exp_Disp
is
71 -----------------------
72 -- Local Subprograms --
73 -----------------------
75 function Default_Prim_Op_Position
(E
: Entity_Id
) return Uint
;
76 -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
77 -- of the default primitive operations.
79 function Has_DT
(Typ
: Entity_Id
) return Boolean;
80 pragma Inline
(Has_DT
);
81 -- Returns true if we generate a dispatch table for tagged type Typ
83 function Is_Predefined_Dispatching_Alias
(Prim
: Entity_Id
) return Boolean;
84 -- Returns true if Prim is not a predefined dispatching primitive but it is
85 -- an alias of a predefined dispatching primitive (i.e. through a renaming)
87 function New_Value
(From
: Node_Id
) return Node_Id
;
88 -- From is the original Expression. New_Value is equivalent to a call to
89 -- Duplicate_Subexpr with an explicit dereference when From is an access
92 function Original_View_In_Visible_Part
(Typ
: Entity_Id
) return Boolean;
93 -- Check if the type has a private view or if the public view appears in
94 -- the visible part of a package spec.
98 Typ
: Entity_Id
) return Node_Id
;
99 -- Ada 2005 (AI-345): Determine the primitive operation kind of Prim
100 -- according to its type Typ. Return a reference to an RE_Prim_Op_Kind
101 -- enumeration value.
103 function Tagged_Kind
(T
: Entity_Id
) return Node_Id
;
104 -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
105 -- to an RE_Tagged_Kind enumeration value.
107 ----------------------
108 -- Apply_Tag_Checks --
109 ----------------------
111 procedure Apply_Tag_Checks
(Call_Node
: Node_Id
) is
112 Loc
: constant Source_Ptr
:= Sloc
(Call_Node
);
113 Ctrl_Arg
: constant Node_Id
:= Controlling_Argument
(Call_Node
);
114 Ctrl_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Ctrl_Arg
));
115 Param_List
: constant List_Id
:= Parameter_Associations
(Call_Node
);
121 Eq_Prim_Op
: Entity_Id
:= Empty
;
124 if No_Run_Time_Mode
then
125 Error_Msg_CRT
("tagged types", Call_Node
);
129 -- Apply_Tag_Checks is called directly from the semantics, so we
130 -- need a check to see whether expansion is active before proceeding.
131 -- In addition, there is no need to expand the call when compiling
132 -- under restriction No_Dispatching_Calls; the semantic analyzer has
133 -- previously notified the violation of this restriction.
135 if not Expander_Active
136 or else Restriction_Active
(No_Dispatching_Calls
)
141 -- Set subprogram. If this is an inherited operation that was
142 -- overridden, the body that is being called is its alias.
144 Subp
:= Entity
(Name
(Call_Node
));
146 if Present
(Alias
(Subp
))
147 and then Is_Inherited_Operation
(Subp
)
148 and then No
(DTC_Entity
(Subp
))
150 Subp
:= Alias
(Subp
);
153 -- Definition of the class-wide type and the tagged type
155 -- If the controlling argument is itself a tag rather than a tagged
156 -- object, then use the class-wide type associated with the subprogram's
157 -- controlling type. This case can occur when a call to an inherited
158 -- primitive has an actual that originated from a default parameter
159 -- given by a tag-indeterminate call and when there is no other
160 -- controlling argument providing the tag (AI-239 requires dispatching).
161 -- This capability of dispatching directly by tag is also needed by the
162 -- implementation of AI-260 (for the generic dispatching constructors).
164 if Ctrl_Typ
= RTE
(RE_Tag
)
165 or else (RTE_Available
(RE_Interface_Tag
)
166 and then Ctrl_Typ
= RTE
(RE_Interface_Tag
))
168 CW_Typ
:= Class_Wide_Type
(Find_Dispatching_Type
(Subp
));
170 -- Class_Wide_Type is applied to the expressions used to initialize
171 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
172 -- there are cases where the controlling type is resolved to a specific
173 -- type (such as for designated types of arguments such as CW'Access).
175 elsif Is_Access_Type
(Ctrl_Typ
) then
176 CW_Typ
:= Class_Wide_Type
(Designated_Type
(Ctrl_Typ
));
179 CW_Typ
:= Class_Wide_Type
(Ctrl_Typ
);
182 Typ
:= Find_Specific_Type
(CW_Typ
);
184 if not Is_Limited_Type
(Typ
) then
185 Eq_Prim_Op
:= Find_Prim_Op
(Typ
, Name_Op_Eq
);
188 -- Dispatching call to C++ primitive
190 if Is_CPP_Class
(Typ
) then
193 -- Dispatching call to Ada primitive
195 elsif Present
(Param_List
) then
197 -- Generate the Tag checks when appropriate
199 Param
:= First_Actual
(Call_Node
);
200 while Present
(Param
) loop
202 -- No tag check with itself
204 if Param
= Ctrl_Arg
then
207 -- No tag check for parameter whose type is neither tagged nor
208 -- access to tagged (for access parameters)
210 elsif No
(Find_Controlling_Arg
(Param
)) then
213 -- No tag check for function dispatching on result if the
214 -- Tag given by the context is this one
216 elsif Find_Controlling_Arg
(Param
) = Ctrl_Arg
then
219 -- "=" is the only dispatching operation allowed to get operands
220 -- with incompatible tags (it just returns false). We use
221 -- Duplicate_Subexpr_Move_Checks instead of calling Relocate_Node
222 -- because the value will be duplicated to check the tags.
224 elsif Subp
= Eq_Prim_Op
then
227 -- No check in presence of suppress flags
229 elsif Tag_Checks_Suppressed
(Etype
(Param
))
230 or else (Is_Access_Type
(Etype
(Param
))
231 and then Tag_Checks_Suppressed
232 (Designated_Type
(Etype
(Param
))))
236 -- Optimization: no tag checks if the parameters are identical
238 elsif Is_Entity_Name
(Param
)
239 and then Is_Entity_Name
(Ctrl_Arg
)
240 and then Entity
(Param
) = Entity
(Ctrl_Arg
)
244 -- Now we need to generate the Tag check
247 -- Generate code for tag equality check
249 -- Perhaps should have Checks.Apply_Tag_Equality_Check???
251 Insert_Action
(Ctrl_Arg
,
252 Make_Implicit_If_Statement
(Call_Node
,
256 Make_Selected_Component
(Loc
,
257 Prefix
=> New_Value
(Ctrl_Arg
),
260 (First_Tag_Component
(Typ
), Loc
)),
263 Make_Selected_Component
(Loc
,
265 Unchecked_Convert_To
(Typ
, New_Value
(Param
)),
268 (First_Tag_Component
(Typ
), Loc
))),
271 New_List
(New_Constraint_Error
(Loc
))));
277 end Apply_Tag_Checks
;
279 ------------------------
280 -- Building_Static_DT --
281 ------------------------
283 function Building_Static_DT
(Typ
: Entity_Id
) return Boolean is
284 Root_Typ
: Entity_Id
:= Root_Type
(Typ
);
288 -- Handle private types
290 if Present
(Full_View
(Root_Typ
)) then
291 Root_Typ
:= Full_View
(Root_Typ
);
295 Building_Static_Dispatch_Tables
296 and then Is_Library_Level_Tagged_Type
(Typ
)
298 -- If the type is derived from a CPP class we cannot statically
299 -- build the dispatch tables because we must inherit primitives
300 -- from the CPP side.
302 and then not Is_CPP_Class
(Root_Typ
);
304 if not Static_DT
then
305 Check_Restriction
(Static_Dispatch_Tables
, Typ
);
309 end Building_Static_DT
;
311 ----------------------------------
312 -- Building_Static_Secondary_DT --
313 ----------------------------------
315 function Building_Static_Secondary_DT
(Typ
: Entity_Id
) return Boolean is
316 Full_Typ
: Entity_Id
:= Typ
;
317 Root_Typ
: Entity_Id
:= Root_Type
(Typ
);
321 -- Handle private types
323 if Present
(Full_View
(Typ
)) then
324 Full_Typ
:= Full_View
(Typ
);
327 if Present
(Full_View
(Root_Typ
)) then
328 Root_Typ
:= Full_View
(Root_Typ
);
332 Building_Static_DT
(Full_Typ
)
333 and then not Is_Interface
(Full_Typ
)
334 and then Has_Interfaces
(Full_Typ
)
335 and then (Full_Typ
= Root_Typ
336 or else not Is_Variable_Size_Record
(Etype
(Full_Typ
)));
339 and then not Is_Interface
(Full_Typ
)
340 and then Has_Interfaces
(Full_Typ
)
342 Check_Restriction
(Static_Dispatch_Tables
, Typ
);
346 end Building_Static_Secondary_DT
;
348 ----------------------------------
349 -- Build_Static_Dispatch_Tables --
350 ----------------------------------
352 procedure Build_Static_Dispatch_Tables
(N
: Entity_Id
) is
353 Target_List
: List_Id
;
355 procedure Build_Dispatch_Tables
(List
: List_Id
);
356 -- Build the static dispatch table of tagged types found in the list of
357 -- declarations. The generated nodes are added at the end of Target_List
359 procedure Build_Package_Dispatch_Tables
(N
: Node_Id
);
360 -- Build static dispatch tables associated with package declaration N
362 ---------------------------
363 -- Build_Dispatch_Tables --
364 ---------------------------
366 procedure Build_Dispatch_Tables
(List
: List_Id
) is
371 while Present
(D
) loop
373 -- Handle nested packages and package bodies recursively. The
374 -- generated code is placed on the Target_List established for
375 -- the enclosing compilation unit.
377 if Nkind
(D
) = N_Package_Declaration
then
378 Build_Package_Dispatch_Tables
(D
);
380 elsif Nkind
(D
) = N_Package_Body
then
381 Build_Dispatch_Tables
(Declarations
(D
));
383 elsif Nkind
(D
) = N_Package_Body_Stub
384 and then Present
(Library_Unit
(D
))
386 Build_Dispatch_Tables
387 (Declarations
(Proper_Body
(Unit
(Library_Unit
(D
)))));
389 -- Handle full type declarations and derivations of library level
392 elsif Nkind_In
(D
, N_Full_Type_Declaration
,
393 N_Derived_Type_Definition
)
394 and then Is_Library_Level_Tagged_Type
(Defining_Entity
(D
))
395 and then Ekind
(Defining_Entity
(D
)) /= E_Record_Subtype
396 and then not Is_Private_Type
(Defining_Entity
(D
))
398 -- We do not generate dispatch tables for the internal types
399 -- created for a type extension with unknown discriminants
400 -- The needed information is shared with the source type,
401 -- See Expand_N_Record_Extension.
403 if Is_Underlying_Record_View
(Defining_Entity
(D
))
405 (not Comes_From_Source
(Defining_Entity
(D
))
407 Has_Unknown_Discriminants
(Etype
(Defining_Entity
(D
)))
409 not Comes_From_Source
410 (First_Subtype
(Defining_Entity
(D
))))
414 Insert_List_After_And_Analyze
(Last
(Target_List
),
415 Make_DT
(Defining_Entity
(D
)));
418 -- Handle private types of library level tagged types. We must
419 -- exchange the private and full-view to ensure the correct
420 -- expansion. If the full view is a synchronized type ignore
421 -- the type because the table will be built for the corresponding
422 -- record type, that has its own declaration.
424 elsif (Nkind
(D
) = N_Private_Type_Declaration
425 or else Nkind
(D
) = N_Private_Extension_Declaration
)
426 and then Present
(Full_View
(Defining_Entity
(D
)))
429 E1
: constant Entity_Id
:= Defining_Entity
(D
);
430 E2
: constant Entity_Id
:= Full_View
(E1
);
433 if Is_Library_Level_Tagged_Type
(E2
)
434 and then Ekind
(E2
) /= E_Record_Subtype
435 and then not Is_Concurrent_Type
(E2
)
437 Exchange_Declarations
(E1
);
438 Insert_List_After_And_Analyze
(Last
(Target_List
),
440 Exchange_Declarations
(E2
);
447 end Build_Dispatch_Tables
;
449 -----------------------------------
450 -- Build_Package_Dispatch_Tables --
451 -----------------------------------
453 procedure Build_Package_Dispatch_Tables
(N
: Node_Id
) is
454 Spec
: constant Node_Id
:= Specification
(N
);
455 Id
: constant Entity_Id
:= Defining_Entity
(N
);
456 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
457 Priv_Decls
: constant List_Id
:= Private_Declarations
(Spec
);
462 if Present
(Priv_Decls
) then
463 Build_Dispatch_Tables
(Vis_Decls
);
464 Build_Dispatch_Tables
(Priv_Decls
);
466 elsif Present
(Vis_Decls
) then
467 Build_Dispatch_Tables
(Vis_Decls
);
471 end Build_Package_Dispatch_Tables
;
473 -- Start of processing for Build_Static_Dispatch_Tables
476 if not Expander_Active
477 or else not Tagged_Type_Expansion
482 if Nkind
(N
) = N_Package_Declaration
then
484 Spec
: constant Node_Id
:= Specification
(N
);
485 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
486 Priv_Decls
: constant List_Id
:= Private_Declarations
(Spec
);
489 if Present
(Priv_Decls
)
490 and then Is_Non_Empty_List
(Priv_Decls
)
492 Target_List
:= Priv_Decls
;
494 elsif not Present
(Vis_Decls
) then
495 Target_List
:= New_List
;
496 Set_Private_Declarations
(Spec
, Target_List
);
498 Target_List
:= Vis_Decls
;
501 Build_Package_Dispatch_Tables
(N
);
504 else pragma Assert
(Nkind
(N
) = N_Package_Body
);
505 Target_List
:= Declarations
(N
);
506 Build_Dispatch_Tables
(Target_List
);
508 end Build_Static_Dispatch_Tables
;
510 ------------------------------
511 -- Convert_Tag_To_Interface --
512 ------------------------------
514 function Convert_Tag_To_Interface
516 Expr
: Node_Id
) return Node_Id
518 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
519 Anon_Type
: Entity_Id
;
523 pragma Assert
(Is_Class_Wide_Type
(Typ
)
524 and then Is_Interface
(Typ
)
526 ((Nkind
(Expr
) = N_Selected_Component
527 and then Is_Tag
(Entity
(Selector_Name
(Expr
))))
529 (Nkind
(Expr
) = N_Function_Call
530 and then RTE_Available
(RE_Displace
)
531 and then Entity
(Name
(Expr
)) = RTE
(RE_Displace
))));
533 Anon_Type
:= Create_Itype
(E_Anonymous_Access_Type
, Expr
);
534 Set_Directly_Designated_Type
(Anon_Type
, Typ
);
535 Set_Etype
(Anon_Type
, Anon_Type
);
536 Set_Can_Never_Be_Null
(Anon_Type
);
538 -- Decorate the size and alignment attributes of the anonymous access
539 -- type, as required by the back end.
541 Layout_Type
(Anon_Type
);
543 if Nkind
(Expr
) = N_Selected_Component
544 and then Is_Tag
(Entity
(Selector_Name
(Expr
)))
547 Make_Explicit_Dereference
(Loc
,
548 Unchecked_Convert_To
(Anon_Type
,
549 Make_Attribute_Reference
(Loc
,
551 Attribute_Name
=> Name_Address
)));
554 Make_Explicit_Dereference
(Loc
,
555 Unchecked_Convert_To
(Anon_Type
, Expr
));
559 end Convert_Tag_To_Interface
;
565 function CPP_Num_Prims
(Typ
: Entity_Id
) return Nat
is
567 Tag_Comp
: Entity_Id
;
570 if not Is_Tagged_Type
(Typ
)
571 or else not Is_CPP_Class
(Root_Type
(Typ
))
576 CPP_Typ
:= Enclosing_CPP_Parent
(Typ
);
577 Tag_Comp
:= First_Tag_Component
(CPP_Typ
);
579 -- If number of primitives already set in the tag component, use it
581 if Present
(Tag_Comp
)
582 and then DT_Entry_Count
(Tag_Comp
) /= No_Uint
584 return UI_To_Int
(DT_Entry_Count
(Tag_Comp
));
586 -- Otherwise, count the primitives of the enclosing CPP type
594 Elmt
:= First_Elmt
(Primitive_Operations
(CPP_Typ
));
595 while Present
(Elmt
) loop
606 ------------------------------
607 -- Default_Prim_Op_Position --
608 ------------------------------
610 function Default_Prim_Op_Position
(E
: Entity_Id
) return Uint
is
611 TSS_Name
: TSS_Name_Type
;
614 Get_Name_String
(Chars
(E
));
617 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
619 if Chars
(E
) = Name_uSize
then
622 elsif TSS_Name
= TSS_Stream_Read
then
625 elsif TSS_Name
= TSS_Stream_Write
then
628 elsif TSS_Name
= TSS_Stream_Input
then
631 elsif TSS_Name
= TSS_Stream_Output
then
634 elsif Chars
(E
) = Name_Op_Eq
then
637 elsif Chars
(E
) = Name_uAssign
then
640 elsif TSS_Name
= TSS_Deep_Adjust
then
643 elsif TSS_Name
= TSS_Deep_Finalize
then
646 -- In VM targets unconditionally allow obtaining the position associated
647 -- with predefined interface primitives since in these platforms any
648 -- tagged type has these primitives.
650 elsif Ada_Version
>= Ada_2005
or else not Tagged_Type_Expansion
then
651 if Chars
(E
) = Name_uDisp_Asynchronous_Select
then
654 elsif Chars
(E
) = Name_uDisp_Conditional_Select
then
657 elsif Chars
(E
) = Name_uDisp_Get_Prim_Op_Kind
then
660 elsif Chars
(E
) = Name_uDisp_Get_Task_Id
then
663 elsif Chars
(E
) = Name_uDisp_Requeue
then
666 elsif Chars
(E
) = Name_uDisp_Timed_Select
then
672 end Default_Prim_Op_Position
;
674 ----------------------
675 -- Elab_Flag_Needed --
676 ----------------------
678 function Elab_Flag_Needed
(Typ
: Entity_Id
) return Boolean is
680 return Ada_Version
>= Ada_2005
681 and then not Is_Interface
(Typ
)
682 and then Has_Interfaces
(Typ
)
683 and then not Building_Static_DT
(Typ
);
684 end Elab_Flag_Needed
;
686 -----------------------------
687 -- Expand_Dispatching_Call --
688 -----------------------------
690 procedure Expand_Dispatching_Call
(Call_Node
: Node_Id
) is
691 Loc
: constant Source_Ptr
:= Sloc
(Call_Node
);
692 Call_Typ
: constant Entity_Id
:= Etype
(Call_Node
);
694 Ctrl_Arg
: constant Node_Id
:= Controlling_Argument
(Call_Node
);
695 Ctrl_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Ctrl_Arg
));
696 Param_List
: constant List_Id
:= Parameter_Associations
(Call_Node
);
701 New_Call_Name
: Node_Id
;
702 New_Params
: List_Id
:= No_List
;
705 Subp_Ptr_Typ
: Entity_Id
;
706 Subp_Typ
: Entity_Id
;
708 Eq_Prim_Op
: Entity_Id
:= Empty
;
709 Controlling_Tag
: Node_Id
;
711 procedure Build_Class_Wide_Check
;
712 -- If the denoted subprogram has a class-wide precondition, generate a
713 -- check using that precondition before the dispatching call, because
714 -- this is the only class-wide precondition that applies to the call.
716 function New_Value
(From
: Node_Id
) return Node_Id
;
717 -- From is the original Expression. New_Value is equivalent to a call
718 -- to Duplicate_Subexpr with an explicit dereference when From is an
721 ----------------------------
722 -- Build_Class_Wide_Check --
723 ----------------------------
725 procedure Build_Class_Wide_Check
is
726 function Replace_Formals
(N
: Node_Id
) return Traverse_Result
;
727 -- Replace occurrences of the formals of the subprogram by the
728 -- corresponding actuals in the call, given that this check is
729 -- performed outside of the body of the subprogram.
731 ---------------------
732 -- Replace_Formals --
733 ---------------------
735 function Replace_Formals
(N
: Node_Id
) return Traverse_Result
is
737 if Is_Entity_Name
(N
)
738 and then Present
(Entity
(N
))
739 and then Is_Formal
(Entity
(N
))
746 F
:= First_Formal
(Subp
);
747 A
:= First_Actual
(Call_Node
);
748 while Present
(F
) loop
749 if F
= Entity
(N
) then
750 Rewrite
(N
, New_Copy_Tree
(A
));
752 -- If the formal is class-wide, and thus not a
753 -- controlling argument, preserve its type because
754 -- it may appear in a nested call with a class-wide
757 if Is_Class_Wide_Type
(Etype
(F
)) then
758 Set_Etype
(N
, Etype
(F
));
760 -- Conversely, if this is a controlling argument
761 -- (in a dispatching call in the condition) that is a
762 -- dereference, the source is an access-to-class-wide
763 -- type, so preserve the dispatching nature of the
764 -- call in the rewritten condition.
766 elsif Nkind
(Parent
(N
)) = N_Explicit_Dereference
767 and then Is_Controlling_Actual
(Parent
(N
))
769 Set_Controlling_Argument
(Parent
(Parent
(N
)),
785 procedure Update
is new Traverse_Proc
(Replace_Formals
);
789 Str_Loc
: constant String := Build_Location_String
(Loc
);
795 -- Start of processing for Build_Class_Wide_Check
799 -- Locate class-wide precondition, if any
801 if Present
(Contract
(Subp
))
802 and then Present
(Pre_Post_Conditions
(Contract
(Subp
)))
804 Prec
:= Pre_Post_Conditions
(Contract
(Subp
));
806 while Present
(Prec
) loop
807 exit when Pragma_Name
(Prec
) = Name_Precondition
808 and then Class_Present
(Prec
);
809 Prec
:= Next_Pragma
(Prec
);
816 -- The expression for the precondition is analyzed within the
817 -- generated pragma. The message text is the last parameter of
818 -- the generated pragma, indicating source of precondition.
822 (Expression
(First
(Pragma_Argument_Associations
(Prec
))));
825 -- Build message indicating the failed precondition and the
826 -- dispatching call that caused it.
828 Msg
:= Expression
(Last
(Pragma_Argument_Associations
(Prec
)));
830 Append
(Global_Name_Buffer
, Strval
(Msg
));
831 Append
(Global_Name_Buffer
, " in dispatching call at ");
832 Append
(Global_Name_Buffer
, Str_Loc
);
833 Msg
:= Make_String_Literal
(Loc
, Name_Buffer
(1 .. Name_Len
));
835 Insert_Action
(Call_Node
,
836 Make_If_Statement
(Loc
,
837 Condition
=> Make_Op_Not
(Loc
, Cond
),
838 Then_Statements
=> New_List
(
839 Make_Procedure_Call_Statement
(Loc
,
841 New_Occurrence_Of
(RTE
(RE_Raise_Assert_Failure
), Loc
),
842 Parameter_Associations
=> New_List
(Msg
)))));
844 end Build_Class_Wide_Check
;
850 function New_Value
(From
: Node_Id
) return Node_Id
is
851 Res
: constant Node_Id
:= Duplicate_Subexpr
(From
);
853 if Is_Access_Type
(Etype
(From
)) then
855 Make_Explicit_Dereference
(Sloc
(From
),
865 SCIL_Node
: Node_Id
:= Empty
;
866 SCIL_Related_Node
: Node_Id
:= Call_Node
;
868 -- Start of processing for Expand_Dispatching_Call
871 if No_Run_Time_Mode
then
872 Error_Msg_CRT
("tagged types", Call_Node
);
876 -- Expand_Dispatching_Call is called directly from the semantics, so we
877 -- only proceed if the expander is active.
879 if not Expander_Active
881 -- And there is no need to expand the call if we are compiling under
882 -- restriction No_Dispatching_Calls; the semantic analyzer has
883 -- previously notified the violation of this restriction.
885 or else Restriction_Active
(No_Dispatching_Calls
)
887 -- No action needed if the dispatching call has been already expanded
889 or else Is_Expanded_Dispatching_Call
(Name
(Call_Node
))
894 -- Set subprogram. If this is an inherited operation that was
895 -- overridden, the body that is being called is its alias.
897 Subp
:= Entity
(Name
(Call_Node
));
899 if Present
(Alias
(Subp
))
900 and then Is_Inherited_Operation
(Subp
)
901 and then No
(DTC_Entity
(Subp
))
903 Subp
:= Alias
(Subp
);
906 Build_Class_Wide_Check
;
908 -- Definition of the class-wide type and the tagged type
910 -- If the controlling argument is itself a tag rather than a tagged
911 -- object, then use the class-wide type associated with the subprogram's
912 -- controlling type. This case can occur when a call to an inherited
913 -- primitive has an actual that originated from a default parameter
914 -- given by a tag-indeterminate call and when there is no other
915 -- controlling argument providing the tag (AI-239 requires dispatching).
916 -- This capability of dispatching directly by tag is also needed by the
917 -- implementation of AI-260 (for the generic dispatching constructors).
919 if Ctrl_Typ
= RTE
(RE_Tag
)
920 or else (RTE_Available
(RE_Interface_Tag
)
921 and then Ctrl_Typ
= RTE
(RE_Interface_Tag
))
923 CW_Typ
:= Class_Wide_Type
(Find_Dispatching_Type
(Subp
));
925 -- Class_Wide_Type is applied to the expressions used to initialize
926 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
927 -- there are cases where the controlling type is resolved to a specific
928 -- type (such as for designated types of arguments such as CW'Access).
930 elsif Is_Access_Type
(Ctrl_Typ
) then
931 CW_Typ
:= Class_Wide_Type
(Designated_Type
(Ctrl_Typ
));
934 CW_Typ
:= Class_Wide_Type
(Ctrl_Typ
);
937 Typ
:= Find_Specific_Type
(CW_Typ
);
939 if not Is_Limited_Type
(Typ
) then
940 Eq_Prim_Op
:= Find_Prim_Op
(Typ
, Name_Op_Eq
);
943 -- Dispatching call to C++ primitive. Create a new parameter list
944 -- with no tag checks.
946 New_Params
:= New_List
;
948 if Is_CPP_Class
(Typ
) then
949 Param
:= First_Actual
(Call_Node
);
950 while Present
(Param
) loop
951 Append_To
(New_Params
, Relocate_Node
(Param
));
955 -- Dispatching call to Ada primitive
957 elsif Present
(Param_List
) then
958 Apply_Tag_Checks
(Call_Node
);
960 Param
:= First_Actual
(Call_Node
);
961 while Present
(Param
) loop
963 -- Cases in which we may have generated run-time checks. Note that
964 -- we strip any qualification from Param before comparing with the
965 -- already-stripped controlling argument.
967 if Unqualify
(Param
) = Ctrl_Arg
or else Subp
= Eq_Prim_Op
then
968 Append_To
(New_Params
,
969 Duplicate_Subexpr_Move_Checks
(Param
));
971 elsif Nkind
(Parent
(Param
)) /= N_Parameter_Association
972 or else not Is_Accessibility_Actual
(Parent
(Param
))
974 Append_To
(New_Params
, Relocate_Node
(Param
));
981 -- Generate the appropriate subprogram pointer type
983 if Etype
(Subp
) = Typ
then
986 Res_Typ
:= Etype
(Subp
);
989 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, Call_Node
);
990 Subp_Ptr_Typ
:= Create_Itype
(E_Access_Subprogram_Type
, Call_Node
);
991 Set_Etype
(Subp_Typ
, Res_Typ
);
992 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
993 Set_Convention
(Subp_Typ
, Convention
(Subp
));
995 -- Notify gigi that the designated type is a dispatching primitive
997 Set_Is_Dispatch_Table_Entity
(Subp_Typ
);
999 -- Create a new list of parameters which is a copy of the old formal
1000 -- list including the creation of a new set of matching entities.
1003 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
1004 New_Formal
: Entity_Id
;
1005 Extra
: Entity_Id
:= Empty
;
1008 if Present
(Old_Formal
) then
1009 New_Formal
:= New_Copy
(Old_Formal
);
1010 Set_First_Entity
(Subp_Typ
, New_Formal
);
1011 Param
:= First_Actual
(Call_Node
);
1014 Set_Scope
(New_Formal
, Subp_Typ
);
1016 -- Change all the controlling argument types to be class-wide
1017 -- to avoid a recursion in dispatching.
1019 if Is_Controlling_Formal
(New_Formal
) then
1020 Set_Etype
(New_Formal
, Etype
(Param
));
1023 -- If the type of the formal is an itype, there was code here
1024 -- introduced in 1998 in revision 1.46, to create a new itype
1025 -- by copy. This seems useless, and in fact leads to semantic
1026 -- errors when the itype is the completion of a type derived
1027 -- from a private type.
1029 Extra
:= New_Formal
;
1030 Next_Formal
(Old_Formal
);
1031 exit when No
(Old_Formal
);
1033 Link_Entities
(New_Formal
, New_Copy
(Old_Formal
));
1034 Next_Entity
(New_Formal
);
1035 Next_Actual
(Param
);
1038 Unlink_Next_Entity
(New_Formal
);
1039 Set_Last_Entity
(Subp_Typ
, Extra
);
1042 -- Now that the explicit formals have been duplicated, any extra
1043 -- formals needed by the subprogram must be created.
1045 if Present
(Extra
) then
1046 Set_Extra_Formal
(Extra
, Empty
);
1049 Create_Extra_Formals
(Subp_Typ
);
1052 -- Complete description of pointer type, including size information, as
1053 -- must be done with itypes to prevent order-of-elaboration anomalies
1056 Set_Etype
(Subp_Ptr_Typ
, Subp_Ptr_Typ
);
1057 Set_Directly_Designated_Type
(Subp_Ptr_Typ
, Subp_Typ
);
1058 Set_Convention
(Subp_Ptr_Typ
, Convention
(Subp_Typ
));
1059 Layout_Type
(Subp_Ptr_Typ
);
1061 -- If the controlling argument is a value of type Ada.Tag or an abstract
1062 -- interface class-wide type then use it directly. Otherwise, the tag
1063 -- must be extracted from the controlling object.
1065 if Ctrl_Typ
= RTE
(RE_Tag
)
1066 or else (RTE_Available
(RE_Interface_Tag
)
1067 and then Ctrl_Typ
= RTE
(RE_Interface_Tag
))
1069 Controlling_Tag
:= Duplicate_Subexpr
(Ctrl_Arg
);
1071 -- Extract the tag from an unchecked type conversion. Done to avoid
1072 -- the expansion of additional code just to obtain the value of such
1073 -- tag because the current management of interface type conversions
1074 -- generates in some cases this unchecked type conversion with the
1075 -- tag of the object (see Expand_Interface_Conversion).
1077 elsif Nkind
(Ctrl_Arg
) = N_Unchecked_Type_Conversion
1079 (Etype
(Expression
(Ctrl_Arg
)) = RTE
(RE_Tag
)
1081 (RTE_Available
(RE_Interface_Tag
)
1083 Etype
(Expression
(Ctrl_Arg
)) = RTE
(RE_Interface_Tag
)))
1085 Controlling_Tag
:= Duplicate_Subexpr
(Expression
(Ctrl_Arg
));
1087 -- Ada 2005 (AI-251): Abstract interface class-wide type
1089 elsif Is_Interface
(Ctrl_Typ
)
1090 and then Is_Class_Wide_Type
(Ctrl_Typ
)
1092 Controlling_Tag
:= Duplicate_Subexpr
(Ctrl_Arg
);
1096 Make_Selected_Component
(Loc
,
1097 Prefix
=> Duplicate_Subexpr_Move_Checks
(Ctrl_Arg
),
1098 Selector_Name
=> New_Occurrence_Of
(DTC_Entity
(Subp
), Loc
));
1101 -- Handle dispatching calls to predefined primitives
1103 if Is_Predefined_Dispatching_Operation
(Subp
)
1104 or else Is_Predefined_Dispatching_Alias
(Subp
)
1106 Build_Get_Predefined_Prim_Op_Address
(Loc
,
1107 Tag_Node
=> Controlling_Tag
,
1108 Position
=> DT_Position
(Subp
),
1109 New_Node
=> New_Node
);
1111 -- Handle dispatching calls to user-defined primitives
1114 Build_Get_Prim_Op_Address
(Loc
,
1115 Typ
=> Underlying_Type
(Find_Dispatching_Type
(Subp
)),
1116 Tag_Node
=> Controlling_Tag
,
1117 Position
=> DT_Position
(Subp
),
1118 New_Node
=> New_Node
);
1122 Unchecked_Convert_To
(Subp_Ptr_Typ
, New_Node
);
1124 -- Generate the SCIL node for this dispatching call. Done now because
1125 -- attribute SCIL_Controlling_Tag must be set after the new call name
1126 -- is built to reference the nodes that will see the SCIL backend
1127 -- (because Build_Get_Prim_Op_Address generates an unchecked type
1128 -- conversion which relocates the controlling tag node).
1130 if Generate_SCIL
then
1131 SCIL_Node
:= Make_SCIL_Dispatching_Call
(Sloc
(Call_Node
));
1132 Set_SCIL_Entity
(SCIL_Node
, Typ
);
1133 Set_SCIL_Target_Prim
(SCIL_Node
, Subp
);
1135 -- Common case: the controlling tag is the tag of an object
1136 -- (for example, obj.tag)
1138 if Nkind
(Controlling_Tag
) = N_Selected_Component
then
1139 Set_SCIL_Controlling_Tag
(SCIL_Node
, Controlling_Tag
);
1141 -- Handle renaming of selected component
1143 elsif Nkind
(Controlling_Tag
) = N_Identifier
1144 and then Nkind
(Parent
(Entity
(Controlling_Tag
))) =
1145 N_Object_Renaming_Declaration
1146 and then Nkind
(Name
(Parent
(Entity
(Controlling_Tag
)))) =
1147 N_Selected_Component
1149 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1150 Name
(Parent
(Entity
(Controlling_Tag
))));
1152 -- If the controlling tag is an identifier, the SCIL node references
1153 -- the corresponding object or parameter declaration
1155 elsif Nkind
(Controlling_Tag
) = N_Identifier
1156 and then Nkind_In
(Parent
(Entity
(Controlling_Tag
)),
1157 N_Object_Declaration
,
1158 N_Parameter_Specification
)
1160 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1161 Parent
(Entity
(Controlling_Tag
)));
1163 -- If the controlling tag is a dereference, the SCIL node references
1164 -- the corresponding object or parameter declaration
1166 elsif Nkind
(Controlling_Tag
) = N_Explicit_Dereference
1167 and then Nkind
(Prefix
(Controlling_Tag
)) = N_Identifier
1168 and then Nkind_In
(Parent
(Entity
(Prefix
(Controlling_Tag
))),
1169 N_Object_Declaration
,
1170 N_Parameter_Specification
)
1172 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1173 Parent
(Entity
(Prefix
(Controlling_Tag
))));
1175 -- For a direct reference of the tag of the type the SCIL node
1176 -- references the internal object declaration containing the tag
1179 elsif Nkind
(Controlling_Tag
) = N_Attribute_Reference
1180 and then Attribute_Name
(Controlling_Tag
) = Name_Tag
1182 Set_SCIL_Controlling_Tag
(SCIL_Node
,
1186 (Access_Disp_Table
(Entity
(Prefix
(Controlling_Tag
)))))));
1188 -- Interfaces are not supported. For now we leave the SCIL node
1189 -- decorated with the Controlling_Tag. More work needed here???
1191 elsif Is_Interface
(Etype
(Controlling_Tag
)) then
1192 Set_SCIL_Controlling_Tag
(SCIL_Node
, Controlling_Tag
);
1195 pragma Assert
(False);
1200 if Nkind
(Call_Node
) = N_Function_Call
then
1202 Make_Function_Call
(Loc
,
1203 Name
=> New_Call_Name
,
1204 Parameter_Associations
=> New_Params
);
1206 -- If this is a dispatching "=", we must first compare the tags so
1207 -- we generate: x.tag = y.tag and then x = y
1209 if Subp
= Eq_Prim_Op
then
1210 Param
:= First_Actual
(Call_Node
);
1216 Make_Selected_Component
(Loc
,
1217 Prefix
=> New_Value
(Param
),
1219 New_Occurrence_Of
(First_Tag_Component
(Typ
),
1223 Make_Selected_Component
(Loc
,
1225 Unchecked_Convert_To
(Typ
,
1226 New_Value
(Next_Actual
(Param
))),
1229 (First_Tag_Component
(Typ
), Loc
))),
1230 Right_Opnd
=> New_Call
);
1232 SCIL_Related_Node
:= Right_Opnd
(New_Call
);
1237 Make_Procedure_Call_Statement
(Loc
,
1238 Name
=> New_Call_Name
,
1239 Parameter_Associations
=> New_Params
);
1242 -- Register the dispatching call in the call graph nodes table
1244 Register_CG_Node
(Call_Node
);
1246 Rewrite
(Call_Node
, New_Call
);
1248 -- Associate the SCIL node of this dispatching call
1250 if Generate_SCIL
then
1251 Set_SCIL_Node
(SCIL_Related_Node
, SCIL_Node
);
1254 -- Suppress all checks during the analysis of the expanded code to avoid
1255 -- the generation of spurious warnings under ZFP run-time.
1257 Analyze_And_Resolve
(Call_Node
, Call_Typ
, Suppress
=> All_Checks
);
1258 end Expand_Dispatching_Call
;
1260 ---------------------------------
1261 -- Expand_Interface_Conversion --
1262 ---------------------------------
1264 procedure Expand_Interface_Conversion
(N
: Node_Id
) is
1265 function Underlying_Record_Type
(Typ
: Entity_Id
) return Entity_Id
;
1266 -- Return the underlying record type of Typ
1268 ----------------------------
1269 -- Underlying_Record_Type --
1270 ----------------------------
1272 function Underlying_Record_Type
(Typ
: Entity_Id
) return Entity_Id
is
1273 E
: Entity_Id
:= Typ
;
1276 -- Handle access types
1278 if Is_Access_Type
(E
) then
1279 E
:= Directly_Designated_Type
(E
);
1282 -- Handle class-wide types. This conversion can appear explicitly in
1283 -- the source code. Example: I'Class (Obj)
1285 if Is_Class_Wide_Type
(E
) then
1289 -- If the target type is a tagged synchronized type, the dispatch
1290 -- table info is in the corresponding record type.
1292 if Is_Concurrent_Type
(E
) then
1293 E
:= Corresponding_Record_Type
(E
);
1296 -- Handle private types
1298 E
:= Underlying_Type
(E
);
1302 return Base_Type
(E
);
1303 end Underlying_Record_Type
;
1307 Loc
: constant Source_Ptr
:= Sloc
(N
);
1308 Etyp
: constant Entity_Id
:= Etype
(N
);
1309 Operand
: constant Node_Id
:= Expression
(N
);
1310 Operand_Typ
: Entity_Id
:= Etype
(Operand
);
1312 Iface_Typ
: constant Entity_Id
:= Underlying_Record_Type
(Etype
(N
));
1313 Iface_Tag
: Entity_Id
;
1314 Is_Static
: Boolean;
1316 -- Start of processing for Expand_Interface_Conversion
1319 -- Freeze the entity associated with the target interface to have
1320 -- available the attribute Access_Disp_Table.
1322 Freeze_Before
(N
, Iface_Typ
);
1324 -- Ada 2005 (AI-345): Handle synchronized interface type derivations
1326 if Is_Concurrent_Type
(Operand_Typ
) then
1327 Operand_Typ
:= Base_Type
(Corresponding_Record_Type
(Operand_Typ
));
1330 -- No displacement of the pointer to the object needed when the type of
1331 -- the operand is not an interface type and the interface is one of
1332 -- its parent types (since they share the primary dispatch table).
1335 Opnd
: Entity_Id
:= Operand_Typ
;
1338 if Is_Access_Type
(Opnd
) then
1339 Opnd
:= Designated_Type
(Opnd
);
1342 if not Is_Interface
(Opnd
)
1343 and then Is_Ancestor
(Iface_Typ
, Opnd
, Use_Full_View
=> True)
1349 -- Evaluate if we can statically displace the pointer to the object
1352 Opnd_Typ
: constant Node_Id
:= Underlying_Record_Type
(Operand_Typ
);
1356 not Is_Interface
(Opnd_Typ
)
1357 and then Interface_Present_In_Ancestor
1360 and then (Etype
(Opnd_Typ
) = Opnd_Typ
1362 Is_Variable_Size_Record
(Etype
(Opnd_Typ
)));
1365 if not Tagged_Type_Expansion
then
1368 -- A static conversion to an interface type that is not class-wide is
1369 -- curious but legal if the interface operation is a null procedure.
1370 -- If the operation is abstract it will be rejected later.
1373 and then Is_Interface
(Etype
(N
))
1374 and then not Is_Class_Wide_Type
(Etype
(N
))
1375 and then Comes_From_Source
(N
)
1377 Rewrite
(N
, Unchecked_Convert_To
(Etype
(N
), N
));
1382 if not Is_Static
then
1384 -- Give error if configurable run-time and Displace not available
1386 if not RTE_Available
(RE_Displace
) then
1387 Error_Msg_CRT
("dynamic interface conversion", N
);
1391 -- Handle conversion of access-to-class-wide interface types. Target
1392 -- can be an access to an object or an access to another class-wide
1393 -- interface (see -1- and -2- in the following example):
1395 -- type Iface1_Ref is access all Iface1'Class;
1396 -- type Iface2_Ref is access all Iface1'Class;
1398 -- Acc1 : Iface1_Ref := new ...
1399 -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1
1400 -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
1402 if Is_Access_Type
(Operand_Typ
) then
1404 Unchecked_Convert_To
(Etype
(N
),
1405 Make_Function_Call
(Loc
,
1406 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
1407 Parameter_Associations
=> New_List
(
1409 Unchecked_Convert_To
(RTE
(RE_Address
),
1410 Relocate_Node
(Expression
(N
))),
1413 (Node
(First_Elmt
(Access_Disp_Table
(Iface_Typ
))),
1421 Make_Function_Call
(Loc
,
1422 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
1423 Parameter_Associations
=> New_List
(
1424 Make_Attribute_Reference
(Loc
,
1425 Prefix
=> Relocate_Node
(Expression
(N
)),
1426 Attribute_Name
=> Name_Address
),
1429 (Node
(First_Elmt
(Access_Disp_Table
(Iface_Typ
))),
1434 -- If target is a class-wide interface, change the type of the data
1435 -- returned by IW_Convert to indicate this is a dispatching call.
1438 New_Itype
: Entity_Id
;
1441 New_Itype
:= Create_Itype
(E_Anonymous_Access_Type
, N
);
1442 Set_Etype
(New_Itype
, New_Itype
);
1443 Set_Directly_Designated_Type
(New_Itype
, Etyp
);
1446 Make_Explicit_Dereference
(Loc
,
1448 Unchecked_Convert_To
(New_Itype
, Relocate_Node
(N
))));
1450 Freeze_Itype
(New_Itype
, N
);
1456 Iface_Tag
:= Find_Interface_Tag
(Operand_Typ
, Iface_Typ
);
1457 pragma Assert
(Iface_Tag
/= Empty
);
1459 -- Keep separate access types to interfaces because one internal
1460 -- function is used to handle the null value (see following comments)
1462 if not Is_Access_Type
(Etype
(N
)) then
1464 -- Statically displace the pointer to the object to reference the
1465 -- component containing the secondary dispatch table.
1468 Convert_Tag_To_Interface
(Class_Wide_Type
(Iface_Typ
),
1469 Make_Selected_Component
(Loc
,
1470 Prefix
=> Relocate_Node
(Expression
(N
)),
1471 Selector_Name
=> New_Occurrence_Of
(Iface_Tag
, Loc
))));
1474 -- Build internal function to handle the case in which the actual is
1475 -- null. If the actual is null returns null because no displacement
1476 -- is required; otherwise performs a type conversion that will be
1477 -- expanded in the code that returns the value of the displaced
1480 -- function Func (O : Address) return Iface_Typ is
1481 -- type Op_Typ is access all Operand_Typ;
1482 -- Aux : Op_Typ := To_Op_Typ (O);
1484 -- if O = Null_Address then
1487 -- return Iface_Typ!(Aux.Iface_Tag'Address);
1492 Desig_Typ
: Entity_Id
;
1494 New_Typ_Decl
: Node_Id
;
1498 Desig_Typ
:= Etype
(Expression
(N
));
1500 if Is_Access_Type
(Desig_Typ
) then
1502 Available_View
(Directly_Designated_Type
(Desig_Typ
));
1505 if Is_Concurrent_Type
(Desig_Typ
) then
1506 Desig_Typ
:= Base_Type
(Corresponding_Record_Type
(Desig_Typ
));
1510 Make_Full_Type_Declaration
(Loc
,
1511 Defining_Identifier
=> Make_Temporary
(Loc
, 'T'),
1513 Make_Access_To_Object_Definition
(Loc
,
1514 All_Present
=> True,
1515 Null_Exclusion_Present
=> False,
1516 Constant_Present
=> False,
1517 Subtype_Indication
=>
1518 New_Occurrence_Of
(Desig_Typ
, Loc
)));
1521 Make_Simple_Return_Statement
(Loc
,
1522 Unchecked_Convert_To
(Etype
(N
),
1523 Make_Attribute_Reference
(Loc
,
1525 Make_Selected_Component
(Loc
,
1527 Unchecked_Convert_To
1528 (Defining_Identifier
(New_Typ_Decl
),
1529 Make_Identifier
(Loc
, Name_uO
)),
1531 New_Occurrence_Of
(Iface_Tag
, Loc
)),
1532 Attribute_Name
=> Name_Address
))));
1534 -- If the type is null-excluding, no need for the null branch.
1535 -- Otherwise we need to check for it and return null.
1537 if not Can_Never_Be_Null
(Etype
(N
)) then
1539 Make_If_Statement
(Loc
,
1542 Left_Opnd
=> Make_Identifier
(Loc
, Name_uO
),
1543 Right_Opnd
=> New_Occurrence_Of
1544 (RTE
(RE_Null_Address
), Loc
)),
1546 Then_Statements
=> New_List
(
1547 Make_Simple_Return_Statement
(Loc
, Make_Null
(Loc
))),
1548 Else_Statements
=> Stats
));
1551 Fent
:= Make_Temporary
(Loc
, 'F');
1553 Make_Subprogram_Body
(Loc
,
1555 Make_Function_Specification
(Loc
,
1556 Defining_Unit_Name
=> Fent
,
1558 Parameter_Specifications
=> New_List
(
1559 Make_Parameter_Specification
(Loc
,
1560 Defining_Identifier
=>
1561 Make_Defining_Identifier
(Loc
, Name_uO
),
1563 New_Occurrence_Of
(RTE
(RE_Address
), Loc
))),
1565 Result_Definition
=>
1566 New_Occurrence_Of
(Etype
(N
), Loc
)),
1568 Declarations
=> New_List
(New_Typ_Decl
),
1570 Handled_Statement_Sequence
=>
1571 Make_Handled_Sequence_Of_Statements
(Loc
, Stats
));
1573 -- Place function body before the expression containing the
1574 -- conversion. We suppress all checks because the body of the
1575 -- internally generated function already takes care of the case
1576 -- in which the actual is null; therefore there is no need to
1577 -- double check that the pointer is not null when the program
1578 -- executes the alternative that performs the type conversion).
1580 Insert_Action
(N
, Func
, Suppress
=> All_Checks
);
1582 if Is_Access_Type
(Etype
(Expression
(N
))) then
1584 -- Generate: Func (Address!(Expression))
1587 Make_Function_Call
(Loc
,
1588 Name
=> New_Occurrence_Of
(Fent
, Loc
),
1589 Parameter_Associations
=> New_List
(
1590 Unchecked_Convert_To
(RTE
(RE_Address
),
1591 Relocate_Node
(Expression
(N
))))));
1594 -- Generate: Func (Operand_Typ!(Expression)'Address)
1597 Make_Function_Call
(Loc
,
1598 Name
=> New_Occurrence_Of
(Fent
, Loc
),
1599 Parameter_Associations
=> New_List
(
1600 Make_Attribute_Reference
(Loc
,
1601 Prefix
=> Unchecked_Convert_To
(Operand_Typ
,
1602 Relocate_Node
(Expression
(N
))),
1603 Attribute_Name
=> Name_Address
))));
1609 end Expand_Interface_Conversion
;
1611 ------------------------------
1612 -- Expand_Interface_Actuals --
1613 ------------------------------
1615 procedure Expand_Interface_Actuals
(Call_Node
: Node_Id
) is
1617 Actual_Dup
: Node_Id
;
1618 Actual_Typ
: Entity_Id
;
1620 Conversion
: Node_Id
;
1622 Formal_Typ
: Entity_Id
;
1624 Formal_DDT
: Entity_Id
:= Empty
; -- initialize to prevent warning
1625 Actual_DDT
: Entity_Id
:= Empty
; -- initialize to prevent warning
1628 -- This subprogram is called directly from the semantics, so we need a
1629 -- check to see whether expansion is active before proceeding.
1631 if not Expander_Active
then
1635 -- Call using access to subprogram with explicit dereference
1637 if Nkind
(Name
(Call_Node
)) = N_Explicit_Dereference
then
1638 Subp
:= Etype
(Name
(Call_Node
));
1640 -- Call using selected component
1642 elsif Nkind
(Name
(Call_Node
)) = N_Selected_Component
then
1643 Subp
:= Entity
(Selector_Name
(Name
(Call_Node
)));
1645 -- Call using direct name
1648 Subp
:= Entity
(Name
(Call_Node
));
1651 -- Ada 2005 (AI-251): Look for interface type formals to force "this"
1654 Formal
:= First_Formal
(Subp
);
1655 Actual
:= First_Actual
(Call_Node
);
1656 while Present
(Formal
) loop
1657 Formal_Typ
:= Etype
(Formal
);
1659 if Ekind
(Formal_Typ
) = E_Record_Type_With_Private
then
1660 Formal_Typ
:= Full_View
(Formal_Typ
);
1663 if Is_Access_Type
(Formal_Typ
) then
1664 Formal_DDT
:= Directly_Designated_Type
(Formal_Typ
);
1667 Actual_Typ
:= Etype
(Actual
);
1669 if Is_Access_Type
(Actual_Typ
) then
1670 Actual_DDT
:= Directly_Designated_Type
(Actual_Typ
);
1673 if Is_Interface
(Formal_Typ
)
1674 and then Is_Class_Wide_Type
(Formal_Typ
)
1676 -- No need to displace the pointer if the type of the actual
1677 -- coincides with the type of the formal.
1679 if Actual_Typ
= Formal_Typ
then
1682 -- No need to displace the pointer if the interface type is a
1683 -- parent of the type of the actual because in this case the
1684 -- interface primitives are located in the primary dispatch table.
1686 elsif Is_Ancestor
(Formal_Typ
, Actual_Typ
,
1687 Use_Full_View
=> True)
1691 -- Implicit conversion to the class-wide formal type to force the
1692 -- displacement of the pointer.
1695 -- Normally, expansion of actuals for calls to build-in-place
1696 -- functions happens as part of Expand_Actuals, but in this
1697 -- case the call will be wrapped in a conversion and soon after
1698 -- expanded further to handle the displacement for a class-wide
1699 -- interface conversion, so if this is a BIP call then we need
1700 -- to handle it now.
1702 if Is_Build_In_Place_Function_Call
(Actual
) then
1703 Make_Build_In_Place_Call_In_Anonymous_Context
(Actual
);
1706 Conversion
:= Convert_To
(Formal_Typ
, Relocate_Node
(Actual
));
1707 Rewrite
(Actual
, Conversion
);
1708 Analyze_And_Resolve
(Actual
, Formal_Typ
);
1711 -- Access to class-wide interface type
1713 elsif Is_Access_Type
(Formal_Typ
)
1714 and then Is_Interface
(Formal_DDT
)
1715 and then Is_Class_Wide_Type
(Formal_DDT
)
1716 and then Interface_Present_In_Ancestor
1718 Iface
=> Etype
(Formal_DDT
))
1720 -- Handle attributes 'Access and 'Unchecked_Access
1722 if Nkind
(Actual
) = N_Attribute_Reference
1724 (Attribute_Name
(Actual
) = Name_Access
1725 or else Attribute_Name
(Actual
) = Name_Unchecked_Access
)
1727 -- This case must have been handled by the analysis and
1728 -- expansion of 'Access. The only exception is when types
1729 -- match and no further expansion is required.
1731 pragma Assert
(Base_Type
(Etype
(Prefix
(Actual
)))
1732 = Base_Type
(Formal_DDT
));
1735 -- No need to displace the pointer if the type of the actual
1736 -- coincides with the type of the formal.
1738 elsif Actual_DDT
= Formal_DDT
then
1741 -- No need to displace the pointer if the interface type is
1742 -- a parent of the type of the actual because in this case the
1743 -- interface primitives are located in the primary dispatch table.
1745 elsif Is_Ancestor
(Formal_DDT
, Actual_DDT
,
1746 Use_Full_View
=> True)
1751 Actual_Dup
:= Relocate_Node
(Actual
);
1753 if From_Limited_With
(Actual_Typ
) then
1755 -- If the type of the actual parameter comes from a limited
1756 -- with_clause and the nonlimited view is already available,
1757 -- we replace the anonymous access type by a duplicate
1758 -- declaration whose designated type is the nonlimited view.
1760 if Has_Non_Limited_View
(Actual_DDT
) then
1761 Anon
:= New_Copy
(Actual_Typ
);
1763 if Is_Itype
(Anon
) then
1764 Set_Scope
(Anon
, Current_Scope
);
1767 Set_Directly_Designated_Type
1768 (Anon
, Non_Limited_View
(Actual_DDT
));
1769 Set_Etype
(Actual_Dup
, Anon
);
1773 Conversion
:= Convert_To
(Formal_Typ
, Actual_Dup
);
1774 Rewrite
(Actual
, Conversion
);
1775 Analyze_And_Resolve
(Actual
, Formal_Typ
);
1779 Next_Actual
(Actual
);
1780 Next_Formal
(Formal
);
1782 end Expand_Interface_Actuals
;
1784 ----------------------------
1785 -- Expand_Interface_Thunk --
1786 ----------------------------
1788 procedure Expand_Interface_Thunk
1790 Thunk_Id
: out Entity_Id
;
1791 Thunk_Code
: out Node_Id
)
1793 Loc
: constant Source_Ptr
:= Sloc
(Prim
);
1794 Actuals
: constant List_Id
:= New_List
;
1795 Decl
: constant List_Id
:= New_List
;
1796 Formals
: constant List_Id
:= New_List
;
1797 Target
: constant Entity_Id
:= Ultimate_Alias
(Prim
);
1804 Iface_Formal
: Node_Id
:= Empty
; -- initialize to prevent warning
1806 Offset_To_Top
: Node_Id
;
1807 Target_Formal
: Entity_Id
;
1811 Thunk_Code
:= Empty
;
1813 -- No thunk needed if the primitive has been eliminated
1815 if Is_Eliminated
(Ultimate_Alias
(Prim
)) then
1818 -- In case of primitives that are functions without formals and a
1819 -- controlling result there is no need to build the thunk.
1821 elsif not Present
(First_Formal
(Target
)) then
1822 pragma Assert
(Ekind
(Target
) = E_Function
1823 and then Has_Controlling_Result
(Target
));
1827 -- Duplicate the formals of the Target primitive. In the thunk, the type
1828 -- of the controlling formal is the covered interface type (instead of
1829 -- the target tagged type). Done to avoid problems with discriminated
1830 -- tagged types because, if the controlling type has discriminants with
1831 -- default values, then the type conversions done inside the body of
1832 -- the thunk (after the displacement of the pointer to the base of the
1833 -- actual object) generate code that modify its contents.
1835 -- Note: This special management is not done for predefined primitives
1838 if not Is_Predefined_Dispatching_Operation
(Prim
) then
1839 Iface_Formal
:= First_Formal
(Interface_Alias
(Prim
));
1842 Formal
:= First_Formal
(Target
);
1843 while Present
(Formal
) loop
1844 Ftyp
:= Etype
(Formal
);
1846 -- Use the interface type as the type of the controlling formal (see
1849 if not Is_Controlling_Formal
(Formal
)
1850 or else Is_Predefined_Dispatching_Operation
(Prim
)
1852 Ftyp
:= Etype
(Formal
);
1853 Expr
:= New_Copy_Tree
(Expression
(Parent
(Formal
)));
1855 Ftyp
:= Etype
(Iface_Formal
);
1860 Make_Parameter_Specification
(Loc
,
1861 Defining_Identifier
=>
1862 Make_Defining_Identifier
(Sloc
(Formal
),
1863 Chars
=> Chars
(Formal
)),
1864 In_Present
=> In_Present
(Parent
(Formal
)),
1865 Out_Present
=> Out_Present
(Parent
(Formal
)),
1866 Parameter_Type
=> New_Occurrence_Of
(Ftyp
, Loc
),
1867 Expression
=> Expr
));
1869 if not Is_Predefined_Dispatching_Operation
(Prim
) then
1870 Next_Formal
(Iface_Formal
);
1873 Next_Formal
(Formal
);
1876 Target_Formal
:= First_Formal
(Target
);
1877 Formal
:= First
(Formals
);
1878 while Present
(Formal
) loop
1880 -- If the parent is a constrained discriminated type, then the
1881 -- primitive operation will have been defined on a first subtype.
1882 -- For proper matching with controlling type, use base type.
1884 if Ekind
(Target_Formal
) = E_In_Parameter
1885 and then Ekind
(Etype
(Target_Formal
)) = E_Anonymous_Access_Type
1888 Base_Type
(Directly_Designated_Type
(Etype
(Target_Formal
)));
1890 Ftyp
:= Base_Type
(Etype
(Target_Formal
));
1893 -- For concurrent types, the relevant information is found in the
1894 -- Corresponding_Record_Type, rather than the type entity itself.
1896 if Is_Concurrent_Type
(Ftyp
) then
1897 Ftyp
:= Corresponding_Record_Type
(Ftyp
);
1900 if Ekind
(Target_Formal
) = E_In_Parameter
1901 and then Ekind
(Etype
(Target_Formal
)) = E_Anonymous_Access_Type
1902 and then Is_Controlling_Formal
(Target_Formal
)
1905 -- type T is access all <<type of the target formal>>
1906 -- S : Storage_Offset := Storage_Offset!(Formal)
1907 -- + Offset_To_Top (address!(Formal))
1910 Make_Full_Type_Declaration
(Loc
,
1911 Defining_Identifier
=> Make_Temporary
(Loc
, 'T'),
1913 Make_Access_To_Object_Definition
(Loc
,
1914 All_Present
=> True,
1915 Null_Exclusion_Present
=> False,
1916 Constant_Present
=> False,
1917 Subtype_Indication
=>
1918 New_Occurrence_Of
(Ftyp
, Loc
)));
1921 Unchecked_Convert_To
(RTE
(RE_Address
),
1922 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
1924 if not RTE_Available
(RE_Offset_To_Top
) then
1926 Build_Offset_To_Top
(Loc
, New_Arg
);
1929 Make_Function_Call
(Loc
,
1930 Name
=> New_Occurrence_Of
(RTE
(RE_Offset_To_Top
), Loc
),
1931 Parameter_Associations
=> New_List
(New_Arg
));
1935 Make_Object_Declaration
(Loc
,
1936 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
1937 Constant_Present
=> True,
1938 Object_Definition
=>
1939 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
1943 Unchecked_Convert_To
1944 (RTE
(RE_Storage_Offset
),
1946 (Defining_Identifier
(Formal
), Loc
)),
1950 Append_To
(Decl
, Decl_2
);
1951 Append_To
(Decl
, Decl_1
);
1953 -- Reference the new actual. Generate:
1957 Unchecked_Convert_To
1958 (Defining_Identifier
(Decl_2
),
1959 New_Occurrence_Of
(Defining_Identifier
(Decl_1
), Loc
)));
1961 elsif Is_Controlling_Formal
(Target_Formal
) then
1964 -- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
1965 -- + Offset_To_Top (Formal'Address)
1966 -- S2 : Addr_Ptr := Addr_Ptr!(S1)
1969 Make_Attribute_Reference
(Loc
,
1971 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
),
1975 if not RTE_Available
(RE_Offset_To_Top
) then
1977 Build_Offset_To_Top
(Loc
, New_Arg
);
1980 Make_Function_Call
(Loc
,
1981 Name
=> New_Occurrence_Of
(RTE
(RE_Offset_To_Top
), Loc
),
1982 Parameter_Associations
=> New_List
(New_Arg
));
1986 Make_Object_Declaration
(Loc
,
1987 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
1988 Constant_Present
=> True,
1989 Object_Definition
=>
1990 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
1994 Unchecked_Convert_To
1995 (RTE
(RE_Storage_Offset
),
1996 Make_Attribute_Reference
(Loc
,
1999 (Defining_Identifier
(Formal
), Loc
),
2000 Attribute_Name
=> Name_Address
)),
2005 Make_Object_Declaration
(Loc
,
2006 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
2007 Constant_Present
=> True,
2008 Object_Definition
=>
2009 New_Occurrence_Of
(RTE
(RE_Addr_Ptr
), Loc
),
2011 Unchecked_Convert_To
2013 New_Occurrence_Of
(Defining_Identifier
(Decl_1
), Loc
)));
2015 Append_To
(Decl
, Decl_1
);
2016 Append_To
(Decl
, Decl_2
);
2018 -- Reference the new actual, generate:
2019 -- Target_Formal (S2.all)
2022 Unchecked_Convert_To
(Ftyp
,
2023 Make_Explicit_Dereference
(Loc
,
2024 New_Occurrence_Of
(Defining_Identifier
(Decl_2
), Loc
))));
2026 -- Ensure proper matching of access types. Required to avoid
2027 -- reporting spurious errors.
2029 elsif Is_Access_Type
(Etype
(Target_Formal
)) then
2031 Unchecked_Convert_To
(Base_Type
(Etype
(Target_Formal
)),
2032 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
)));
2034 -- No special management required for this actual
2038 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
2041 Next_Formal
(Target_Formal
);
2045 Thunk_Id
:= Make_Temporary
(Loc
, 'T');
2046 Set_Ekind
(Thunk_Id
, Ekind
(Prim
));
2047 Set_Is_Thunk
(Thunk_Id
);
2048 Set_Convention
(Thunk_Id
, Convention
(Prim
));
2049 Set_Thunk_Entity
(Thunk_Id
, Target
);
2053 if Ekind
(Target
) = E_Procedure
then
2055 Make_Subprogram_Body
(Loc
,
2057 Make_Procedure_Specification
(Loc
,
2058 Defining_Unit_Name
=> Thunk_Id
,
2059 Parameter_Specifications
=> Formals
),
2060 Declarations
=> Decl
,
2061 Handled_Statement_Sequence
=>
2062 Make_Handled_Sequence_Of_Statements
(Loc
,
2063 Statements
=> New_List
(
2064 Make_Procedure_Call_Statement
(Loc
,
2065 Name
=> New_Occurrence_Of
(Target
, Loc
),
2066 Parameter_Associations
=> Actuals
))));
2070 else pragma Assert
(Ekind
(Target
) = E_Function
);
2072 Result_Def
: Node_Id
;
2073 Call_Node
: Node_Id
;
2077 Make_Function_Call
(Loc
,
2078 Name
=> New_Occurrence_Of
(Target
, Loc
),
2079 Parameter_Associations
=> Actuals
);
2081 if not Is_Interface
(Etype
(Prim
)) then
2082 Result_Def
:= New_Copy
(Result_Definition
(Parent
(Target
)));
2084 -- Thunk of function returning a class-wide interface object. No
2085 -- extra displacement needed since the displacement is generated
2086 -- in the return statement of Prim. Example:
2088 -- type Iface is interface ...
2089 -- function F (O : Iface) return Iface'Class;
2091 -- type T is new ... and Iface with ...
2092 -- function F (O : T) return Iface'Class;
2094 elsif Is_Class_Wide_Type
(Etype
(Prim
)) then
2095 Result_Def
:= New_Occurrence_Of
(Etype
(Prim
), Loc
);
2097 -- Thunk of function returning an interface object. Displacement
2100 -- type Iface is interface ...
2101 -- function F (O : Iface) return Iface;
2103 -- type T is new ... and Iface with ...
2104 -- function F (O : T) return T;
2108 New_Occurrence_Of
(Class_Wide_Type
(Etype
(Prim
)), Loc
);
2110 -- Adding implicit conversion to force the displacement of
2111 -- the pointer to the object to reference the corresponding
2112 -- secondary dispatch table.
2115 Make_Type_Conversion
(Loc
,
2117 New_Occurrence_Of
(Class_Wide_Type
(Etype
(Prim
)), Loc
),
2118 Expression
=> Relocate_Node
(Call_Node
));
2122 Make_Subprogram_Body
(Loc
,
2124 Make_Function_Specification
(Loc
,
2125 Defining_Unit_Name
=> Thunk_Id
,
2126 Parameter_Specifications
=> Formals
,
2127 Result_Definition
=> Result_Def
),
2128 Declarations
=> Decl
,
2129 Handled_Statement_Sequence
=>
2130 Make_Handled_Sequence_Of_Statements
(Loc
,
2131 Statements
=> New_List
(
2132 Make_Simple_Return_Statement
(Loc
, Call_Node
))));
2135 end Expand_Interface_Thunk
;
2137 --------------------------
2138 -- Has_CPP_Constructors --
2139 --------------------------
2141 function Has_CPP_Constructors
(Typ
: Entity_Id
) return Boolean is
2145 -- Look for the constructor entities
2147 E
:= Next_Entity
(Typ
);
2148 while Present
(E
) loop
2149 if Ekind
(E
) = E_Function
and then Is_Constructor
(E
) then
2157 end Has_CPP_Constructors
;
2163 function Has_DT
(Typ
: Entity_Id
) return Boolean is
2165 return not Is_Interface
(Typ
)
2166 and then not Restriction_Active
(No_Dispatching_Calls
);
2169 ----------------------------------
2170 -- Is_Expanded_Dispatching_Call --
2171 ----------------------------------
2173 function Is_Expanded_Dispatching_Call
(N
: Node_Id
) return Boolean is
2175 return Nkind
(N
) in N_Subprogram_Call
2176 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
2177 and then Is_Dispatch_Table_Entity
(Etype
(Name
(N
)));
2178 end Is_Expanded_Dispatching_Call
;
2180 -------------------------------------
2181 -- Is_Predefined_Dispatching_Alias --
2182 -------------------------------------
2184 function Is_Predefined_Dispatching_Alias
(Prim
: Entity_Id
) return Boolean
2187 return not Is_Predefined_Dispatching_Operation
(Prim
)
2188 and then Present
(Alias
(Prim
))
2189 and then Is_Predefined_Dispatching_Operation
(Ultimate_Alias
(Prim
));
2190 end Is_Predefined_Dispatching_Alias
;
2192 ----------------------------------------
2193 -- Make_Disp_Asynchronous_Select_Body --
2194 ----------------------------------------
2196 -- For interface types, generate:
2198 -- procedure _Disp_Asynchronous_Select
2199 -- (T : in out <Typ>;
2201 -- P : System.Address;
2202 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2207 -- C := Ada.Tags.POK_Function;
2208 -- end _Disp_Asynchronous_Select;
2210 -- For protected types, generate:
2212 -- procedure _Disp_Asynchronous_Select
2213 -- (T : in out <Typ>;
2215 -- P : System.Address;
2216 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2220 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2221 -- Bnn : System.Tasking.Protected_Objects.Operations.
2222 -- Communication_Block;
2224 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2225 -- (T._object'Access,
2226 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2228 -- System.Tasking.Asynchronous_Call,
2230 -- B := System.Storage_Elements.Dummy_Communication_Block (Bnn);
2231 -- end _Disp_Asynchronous_Select;
2233 -- For task types, generate:
2235 -- procedure _Disp_Asynchronous_Select
2236 -- (T : in out <Typ>;
2238 -- P : System.Address;
2239 -- B : out System.Storage_Elements.Dummy_Communication_Block;
2243 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2245 -- System.Tasking.Rendezvous.Task_Entry_Call
2247 -- System.Tasking.Task_Entry_Index (I),
2249 -- System.Tasking.Asynchronous_Call,
2251 -- end _Disp_Asynchronous_Select;
2253 function Make_Disp_Asynchronous_Select_Body
2254 (Typ
: Entity_Id
) return Node_Id
2256 Com_Block
: Entity_Id
;
2257 Conc_Typ
: Entity_Id
:= Empty
;
2258 Decls
: constant List_Id
:= New_List
;
2259 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2261 Stmts
: constant List_Id
:= New_List
;
2265 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2267 -- Null body is generated for interface types
2269 if Is_Interface
(Typ
) then
2271 Make_Subprogram_Body
(Loc
,
2273 Make_Disp_Asynchronous_Select_Spec
(Typ
),
2274 Declarations
=> New_List
,
2275 Handled_Statement_Sequence
=>
2276 Make_Handled_Sequence_Of_Statements
(Loc
,
2278 Make_Assignment_Statement
(Loc
,
2279 Name
=> Make_Identifier
(Loc
, Name_uF
),
2280 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
2283 if Is_Concurrent_Record_Type
(Typ
) then
2284 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
2288 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2290 -- where I will be used to capture the entry index of the primitive
2291 -- wrapper at position S.
2293 if Tagged_Type_Expansion
then
2295 Unchecked_Convert_To
(RTE
(RE_Tag
),
2297 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
2300 Make_Attribute_Reference
(Loc
,
2301 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
2302 Attribute_Name
=> Name_Tag
);
2306 Make_Object_Declaration
(Loc
,
2307 Defining_Identifier
=>
2308 Make_Defining_Identifier
(Loc
, Name_uI
),
2309 Object_Definition
=>
2310 New_Occurrence_Of
(Standard_Integer
, Loc
),
2312 Make_Function_Call
(Loc
,
2314 New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
2315 Parameter_Associations
=>
2316 New_List
(Tag_Node
, Make_Identifier
(Loc
, Name_uS
)))));
2318 if Ekind
(Conc_Typ
) = E_Protected_Type
then
2321 -- Bnn : Communication_Block;
2323 Com_Block
:= Make_Temporary
(Loc
, 'B');
2325 Make_Object_Declaration
(Loc
,
2326 Defining_Identifier
=> Com_Block
,
2327 Object_Definition
=>
2328 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
2330 -- Build T._object'Access for calls below
2333 Make_Attribute_Reference
(Loc
,
2334 Attribute_Name
=> Name_Unchecked_Access
,
2336 Make_Selected_Component
(Loc
,
2337 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2338 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
2340 case Corresponding_Runtime_Package
(Conc_Typ
) is
2341 when System_Tasking_Protected_Objects_Entries
=>
2344 -- Protected_Entry_Call
2345 -- (T._object'Access, -- Object
2346 -- Protected_Entry_Index! (I), -- E
2347 -- P, -- Uninterpreted_Data
2348 -- Asynchronous_Call, -- Mode
2349 -- Bnn); -- Communication_Block
2351 -- where T is the protected object, I is the entry index, P
2352 -- is the wrapped parameters and B is the name of the
2353 -- communication block.
2356 Make_Procedure_Call_Statement
(Loc
,
2358 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
2359 Parameter_Associations
=>
2363 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2366 (RTE
(RE_Protected_Entry_Index
), Loc
),
2367 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2369 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2370 New_Occurrence_Of
-- Asynchronous_Call
2371 (RTE
(RE_Asynchronous_Call
), Loc
),
2372 New_Occurrence_Of
-- comm block
2373 (Com_Block
, Loc
))));
2376 raise Program_Error
;
2380 -- B := Dummy_Communication_Block (Bnn);
2383 Make_Assignment_Statement
(Loc
,
2384 Name
=> Make_Identifier
(Loc
, Name_uB
),
2386 Make_Unchecked_Type_Conversion
(Loc
,
2389 (RTE
(RE_Dummy_Communication_Block
), Loc
),
2390 Expression
=> New_Occurrence_Of
(Com_Block
, Loc
))));
2396 Make_Assignment_Statement
(Loc
,
2397 Name
=> Make_Identifier
(Loc
, Name_uF
),
2398 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
2401 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
2405 -- (T._task_id, -- Acceptor
2406 -- Task_Entry_Index! (I), -- E
2407 -- P, -- Uninterpreted_Data
2408 -- Asynchronous_Call, -- Mode
2409 -- F); -- Rendezvous_Successful
2411 -- where T is the task object, I is the entry index, P is the
2412 -- wrapped parameters and F is the status flag.
2415 Make_Procedure_Call_Statement
(Loc
,
2417 New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
2418 Parameter_Associations
=>
2420 Make_Selected_Component
(Loc
, -- T._task_id
2421 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2422 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
2424 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2426 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
2427 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2429 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2430 New_Occurrence_Of
-- Asynchronous_Call
2431 (RTE
(RE_Asynchronous_Call
), Loc
),
2432 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
2436 -- Ensure that the statements list is non-empty
2439 Make_Assignment_Statement
(Loc
,
2440 Name
=> Make_Identifier
(Loc
, Name_uF
),
2441 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
2445 Make_Subprogram_Body
(Loc
,
2447 Make_Disp_Asynchronous_Select_Spec
(Typ
),
2448 Declarations
=> Decls
,
2449 Handled_Statement_Sequence
=>
2450 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
2451 end Make_Disp_Asynchronous_Select_Body
;
2453 ----------------------------------------
2454 -- Make_Disp_Asynchronous_Select_Spec --
2455 ----------------------------------------
2457 function Make_Disp_Asynchronous_Select_Spec
2458 (Typ
: Entity_Id
) return Node_Id
2460 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2461 Def_Id
: constant Node_Id
:=
2462 Make_Defining_Identifier
(Loc
,
2463 Name_uDisp_Asynchronous_Select
);
2464 Params
: constant List_Id
:= New_List
;
2467 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2469 -- T : in out Typ; -- Object parameter
2470 -- S : Integer; -- Primitive operation slot
2471 -- P : Address; -- Wrapped parameters
2472 -- B : out Dummy_Communication_Block; -- Communication block dummy
2473 -- F : out Boolean; -- Status flag
2475 Append_List_To
(Params
, New_List
(
2477 Make_Parameter_Specification
(Loc
,
2478 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
2479 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
2481 Out_Present
=> True),
2483 Make_Parameter_Specification
(Loc
,
2484 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
2485 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
2487 Make_Parameter_Specification
(Loc
,
2488 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
2489 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2491 Make_Parameter_Specification
(Loc
,
2492 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uB
),
2494 New_Occurrence_Of
(RTE
(RE_Dummy_Communication_Block
), Loc
),
2495 Out_Present
=> True),
2497 Make_Parameter_Specification
(Loc
,
2498 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
2499 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
2500 Out_Present
=> True)));
2503 Make_Procedure_Specification
(Loc
,
2504 Defining_Unit_Name
=> Def_Id
,
2505 Parameter_Specifications
=> Params
);
2506 end Make_Disp_Asynchronous_Select_Spec
;
2508 ---------------------------------------
2509 -- Make_Disp_Conditional_Select_Body --
2510 ---------------------------------------
2512 -- For interface types, generate:
2514 -- procedure _Disp_Conditional_Select
2515 -- (T : in out <Typ>;
2517 -- P : System.Address;
2518 -- C : out Ada.Tags.Prim_Op_Kind;
2523 -- C := Ada.Tags.POK_Function;
2524 -- end _Disp_Conditional_Select;
2526 -- For protected types, generate:
2528 -- procedure _Disp_Conditional_Select
2529 -- (T : in out <Typ>;
2531 -- P : System.Address;
2532 -- C : out Ada.Tags.Prim_Op_Kind;
2536 -- Bnn : System.Tasking.Protected_Objects.Operations.
2537 -- Communication_Block;
2540 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S));
2542 -- if C = Ada.Tags.POK_Procedure
2543 -- or else C = Ada.Tags.POK_Protected_Procedure
2544 -- or else C = Ada.Tags.POK_Task_Procedure
2550 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2551 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2552 -- (T.object'Access,
2553 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2555 -- System.Tasking.Conditional_Call,
2557 -- F := not Cancelled (Bnn);
2558 -- end _Disp_Conditional_Select;
2560 -- For task types, generate:
2562 -- procedure _Disp_Conditional_Select
2563 -- (T : in out <Typ>;
2565 -- P : System.Address;
2566 -- C : out Ada.Tags.Prim_Op_Kind;
2572 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2573 -- System.Tasking.Rendezvous.Task_Entry_Call
2575 -- System.Tasking.Task_Entry_Index (I),
2577 -- System.Tasking.Conditional_Call,
2579 -- end _Disp_Conditional_Select;
2581 function Make_Disp_Conditional_Select_Body
2582 (Typ
: Entity_Id
) return Node_Id
2584 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2585 Blk_Nam
: Entity_Id
;
2586 Conc_Typ
: Entity_Id
:= Empty
;
2587 Decls
: constant List_Id
:= New_List
;
2589 Stmts
: constant List_Id
:= New_List
;
2593 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2595 -- Null body is generated for interface types
2597 if Is_Interface
(Typ
) then
2599 Make_Subprogram_Body
(Loc
,
2601 Make_Disp_Conditional_Select_Spec
(Typ
),
2602 Declarations
=> No_List
,
2603 Handled_Statement_Sequence
=>
2604 Make_Handled_Sequence_Of_Statements
(Loc
,
2605 New_List
(Make_Assignment_Statement
(Loc
,
2606 Name
=> Make_Identifier
(Loc
, Name_uF
),
2607 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
2610 if Is_Concurrent_Record_Type
(Typ
) then
2611 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
2616 -- where I will be used to capture the entry index of the primitive
2617 -- wrapper at position S.
2620 Make_Object_Declaration
(Loc
,
2621 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uI
),
2622 Object_Definition
=>
2623 New_Occurrence_Of
(Standard_Integer
, Loc
)));
2626 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S);
2628 -- if C = POK_Procedure
2629 -- or else C = POK_Protected_Procedure
2630 -- or else C = POK_Task_Procedure;
2636 Build_Common_Dispatching_Select_Statements
(Typ
, Stmts
);
2639 -- Bnn : Communication_Block;
2641 -- where Bnn is the name of the communication block used in the
2642 -- call to Protected_Entry_Call.
2644 Blk_Nam
:= Make_Temporary
(Loc
, 'B');
2646 Make_Object_Declaration
(Loc
,
2647 Defining_Identifier
=> Blk_Nam
,
2648 Object_Definition
=>
2649 New_Occurrence_Of
(RTE
(RE_Communication_Block
), Loc
)));
2652 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2654 -- I is the entry index and S is the dispatch table slot
2656 if Tagged_Type_Expansion
then
2658 Unchecked_Convert_To
(RTE
(RE_Tag
),
2660 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
2664 Make_Attribute_Reference
(Loc
,
2665 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
2666 Attribute_Name
=> Name_Tag
);
2670 Make_Assignment_Statement
(Loc
,
2671 Name
=> Make_Identifier
(Loc
, Name_uI
),
2673 Make_Function_Call
(Loc
,
2675 New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
2676 Parameter_Associations
=> New_List
(
2678 Make_Identifier
(Loc
, Name_uS
)))));
2680 if Ekind
(Conc_Typ
) = E_Protected_Type
then
2682 Obj_Ref
:= -- T._object'Access
2683 Make_Attribute_Reference
(Loc
,
2684 Attribute_Name
=> Name_Unchecked_Access
,
2686 Make_Selected_Component
(Loc
,
2687 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2688 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
2690 case Corresponding_Runtime_Package
(Conc_Typ
) is
2691 when System_Tasking_Protected_Objects_Entries
=>
2694 -- Protected_Entry_Call
2695 -- (T._object'Access, -- Object
2696 -- Protected_Entry_Index! (I), -- E
2697 -- P, -- Uninterpreted_Data
2698 -- Conditional_Call, -- Mode
2701 -- where T is the protected object, I is the entry index, P
2702 -- are the wrapped parameters and Bnn is the name of the
2703 -- communication block.
2706 Make_Procedure_Call_Statement
(Loc
,
2708 New_Occurrence_Of
(RTE
(RE_Protected_Entry_Call
), Loc
),
2709 Parameter_Associations
=> New_List
(
2712 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2715 (RTE
(RE_Protected_Entry_Index
), Loc
),
2716 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2718 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2720 New_Occurrence_Of
-- Conditional_Call
2721 (RTE
(RE_Conditional_Call
), Loc
),
2722 New_Occurrence_Of
-- Bnn
2725 when System_Tasking_Protected_Objects_Single_Entry
=>
2727 -- If we are compiling for a restricted run-time, the call
2728 -- uses the simpler form.
2731 Make_Procedure_Call_Statement
(Loc
,
2734 (RTE
(RE_Protected_Single_Entry_Call
), Loc
),
2735 Parameter_Associations
=> New_List
(
2738 Make_Attribute_Reference
(Loc
,
2739 Prefix
=> Make_Identifier
(Loc
, Name_uP
),
2740 Attribute_Name
=> Name_Address
),
2743 (RTE
(RE_Conditional_Call
), Loc
))));
2745 raise Program_Error
;
2749 -- F := not Cancelled (Bnn);
2751 -- where F is the success flag. The status of Cancelled is negated
2752 -- in order to match the behavior of the version for task types.
2755 Make_Assignment_Statement
(Loc
,
2756 Name
=> Make_Identifier
(Loc
, Name_uF
),
2760 Make_Function_Call
(Loc
,
2762 New_Occurrence_Of
(RTE
(RE_Cancelled
), Loc
),
2763 Parameter_Associations
=> New_List
(
2764 New_Occurrence_Of
(Blk_Nam
, Loc
))))));
2766 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
2770 -- (T._task_id, -- Acceptor
2771 -- Task_Entry_Index! (I), -- E
2772 -- P, -- Uninterpreted_Data
2773 -- Conditional_Call, -- Mode
2774 -- F); -- Rendezvous_Successful
2776 -- where T is the task object, I is the entry index, P are the
2777 -- wrapped parameters and F is the status flag.
2780 Make_Procedure_Call_Statement
(Loc
,
2782 New_Occurrence_Of
(RTE
(RE_Task_Entry_Call
), Loc
),
2783 Parameter_Associations
=> New_List
(
2785 Make_Selected_Component
(Loc
, -- T._task_id
2786 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2787 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
2789 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2791 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
2792 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2794 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2795 New_Occurrence_Of
-- Conditional_Call
2796 (RTE
(RE_Conditional_Call
), Loc
),
2797 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
2801 -- Initialize out parameters
2804 Make_Assignment_Statement
(Loc
,
2805 Name
=> Make_Identifier
(Loc
, Name_uF
),
2806 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
2808 Make_Assignment_Statement
(Loc
,
2809 Name
=> Make_Identifier
(Loc
, Name_uC
),
2810 Expression
=> New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
)));
2814 Make_Subprogram_Body
(Loc
,
2816 Make_Disp_Conditional_Select_Spec
(Typ
),
2817 Declarations
=> Decls
,
2818 Handled_Statement_Sequence
=>
2819 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
2820 end Make_Disp_Conditional_Select_Body
;
2822 ---------------------------------------
2823 -- Make_Disp_Conditional_Select_Spec --
2824 ---------------------------------------
2826 function Make_Disp_Conditional_Select_Spec
2827 (Typ
: Entity_Id
) return Node_Id
2829 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2830 Def_Id
: constant Node_Id
:=
2831 Make_Defining_Identifier
(Loc
,
2832 Name_uDisp_Conditional_Select
);
2833 Params
: constant List_Id
:= New_List
;
2836 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2838 -- T : in out Typ; -- Object parameter
2839 -- S : Integer; -- Primitive operation slot
2840 -- P : Address; -- Wrapped parameters
2841 -- C : out Prim_Op_Kind; -- Call kind
2842 -- F : out Boolean; -- Status flag
2844 Append_List_To
(Params
, New_List
(
2846 Make_Parameter_Specification
(Loc
,
2847 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
2848 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
2850 Out_Present
=> True),
2852 Make_Parameter_Specification
(Loc
,
2853 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
2854 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
2856 Make_Parameter_Specification
(Loc
,
2857 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
2858 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2860 Make_Parameter_Specification
(Loc
,
2861 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
2863 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
2864 Out_Present
=> True),
2866 Make_Parameter_Specification
(Loc
,
2867 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
2868 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
2869 Out_Present
=> True)));
2872 Make_Procedure_Specification
(Loc
,
2873 Defining_Unit_Name
=> Def_Id
,
2874 Parameter_Specifications
=> Params
);
2875 end Make_Disp_Conditional_Select_Spec
;
2877 -------------------------------------
2878 -- Make_Disp_Get_Prim_Op_Kind_Body --
2879 -------------------------------------
2881 function Make_Disp_Get_Prim_Op_Kind_Body
(Typ
: Entity_Id
) return Node_Id
is
2882 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2886 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2888 if Is_Interface
(Typ
) then
2890 Make_Subprogram_Body
(Loc
,
2892 Make_Disp_Get_Prim_Op_Kind_Spec
(Typ
),
2893 Declarations
=> New_List
,
2894 Handled_Statement_Sequence
=>
2895 Make_Handled_Sequence_Of_Statements
(Loc
,
2896 New_List
(Make_Null_Statement
(Loc
))));
2900 -- C := get_prim_op_kind (tag! (<type>VP), S);
2902 -- where C is the out parameter capturing the call kind and S is the
2903 -- dispatch table slot number.
2905 if Tagged_Type_Expansion
then
2907 Unchecked_Convert_To
(RTE
(RE_Tag
),
2909 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
2913 Make_Attribute_Reference
(Loc
,
2914 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
2915 Attribute_Name
=> Name_Tag
);
2919 Make_Subprogram_Body
(Loc
,
2921 Make_Disp_Get_Prim_Op_Kind_Spec
(Typ
),
2922 Declarations
=> New_List
,
2923 Handled_Statement_Sequence
=>
2924 Make_Handled_Sequence_Of_Statements
(Loc
,
2926 Make_Assignment_Statement
(Loc
,
2927 Name
=> Make_Identifier
(Loc
, Name_uC
),
2929 Make_Function_Call
(Loc
,
2931 New_Occurrence_Of
(RTE
(RE_Get_Prim_Op_Kind
), Loc
),
2932 Parameter_Associations
=> New_List
(
2934 Make_Identifier
(Loc
, Name_uS
)))))));
2935 end Make_Disp_Get_Prim_Op_Kind_Body
;
2937 -------------------------------------
2938 -- Make_Disp_Get_Prim_Op_Kind_Spec --
2939 -------------------------------------
2941 function Make_Disp_Get_Prim_Op_Kind_Spec
2942 (Typ
: Entity_Id
) return Node_Id
2944 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2945 Def_Id
: constant Node_Id
:=
2946 Make_Defining_Identifier
(Loc
, Name_uDisp_Get_Prim_Op_Kind
);
2947 Params
: constant List_Id
:= New_List
;
2950 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2952 -- T : in out Typ; -- Object parameter
2953 -- S : Integer; -- Primitive operation slot
2954 -- C : out Prim_Op_Kind; -- Call kind
2956 Append_List_To
(Params
, New_List
(
2958 Make_Parameter_Specification
(Loc
,
2959 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
2960 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
2962 Out_Present
=> True),
2964 Make_Parameter_Specification
(Loc
,
2965 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
2966 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
2968 Make_Parameter_Specification
(Loc
,
2969 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
2971 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
2972 Out_Present
=> True)));
2975 Make_Procedure_Specification
(Loc
,
2976 Defining_Unit_Name
=> Def_Id
,
2977 Parameter_Specifications
=> Params
);
2978 end Make_Disp_Get_Prim_Op_Kind_Spec
;
2980 --------------------------------
2981 -- Make_Disp_Get_Task_Id_Body --
2982 --------------------------------
2984 function Make_Disp_Get_Task_Id_Body
2985 (Typ
: Entity_Id
) return Node_Id
2987 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2991 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2993 if Is_Concurrent_Record_Type
(Typ
)
2994 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) = E_Task_Type
2997 -- return To_Address (_T._task_id);
3000 Make_Simple_Return_Statement
(Loc
,
3002 Make_Unchecked_Type_Conversion
(Loc
,
3003 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
3005 Make_Selected_Component
(Loc
,
3006 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
3007 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
))));
3009 -- A null body is constructed for non-task types
3013 -- return Null_Address;
3016 Make_Simple_Return_Statement
(Loc
,
3017 Expression
=> New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
3021 Make_Subprogram_Body
(Loc
,
3022 Specification
=> Make_Disp_Get_Task_Id_Spec
(Typ
),
3023 Declarations
=> New_List
,
3024 Handled_Statement_Sequence
=>
3025 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Ret
)));
3026 end Make_Disp_Get_Task_Id_Body
;
3028 --------------------------------
3029 -- Make_Disp_Get_Task_Id_Spec --
3030 --------------------------------
3032 function Make_Disp_Get_Task_Id_Spec
3033 (Typ
: Entity_Id
) return Node_Id
3035 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3038 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3041 Make_Function_Specification
(Loc
,
3042 Defining_Unit_Name
=>
3043 Make_Defining_Identifier
(Loc
, Name_uDisp_Get_Task_Id
),
3044 Parameter_Specifications
=> New_List
(
3045 Make_Parameter_Specification
(Loc
,
3046 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
3047 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
3048 Result_Definition
=>
3049 New_Occurrence_Of
(RTE
(RE_Address
), Loc
));
3050 end Make_Disp_Get_Task_Id_Spec
;
3052 ----------------------------
3053 -- Make_Disp_Requeue_Body --
3054 ----------------------------
3056 function Make_Disp_Requeue_Body
3057 (Typ
: Entity_Id
) return Node_Id
3059 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3060 Conc_Typ
: Entity_Id
:= Empty
;
3061 Stmts
: constant List_Id
:= New_List
;
3064 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3066 -- Null body is generated for interface types and non-concurrent
3069 if Is_Interface
(Typ
)
3070 or else not Is_Concurrent_Record_Type
(Typ
)
3073 Make_Subprogram_Body
(Loc
,
3074 Specification
=> Make_Disp_Requeue_Spec
(Typ
),
3075 Declarations
=> No_List
,
3076 Handled_Statement_Sequence
=>
3077 Make_Handled_Sequence_Of_Statements
(Loc
,
3078 New_List
(Make_Null_Statement
(Loc
))));
3081 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
3083 if Ekind
(Conc_Typ
) = E_Protected_Type
then
3085 -- Generate statements:
3087 -- System.Tasking.Protected_Objects.Operations.
3088 -- Requeue_Protected_Entry
3089 -- (Protection_Entries_Access (P),
3090 -- O._object'Unchecked_Access,
3091 -- Protected_Entry_Index (I),
3094 -- System.Tasking.Protected_Objects.Operations.
3095 -- Requeue_Task_To_Protected_Entry
3096 -- (O._object'Unchecked_Access,
3097 -- Protected_Entry_Index (I),
3101 if Restriction_Active
(No_Entry_Queue
) then
3102 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
3105 Make_If_Statement
(Loc
,
3106 Condition
=> Make_Identifier
(Loc
, Name_uF
),
3111 -- Call to Requeue_Protected_Entry
3113 Make_Procedure_Call_Statement
(Loc
,
3116 (RTE
(RE_Requeue_Protected_Entry
), Loc
),
3117 Parameter_Associations
=>
3120 Make_Unchecked_Type_Conversion
(Loc
, -- PEA (P)
3123 RTE
(RE_Protection_Entries_Access
), Loc
),
3125 Make_Identifier
(Loc
, Name_uP
)),
3127 Make_Attribute_Reference
(Loc
, -- O._object'Acc
3129 Name_Unchecked_Access
,
3131 Make_Selected_Component
(Loc
,
3133 Make_Identifier
(Loc
, Name_uO
),
3135 Make_Identifier
(Loc
, Name_uObject
))),
3137 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3140 (RTE
(RE_Protected_Entry_Index
), Loc
),
3141 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3143 Make_Identifier
(Loc
, Name_uA
)))), -- abort status
3148 -- Call to Requeue_Task_To_Protected_Entry
3150 Make_Procedure_Call_Statement
(Loc
,
3153 (RTE
(RE_Requeue_Task_To_Protected_Entry
), Loc
),
3154 Parameter_Associations
=>
3157 Make_Attribute_Reference
(Loc
, -- O._object'Acc
3158 Attribute_Name
=> Name_Unchecked_Access
,
3160 Make_Selected_Component
(Loc
,
3162 Make_Identifier
(Loc
, Name_uO
),
3164 Make_Identifier
(Loc
, Name_uObject
))),
3166 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3169 (RTE
(RE_Protected_Entry_Index
), Loc
),
3170 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3172 Make_Identifier
(Loc
, Name_uA
)))))); -- abort status
3176 pragma Assert
(Is_Task_Type
(Conc_Typ
));
3180 -- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry
3181 -- (Protection_Entries_Access (P),
3183 -- Task_Entry_Index (I),
3186 -- System.Tasking.Rendezvous.Requeue_Task_Entry
3188 -- Task_Entry_Index (I),
3193 Make_If_Statement
(Loc
,
3194 Condition
=> Make_Identifier
(Loc
, Name_uF
),
3196 Then_Statements
=> New_List
(
3198 -- Call to Requeue_Protected_To_Task_Entry
3200 Make_Procedure_Call_Statement
(Loc
,
3203 (RTE
(RE_Requeue_Protected_To_Task_Entry
), Loc
),
3205 Parameter_Associations
=> New_List
(
3207 Make_Unchecked_Type_Conversion
(Loc
, -- PEA (P)
3210 (RTE
(RE_Protection_Entries_Access
), Loc
),
3211 Expression
=> Make_Identifier
(Loc
, Name_uP
)),
3213 Make_Selected_Component
(Loc
, -- O._task_id
3214 Prefix
=> Make_Identifier
(Loc
, Name_uO
),
3215 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3217 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3219 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
3220 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3222 Make_Identifier
(Loc
, Name_uA
)))), -- abort status
3224 Else_Statements
=> New_List
(
3226 -- Call to Requeue_Task_Entry
3228 Make_Procedure_Call_Statement
(Loc
,
3230 New_Occurrence_Of
(RTE
(RE_Requeue_Task_Entry
), Loc
),
3232 Parameter_Associations
=> New_List
(
3234 Make_Selected_Component
(Loc
, -- O._task_id
3235 Prefix
=> Make_Identifier
(Loc
, Name_uO
),
3236 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3238 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3240 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
3241 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3243 Make_Identifier
(Loc
, Name_uA
)))))); -- abort status
3246 -- Even though no declarations are needed in both cases, we allocate
3247 -- a list for entities added by Freeze.
3250 Make_Subprogram_Body
(Loc
,
3251 Specification
=> Make_Disp_Requeue_Spec
(Typ
),
3252 Declarations
=> New_List
,
3253 Handled_Statement_Sequence
=>
3254 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
3255 end Make_Disp_Requeue_Body
;
3257 ----------------------------
3258 -- Make_Disp_Requeue_Spec --
3259 ----------------------------
3261 function Make_Disp_Requeue_Spec
3262 (Typ
: Entity_Id
) return Node_Id
3264 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3267 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3269 -- O : in out Typ; - Object parameter
3270 -- F : Boolean; - Protected (True) / task (False) flag
3271 -- P : Address; - Protection_Entries_Access value
3272 -- I : Entry_Index - Index of entry call
3273 -- A : Boolean - Abort flag
3275 -- Note that the Protection_Entries_Access value is represented as a
3276 -- System.Address in order to avoid dragging in the tasking runtime
3277 -- when compiling sources without tasking constructs.
3280 Make_Procedure_Specification
(Loc
,
3281 Defining_Unit_Name
=>
3282 Make_Defining_Identifier
(Loc
, Name_uDisp_Requeue
),
3284 Parameter_Specifications
=> New_List
(
3286 Make_Parameter_Specification
(Loc
, -- O
3287 Defining_Identifier
=>
3288 Make_Defining_Identifier
(Loc
, Name_uO
),
3290 New_Occurrence_Of
(Typ
, Loc
),
3292 Out_Present
=> True),
3294 Make_Parameter_Specification
(Loc
, -- F
3295 Defining_Identifier
=>
3296 Make_Defining_Identifier
(Loc
, Name_uF
),
3298 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
3300 Make_Parameter_Specification
(Loc
, -- P
3301 Defining_Identifier
=>
3302 Make_Defining_Identifier
(Loc
, Name_uP
),
3304 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3306 Make_Parameter_Specification
(Loc
, -- I
3307 Defining_Identifier
=>
3308 Make_Defining_Identifier
(Loc
, Name_uI
),
3310 New_Occurrence_Of
(Standard_Integer
, Loc
)),
3312 Make_Parameter_Specification
(Loc
, -- A
3313 Defining_Identifier
=>
3314 Make_Defining_Identifier
(Loc
, Name_uA
),
3316 New_Occurrence_Of
(Standard_Boolean
, Loc
))));
3317 end Make_Disp_Requeue_Spec
;
3319 ---------------------------------
3320 -- Make_Disp_Timed_Select_Body --
3321 ---------------------------------
3323 -- For interface types, generate:
3325 -- procedure _Disp_Timed_Select
3326 -- (T : in out <Typ>;
3328 -- P : System.Address;
3331 -- C : out Ada.Tags.Prim_Op_Kind;
3336 -- C := Ada.Tags.POK_Function;
3337 -- end _Disp_Timed_Select;
3339 -- For protected types, generate:
3341 -- procedure _Disp_Timed_Select
3342 -- (T : in out <Typ>;
3344 -- P : System.Address;
3347 -- C : out Ada.Tags.Prim_Op_Kind;
3353 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S);
3355 -- if C = Ada.Tags.POK_Procedure
3356 -- or else C = Ada.Tags.POK_Protected_Procedure
3357 -- or else C = Ada.Tags.POK_Task_Procedure
3363 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3364 -- System.Tasking.Protected_Objects.Operations.
3365 -- Timed_Protected_Entry_Call
3366 -- (T._object'Access,
3367 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
3372 -- end _Disp_Timed_Select;
3374 -- For task types, generate:
3376 -- procedure _Disp_Timed_Select
3377 -- (T : in out <Typ>;
3379 -- P : System.Address;
3382 -- C : out Ada.Tags.Prim_Op_Kind;
3388 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3389 -- System.Tasking.Rendezvous.Timed_Task_Entry_Call
3391 -- System.Tasking.Task_Entry_Index (I),
3396 -- end _Disp_Time_Select;
3398 function Make_Disp_Timed_Select_Body
3399 (Typ
: Entity_Id
) return Node_Id
3401 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3402 Conc_Typ
: Entity_Id
:= Empty
;
3403 Decls
: constant List_Id
:= New_List
;
3405 Stmts
: constant List_Id
:= New_List
;
3409 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3411 -- Null body is generated for interface types
3413 if Is_Interface
(Typ
) then
3415 Make_Subprogram_Body
(Loc
,
3416 Specification
=> Make_Disp_Timed_Select_Spec
(Typ
),
3417 Declarations
=> New_List
,
3418 Handled_Statement_Sequence
=>
3419 Make_Handled_Sequence_Of_Statements
(Loc
,
3421 Make_Assignment_Statement
(Loc
,
3422 Name
=> Make_Identifier
(Loc
, Name_uF
),
3423 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
3426 if Is_Concurrent_Record_Type
(Typ
) then
3427 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
3432 -- where I will be used to capture the entry index of the primitive
3433 -- wrapper at position S.
3436 Make_Object_Declaration
(Loc
,
3437 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uI
),
3438 Object_Definition
=>
3439 New_Occurrence_Of
(Standard_Integer
, Loc
)));
3442 -- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
3444 -- if C = POK_Procedure
3445 -- or else C = POK_Protected_Procedure
3446 -- or else C = POK_Task_Procedure;
3452 Build_Common_Dispatching_Select_Statements
(Typ
, Stmts
);
3455 -- I := Get_Entry_Index (tag! (<type>VP), S);
3457 -- I is the entry index and S is the dispatch table slot
3459 if Tagged_Type_Expansion
then
3461 Unchecked_Convert_To
(RTE
(RE_Tag
),
3463 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
3467 Make_Attribute_Reference
(Loc
,
3468 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
3469 Attribute_Name
=> Name_Tag
);
3473 Make_Assignment_Statement
(Loc
,
3474 Name
=> Make_Identifier
(Loc
, Name_uI
),
3476 Make_Function_Call
(Loc
,
3477 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Entry_Index
), Loc
),
3478 Parameter_Associations
=> New_List
(
3480 Make_Identifier
(Loc
, Name_uS
)))));
3484 if Ekind
(Conc_Typ
) = E_Protected_Type
then
3486 -- Build T._object'Access
3489 Make_Attribute_Reference
(Loc
,
3490 Attribute_Name
=> Name_Unchecked_Access
,
3492 Make_Selected_Component
(Loc
,
3493 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
3494 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
3496 -- Normal case, No_Entry_Queue restriction not active. In this
3497 -- case we generate:
3499 -- Timed_Protected_Entry_Call
3500 -- (T._object'access,
3501 -- Protected_Entry_Index! (I),
3504 -- where T is the protected object, I is the entry index, P are
3505 -- the wrapped parameters, D is the delay amount, M is the delay
3506 -- mode and F is the status flag.
3508 -- Historically, there was also an implementation for single
3509 -- entry protected types (in s-tposen). However, it was removed
3510 -- by also testing for no No_Select_Statements restriction in
3511 -- Exp_Utils.Corresponding_Runtime_Package. This simplified the
3512 -- implementation of s-tposen.adb and provided consistency between
3513 -- all versions of System.Tasking.Protected_Objects.Single_Entry
3516 case Corresponding_Runtime_Package
(Conc_Typ
) is
3517 when System_Tasking_Protected_Objects_Entries
=>
3519 Make_Procedure_Call_Statement
(Loc
,
3522 (RTE
(RE_Timed_Protected_Entry_Call
), Loc
),
3523 Parameter_Associations
=> New_List
(
3526 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3529 (RTE
(RE_Protected_Entry_Index
), Loc
),
3530 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3532 Make_Identifier
(Loc
, Name_uP
), -- parameter block
3533 Make_Identifier
(Loc
, Name_uD
), -- delay
3534 Make_Identifier
(Loc
, Name_uM
), -- delay mode
3535 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
3538 raise Program_Error
;
3544 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
3547 -- Timed_Task_Entry_Call (
3549 -- Task_Entry_Index! (I),
3555 -- where T is the task object, I is the entry index, P are the
3556 -- wrapped parameters, D is the delay amount, M is the delay
3557 -- mode and F is the status flag.
3560 Make_Procedure_Call_Statement
(Loc
,
3562 New_Occurrence_Of
(RTE
(RE_Timed_Task_Entry_Call
), Loc
),
3564 Parameter_Associations
=> New_List
(
3565 Make_Selected_Component
(Loc
, -- T._task_id
3566 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
3567 Selector_Name
=> Make_Identifier
(Loc
, Name_uTask_Id
)),
3569 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
3571 New_Occurrence_Of
(RTE
(RE_Task_Entry_Index
), Loc
),
3572 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
3574 Make_Identifier
(Loc
, Name_uP
), -- parameter block
3575 Make_Identifier
(Loc
, Name_uD
), -- delay
3576 Make_Identifier
(Loc
, Name_uM
), -- delay mode
3577 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
3581 -- Initialize out parameters
3584 Make_Assignment_Statement
(Loc
,
3585 Name
=> Make_Identifier
(Loc
, Name_uF
),
3586 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3588 Make_Assignment_Statement
(Loc
,
3589 Name
=> Make_Identifier
(Loc
, Name_uC
),
3590 Expression
=> New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
)));
3594 Make_Subprogram_Body
(Loc
,
3595 Specification
=> Make_Disp_Timed_Select_Spec
(Typ
),
3596 Declarations
=> Decls
,
3597 Handled_Statement_Sequence
=>
3598 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
3599 end Make_Disp_Timed_Select_Body
;
3601 ---------------------------------
3602 -- Make_Disp_Timed_Select_Spec --
3603 ---------------------------------
3605 function Make_Disp_Timed_Select_Spec
3606 (Typ
: Entity_Id
) return Node_Id
3608 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3609 Def_Id
: constant Node_Id
:=
3610 Make_Defining_Identifier
(Loc
,
3611 Name_uDisp_Timed_Select
);
3612 Params
: constant List_Id
:= New_List
;
3615 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3617 -- T : in out Typ; -- Object parameter
3618 -- S : Integer; -- Primitive operation slot
3619 -- P : Address; -- Wrapped parameters
3620 -- D : Duration; -- Delay
3621 -- M : Integer; -- Delay Mode
3622 -- C : out Prim_Op_Kind; -- Call kind
3623 -- F : out Boolean; -- Status flag
3625 Append_List_To
(Params
, New_List
(
3627 Make_Parameter_Specification
(Loc
,
3628 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uT
),
3629 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
),
3631 Out_Present
=> True),
3633 Make_Parameter_Specification
(Loc
,
3634 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uS
),
3635 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3637 Make_Parameter_Specification
(Loc
,
3638 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
3639 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
3641 Make_Parameter_Specification
(Loc
,
3642 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uD
),
3643 Parameter_Type
=> New_Occurrence_Of
(Standard_Duration
, Loc
)),
3645 Make_Parameter_Specification
(Loc
,
3646 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uM
),
3647 Parameter_Type
=> New_Occurrence_Of
(Standard_Integer
, Loc
)),
3649 Make_Parameter_Specification
(Loc
,
3650 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uC
),
3652 New_Occurrence_Of
(RTE
(RE_Prim_Op_Kind
), Loc
),
3653 Out_Present
=> True)));
3656 Make_Parameter_Specification
(Loc
,
3657 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uF
),
3658 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3659 Out_Present
=> True));
3662 Make_Procedure_Specification
(Loc
,
3663 Defining_Unit_Name
=> Def_Id
,
3664 Parameter_Specifications
=> Params
);
3665 end Make_Disp_Timed_Select_Spec
;
3671 -- The frontend supports two models for expanding dispatch tables
3672 -- associated with library-level defined tagged types: statically and
3673 -- non-statically allocated dispatch tables. In the former case the object
3674 -- containing the dispatch table is constant and it is initialized by means
3675 -- of a positional aggregate. In the latter case, the object containing
3676 -- the dispatch table is a variable which is initialized by means of
3679 -- In case of locally defined tagged types, the object containing the
3680 -- object containing the dispatch table is always a variable (instead of a
3681 -- constant). This is currently required to give support to late overriding
3682 -- of primitives. For example:
3684 -- procedure Example is
3686 -- type T1 is tagged null record;
3687 -- procedure Prim (O : T1);
3690 -- type T2 is new Pkg.T1 with null record;
3691 -- procedure Prim (X : T2) is -- late overriding
3697 -- WARNING: This routine manages Ghost regions. Return statements must be
3698 -- replaced by gotos which jump to the end of the routine and restore the
3701 function Make_DT
(Typ
: Entity_Id
; N
: Node_Id
:= Empty
) return List_Id
is
3702 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3704 Max_Predef_Prims
: constant Int
:=
3708 (Parent
(RTE
(RE_Max_Predef_Prims
)))));
3710 DT_Decl
: constant Elist_Id
:= New_Elmt_List
;
3711 DT_Aggr
: constant Elist_Id
:= New_Elmt_List
;
3712 -- Entities marked with attribute Is_Dispatch_Table_Entity
3714 Dummy_Object
: Entity_Id
:= Empty
;
3715 -- Extra nonexistent object of type Typ internally used to compute the
3716 -- offset to the components that reference secondary dispatch tables.
3717 -- Used to statically allocate secondary dispatch tables.
3719 procedure Check_Premature_Freezing
3721 Tagged_Type
: Entity_Id
;
3723 -- Verify that all untagged types in the profile of a subprogram are
3724 -- frozen at the point the subprogram is frozen. This enforces the rule
3725 -- on RM 13.14 (14) as modified by AI05-019. At the point a subprogram
3726 -- is frozen, enough must be known about it to build the activation
3727 -- record for it, which requires at least that the size of all
3728 -- parameters be known. Controlling arguments are by-reference,
3729 -- and therefore the rule only applies to untagged types. Typical
3730 -- violation of the rule involves an object declaration that freezes a
3731 -- tagged type, when one of its primitive operations has a type in its
3732 -- profile whose full view has not been analyzed yet. More complex cases
3733 -- involve composite types that have one private unfrozen subcomponent.
3735 procedure Export_DT
(Typ
: Entity_Id
; DT
: Entity_Id
; Index
: Nat
:= 0);
3736 -- Export the dispatch table DT of tagged type Typ. Required to generate
3737 -- forward references and statically allocate the table. For primary
3738 -- dispatch tables Index is 0; for secondary dispatch tables the value
3739 -- of index must match the Suffix_Index value assigned to the table by
3740 -- Make_Tags when generating its unique external name, and it is used to
3741 -- retrieve from the Dispatch_Table_Wrappers list associated with Typ
3742 -- the external name generated by Import_DT.
3744 procedure Make_Secondary_DT
3747 Iface_Comp
: Node_Id
;
3749 Num_Iface_Prims
: Nat
;
3750 Iface_DT_Ptr
: Entity_Id
;
3751 Predef_Prims_Ptr
: Entity_Id
;
3752 Build_Thunks
: Boolean;
3754 -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch
3755 -- Table of Typ associated with Iface. Each abstract interface of Typ
3756 -- has two secondary dispatch tables: one containing pointers to thunks
3757 -- and another containing pointers to the primitives covering the
3758 -- interface primitives. The former secondary table is generated when
3759 -- Build_Thunks is True, and provides common support for dispatching
3760 -- calls through interface types; the latter secondary table is
3761 -- generated when Build_Thunks is False, and provides support for
3762 -- Generic Dispatching Constructors that dispatch calls through
3763 -- interface types. When constructing this latter table the value of
3764 -- Suffix_Index is -1 to indicate that there is no need to export such
3765 -- table when building statically allocated dispatch tables; a positive
3766 -- value of Suffix_Index must match the Suffix_Index value assigned to
3767 -- this secondary dispatch table by Make_Tags when its unique external
3768 -- name was generated.
3770 ------------------------------
3771 -- Check_Premature_Freezing --
3772 ------------------------------
3774 procedure Check_Premature_Freezing
3776 Tagged_Type
: Entity_Id
;
3781 function Is_Actual_For_Formal_Incomplete_Type
3782 (T
: Entity_Id
) return Boolean;
3783 -- In Ada 2012, if a nested generic has an incomplete formal type,
3784 -- the actual may be (and usually is) a private type whose completion
3785 -- appears later. It is safe to build the dispatch table in this
3786 -- case, gigi will have full views available.
3788 ------------------------------------------
3789 -- Is_Actual_For_Formal_Incomplete_Type --
3790 ------------------------------------------
3792 function Is_Actual_For_Formal_Incomplete_Type
3793 (T
: Entity_Id
) return Boolean
3795 Gen_Par
: Entity_Id
;
3799 if not Is_Generic_Instance
(Current_Scope
)
3800 or else not Used_As_Generic_Actual
(T
)
3804 Gen_Par
:= Generic_Parent
(Parent
(Current_Scope
));
3809 (Generic_Formal_Declarations
3810 (Unit_Declaration_Node
(Gen_Par
)));
3811 while Present
(F
) loop
3812 if Ekind
(Defining_Identifier
(F
)) = E_Incomplete_Type
then
3820 end Is_Actual_For_Formal_Incomplete_Type
;
3822 -- Start of processing for Check_Premature_Freezing
3825 -- Note that if the type is a (subtype of) a generic actual, the
3826 -- actual will have been frozen by the instantiation.
3829 and then Is_Private_Type
(Typ
)
3830 and then No
(Full_View
(Typ
))
3831 and then not Is_Generic_Type
(Typ
)
3832 and then not Is_Tagged_Type
(Typ
)
3833 and then not Is_Frozen
(Typ
)
3834 and then not Is_Generic_Actual_Type
(Typ
)
3836 Error_Msg_Sloc
:= Sloc
(Subp
);
3838 ("declaration must appear after completion of type &", N
, Typ
);
3840 ("\which is an untagged type in the profile of "
3841 & "primitive operation & declared#", N
, Subp
);
3844 Comp
:= Private_Component
(Typ
);
3846 if not Is_Tagged_Type
(Typ
)
3847 and then Present
(Comp
)
3848 and then not Is_Frozen
(Comp
)
3849 and then not Is_Actual_For_Formal_Incomplete_Type
(Comp
)
3851 Error_Msg_Sloc
:= Sloc
(Subp
);
3852 Error_Msg_Node_2
:= Subp
;
3853 Error_Msg_Name_1
:= Chars
(Tagged_Type
);
3855 ("declaration must appear after completion of type &",
3858 ("\which is a component of untagged type& in the profile "
3859 & "of primitive & of type % that is frozen by the "
3860 & "declaration ", N
, Typ
);
3863 end Check_Premature_Freezing
;
3869 procedure Export_DT
(Typ
: Entity_Id
; DT
: Entity_Id
; Index
: Nat
:= 0)
3875 Set_Is_Statically_Allocated
(DT
);
3876 Set_Is_True_Constant
(DT
);
3877 Set_Is_Exported
(DT
);
3880 Elmt
:= First_Elmt
(Dispatch_Table_Wrappers
(Typ
));
3881 while Count
/= Index
loop
3886 pragma Assert
(Related_Type
(Node
(Elmt
)) = Typ
);
3888 Get_External_Name
(Node
(Elmt
));
3889 Set_Interface_Name
(DT
,
3890 Make_String_Literal
(Loc
,
3891 Strval
=> String_From_Name_Buffer
));
3893 -- Ensure proper Sprint output of this implicit importation
3895 Set_Is_Internal
(DT
);
3899 -----------------------
3900 -- Make_Secondary_DT --
3901 -----------------------
3903 procedure Make_Secondary_DT
3906 Iface_Comp
: Node_Id
;
3908 Num_Iface_Prims
: Nat
;
3909 Iface_DT_Ptr
: Entity_Id
;
3910 Predef_Prims_Ptr
: Entity_Id
;
3911 Build_Thunks
: Boolean;
3914 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3915 Exporting_Table
: constant Boolean :=
3916 Building_Static_DT
(Typ
)
3917 and then Suffix_Index
> 0;
3918 Iface_DT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
3919 Predef_Prims
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
3920 DT_Constr_List
: List_Id
;
3921 DT_Aggr_List
: List_Id
;
3922 Empty_DT
: Boolean := False;
3923 Nb_Predef_Prims
: Nat
:= 0;
3927 OSD_Aggr_List
: List_Id
;
3930 Prim_Elmt
: Elmt_Id
;
3931 Prim_Ops_Aggr_List
: List_Id
;
3934 -- Handle cases in which we do not generate statically allocated
3937 if not Building_Static_DT
(Typ
) then
3938 Set_Ekind
(Predef_Prims
, E_Variable
);
3939 Set_Ekind
(Iface_DT
, E_Variable
);
3941 -- Statically allocated dispatch tables and related entities are
3945 Set_Ekind
(Predef_Prims
, E_Constant
);
3946 Set_Is_Statically_Allocated
(Predef_Prims
);
3947 Set_Is_True_Constant
(Predef_Prims
);
3949 Set_Ekind
(Iface_DT
, E_Constant
);
3950 Set_Is_Statically_Allocated
(Iface_DT
);
3951 Set_Is_True_Constant
(Iface_DT
);
3954 -- Calculate the number of slots of the dispatch table. If the number
3955 -- of primitives of Typ is 0 we reserve a dummy single entry for its
3956 -- DT because at run time the pointer to this dummy entry will be
3959 if Num_Iface_Prims
= 0 then
3963 Nb_Prim
:= Num_Iface_Prims
;
3968 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
3969 -- (predef-prim-op-thunk-1'address,
3970 -- predef-prim-op-thunk-2'address,
3972 -- predef-prim-op-thunk-n'address);
3973 -- for Predef_Prims'Alignment use Address'Alignment
3975 -- Stage 1: Calculate the number of predefined primitives
3977 if not Building_Static_DT
(Typ
) then
3978 Nb_Predef_Prims
:= Max_Predef_Prims
;
3980 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
3981 while Present
(Prim_Elmt
) loop
3982 Prim
:= Node
(Prim_Elmt
);
3984 if Is_Predefined_Dispatching_Operation
(Prim
)
3985 and then not Is_Abstract_Subprogram
(Prim
)
3987 Pos
:= UI_To_Int
(DT_Position
(Prim
));
3989 if Pos
> Nb_Predef_Prims
then
3990 Nb_Predef_Prims
:= Pos
;
3994 Next_Elmt
(Prim_Elmt
);
3998 if Generate_SCIL
then
3999 Nb_Predef_Prims
:= 0;
4002 -- Stage 2: Create the thunks associated with the predefined
4003 -- primitives and save their entity to fill the aggregate.
4006 Prim_Table
: array (Nat
range 1 .. Nb_Predef_Prims
) of Entity_Id
;
4008 Thunk_Id
: Entity_Id
;
4009 Thunk_Code
: Node_Id
;
4012 Prim_Ops_Aggr_List
:= New_List
;
4013 Prim_Table
:= (others => Empty
);
4015 if Building_Static_DT
(Typ
) then
4016 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4017 while Present
(Prim_Elmt
) loop
4018 Prim
:= Node
(Prim_Elmt
);
4020 if Is_Predefined_Dispatching_Operation
(Prim
)
4021 and then not Is_Abstract_Subprogram
(Prim
)
4022 and then not Is_Eliminated
(Prim
)
4023 and then not Generate_SCIL
4024 and then not Present
(Prim_Table
4025 (UI_To_Int
(DT_Position
(Prim
))))
4027 if not Build_Thunks
then
4028 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) :=
4032 Expand_Interface_Thunk
4033 (Ultimate_Alias
(Prim
), Thunk_Id
, Thunk_Code
);
4035 if Present
(Thunk_Id
) then
4036 Append_To
(Result
, Thunk_Code
);
4037 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) :=
4043 Next_Elmt
(Prim_Elmt
);
4047 for J
in Prim_Table
'Range loop
4048 if Present
(Prim_Table
(J
)) then
4050 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
4051 Make_Attribute_Reference
(Loc
,
4052 Prefix
=> New_Occurrence_Of
(Prim_Table
(J
), Loc
),
4053 Attribute_Name
=> Name_Unrestricted_Access
));
4055 New_Node
:= Make_Null
(Loc
);
4058 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
4062 Make_Aggregate
(Loc
, Expressions
=> Prim_Ops_Aggr_List
);
4064 -- Remember aggregates initializing dispatch tables
4066 Append_Elmt
(New_Node
, DT_Aggr
);
4069 Make_Subtype_Declaration
(Loc
,
4070 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
4071 Subtype_Indication
=>
4072 New_Occurrence_Of
(RTE
(RE_Address_Array
), Loc
));
4074 Append_To
(Result
, Decl
);
4077 Make_Object_Declaration
(Loc
,
4078 Defining_Identifier
=> Predef_Prims
,
4079 Constant_Present
=> Building_Static_DT
(Typ
),
4080 Aliased_Present
=> True,
4081 Object_Definition
=> New_Occurrence_Of
4082 (Defining_Identifier
(Decl
), Loc
),
4083 Expression
=> New_Node
));
4086 Make_Attribute_Definition_Clause
(Loc
,
4087 Name
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
4088 Chars
=> Name_Alignment
,
4090 Make_Attribute_Reference
(Loc
,
4092 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4093 Attribute_Name
=> Name_Alignment
)));
4098 -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
4099 -- (OSD_Table => (1 => <value>,
4103 -- Iface_DT : Dispatch_Table (Nb_Prims) :=
4104 -- ([ Signature => <sig-value> ],
4105 -- Tag_Kind => <tag_kind-value>,
4106 -- Predef_Prims => Predef_Prims'Address,
4107 -- Offset_To_Top => 0,
4108 -- OSD => OSD'Address,
4109 -- Prims_Ptr => (prim-op-1'address,
4110 -- prim-op-2'address,
4112 -- prim-op-n'address));
4113 -- for Iface_DT'Alignment use Address'Alignment;
4115 -- Stage 3: Initialize the discriminant and the record components
4117 DT_Constr_List
:= New_List
;
4118 DT_Aggr_List
:= New_List
;
4122 Append_To
(DT_Constr_List
, Make_Integer_Literal
(Loc
, Nb_Prim
));
4123 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, Nb_Prim
));
4127 if RTE_Record_Component_Available
(RE_Signature
) then
4128 Append_To
(DT_Aggr_List
,
4129 New_Occurrence_Of
(RTE
(RE_Secondary_DT
), Loc
));
4134 if RTE_Record_Component_Available
(RE_Tag_Kind
) then
4135 Append_To
(DT_Aggr_List
, Tagged_Kind
(Typ
));
4140 Append_To
(DT_Aggr_List
,
4141 Make_Attribute_Reference
(Loc
,
4142 Prefix
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
4143 Attribute_Name
=> Name_Address
));
4145 -- If the location of the component that references this secondary
4146 -- dispatch table is variable then we have not declared the internal
4147 -- dummy object; the value of Offset_To_Top will be set by the init
4150 if No
(Dummy_Object
) then
4151 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
4154 Append_To
(DT_Aggr_List
,
4156 Make_Attribute_Reference
(Loc
,
4158 Make_Selected_Component
(Loc
,
4160 New_Occurrence_Of
(Dummy_Object
, Loc
),
4162 New_Occurrence_Of
(Iface_Comp
, Loc
)),
4163 Attribute_Name
=> Name_Position
)));
4166 -- Generate the Object Specific Data table required to dispatch calls
4167 -- through synchronized interfaces.
4170 or else Is_Abstract_Type
(Typ
)
4171 or else Is_Controlled
(Typ
)
4172 or else Restriction_Active
(No_Dispatching_Calls
)
4173 or else not Is_Limited_Type
(Typ
)
4174 or else not Has_Interfaces
(Typ
)
4175 or else not Build_Thunks
4176 or else not RTE_Record_Component_Available
(RE_OSD_Table
)
4178 -- No OSD table required
4180 Append_To
(DT_Aggr_List
,
4181 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
4184 OSD_Aggr_List
:= New_List
;
4187 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
4189 Prim_Alias
: Entity_Id
;
4190 Prim_Elmt
: Elmt_Id
;
4196 Prim_Table
:= (others => Empty
);
4197 Prim_Alias
:= Empty
;
4199 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4200 while Present
(Prim_Elmt
) loop
4201 Prim
:= Node
(Prim_Elmt
);
4203 if Present
(Interface_Alias
(Prim
))
4204 and then Find_Dispatching_Type
4205 (Interface_Alias
(Prim
)) = Iface
4207 Prim_Alias
:= Interface_Alias
(Prim
);
4208 E
:= Ultimate_Alias
(Prim
);
4209 Pos
:= UI_To_Int
(DT_Position
(Prim_Alias
));
4211 if Present
(Prim_Table
(Pos
)) then
4212 pragma Assert
(Prim_Table
(Pos
) = E
);
4216 Prim_Table
(Pos
) := E
;
4218 Append_To
(OSD_Aggr_List
,
4219 Make_Component_Association
(Loc
,
4220 Choices
=> New_List
(
4221 Make_Integer_Literal
(Loc
,
4222 DT_Position
(Prim_Alias
))),
4224 Make_Integer_Literal
(Loc
,
4225 DT_Position
(Alias
(Prim
)))));
4231 Next_Elmt
(Prim_Elmt
);
4233 pragma Assert
(Count
= Nb_Prim
);
4236 OSD
:= Make_Temporary
(Loc
, 'I');
4239 Make_Object_Declaration
(Loc
,
4240 Defining_Identifier
=> OSD
,
4241 Object_Definition
=>
4242 Make_Subtype_Indication
(Loc
,
4244 New_Occurrence_Of
(RTE
(RE_Object_Specific_Data
), Loc
),
4246 Make_Index_Or_Discriminant_Constraint
(Loc
,
4247 Constraints
=> New_List
(
4248 Make_Integer_Literal
(Loc
, Nb_Prim
)))),
4251 Make_Aggregate
(Loc
,
4252 Component_Associations
=> New_List
(
4253 Make_Component_Association
(Loc
,
4254 Choices
=> New_List
(
4256 (RTE_Record_Component
(RE_OSD_Num_Prims
), Loc
)),
4258 Make_Integer_Literal
(Loc
, Nb_Prim
)),
4260 Make_Component_Association
(Loc
,
4261 Choices
=> New_List
(
4263 (RTE_Record_Component
(RE_OSD_Table
), Loc
)),
4264 Expression
=> Make_Aggregate
(Loc
,
4265 Component_Associations
=> OSD_Aggr_List
))))));
4268 Make_Attribute_Definition_Clause
(Loc
,
4269 Name
=> New_Occurrence_Of
(OSD
, Loc
),
4270 Chars
=> Name_Alignment
,
4272 Make_Attribute_Reference
(Loc
,
4274 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4275 Attribute_Name
=> Name_Alignment
)));
4277 -- In secondary dispatch tables the Typeinfo component contains
4278 -- the address of the Object Specific Data (see a-tags.ads)
4280 Append_To
(DT_Aggr_List
,
4281 Make_Attribute_Reference
(Loc
,
4282 Prefix
=> New_Occurrence_Of
(OSD
, Loc
),
4283 Attribute_Name
=> Name_Address
));
4286 -- Initialize the table of primitive operations
4288 Prim_Ops_Aggr_List
:= New_List
;
4291 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
4293 elsif Is_Abstract_Type
(Typ
)
4294 or else not Building_Static_DT
(Typ
)
4296 for J
in 1 .. Nb_Prim
loop
4297 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
4302 CPP_Nb_Prims
: constant Nat
:= CPP_Num_Prims
(Typ
);
4305 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
4306 Thunk_Code
: Node_Id
;
4307 Thunk_Id
: Entity_Id
;
4310 Prim_Table
:= (others => Empty
);
4312 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4313 while Present
(Prim_Elmt
) loop
4314 Prim
:= Node
(Prim_Elmt
);
4315 E
:= Ultimate_Alias
(Prim
);
4316 Prim_Pos
:= UI_To_Int
(DT_Position
(E
));
4318 -- Do not reference predefined primitives because they are
4319 -- located in a separate dispatch table; skip abstract and
4320 -- eliminated primitives; skip primitives located in the C++
4321 -- part of the dispatch table because their slot is set by
4324 if not Is_Predefined_Dispatching_Operation
(Prim
)
4325 and then Present
(Interface_Alias
(Prim
))
4326 and then not Is_Abstract_Subprogram
(Alias
(Prim
))
4327 and then not Is_Eliminated
(Alias
(Prim
))
4328 and then (not Is_CPP_Class
(Root_Type
(Typ
))
4329 or else Prim_Pos
> CPP_Nb_Prims
)
4330 and then Find_Dispatching_Type
4331 (Interface_Alias
(Prim
)) = Iface
4333 -- Generate the code of the thunk only if the abstract
4334 -- interface type is not an immediate ancestor of
4335 -- Tagged_Type. Otherwise the DT associated with the
4336 -- interface is the primary DT.
4338 and then not Is_Ancestor
(Iface
, Typ
,
4339 Use_Full_View
=> True)
4341 if not Build_Thunks
then
4343 UI_To_Int
(DT_Position
(Interface_Alias
(Prim
)));
4344 Prim_Table
(Prim_Pos
) := Alias
(Prim
);
4347 Expand_Interface_Thunk
(Prim
, Thunk_Id
, Thunk_Code
);
4349 if Present
(Thunk_Id
) then
4351 UI_To_Int
(DT_Position
(Interface_Alias
(Prim
)));
4353 Prim_Table
(Prim_Pos
) := Thunk_Id
;
4354 Append_To
(Result
, Thunk_Code
);
4359 Next_Elmt
(Prim_Elmt
);
4362 for J
in Prim_Table
'Range loop
4363 if Present
(Prim_Table
(J
)) then
4365 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
4366 Make_Attribute_Reference
(Loc
,
4367 Prefix
=> New_Occurrence_Of
(Prim_Table
(J
), Loc
),
4368 Attribute_Name
=> Name_Unrestricted_Access
));
4371 New_Node
:= Make_Null
(Loc
);
4374 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
4380 Make_Aggregate
(Loc
,
4381 Expressions
=> Prim_Ops_Aggr_List
);
4383 Append_To
(DT_Aggr_List
, New_Node
);
4385 -- Remember aggregates initializing dispatch tables
4387 Append_Elmt
(New_Node
, DT_Aggr
);
4389 -- Note: Secondary dispatch tables are declared constant only if
4390 -- we can compute their offset field by means of the extra dummy
4391 -- object; otherwise they cannot be declared constant and the
4392 -- Offset_To_Top component is initialized by the IP routine.
4395 Make_Object_Declaration
(Loc
,
4396 Defining_Identifier
=> Iface_DT
,
4397 Aliased_Present
=> True,
4398 Constant_Present
=> Present
(Dummy_Object
),
4400 Object_Definition
=>
4401 Make_Subtype_Indication
(Loc
,
4402 Subtype_Mark
=> New_Occurrence_Of
4403 (RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
4404 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
4405 Constraints
=> DT_Constr_List
)),
4408 Make_Aggregate
(Loc
,
4409 Expressions
=> DT_Aggr_List
)));
4412 Make_Attribute_Definition_Clause
(Loc
,
4413 Name
=> New_Occurrence_Of
(Iface_DT
, Loc
),
4414 Chars
=> Name_Alignment
,
4417 Make_Attribute_Reference
(Loc
,
4419 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4420 Attribute_Name
=> Name_Alignment
)));
4422 if Exporting_Table
then
4423 Export_DT
(Typ
, Iface_DT
, Suffix_Index
);
4425 -- Generate code to create the pointer to the dispatch table
4427 -- Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address);
4429 -- Note: This declaration is not added here if the table is exported
4430 -- because in such case Make_Tags has already added this declaration.
4434 Make_Object_Declaration
(Loc
,
4435 Defining_Identifier
=> Iface_DT_Ptr
,
4436 Constant_Present
=> True,
4438 Object_Definition
=>
4439 New_Occurrence_Of
(RTE
(RE_Interface_Tag
), Loc
),
4442 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
4443 Make_Attribute_Reference
(Loc
,
4445 Make_Selected_Component
(Loc
,
4446 Prefix
=> New_Occurrence_Of
(Iface_DT
, Loc
),
4449 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
4450 Attribute_Name
=> Name_Address
))));
4454 Make_Object_Declaration
(Loc
,
4455 Defining_Identifier
=> Predef_Prims_Ptr
,
4456 Constant_Present
=> True,
4458 Object_Definition
=>
4459 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
4462 Make_Attribute_Reference
(Loc
,
4464 Make_Selected_Component
(Loc
,
4465 Prefix
=> New_Occurrence_Of
(Iface_DT
, Loc
),
4468 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
4469 Attribute_Name
=> Name_Address
)));
4471 -- Remember entities containing dispatch tables
4473 Append_Elmt
(Predef_Prims
, DT_Decl
);
4474 Append_Elmt
(Iface_DT
, DT_Decl
);
4475 end Make_Secondary_DT
;
4479 Elab_Code
: constant List_Id
:= New_List
;
4480 Result
: constant List_Id
:= New_List
;
4481 Tname
: constant Name_Id
:= Chars
(Typ
);
4483 -- When pragmas Discard_Names and No_Tagged_Streams simultaneously apply
4484 -- we initialize the Expanded_Name and the External_Tag of this tagged
4485 -- type with an empty string. This is useful to avoid exposing entity
4486 -- names at binary level. It can be done when both pragmas apply because
4487 -- (1) Discard_Names allows initializing Expanded_Name with an
4488 -- implementation defined value (Ada RM Section C.5 (7/2)).
4489 -- (2) External_Tag (combined with Internal_Tag) is used for object
4490 -- streaming and No_Tagged_Streams inhibits the generation of
4493 Discard_Names
: constant Boolean :=
4494 Present
(No_Tagged_Streams_Pragma
(Typ
))
4495 and then (Global_Discard_Names
4496 or else Einfo
.Discard_Names
(Typ
));
4498 -- The following name entries are used by Make_DT to generate a number
4499 -- of entities related to a tagged type. These entities may be generated
4500 -- in a scope other than that of the tagged type declaration, and if
4501 -- the entities for two tagged types with the same name happen to be
4502 -- generated in the same scope, we have to take care to use different
4503 -- names. This is achieved by means of a unique serial number appended
4504 -- to each generated entity name.
4506 Name_DT
: constant Name_Id
:=
4507 New_External_Name
(Tname
, 'T', Suffix_Index
=> -1);
4508 Name_Exname
: constant Name_Id
:=
4509 New_External_Name
(Tname
, 'E', Suffix_Index
=> -1);
4510 Name_HT_Link
: constant Name_Id
:=
4511 New_External_Name
(Tname
, 'H', Suffix_Index
=> -1);
4512 Name_Predef_Prims
: constant Name_Id
:=
4513 New_External_Name
(Tname
, 'R', Suffix_Index
=> -1);
4514 Name_SSD
: constant Name_Id
:=
4515 New_External_Name
(Tname
, 'S', Suffix_Index
=> -1);
4516 Name_TSD
: constant Name_Id
:=
4517 New_External_Name
(Tname
, 'B', Suffix_Index
=> -1);
4519 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
4520 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
4521 -- Save the Ghost-related attributes to restore on exit
4524 AI_Tag_Elmt
: Elmt_Id
;
4525 AI_Tag_Comp
: Elmt_Id
;
4527 DT_Aggr_List
: List_Id
;
4528 DT_Constr_List
: List_Id
;
4531 HT_Link
: Entity_Id
;
4534 Iface_Table_Node
: Node_Id
;
4535 Name_ITable
: Name_Id
;
4536 Nb_Predef_Prims
: Nat
:= 0;
4539 Num_Ifaces
: Nat
:= 0;
4540 Parent_Typ
: Entity_Id
;
4541 Predef_Prims
: Entity_Id
;
4543 Prim_Elmt
: Elmt_Id
;
4544 Prim_Ops_Aggr_List
: List_Id
;
4547 Typ_Comps
: Elist_Id
;
4548 Typ_Ifaces
: Elist_Id
;
4550 TSD_Aggr_List
: List_Id
;
4551 TSD_Tags_List
: List_Id
;
4553 -- Start of processing for Make_DT
4556 pragma Assert
(Is_Frozen
(Typ
));
4558 -- The tagged type being processed may be subject to pragma Ghost. Set
4559 -- the mode now to ensure that any nodes generated during dispatch table
4560 -- creation are properly marked as Ghost.
4562 Set_Ghost_Mode
(Typ
);
4564 -- Handle cases in which there is no need to build the dispatch table
4566 if Has_Dispatch_Table
(Typ
)
4567 or else No
(Access_Disp_Table
(Typ
))
4568 or else Is_CPP_Class
(Typ
)
4572 elsif No_Run_Time_Mode
then
4573 Error_Msg_CRT
("tagged types", Typ
);
4576 elsif not RTE_Available
(RE_Tag
) then
4578 Make_Object_Declaration
(Loc
,
4579 Defining_Identifier
=>
4580 Node
(First_Elmt
(Access_Disp_Table
(Typ
))),
4581 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
4582 Constant_Present
=> True,
4584 Unchecked_Convert_To
(RTE
(RE_Tag
),
4585 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
4587 Analyze_List
(Result
, Suppress
=> All_Checks
);
4588 Error_Msg_CRT
("tagged types", Typ
);
4592 -- Ensure that the value of Max_Predef_Prims defined in a-tags is
4593 -- correct. Valid values are 9 under configurable runtime or 15
4594 -- with full runtime.
4596 if RTE_Available
(RE_Interface_Data
) then
4597 if Max_Predef_Prims
/= 15 then
4598 Error_Msg_N
("run-time library configuration error", Typ
);
4602 if Max_Predef_Prims
/= 9 then
4603 Error_Msg_N
("run-time library configuration error", Typ
);
4604 Error_Msg_CRT
("tagged types", Typ
);
4609 DT
:= Make_Defining_Identifier
(Loc
, Name_DT
);
4610 Exname
:= Make_Defining_Identifier
(Loc
, Name_Exname
);
4611 HT_Link
:= Make_Defining_Identifier
(Loc
, Name_HT_Link
);
4612 Predef_Prims
:= Make_Defining_Identifier
(Loc
, Name_Predef_Prims
);
4613 SSD
:= Make_Defining_Identifier
(Loc
, Name_SSD
);
4614 TSD
:= Make_Defining_Identifier
(Loc
, Name_TSD
);
4616 -- Initialize Parent_Typ handling private types
4618 Parent_Typ
:= Etype
(Typ
);
4620 if Present
(Full_View
(Parent_Typ
)) then
4621 Parent_Typ
:= Full_View
(Parent_Typ
);
4624 -- Ensure that all the primitives are frozen. This is only required when
4625 -- building static dispatch tables --- the primitives must be frozen to
4626 -- be referenced (otherwise we have problems with the backend). It is
4627 -- not a requirement with nonstatic dispatch tables because in this case
4628 -- we generate now an empty dispatch table; the extra code required to
4629 -- register the primitives in the slots will be generated later --- when
4630 -- each primitive is frozen (see Freeze_Subprogram).
4632 if Building_Static_DT
(Typ
) then
4634 Saved_FLLTT
: constant Boolean :=
4635 Freezing_Library_Level_Tagged_Type
;
4640 Prim_Elmt
: Elmt_Id
;
4643 Freezing_Library_Level_Tagged_Type
:= True;
4645 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4646 while Present
(Prim_Elmt
) loop
4647 Prim
:= Node
(Prim_Elmt
);
4648 Frnodes
:= Freeze_Entity
(Prim
, Typ
);
4650 -- We disable this check for abstract subprograms, given that
4651 -- they cannot be called directly and thus the state of their
4652 -- untagged formals is of no concern. The RM is unclear in any
4653 -- case concerning the need for this check, and this topic may
4654 -- go back to the ARG.
4656 if not Is_Abstract_Subprogram
(Prim
) then
4657 Formal
:= First_Formal
(Prim
);
4658 while Present
(Formal
) loop
4659 Check_Premature_Freezing
(Prim
, Typ
, Etype
(Formal
));
4660 Next_Formal
(Formal
);
4663 Check_Premature_Freezing
(Prim
, Typ
, Etype
(Prim
));
4666 if Present
(Frnodes
) then
4667 Append_List_To
(Result
, Frnodes
);
4670 Next_Elmt
(Prim_Elmt
);
4673 Freezing_Library_Level_Tagged_Type
:= Saved_FLLTT
;
4677 if Building_Static_Secondary_DT
(Typ
) then
4679 Cannot_Have_Null_Disc
: Boolean := False;
4680 Name_Dummy_Object
: constant Name_Id
:=
4681 New_External_Name
(Tname
,
4682 'P', Suffix_Index
=> -1);
4684 Dummy_Object
:= Make_Defining_Identifier
(Loc
, Name_Dummy_Object
);
4686 -- Define the extra object imported and constant to avoid linker
4687 -- errors (since this object is never declared). Required because
4688 -- we implement RM 13.3(19) for exported and imported (variable)
4689 -- objects by making them volatile.
4691 Set_Is_Imported
(Dummy_Object
);
4692 Set_Ekind
(Dummy_Object
, E_Constant
);
4693 Set_Is_True_Constant
(Dummy_Object
);
4694 Set_Related_Type
(Dummy_Object
, Typ
);
4696 -- The scope must be set now to call Get_External_Name
4698 Set_Scope
(Dummy_Object
, Current_Scope
);
4700 Get_External_Name
(Dummy_Object
);
4701 Set_Interface_Name
(Dummy_Object
,
4702 Make_String_Literal
(Loc
, Strval
=> String_From_Name_Buffer
));
4704 -- Ensure proper Sprint output of this implicit importation
4706 Set_Is_Internal
(Dummy_Object
);
4708 if not Has_Discriminants
(Typ
) then
4710 Make_Object_Declaration
(Loc
,
4711 Defining_Identifier
=> Dummy_Object
,
4712 Constant_Present
=> True,
4713 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)));
4716 Constr_List
: constant List_Id
:= New_List
;
4720 Discrim
:= First_Discriminant
(Typ
);
4721 while Present
(Discrim
) loop
4722 if Is_Discrete_Type
(Etype
(Discrim
)) then
4723 Append_To
(Constr_List
,
4724 Make_Attribute_Reference
(Loc
,
4726 New_Occurrence_Of
(Etype
(Discrim
), Loc
),
4727 Attribute_Name
=> Name_First
));
4730 pragma Assert
(Is_Access_Type
(Etype
(Discrim
)));
4731 Cannot_Have_Null_Disc
:=
4732 Cannot_Have_Null_Disc
4733 or else Can_Never_Be_Null
(Etype
(Discrim
));
4734 Append_To
(Constr_List
, Make_Null
(Loc
));
4737 Next_Discriminant
(Discrim
);
4741 Make_Object_Declaration
(Loc
,
4742 Defining_Identifier
=> Dummy_Object
,
4743 Constant_Present
=> True,
4744 Object_Definition
=>
4745 Make_Subtype_Indication
(Loc
,
4746 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
4748 Make_Index_Or_Discriminant_Constraint
(Loc
,
4749 Constraints
=> Constr_List
))));
4753 -- Given that the dummy object will not be declared at run time,
4754 -- analyze its declaration with expansion disabled and warnings
4755 -- and error messages ignored.
4757 Expander_Mode_Save_And_Set
(False);
4758 Ignore_Errors_Enable
:= Ignore_Errors_Enable
+ 1;
4759 Analyze
(Last
(Result
), Suppress
=> All_Checks
);
4760 Ignore_Errors_Enable
:= Ignore_Errors_Enable
- 1;
4761 Expander_Mode_Restore
;
4765 -- Ada 2005 (AI-251): Build the secondary dispatch tables
4767 if Has_Interfaces
(Typ
) then
4768 Collect_Interface_Components
(Typ
, Typ_Comps
);
4770 -- Each secondary dispatch table is assigned an unique positive
4771 -- suffix index; such value also corresponds with the location of
4772 -- its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
4774 -- Note: This value must be kept sync with the Suffix_Index values
4775 -- generated by Make_Tags
4779 Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
4781 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
4782 while Present
(AI_Tag_Comp
) loop
4783 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'P'));
4785 -- Build the secondary table containing pointers to thunks
4790 Base_Type
(Related_Type
(Node
(AI_Tag_Comp
))),
4791 Iface_Comp
=> Node
(AI_Tag_Comp
),
4792 Suffix_Index
=> Suffix_Index
,
4794 UI_To_Int
(DT_Entry_Count
(Node
(AI_Tag_Comp
))),
4795 Iface_DT_Ptr
=> Node
(AI_Tag_Elmt
),
4796 Predef_Prims_Ptr
=> Node
(Next_Elmt
(AI_Tag_Elmt
)),
4797 Build_Thunks
=> True,
4800 -- Skip secondary dispatch table referencing thunks to predefined
4803 Next_Elmt
(AI_Tag_Elmt
);
4804 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'Y'));
4806 -- Secondary dispatch table referencing user-defined primitives
4807 -- covered by this interface.
4809 Next_Elmt
(AI_Tag_Elmt
);
4810 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'D'));
4812 -- Build the secondary table containing pointers to primitives
4813 -- (used to give support to Generic Dispatching Constructors).
4818 (Related_Type
(Node
(AI_Tag_Comp
))),
4819 Iface_Comp
=> Node
(AI_Tag_Comp
),
4821 Num_Iface_Prims
=> UI_To_Int
4822 (DT_Entry_Count
(Node
(AI_Tag_Comp
))),
4823 Iface_DT_Ptr
=> Node
(AI_Tag_Elmt
),
4824 Predef_Prims_Ptr
=> Node
(Next_Elmt
(AI_Tag_Elmt
)),
4825 Build_Thunks
=> False,
4828 -- Skip secondary dispatch table referencing predefined primitives
4830 Next_Elmt
(AI_Tag_Elmt
);
4831 pragma Assert
(Has_Suffix
(Node
(AI_Tag_Elmt
), 'Z'));
4833 Suffix_Index
:= Suffix_Index
+ 1;
4834 Next_Elmt
(AI_Tag_Elmt
);
4835 Next_Elmt
(AI_Tag_Comp
);
4839 -- Get the _tag entity and number of primitives of its dispatch table
4841 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
4842 Nb_Prim
:= UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Typ
)));
4844 if Generate_SCIL
then
4848 Set_Is_Statically_Allocated
(DT
, Is_Library_Level_Tagged_Type
(Typ
));
4849 Set_Is_Statically_Allocated
(SSD
, Is_Library_Level_Tagged_Type
(Typ
));
4850 Set_Is_Statically_Allocated
(TSD
, Is_Library_Level_Tagged_Type
(Typ
));
4851 Set_Is_Statically_Allocated
(Predef_Prims
,
4852 Is_Library_Level_Tagged_Type
(Typ
));
4854 -- In case of locally defined tagged type we declare the object
4855 -- containing the dispatch table by means of a variable. Its
4856 -- initialization is done later by means of an assignment. This is
4857 -- required to generate its External_Tag.
4859 if not Building_Static_DT
(Typ
) then
4862 -- DT : No_Dispatch_Table_Wrapper;
4863 -- for DT'Alignment use Address'Alignment;
4864 -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
4866 if not Has_DT
(Typ
) then
4868 Make_Object_Declaration
(Loc
,
4869 Defining_Identifier
=> DT
,
4870 Aliased_Present
=> True,
4871 Constant_Present
=> False,
4872 Object_Definition
=>
4874 (RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
)));
4877 Make_Attribute_Definition_Clause
(Loc
,
4878 Name
=> New_Occurrence_Of
(DT
, Loc
),
4879 Chars
=> Name_Alignment
,
4881 Make_Attribute_Reference
(Loc
,
4883 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4884 Attribute_Name
=> Name_Alignment
)));
4887 Make_Object_Declaration
(Loc
,
4888 Defining_Identifier
=> DT_Ptr
,
4889 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
4890 Constant_Present
=> True,
4892 Unchecked_Convert_To
(RTE
(RE_Tag
),
4893 Make_Attribute_Reference
(Loc
,
4895 Make_Selected_Component
(Loc
,
4896 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
4899 (RTE_Record_Component
(RE_NDT_Prims_Ptr
), Loc
)),
4900 Attribute_Name
=> Name_Address
))));
4902 Set_Is_Statically_Allocated
(DT_Ptr
,
4903 Is_Library_Level_Tagged_Type
(Typ
));
4905 -- Generate the SCIL node for the previous object declaration
4906 -- because it has a tag initialization.
4908 if Generate_SCIL
then
4910 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
4911 Set_SCIL_Entity
(New_Node
, Typ
);
4912 Set_SCIL_Node
(Last
(Result
), New_Node
);
4916 -- Gnat2scil has its own implementation of dispatch tables,
4917 -- different than what is being implemented here. Generating
4918 -- further dispatch table initialization code would just
4919 -- cause gnat2scil to generate useless Scil which CodePeer
4920 -- would waste time and space analyzing, so we skip it.
4924 -- DT : Dispatch_Table_Wrapper (Nb_Prim);
4925 -- for DT'Alignment use Address'Alignment;
4926 -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
4929 -- If the tagged type has no primitives we add a dummy slot
4930 -- whose address will be the tag of this type.
4934 New_List
(Make_Integer_Literal
(Loc
, 1));
4937 New_List
(Make_Integer_Literal
(Loc
, Nb_Prim
));
4941 Make_Object_Declaration
(Loc
,
4942 Defining_Identifier
=> DT
,
4943 Aliased_Present
=> True,
4944 Constant_Present
=> False,
4945 Object_Definition
=>
4946 Make_Subtype_Indication
(Loc
,
4948 New_Occurrence_Of
(RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
4950 Make_Index_Or_Discriminant_Constraint
(Loc
,
4951 Constraints
=> DT_Constr_List
))));
4954 Make_Attribute_Definition_Clause
(Loc
,
4955 Name
=> New_Occurrence_Of
(DT
, Loc
),
4956 Chars
=> Name_Alignment
,
4958 Make_Attribute_Reference
(Loc
,
4960 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
4961 Attribute_Name
=> Name_Alignment
)));
4964 Make_Object_Declaration
(Loc
,
4965 Defining_Identifier
=> DT_Ptr
,
4966 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
4967 Constant_Present
=> True,
4969 Unchecked_Convert_To
(RTE
(RE_Tag
),
4970 Make_Attribute_Reference
(Loc
,
4972 Make_Selected_Component
(Loc
,
4973 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
4976 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
4977 Attribute_Name
=> Name_Address
))));
4979 Set_Is_Statically_Allocated
(DT_Ptr
,
4980 Is_Library_Level_Tagged_Type
(Typ
));
4982 -- Generate the SCIL node for the previous object declaration
4983 -- because it has a tag initialization.
4985 if Generate_SCIL
then
4987 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
4988 Set_SCIL_Entity
(New_Node
, Typ
);
4989 Set_SCIL_Node
(Last
(Result
), New_Node
);
4993 -- Gnat2scil has its own implementation of dispatch tables,
4994 -- different than what is being implemented here. Generating
4995 -- further dispatch table initialization code would just
4996 -- cause gnat2scil to generate useless Scil which CodePeer
4997 -- would waste time and space analyzing, so we skip it.
5001 Make_Object_Declaration
(Loc
,
5002 Defining_Identifier
=>
5003 Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
)))),
5004 Constant_Present
=> True,
5005 Object_Definition
=>
5006 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
5008 Make_Attribute_Reference
(Loc
,
5010 Make_Selected_Component
(Loc
,
5011 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
5014 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
5015 Attribute_Name
=> Name_Address
)));
5019 -- Generate: Expanded_Name : constant String := "";
5021 if Discard_Names
then
5023 Make_Object_Declaration
(Loc
,
5024 Defining_Identifier
=> Exname
,
5025 Constant_Present
=> True,
5026 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
5028 Make_String_Literal
(Loc
, "")));
5030 -- Generate: Exname : constant String := full_qualified_name (typ);
5031 -- The type itself may be an anonymous parent type, so use the first
5032 -- subtype to have a user-recognizable name.
5036 Make_Object_Declaration
(Loc
,
5037 Defining_Identifier
=> Exname
,
5038 Constant_Present
=> True,
5039 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
5041 Make_String_Literal
(Loc
,
5042 Fully_Qualified_Name_String
(First_Subtype
(Typ
)))));
5045 Set_Is_Statically_Allocated
(Exname
);
5046 Set_Is_True_Constant
(Exname
);
5048 -- Declare the object used by Ada.Tags.Register_Tag
5050 if RTE_Available
(RE_Register_Tag
) then
5052 Make_Object_Declaration
(Loc
,
5053 Defining_Identifier
=> HT_Link
,
5054 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
5055 Expression
=> New_Occurrence_Of
(RTE
(RE_No_Tag
), Loc
)));
5058 -- Generate code to create the storage for the type specific data object
5059 -- with enough space to store the tags of the ancestors plus the tags
5060 -- of all the implemented interfaces (as described in a-tags.adb).
5062 -- TSD : Type_Specific_Data (I_Depth) :=
5063 -- (Idepth => I_Depth,
5064 -- Access_Level => Type_Access_Level (Typ),
5065 -- Alignment => Typ'Alignment,
5066 -- Expanded_Name => Cstring_Ptr!(Exname'Address))
5067 -- External_Tag => Cstring_Ptr!(Exname'Address))
5068 -- HT_Link => HT_Link'Address,
5069 -- Transportable => <<boolean-value>>,
5070 -- Is_Abstract => <<boolean-value>>,
5071 -- Needs_Finalization => <<boolean-value>>,
5072 -- [ Size_Func => Size_Prim'Access, ]
5073 -- [ Interfaces_Table => <<access-value>>, ]
5074 -- [ SSD => SSD_Table'Address ]
5075 -- Tags_Table => (0 => null,
5078 -- for TSD'Alignment use Address'Alignment
5080 TSD_Aggr_List
:= New_List
;
5082 -- Idepth: Count ancestors to compute the inheritance depth. For private
5083 -- extensions, always go to the full view in order to compute the real
5084 -- inheritance depth.
5087 Current_Typ
: Entity_Id
;
5088 Parent_Typ
: Entity_Id
;
5094 Parent_Typ
:= Etype
(Current_Typ
);
5096 if Is_Private_Type
(Parent_Typ
) then
5097 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
5100 exit when Parent_Typ
= Current_Typ
;
5102 I_Depth
:= I_Depth
+ 1;
5103 Current_Typ
:= Parent_Typ
;
5107 Append_To
(TSD_Aggr_List
,
5108 Make_Integer_Literal
(Loc
, I_Depth
));
5112 Append_To
(TSD_Aggr_List
,
5113 Make_Integer_Literal
(Loc
, Type_Access_Level
(Typ
)));
5117 -- For CPP types we cannot rely on the value of 'Alignment provided
5118 -- by the backend to initialize this TSD field.
5120 if Convention
(Typ
) = Convention_CPP
5121 or else Is_CPP_Class
(Root_Type
(Typ
))
5123 Append_To
(TSD_Aggr_List
,
5124 Make_Integer_Literal
(Loc
, 0));
5126 Append_To
(TSD_Aggr_List
,
5127 Make_Attribute_Reference
(Loc
,
5128 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
5129 Attribute_Name
=> Name_Alignment
));
5134 Append_To
(TSD_Aggr_List
,
5135 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5136 Make_Attribute_Reference
(Loc
,
5137 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5138 Attribute_Name
=> Name_Address
)));
5140 -- External_Tag of a local tagged type
5142 -- <typ>A : constant String :=
5143 -- "Internal tag at 16#tag-addr#: <full-name-of-typ>";
5145 -- The reason we generate this strange name is that we do not want to
5146 -- enter local tagged types in the global hash table used to compute
5147 -- the Internal_Tag attribute for two reasons:
5149 -- 1. It is hard to avoid a tasking race condition for entering the
5150 -- entry into the hash table.
5152 -- 2. It would cause a storage leak, unless we rig up considerable
5153 -- mechanism to remove the entry from the hash table on exit.
5155 -- So what we do is to generate the above external tag name, where the
5156 -- hex address is the address of the local dispatch table (i.e. exactly
5157 -- the value we want if Internal_Tag is computed from this string).
5159 -- Of course this value will only be valid if the tagged type is still
5160 -- in scope, but it clearly must be erroneous to compute the internal
5161 -- tag of a tagged type that is out of scope.
5163 -- We don't do this processing if an explicit external tag has been
5164 -- specified. That's an odd case for which we have already issued a
5165 -- warning, where we will not be able to compute the internal tag.
5167 if not Discard_Names
5168 and then not Is_Library_Level_Entity
(Typ
)
5169 and then not Has_External_Tag_Rep_Clause
(Typ
)
5172 Exname
: constant Entity_Id
:=
5173 Make_Defining_Identifier
(Loc
,
5174 Chars
=> New_External_Name
(Tname
, 'A'));
5175 Full_Name
: constant String_Id
:=
5176 Fully_Qualified_Name_String
(First_Subtype
(Typ
));
5177 Str1_Id
: String_Id
;
5178 Str2_Id
: String_Id
;
5182 -- Str1 = "Internal tag at 16#";
5185 Store_String_Chars
("Internal tag at 16#");
5186 Str1_Id
:= End_String
;
5189 -- Str2 = "#: <type-full-name>";
5192 Store_String_Chars
("#: ");
5193 Store_String_Chars
(Full_Name
);
5194 Str2_Id
:= End_String
;
5197 -- Exname : constant String :=
5198 -- Str1 & Address_Image (Tag) & Str2;
5200 if RTE_Available
(RE_Address_Image
) then
5202 Make_Object_Declaration
(Loc
,
5203 Defining_Identifier
=> Exname
,
5204 Constant_Present
=> True,
5205 Object_Definition
=> New_Occurrence_Of
5206 (Standard_String
, Loc
),
5208 Make_Op_Concat
(Loc
,
5209 Left_Opnd
=> Make_String_Literal
(Loc
, Str1_Id
),
5211 Make_Op_Concat
(Loc
,
5213 Make_Function_Call
(Loc
,
5216 (RTE
(RE_Address_Image
), Loc
),
5217 Parameter_Associations
=> New_List
(
5218 Unchecked_Convert_To
(RTE
(RE_Address
),
5219 New_Occurrence_Of
(DT_Ptr
, Loc
)))),
5221 Make_String_Literal
(Loc
, Str2_Id
)))));
5224 -- Exname : constant String := Str1 & Str2;
5228 Make_Object_Declaration
(Loc
,
5229 Defining_Identifier
=> Exname
,
5230 Constant_Present
=> True,
5231 Object_Definition
=>
5232 New_Occurrence_Of
(Standard_String
, Loc
),
5234 Make_Op_Concat
(Loc
,
5235 Left_Opnd
=> Make_String_Literal
(Loc
, Str1_Id
),
5236 Right_Opnd
=> Make_String_Literal
(Loc
, Str2_Id
))));
5240 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5241 Make_Attribute_Reference
(Loc
,
5242 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5243 Attribute_Name
=> Name_Address
));
5246 -- External tag of a library-level tagged type: Check for a definition
5247 -- of External_Tag. The clause is considered only if it applies to this
5248 -- specific tagged type, as opposed to one of its ancestors.
5249 -- If the type is an unconstrained type extension, we are building the
5250 -- dispatch table of its anonymous base type, so the external tag, if
5251 -- any was specified, must be retrieved from the first subtype. Go to
5252 -- the full view in case the clause is in the private part.
5256 Def
: constant Node_Id
:= Get_Attribute_Definition_Clause
5257 (Underlying_Type
(First_Subtype
(Typ
)),
5258 Attribute_External_Tag
);
5260 Old_Val
: String_Id
;
5261 New_Val
: String_Id
;
5265 if not Present
(Def
)
5266 or else Entity
(Name
(Def
)) /= First_Subtype
(Typ
)
5269 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5270 Make_Attribute_Reference
(Loc
,
5271 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
5272 Attribute_Name
=> Name_Address
));
5274 Old_Val
:= Strval
(Expr_Value_S
(Expression
(Def
)));
5276 -- For the rep clause "for <typ>'external_tag use y" generate:
5278 -- <typ>A : constant string := y;
5280 -- <typ>A'Address is used to set the External_Tag component
5283 -- Create a new nul terminated string if it is not already
5285 if String_Length
(Old_Val
) > 0
5287 Get_String_Char
(Old_Val
, String_Length
(Old_Val
)) = 0
5291 Start_String
(Old_Val
);
5292 Store_String_Char
(Get_Char_Code
(ASCII
.NUL
));
5293 New_Val
:= End_String
;
5296 E
:= Make_Defining_Identifier
(Loc
,
5297 New_External_Name
(Chars
(Typ
), 'A'));
5300 Make_Object_Declaration
(Loc
,
5301 Defining_Identifier
=> E
,
5302 Constant_Present
=> True,
5303 Object_Definition
=>
5304 New_Occurrence_Of
(Standard_String
, Loc
),
5306 Make_String_Literal
(Loc
, New_Val
)));
5309 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
5310 Make_Attribute_Reference
(Loc
,
5311 Prefix
=> New_Occurrence_Of
(E
, Loc
),
5312 Attribute_Name
=> Name_Address
));
5317 Append_To
(TSD_Aggr_List
, New_Node
);
5321 if RTE_Available
(RE_Register_Tag
) then
5322 Append_To
(TSD_Aggr_List
,
5323 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
5324 Make_Attribute_Reference
(Loc
,
5325 Prefix
=> New_Occurrence_Of
(HT_Link
, Loc
),
5326 Attribute_Name
=> Name_Address
)));
5328 elsif RTE_Record_Component_Available
(RE_HT_Link
) then
5329 Append_To
(TSD_Aggr_List
,
5330 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
5331 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5334 -- Transportable: Set for types that can be used in remote calls
5335 -- with respect to E.4(18) legality rules.
5338 Transportable
: Entity_Id
;
5344 or else Is_Shared_Passive
(Typ
)
5346 ((Is_Remote_Types
(Typ
)
5347 or else Is_Remote_Call_Interface
(Typ
))
5348 and then Original_View_In_Visible_Part
(Typ
))
5349 or else not Comes_From_Source
(Typ
));
5351 Append_To
(TSD_Aggr_List
,
5352 New_Occurrence_Of
(Transportable
, Loc
));
5355 -- Is_Abstract (Ada 2012: AI05-0173). This functionality is not
5356 -- available in the HIE runtime.
5358 if RTE_Record_Component_Available
(RE_Is_Abstract
) then
5360 Is_Abstract
: Entity_Id
;
5362 Is_Abstract
:= Boolean_Literals
(Is_Abstract_Type
(Typ
));
5363 Append_To
(TSD_Aggr_List
,
5364 New_Occurrence_Of
(Is_Abstract
, Loc
));
5368 -- Needs_Finalization: Set if the type is controlled or has controlled
5372 Needs_Fin
: Entity_Id
;
5374 Needs_Fin
:= Boolean_Literals
(Needs_Finalization
(Typ
));
5375 Append_To
(TSD_Aggr_List
, New_Occurrence_Of
(Needs_Fin
, Loc
));
5380 if RTE_Record_Component_Available
(RE_Size_Func
) then
5382 -- Initialize this field to Null_Address if we are not building
5383 -- static dispatch tables static or if the size function is not
5384 -- available. In the former case we cannot initialize this field
5385 -- until the function is frozen and registered in the dispatch
5386 -- table (see Register_Primitive).
5388 if not Building_Static_DT
(Typ
) or else not Has_DT
(Typ
) then
5389 Append_To
(TSD_Aggr_List
,
5390 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5391 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5395 Prim_Elmt
: Elmt_Id
;
5397 Size_Comp
: Node_Id
:= Empty
;
5400 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5401 while Present
(Prim_Elmt
) loop
5402 Prim
:= Node
(Prim_Elmt
);
5404 if Chars
(Prim
) = Name_uSize
then
5405 Prim
:= Ultimate_Alias
(Prim
);
5407 if Is_Abstract_Subprogram
(Prim
) then
5409 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5410 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
));
5413 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
5414 Make_Attribute_Reference
(Loc
,
5415 Prefix
=> New_Occurrence_Of
(Prim
, Loc
),
5416 Attribute_Name
=> Name_Unrestricted_Access
));
5422 Next_Elmt
(Prim_Elmt
);
5425 pragma Assert
(Present
(Size_Comp
));
5426 Append_To
(TSD_Aggr_List
, Size_Comp
);
5431 -- Interfaces_Table (required for AI-405)
5433 if RTE_Record_Component_Available
(RE_Interfaces_Table
) then
5435 -- Count the number of interface types implemented by Typ
5437 Collect_Interfaces
(Typ
, Typ_Ifaces
);
5439 AI
:= First_Elmt
(Typ_Ifaces
);
5440 while Present
(AI
) loop
5441 Num_Ifaces
:= Num_Ifaces
+ 1;
5445 if Num_Ifaces
= 0 then
5446 Iface_Table_Node
:= Make_Null
(Loc
);
5448 -- Generate the Interface_Table object
5452 TSD_Ifaces_List
: constant List_Id
:= New_List
;
5454 Ifaces_List
: Elist_Id
:= No_Elist
;
5455 Ifaces_Comp_List
: Elist_Id
:= No_Elist
;
5456 Ifaces_Tag_List
: Elist_Id
;
5457 Offset_To_Top
: Node_Id
;
5458 Sec_DT_Tag
: Node_Id
;
5461 -- Collect interfaces information if we need to compute the
5462 -- offset to the top using the dummy object.
5464 if Present
(Dummy_Object
) then
5465 Collect_Interfaces_Info
(Typ
,
5466 Ifaces_List
, Ifaces_Comp_List
, Ifaces_Tag_List
);
5469 AI
:= First_Elmt
(Typ_Ifaces
);
5470 while Present
(AI
) loop
5471 if Is_Ancestor
(Node
(AI
), Typ
, Use_Full_View
=> True) then
5472 Sec_DT_Tag
:= New_Occurrence_Of
(DT_Ptr
, Loc
);
5477 (Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
5478 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5480 while Is_Tag
(Node
(Elmt
))
5482 Is_Ancestor
(Node
(AI
), Related_Type
(Node
(Elmt
)),
5483 Use_Full_View
=> True)
5485 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5487 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
5489 pragma Assert
(not Has_Thunks
(Node
(Elmt
)));
5491 pragma Assert
(not Has_Thunks
(Node
(Elmt
)));
5495 pragma Assert
(Ekind
(Node
(Elmt
)) = E_Constant
5497 Has_Thunks
(Node
(Next_Elmt
(Next_Elmt
(Elmt
)))));
5501 (Node
(Next_Elmt
(Next_Elmt
(Elmt
))), Loc
);
5504 -- For static dispatch tables compute Offset_To_Top using
5505 -- the dummy object.
5507 if Present
(Dummy_Object
) then
5509 Iface
: constant Node_Id
:= Node
(AI
);
5510 Iface_Comp
: Node_Id
:= Empty
;
5511 Iface_Comp_Elmt
: Elmt_Id
;
5512 Iface_Elmt
: Elmt_Id
;
5515 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
5516 Iface_Comp_Elmt
:= First_Elmt
(Ifaces_Comp_List
);
5518 while Present
(Iface_Elmt
) loop
5519 if Node
(Iface_Elmt
) = Iface
then
5520 Iface_Comp
:= Node
(Iface_Comp_Elmt
);
5524 Next_Elmt
(Iface_Elmt
);
5525 Next_Elmt
(Iface_Comp_Elmt
);
5528 pragma Assert
(Present
(Iface_Comp
));
5532 Make_Attribute_Reference
(Loc
,
5534 Make_Selected_Component
(Loc
,
5536 New_Occurrence_Of
(Dummy_Object
, Loc
),
5538 New_Occurrence_Of
(Iface_Comp
, Loc
)),
5539 Attribute_Name
=> Name_Position
));
5542 Offset_To_Top
:= Make_Integer_Literal
(Loc
, 0);
5545 Append_To
(TSD_Ifaces_List
,
5546 Make_Aggregate
(Loc
,
5547 Expressions
=> New_List
(
5551 Unchecked_Convert_To
(RTE
(RE_Tag
),
5553 (Node
(First_Elmt
(Access_Disp_Table
(Node
(AI
)))),
5556 -- Static_Offset_To_Top
5558 New_Occurrence_Of
(Standard_True
, Loc
),
5560 -- Offset_To_Top_Value
5564 -- Offset_To_Top_Func
5570 Unchecked_Convert_To
(RTE
(RE_Tag
), Sec_DT_Tag
))));
5575 Name_ITable
:= New_External_Name
(Tname
, 'I');
5576 ITable
:= Make_Defining_Identifier
(Loc
, Name_ITable
);
5577 Set_Is_Statically_Allocated
(ITable
,
5578 Is_Library_Level_Tagged_Type
(Typ
));
5580 -- The table of interfaces is constant if we are building a
5581 -- static dispatch table; otherwise is not constant because
5582 -- its slots are filled at run time by the IP routine.
5585 Make_Object_Declaration
(Loc
,
5586 Defining_Identifier
=> ITable
,
5587 Aliased_Present
=> True,
5588 Constant_Present
=> Present
(Dummy_Object
),
5589 Object_Definition
=>
5590 Make_Subtype_Indication
(Loc
,
5592 New_Occurrence_Of
(RTE
(RE_Interface_Data
), Loc
),
5594 Make_Index_Or_Discriminant_Constraint
(Loc
,
5595 Constraints
=> New_List
(
5596 Make_Integer_Literal
(Loc
, Num_Ifaces
)))),
5599 Make_Aggregate
(Loc
,
5600 Expressions
=> New_List
(
5601 Make_Integer_Literal
(Loc
, Num_Ifaces
),
5602 Make_Aggregate
(Loc
, TSD_Ifaces_List
)))));
5605 Make_Attribute_Definition_Clause
(Loc
,
5606 Name
=> New_Occurrence_Of
(ITable
, Loc
),
5607 Chars
=> Name_Alignment
,
5609 Make_Attribute_Reference
(Loc
,
5611 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5612 Attribute_Name
=> Name_Alignment
)));
5615 Make_Attribute_Reference
(Loc
,
5616 Prefix
=> New_Occurrence_Of
(ITable
, Loc
),
5617 Attribute_Name
=> Name_Unchecked_Access
);
5621 Append_To
(TSD_Aggr_List
, Iface_Table_Node
);
5624 -- Generate the Select Specific Data table for synchronized types that
5625 -- implement synchronized interfaces. The size of the table is
5626 -- constrained by the number of non-predefined primitive operations.
5628 if RTE_Record_Component_Available
(RE_SSD
) then
5629 if Ada_Version
>= Ada_2005
5630 and then Has_DT
(Typ
)
5631 and then Is_Concurrent_Record_Type
(Typ
)
5632 and then Has_Interfaces
(Typ
)
5633 and then Nb_Prim
> 0
5634 and then not Is_Abstract_Type
(Typ
)
5635 and then not Is_Controlled
(Typ
)
5636 and then not Restriction_Active
(No_Dispatching_Calls
)
5637 and then not Restriction_Active
(No_Select_Statements
)
5640 Make_Object_Declaration
(Loc
,
5641 Defining_Identifier
=> SSD
,
5642 Aliased_Present
=> True,
5643 Object_Definition
=>
5644 Make_Subtype_Indication
(Loc
,
5645 Subtype_Mark
=> New_Occurrence_Of
(
5646 RTE
(RE_Select_Specific_Data
), Loc
),
5648 Make_Index_Or_Discriminant_Constraint
(Loc
,
5649 Constraints
=> New_List
(
5650 Make_Integer_Literal
(Loc
, Nb_Prim
))))));
5653 Make_Attribute_Definition_Clause
(Loc
,
5654 Name
=> New_Occurrence_Of
(SSD
, Loc
),
5655 Chars
=> Name_Alignment
,
5657 Make_Attribute_Reference
(Loc
,
5659 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5660 Attribute_Name
=> Name_Alignment
)));
5662 -- This table is initialized by Make_Select_Specific_Data_Table,
5663 -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
5665 Append_To
(TSD_Aggr_List
,
5666 Make_Attribute_Reference
(Loc
,
5667 Prefix
=> New_Occurrence_Of
(SSD
, Loc
),
5668 Attribute_Name
=> Name_Unchecked_Access
));
5670 Append_To
(TSD_Aggr_List
, Make_Null
(Loc
));
5674 -- Initialize the table of ancestor tags. In case of interface types
5675 -- this table is not needed.
5677 TSD_Tags_List
:= New_List
;
5679 -- If we are not statically allocating the dispatch table then we must
5680 -- fill position 0 with null because we still have not generated the
5683 if not Building_Static_DT
(Typ
)
5684 or else Is_Interface
(Typ
)
5686 Append_To
(TSD_Tags_List
,
5687 Unchecked_Convert_To
(RTE
(RE_Tag
),
5688 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5690 -- Otherwise we can safely reference the tag
5693 Append_To
(TSD_Tags_List
,
5694 New_Occurrence_Of
(DT_Ptr
, Loc
));
5697 -- Fill the rest of the table with the tags of the ancestors
5700 Current_Typ
: Entity_Id
;
5701 Parent_Typ
: Entity_Id
;
5709 Parent_Typ
:= Etype
(Current_Typ
);
5711 if Is_Private_Type
(Parent_Typ
) then
5712 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
5715 exit when Parent_Typ
= Current_Typ
;
5717 if Is_CPP_Class
(Parent_Typ
) then
5719 -- The tags defined in the C++ side will be inherited when
5720 -- the object is constructed (Exp_Ch3.Build_Init_Procedure)
5722 Append_To
(TSD_Tags_List
,
5723 Unchecked_Convert_To
(RTE
(RE_Tag
),
5724 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)));
5726 Append_To
(TSD_Tags_List
,
5728 (Node
(First_Elmt
(Access_Disp_Table
(Parent_Typ
))),
5733 Current_Typ
:= Parent_Typ
;
5736 pragma Assert
(Pos
= I_Depth
+ 1);
5739 Append_To
(TSD_Aggr_List
,
5740 Make_Aggregate
(Loc
,
5741 Expressions
=> TSD_Tags_List
));
5743 -- Build the TSD object
5746 Make_Object_Declaration
(Loc
,
5747 Defining_Identifier
=> TSD
,
5748 Aliased_Present
=> True,
5749 Constant_Present
=> Building_Static_DT
(Typ
),
5750 Object_Definition
=>
5751 Make_Subtype_Indication
(Loc
,
5752 Subtype_Mark
=> New_Occurrence_Of
(
5753 RTE
(RE_Type_Specific_Data
), Loc
),
5755 Make_Index_Or_Discriminant_Constraint
(Loc
,
5756 Constraints
=> New_List
(
5757 Make_Integer_Literal
(Loc
, I_Depth
)))),
5759 Expression
=> Make_Aggregate
(Loc
,
5760 Expressions
=> TSD_Aggr_List
)));
5762 Set_Is_True_Constant
(TSD
, Building_Static_DT
(Typ
));
5765 Make_Attribute_Definition_Clause
(Loc
,
5766 Name
=> New_Occurrence_Of
(TSD
, Loc
),
5767 Chars
=> Name_Alignment
,
5769 Make_Attribute_Reference
(Loc
,
5771 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5772 Attribute_Name
=> Name_Alignment
)));
5774 -- Initialize or declare the dispatch table object
5776 if not Has_DT
(Typ
) then
5777 DT_Constr_List
:= New_List
;
5778 DT_Aggr_List
:= New_List
;
5783 Make_Attribute_Reference
(Loc
,
5784 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
5785 Attribute_Name
=> Name_Address
);
5787 Append_To
(DT_Constr_List
, New_Node
);
5788 Append_To
(DT_Aggr_List
, New_Copy
(New_Node
));
5789 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
5791 -- In case of locally defined tagged types we have already declared
5792 -- and uninitialized object for the dispatch table, which is now
5793 -- initialized by means of the following assignment:
5795 -- DT := (TSD'Address, 0);
5797 if not Building_Static_DT
(Typ
) then
5799 Make_Assignment_Statement
(Loc
,
5800 Name
=> New_Occurrence_Of
(DT
, Loc
),
5801 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5803 -- In case of library level tagged types we declare and export now
5804 -- the constant object containing the dummy dispatch table. There
5805 -- is no need to declare the tag here because it has been previously
5806 -- declared by Make_Tags
5808 -- DT : aliased constant No_Dispatch_Table :=
5809 -- (NDT_TSD => TSD'Address;
5810 -- NDT_Prims_Ptr => 0);
5811 -- for DT'Alignment use Address'Alignment;
5815 Make_Object_Declaration
(Loc
,
5816 Defining_Identifier
=> DT
,
5817 Aliased_Present
=> True,
5818 Constant_Present
=> True,
5819 Object_Definition
=>
5820 New_Occurrence_Of
(RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
),
5821 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
5824 Make_Attribute_Definition_Clause
(Loc
,
5825 Name
=> New_Occurrence_Of
(DT
, Loc
),
5826 Chars
=> Name_Alignment
,
5828 Make_Attribute_Reference
(Loc
,
5830 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5831 Attribute_Name
=> Name_Alignment
)));
5833 Export_DT
(Typ
, DT
);
5836 -- Common case: Typ has a dispatch table
5840 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
5841 -- (predef-prim-op-1'address,
5842 -- predef-prim-op-2'address,
5844 -- predef-prim-op-n'address);
5845 -- for Predef_Prims'Alignment use Address'Alignment
5847 -- DT : Dispatch_Table (Nb_Prims) :=
5848 -- (Signature => <sig-value>,
5849 -- Tag_Kind => <tag_kind-value>,
5850 -- Predef_Prims => Predef_Prims'First'Address,
5851 -- Offset_To_Top => 0,
5852 -- TSD => TSD'Address;
5853 -- Prims_Ptr => (prim-op-1'address,
5854 -- prim-op-2'address,
5856 -- prim-op-n'address));
5857 -- for DT'Alignment use Address'Alignment
5864 if not Building_Static_DT
(Typ
) then
5865 Nb_Predef_Prims
:= Max_Predef_Prims
;
5868 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5869 while Present
(Prim_Elmt
) loop
5870 Prim
:= Node
(Prim_Elmt
);
5872 if Is_Predefined_Dispatching_Operation
(Prim
)
5873 and then not Is_Abstract_Subprogram
(Prim
)
5875 Pos
:= UI_To_Int
(DT_Position
(Prim
));
5877 if Pos
> Nb_Predef_Prims
then
5878 Nb_Predef_Prims
:= Pos
;
5882 Next_Elmt
(Prim_Elmt
);
5888 (Nat
range 1 .. Nb_Predef_Prims
) of Entity_Id
;
5893 Prim_Ops_Aggr_List
:= New_List
;
5895 Prim_Table
:= (others => Empty
);
5897 if Building_Static_DT
(Typ
) then
5898 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5899 while Present
(Prim_Elmt
) loop
5900 Prim
:= Node
(Prim_Elmt
);
5902 if Is_Predefined_Dispatching_Operation
(Prim
)
5903 and then not Is_Abstract_Subprogram
(Prim
)
5904 and then not Is_Eliminated
(Prim
)
5905 and then not Present
(Prim_Table
5906 (UI_To_Int
(DT_Position
(Prim
))))
5908 E
:= Ultimate_Alias
(Prim
);
5909 pragma Assert
(not Is_Abstract_Subprogram
(E
));
5910 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) := E
;
5913 Next_Elmt
(Prim_Elmt
);
5917 for J
in Prim_Table
'Range loop
5918 if Present
(Prim_Table
(J
)) then
5920 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
5921 Make_Attribute_Reference
(Loc
,
5923 New_Occurrence_Of
(Prim_Table
(J
), Loc
),
5924 Attribute_Name
=> Name_Unrestricted_Access
));
5926 New_Node
:= Make_Null
(Loc
);
5929 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
5933 Make_Aggregate
(Loc
,
5934 Expressions
=> Prim_Ops_Aggr_List
);
5937 Make_Subtype_Declaration
(Loc
,
5938 Defining_Identifier
=> Make_Temporary
(Loc
, 'S'),
5939 Subtype_Indication
=>
5940 New_Occurrence_Of
(RTE
(RE_Address_Array
), Loc
));
5942 Append_To
(Result
, Decl
);
5945 Make_Object_Declaration
(Loc
,
5946 Defining_Identifier
=> Predef_Prims
,
5947 Aliased_Present
=> True,
5948 Constant_Present
=> Building_Static_DT
(Typ
),
5949 Object_Definition
=>
5950 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
),
5951 Expression
=> New_Node
));
5953 -- Remember aggregates initializing dispatch tables
5955 Append_Elmt
(New_Node
, DT_Aggr
);
5958 Make_Attribute_Definition_Clause
(Loc
,
5959 Name
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
5960 Chars
=> Name_Alignment
,
5962 Make_Attribute_Reference
(Loc
,
5964 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
5965 Attribute_Name
=> Name_Alignment
)));
5969 -- Stage 1: Initialize the discriminant and the record components
5971 DT_Constr_List
:= New_List
;
5972 DT_Aggr_List
:= New_List
;
5974 -- Num_Prims. If the tagged type has no primitives we add a dummy
5975 -- slot whose address will be the tag of this type.
5978 New_Node
:= Make_Integer_Literal
(Loc
, 1);
5980 New_Node
:= Make_Integer_Literal
(Loc
, Nb_Prim
);
5983 Append_To
(DT_Constr_List
, New_Node
);
5984 Append_To
(DT_Aggr_List
, New_Copy
(New_Node
));
5988 if RTE_Record_Component_Available
(RE_Signature
) then
5989 Append_To
(DT_Aggr_List
,
5990 New_Occurrence_Of
(RTE
(RE_Primary_DT
), Loc
));
5995 if RTE_Record_Component_Available
(RE_Tag_Kind
) then
5996 Append_To
(DT_Aggr_List
, Tagged_Kind
(Typ
));
6001 Append_To
(DT_Aggr_List
,
6002 Make_Attribute_Reference
(Loc
,
6003 Prefix
=> New_Occurrence_Of
(Predef_Prims
, Loc
),
6004 Attribute_Name
=> Name_Address
));
6008 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
6012 Append_To
(DT_Aggr_List
,
6013 Make_Attribute_Reference
(Loc
,
6014 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6015 Attribute_Name
=> Name_Address
));
6017 -- Stage 2: Initialize the table of user-defined primitive operations
6019 Prim_Ops_Aggr_List
:= New_List
;
6022 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
6024 elsif not Building_Static_DT
(Typ
) then
6025 for J
in 1 .. Nb_Prim
loop
6026 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
6031 CPP_Nb_Prims
: constant Nat
:= CPP_Num_Prims
(Typ
);
6034 Prim_Elmt
: Elmt_Id
;
6036 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
6039 Prim_Table
:= (others => Empty
);
6041 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6042 while Present
(Prim_Elmt
) loop
6043 Prim
:= Node
(Prim_Elmt
);
6045 -- Retrieve the ultimate alias of the primitive for proper
6046 -- handling of renamings and eliminated primitives.
6048 E
:= Ultimate_Alias
(Prim
);
6050 -- If the alias is not a primitive operation then Prim does
6051 -- not rename another primitive, but rather an operation
6052 -- declared elsewhere (e.g. in another scope) and therefore
6053 -- Prim is a new primitive.
6055 if No
(Find_Dispatching_Type
(E
)) then
6059 Prim_Pos
:= UI_To_Int
(DT_Position
(E
));
6061 -- Skip predefined primitives because they are located in a
6062 -- separate dispatch table.
6064 if not Is_Predefined_Dispatching_Operation
(Prim
)
6065 and then not Is_Predefined_Dispatching_Operation
(E
)
6067 -- Skip entities with attribute Interface_Alias because
6068 -- those are only required to build secondary dispatch
6071 and then not Present
(Interface_Alias
(Prim
))
6073 -- Skip abstract and eliminated primitives
6075 and then not Is_Abstract_Subprogram
(E
)
6076 and then not Is_Eliminated
(E
)
6078 -- For derivations of CPP types skip primitives located in
6079 -- the C++ part of the dispatch table because their slots
6080 -- are initialized by the IC routine.
6082 and then (not Is_CPP_Class
(Root_Type
(Typ
))
6083 or else Prim_Pos
> CPP_Nb_Prims
)
6085 -- Skip ignored Ghost subprograms as those will be removed
6086 -- from the executable.
6088 and then not Is_Ignored_Ghost_Entity
(E
)
6091 (UI_To_Int
(DT_Position
(Prim
)) <= Nb_Prim
);
6093 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) := E
;
6096 Next_Elmt
(Prim_Elmt
);
6099 for J
in Prim_Table
'Range loop
6100 if Present
(Prim_Table
(J
)) then
6102 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
6103 Make_Attribute_Reference
(Loc
,
6105 New_Occurrence_Of
(Prim_Table
(J
), Loc
),
6106 Attribute_Name
=> Name_Unrestricted_Access
));
6108 New_Node
:= Make_Null
(Loc
);
6111 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
6117 Make_Aggregate
(Loc
,
6118 Expressions
=> Prim_Ops_Aggr_List
);
6120 Append_To
(DT_Aggr_List
, New_Node
);
6122 -- Remember aggregates initializing dispatch tables
6124 Append_Elmt
(New_Node
, DT_Aggr
);
6126 -- In case of locally defined tagged types we have already declared
6127 -- and uninitialized object for the dispatch table, which is now
6128 -- initialized by means of an assignment.
6130 if not Building_Static_DT
(Typ
) then
6132 Make_Assignment_Statement
(Loc
,
6133 Name
=> New_Occurrence_Of
(DT
, Loc
),
6134 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
6136 -- In case of library level tagged types we declare now and export
6137 -- the constant object containing the dispatch table.
6141 Make_Object_Declaration
(Loc
,
6142 Defining_Identifier
=> DT
,
6143 Aliased_Present
=> True,
6144 Constant_Present
=> True,
6145 Object_Definition
=>
6146 Make_Subtype_Indication
(Loc
,
6147 Subtype_Mark
=> New_Occurrence_Of
6148 (RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
6149 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
6150 Constraints
=> DT_Constr_List
)),
6151 Expression
=> Make_Aggregate
(Loc
, DT_Aggr_List
)));
6154 Make_Attribute_Definition_Clause
(Loc
,
6155 Name
=> New_Occurrence_Of
(DT
, Loc
),
6156 Chars
=> Name_Alignment
,
6158 Make_Attribute_Reference
(Loc
,
6160 New_Occurrence_Of
(RTE
(RE_Integer_Address
), Loc
),
6161 Attribute_Name
=> Name_Alignment
)));
6163 Export_DT
(Typ
, DT
);
6167 -- Initialize the table of ancestor tags if not building static
6170 if not Building_Static_DT
(Typ
)
6171 and then not Is_Interface
(Typ
)
6172 and then not Is_CPP_Class
(Typ
)
6175 Make_Assignment_Statement
(Loc
,
6177 Make_Indexed_Component
(Loc
,
6179 Make_Selected_Component
(Loc
,
6180 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6183 (RTE_Record_Component
(RE_Tags_Table
), Loc
)),
6185 New_List
(Make_Integer_Literal
(Loc
, 0))),
6189 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
)));
6192 -- Inherit the dispatch tables of the parent. There is no need to
6193 -- inherit anything from the parent when building static dispatch tables
6194 -- because the whole dispatch table (including inherited primitives) has
6195 -- been already built.
6197 if Building_Static_DT
(Typ
) then
6200 -- If the ancestor is a CPP_Class type we inherit the dispatch tables
6201 -- in the init proc, and we don't need to fill them in here.
6203 elsif Is_CPP_Class
(Parent_Typ
) then
6206 -- Otherwise we fill in the dispatch tables here
6209 if Typ
/= Parent_Typ
6210 and then not Is_Interface
(Typ
)
6211 and then not Restriction_Active
(No_Dispatching_Calls
)
6213 -- Inherit the dispatch table
6215 if not Is_Interface
(Typ
)
6216 and then not Is_Interface
(Parent_Typ
)
6217 and then not Is_CPP_Class
(Parent_Typ
)
6220 Nb_Prims
: constant Int
:=
6221 UI_To_Int
(DT_Entry_Count
6222 (First_Tag_Component
(Parent_Typ
)));
6225 Append_To
(Elab_Code
,
6226 Build_Inherit_Predefined_Prims
(Loc
,
6232 (Access_Disp_Table
(Parent_Typ
)))), Loc
),
6238 (Access_Disp_Table
(Typ
)))), Loc
)));
6240 if Nb_Prims
/= 0 then
6241 Append_To
(Elab_Code
,
6242 Build_Inherit_Prims
(Loc
,
6248 (Access_Disp_Table
(Parent_Typ
))), Loc
),
6249 New_Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
6250 Num_Prims
=> Nb_Prims
));
6255 -- Inherit the secondary dispatch tables of the ancestor
6257 if not Is_CPP_Class
(Parent_Typ
) then
6259 Sec_DT_Ancestor
: Elmt_Id
:=
6265 Sec_DT_Typ
: Elmt_Id
:=
6269 (Access_Disp_Table
(Typ
))));
6271 procedure Copy_Secondary_DTs
(Typ
: Entity_Id
);
6272 -- Local procedure required to climb through the ancestors
6273 -- and copy the contents of all their secondary dispatch
6276 ------------------------
6277 -- Copy_Secondary_DTs --
6278 ------------------------
6280 procedure Copy_Secondary_DTs
(Typ
: Entity_Id
) is
6285 -- Climb to the ancestor (if any) handling private types
6287 if Present
(Full_View
(Etype
(Typ
))) then
6288 if Full_View
(Etype
(Typ
)) /= Typ
then
6289 Copy_Secondary_DTs
(Full_View
(Etype
(Typ
)));
6292 elsif Etype
(Typ
) /= Typ
then
6293 Copy_Secondary_DTs
(Etype
(Typ
));
6296 if Present
(Interfaces
(Typ
))
6297 and then not Is_Empty_Elmt_List
(Interfaces
(Typ
))
6299 Iface
:= First_Elmt
(Interfaces
(Typ
));
6300 E
:= First_Entity
(Typ
);
6302 and then Present
(Node
(Sec_DT_Ancestor
))
6303 and then Ekind
(Node
(Sec_DT_Ancestor
)) = E_Constant
6305 if Is_Tag
(E
) and then Chars
(E
) /= Name_uTag
then
6307 Num_Prims
: constant Int
:=
6308 UI_To_Int
(DT_Entry_Count
(E
));
6311 if not Is_Interface
(Etype
(Typ
)) then
6313 -- Inherit first secondary dispatch table
6315 Append_To
(Elab_Code
,
6316 Build_Inherit_Predefined_Prims
(Loc
,
6318 Unchecked_Convert_To
(RTE
(RE_Tag
),
6321 (Next_Elmt
(Sec_DT_Ancestor
)),
6324 Unchecked_Convert_To
(RTE
(RE_Tag
),
6326 (Node
(Next_Elmt
(Sec_DT_Typ
)),
6329 if Num_Prims
/= 0 then
6330 Append_To
(Elab_Code
,
6331 Build_Inherit_Prims
(Loc
,
6332 Typ
=> Node
(Iface
),
6334 Unchecked_Convert_To
6337 (Node
(Sec_DT_Ancestor
),
6340 Unchecked_Convert_To
6343 (Node
(Sec_DT_Typ
), Loc
)),
6344 Num_Prims
=> Num_Prims
));
6348 Next_Elmt
(Sec_DT_Ancestor
);
6349 Next_Elmt
(Sec_DT_Typ
);
6351 -- Skip the secondary dispatch table of
6352 -- predefined primitives
6354 Next_Elmt
(Sec_DT_Ancestor
);
6355 Next_Elmt
(Sec_DT_Typ
);
6357 if not Is_Interface
(Etype
(Typ
)) then
6359 -- Inherit second secondary dispatch table
6361 Append_To
(Elab_Code
,
6362 Build_Inherit_Predefined_Prims
(Loc
,
6364 Unchecked_Convert_To
(RTE
(RE_Tag
),
6367 (Next_Elmt
(Sec_DT_Ancestor
)),
6370 Unchecked_Convert_To
(RTE
(RE_Tag
),
6372 (Node
(Next_Elmt
(Sec_DT_Typ
)),
6375 if Num_Prims
/= 0 then
6376 Append_To
(Elab_Code
,
6377 Build_Inherit_Prims
(Loc
,
6378 Typ
=> Node
(Iface
),
6380 Unchecked_Convert_To
6383 (Node
(Sec_DT_Ancestor
),
6386 Unchecked_Convert_To
6389 (Node
(Sec_DT_Typ
), Loc
)),
6390 Num_Prims
=> Num_Prims
));
6395 Next_Elmt
(Sec_DT_Ancestor
);
6396 Next_Elmt
(Sec_DT_Typ
);
6398 -- Skip the secondary dispatch table of
6399 -- predefined primitives
6401 Next_Elmt
(Sec_DT_Ancestor
);
6402 Next_Elmt
(Sec_DT_Typ
);
6410 end Copy_Secondary_DTs
;
6413 if Present
(Node
(Sec_DT_Ancestor
))
6414 and then Ekind
(Node
(Sec_DT_Ancestor
)) = E_Constant
6416 -- Handle private types
6418 if Present
(Full_View
(Typ
)) then
6419 Copy_Secondary_DTs
(Full_View
(Typ
));
6421 Copy_Secondary_DTs
(Typ
);
6429 -- Generate code to check if the external tag of this type is the same
6430 -- as the external tag of some other declaration.
6432 -- Check_TSD (TSD'Unrestricted_Access);
6434 -- This check is a consequence of AI05-0113-1/06, so it officially
6435 -- applies to Ada 2005 (and Ada 2012). It might be argued that it is
6436 -- a desirable check to add in Ada 95 mode, but we hesitate to make
6437 -- this change, as it would be incompatible, and could conceivably
6438 -- cause a problem in existing Ada 95 code.
6440 -- We check for No_Run_Time_Mode here, because we do not want to pick
6441 -- up the RE_Check_TSD entity and call it in No_Run_Time mode.
6443 -- We cannot perform this check if the generation of its expanded name
6446 if not No_Run_Time_Mode
6447 and then not Discard_Names
6448 and then Ada_Version
>= Ada_2005
6449 and then RTE_Available
(RE_Check_TSD
)
6450 and then not Duplicated_Tag_Checks_Suppressed
(Typ
)
6452 Append_To
(Elab_Code
,
6453 Make_Procedure_Call_Statement
(Loc
,
6455 New_Occurrence_Of
(RTE
(RE_Check_TSD
), Loc
),
6456 Parameter_Associations
=> New_List
(
6457 Make_Attribute_Reference
(Loc
,
6458 Prefix
=> New_Occurrence_Of
(TSD
, Loc
),
6459 Attribute_Name
=> Name_Unchecked_Access
))));
6462 -- Generate code to register the Tag in the External_Tag hash table for
6463 -- the pure Ada type only.
6465 -- Register_Tag (Dt_Ptr);
6467 -- Skip this action in the following cases:
6468 -- 1) if Register_Tag is not available.
6469 -- 2) in No_Run_Time mode.
6470 -- 3) if Typ is not defined at the library level (this is required
6471 -- to avoid adding concurrency control to the hash table used
6472 -- by the run-time to register the tags).
6474 if not No_Run_Time_Mode
6475 and then Is_Library_Level_Entity
(Typ
)
6476 and then RTE_Available
(RE_Register_Tag
)
6478 Append_To
(Elab_Code
,
6479 Make_Procedure_Call_Statement
(Loc
,
6481 New_Occurrence_Of
(RTE
(RE_Register_Tag
), Loc
),
6482 Parameter_Associations
=>
6483 New_List
(New_Occurrence_Of
(DT_Ptr
, Loc
))));
6486 if not Is_Empty_List
(Elab_Code
) then
6487 Append_List_To
(Result
, Elab_Code
);
6490 -- Populate the two auxiliary tables used for dispatching asynchronous,
6491 -- conditional and timed selects for synchronized types that implement
6492 -- a limited interface. Skip this step in Ravenscar profile or when
6493 -- general dispatching is forbidden.
6495 if Ada_Version
>= Ada_2005
6496 and then Is_Concurrent_Record_Type
(Typ
)
6497 and then Has_Interfaces
(Typ
)
6498 and then not Restriction_Active
(No_Dispatching_Calls
)
6499 and then not Restriction_Active
(No_Select_Statements
)
6501 Append_List_To
(Result
,
6502 Make_Select_Specific_Data_Table
(Typ
));
6505 -- Remember entities containing dispatch tables
6507 Append_Elmt
(Predef_Prims
, DT_Decl
);
6508 Append_Elmt
(DT
, DT_Decl
);
6510 Analyze_List
(Result
, Suppress
=> All_Checks
);
6511 Set_Has_Dispatch_Table
(Typ
);
6513 -- Mark entities containing dispatch tables. Required by the backend to
6514 -- handle them properly.
6516 if Has_DT
(Typ
) then
6521 -- Object declarations
6523 Elmt
:= First_Elmt
(DT_Decl
);
6524 while Present
(Elmt
) loop
6525 Set_Is_Dispatch_Table_Entity
(Node
(Elmt
));
6526 pragma Assert
(Ekind
(Etype
(Node
(Elmt
))) = E_Array_Subtype
6527 or else Ekind
(Etype
(Node
(Elmt
))) = E_Record_Subtype
);
6528 Set_Is_Dispatch_Table_Entity
(Etype
(Node
(Elmt
)));
6532 -- Aggregates initializing dispatch tables
6534 Elmt
:= First_Elmt
(DT_Aggr
);
6535 while Present
(Elmt
) loop
6536 Set_Is_Dispatch_Table_Entity
(Etype
(Node
(Elmt
)));
6544 -- Register the tagged type in the call graph nodes table
6546 Register_CG_Node
(Typ
);
6549 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
6554 -------------------------------------
6555 -- Make_Select_Specific_Data_Table --
6556 -------------------------------------
6558 function Make_Select_Specific_Data_Table
6559 (Typ
: Entity_Id
) return List_Id
6561 Assignments
: constant List_Id
:= New_List
;
6562 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6564 Conc_Typ
: Entity_Id
;
6565 Decls
: List_Id
:= No_List
;
6567 Prim_Als
: Entity_Id
;
6568 Prim_Elmt
: Elmt_Id
;
6572 type Examined_Array
is array (Int
range <>) of Boolean;
6574 function Find_Entry_Index
(E
: Entity_Id
) return Uint
;
6575 -- Given an entry, find its index in the visible declarations of the
6576 -- corresponding concurrent type of Typ.
6578 ----------------------
6579 -- Find_Entry_Index --
6580 ----------------------
6582 function Find_Entry_Index
(E
: Entity_Id
) return Uint
is
6583 Index
: Uint
:= Uint_1
;
6584 Subp_Decl
: Entity_Id
;
6588 and then not Is_Empty_List
(Decls
)
6590 Subp_Decl
:= First
(Decls
);
6591 while Present
(Subp_Decl
) loop
6592 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
6593 if Defining_Identifier
(Subp_Decl
) = E
then
6605 end Find_Entry_Index
;
6611 -- Start of processing for Make_Select_Specific_Data_Table
6614 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
6616 if Present
(Corresponding_Concurrent_Type
(Typ
)) then
6617 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
6619 if Present
(Full_View
(Conc_Typ
)) then
6620 Conc_Typ
:= Full_View
(Conc_Typ
);
6623 if Ekind
(Conc_Typ
) = E_Protected_Type
then
6624 Decls
:= Visible_Declarations
(Protected_Definition
(
6625 Parent
(Conc_Typ
)));
6627 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
6628 Decls
:= Visible_Declarations
(Task_Definition
(
6629 Parent
(Conc_Typ
)));
6633 -- Count the non-predefined primitive operations
6635 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6636 while Present
(Prim_Elmt
) loop
6637 Prim
:= Node
(Prim_Elmt
);
6639 if not (Is_Predefined_Dispatching_Operation
(Prim
)
6640 or else Is_Predefined_Dispatching_Alias
(Prim
))
6642 Nb_Prim
:= Nb_Prim
+ 1;
6645 Next_Elmt
(Prim_Elmt
);
6649 Examined
: Examined_Array
(1 .. Nb_Prim
) := (others => False);
6652 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6653 while Present
(Prim_Elmt
) loop
6654 Prim
:= Node
(Prim_Elmt
);
6656 -- Look for primitive overriding an abstract interface subprogram
6658 if Present
(Interface_Alias
(Prim
))
6661 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
6662 Use_Full_View
=> True)
6663 and then not Examined
(UI_To_Int
(DT_Position
(Alias
(Prim
))))
6665 Prim_Pos
:= DT_Position
(Alias
(Prim
));
6666 pragma Assert
(UI_To_Int
(Prim_Pos
) <= Nb_Prim
);
6667 Examined
(UI_To_Int
(Prim_Pos
)) := True;
6669 -- Set the primitive operation kind regardless of subprogram
6671 -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
6673 if Tagged_Type_Expansion
then
6676 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
);
6680 Make_Attribute_Reference
(Loc
,
6681 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6682 Attribute_Name
=> Name_Tag
);
6685 Append_To
(Assignments
,
6686 Make_Procedure_Call_Statement
(Loc
,
6687 Name
=> New_Occurrence_Of
(RTE
(RE_Set_Prim_Op_Kind
), Loc
),
6688 Parameter_Associations
=> New_List
(
6690 Make_Integer_Literal
(Loc
, Prim_Pos
),
6691 Prim_Op_Kind
(Alias
(Prim
), Typ
))));
6693 -- Retrieve the root of the alias chain
6695 Prim_Als
:= Ultimate_Alias
(Prim
);
6697 -- In the case of an entry wrapper, set the entry index
6699 if Ekind
(Prim
) = E_Procedure
6700 and then Is_Primitive_Wrapper
(Prim_Als
)
6701 and then Ekind
(Wrapped_Entity
(Prim_Als
)) = E_Entry
6704 -- Ada.Tags.Set_Entry_Index
6705 -- (DT_Ptr, <position>, <index>);
6707 if Tagged_Type_Expansion
then
6710 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
);
6713 Make_Attribute_Reference
(Loc
,
6714 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6715 Attribute_Name
=> Name_Tag
);
6718 Append_To
(Assignments
,
6719 Make_Procedure_Call_Statement
(Loc
,
6721 New_Occurrence_Of
(RTE
(RE_Set_Entry_Index
), Loc
),
6722 Parameter_Associations
=> New_List
(
6724 Make_Integer_Literal
(Loc
, Prim_Pos
),
6725 Make_Integer_Literal
(Loc
,
6726 Find_Entry_Index
(Wrapped_Entity
(Prim_Als
))))));
6730 Next_Elmt
(Prim_Elmt
);
6735 end Make_Select_Specific_Data_Table
;
6741 function Make_Tags
(Typ
: Entity_Id
) return List_Id
is
6742 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6743 Result
: constant List_Id
:= New_List
;
6746 (Tag_Typ
: Entity_Id
;
6748 Is_Secondary_DT
: Boolean);
6749 -- Import the dispatch table DT of tagged type Tag_Typ. Required to
6750 -- generate forward references and statically allocate the table. For
6751 -- primary dispatch tables that require no dispatch table generate:
6753 -- DT : static aliased constant Non_Dispatch_Table_Wrapper;
6754 -- pragma Import (Ada, DT);
6756 -- Otherwise generate:
6758 -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
6759 -- pragma Import (Ada, DT);
6766 (Tag_Typ
: Entity_Id
;
6768 Is_Secondary_DT
: Boolean)
6770 DT_Constr_List
: List_Id
;
6774 Set_Is_Imported
(DT
);
6775 Set_Ekind
(DT
, E_Constant
);
6776 Set_Related_Type
(DT
, Typ
);
6778 -- The scope must be set now to call Get_External_Name
6780 Set_Scope
(DT
, Current_Scope
);
6782 Get_External_Name
(DT
);
6783 Set_Interface_Name
(DT
,
6784 Make_String_Literal
(Loc
, Strval
=> String_From_Name_Buffer
));
6786 -- Ensure proper Sprint output of this implicit importation
6788 Set_Is_Internal
(DT
);
6790 -- Save this entity to allow Make_DT to generate its exportation
6792 Append_Elmt
(DT
, Dispatch_Table_Wrappers
(Typ
));
6794 -- No dispatch table required
6796 if not Is_Secondary_DT
and then not Has_DT
(Tag_Typ
) then
6798 Make_Object_Declaration
(Loc
,
6799 Defining_Identifier
=> DT
,
6800 Aliased_Present
=> True,
6801 Constant_Present
=> True,
6802 Object_Definition
=>
6804 (RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
)));
6807 -- Calculate the number of primitives of the dispatch table and
6808 -- the size of the Type_Specific_Data record.
6811 UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Tag_Typ
)));
6813 -- If the tagged type has no primitives we add a dummy slot whose
6814 -- address will be the tag of this type.
6818 New_List
(Make_Integer_Literal
(Loc
, 1));
6821 New_List
(Make_Integer_Literal
(Loc
, Nb_Prim
));
6825 Make_Object_Declaration
(Loc
,
6826 Defining_Identifier
=> DT
,
6827 Aliased_Present
=> True,
6828 Constant_Present
=> True,
6829 Object_Definition
=>
6830 Make_Subtype_Indication
(Loc
,
6832 New_Occurrence_Of
(RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
6833 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
6834 Constraints
=> DT_Constr_List
))));
6840 Tname
: constant Name_Id
:= Chars
(Typ
);
6841 AI_Tag_Comp
: Elmt_Id
;
6842 DT
: Node_Id
:= Empty
;
6844 Predef_Prims_Ptr
: Node_Id
;
6845 Iface_DT
: Node_Id
:= Empty
;
6846 Iface_DT_Ptr
: Node_Id
;
6850 Typ_Comps
: Elist_Id
;
6852 -- Start of processing for Make_Tags
6855 pragma Assert
(No
(Access_Disp_Table
(Typ
)));
6856 Set_Access_Disp_Table
(Typ
, New_Elmt_List
);
6858 -- If the elaboration of this tagged type needs a boolean flag then
6859 -- define now its entity. It is initialized to True to indicate that
6860 -- elaboration is still pending; set to False by the IP routine.
6862 -- TypFxx : boolean := True;
6864 if Elab_Flag_Needed
(Typ
) then
6865 Set_Access_Disp_Table_Elab_Flag
(Typ
,
6866 Make_Defining_Identifier
(Loc
,
6867 Chars
=> New_External_Name
(Tname
, 'F')));
6870 Make_Object_Declaration
(Loc
,
6871 Defining_Identifier
=> Access_Disp_Table_Elab_Flag
(Typ
),
6872 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
6873 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
6876 -- 1) Generate the primary tag entities
6878 -- Primary dispatch table containing user-defined primitives
6880 DT_Ptr
:= Make_Defining_Identifier
(Loc
, New_External_Name
(Tname
, 'P'));
6881 Set_Etype
(DT_Ptr
, RTE
(RE_Tag
));
6882 Append_Elmt
(DT_Ptr
, Access_Disp_Table
(Typ
));
6884 -- Minimum decoration
6886 Set_Ekind
(DT_Ptr
, E_Variable
);
6887 Set_Related_Type
(DT_Ptr
, Typ
);
6889 -- Notify back end that the types are associated with a dispatch table
6891 Set_Is_Dispatch_Table_Entity
(RTE
(RE_Prim_Ptr
));
6892 Set_Is_Dispatch_Table_Entity
(RTE
(RE_Predef_Prims_Table_Ptr
));
6894 -- For CPP types there is no need to build the dispatch tables since
6895 -- they are imported from the C++ side. If the CPP type has an IP then
6896 -- we declare now the variable that will store the copy of the C++ tag.
6897 -- If the CPP type is an interface, we need the variable as well because
6898 -- it becomes the pointer to the corresponding secondary table.
6900 if Is_CPP_Class
(Typ
) then
6901 if Has_CPP_Constructors
(Typ
) or else Is_Interface
(Typ
) then
6903 Make_Object_Declaration
(Loc
,
6904 Defining_Identifier
=> DT_Ptr
,
6905 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
6907 Unchecked_Convert_To
(RTE
(RE_Tag
),
6908 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
6910 Set_Is_Statically_Allocated
(DT_Ptr
,
6911 Is_Library_Level_Tagged_Type
(Typ
));
6917 -- Primary dispatch table containing predefined primitives
6920 Make_Defining_Identifier
(Loc
,
6921 Chars
=> New_External_Name
(Tname
, 'Y'));
6922 Set_Etype
(Predef_Prims_Ptr
, RTE
(RE_Address
));
6923 Append_Elmt
(Predef_Prims_Ptr
, Access_Disp_Table
(Typ
));
6925 -- Import the forward declaration of the Dispatch Table wrapper
6926 -- record (Make_DT will take care of exporting it).
6928 if Building_Static_DT
(Typ
) then
6929 Set_Dispatch_Table_Wrappers
(Typ
, New_Elmt_List
);
6932 Make_Defining_Identifier
(Loc
,
6933 Chars
=> New_External_Name
(Tname
, 'T'));
6935 Import_DT
(Typ
, DT
, Is_Secondary_DT
=> False);
6937 if Has_DT
(Typ
) then
6939 Make_Object_Declaration
(Loc
,
6940 Defining_Identifier
=> DT_Ptr
,
6941 Constant_Present
=> True,
6942 Object_Definition
=>
6943 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
6945 Unchecked_Convert_To
(RTE
(RE_Tag
),
6946 Make_Attribute_Reference
(Loc
,
6948 Make_Selected_Component
(Loc
,
6949 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
6952 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
6953 Attribute_Name
=> Name_Address
))));
6955 -- Generate the SCIL node for the previous object declaration
6956 -- because it has a tag initialization.
6958 if Generate_SCIL
then
6960 Make_SCIL_Dispatch_Table_Tag_Init
(Sloc
(Last
(Result
)));
6961 Set_SCIL_Entity
(New_Node
, Typ
);
6962 Set_SCIL_Node
(Last
(Result
), New_Node
);
6966 Make_Object_Declaration
(Loc
,
6967 Defining_Identifier
=> Predef_Prims_Ptr
,
6968 Constant_Present
=> True,
6969 Object_Definition
=>
6970 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
6972 Make_Attribute_Reference
(Loc
,
6974 Make_Selected_Component
(Loc
,
6975 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
6978 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
6979 Attribute_Name
=> Name_Address
)));
6981 -- No dispatch table required
6985 Make_Object_Declaration
(Loc
,
6986 Defining_Identifier
=> DT_Ptr
,
6987 Constant_Present
=> True,
6988 Object_Definition
=>
6989 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
6991 Unchecked_Convert_To
(RTE
(RE_Tag
),
6992 Make_Attribute_Reference
(Loc
,
6994 Make_Selected_Component
(Loc
,
6995 Prefix
=> New_Occurrence_Of
(DT
, Loc
),
6998 (RTE_Record_Component
(RE_NDT_Prims_Ptr
),
7000 Attribute_Name
=> Name_Address
))));
7003 Set_Is_True_Constant
(DT_Ptr
);
7004 Set_Is_Statically_Allocated
(DT_Ptr
);
7008 -- 2) Generate the secondary tag entities
7010 -- Collect the components associated with secondary dispatch tables
7012 if Has_Interfaces
(Typ
) then
7013 Collect_Interface_Components
(Typ
, Typ_Comps
);
7015 -- For each interface type we build a unique external name associated
7016 -- with its secondary dispatch table. This name is used to declare an
7017 -- object that references this secondary dispatch table, whose value
7018 -- will be used for the elaboration of Typ objects, and also for the
7019 -- elaboration of objects of types derived from Typ that do not
7020 -- override the primitives of this interface type.
7024 -- Note: The value of Suffix_Index must be in sync with the values of
7025 -- Suffix_Index in secondary dispatch tables generated by Make_DT.
7027 if Is_CPP_Class
(Typ
) then
7028 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
7029 while Present
(AI_Tag_Comp
) loop
7030 Get_Secondary_DT_External_Name
7031 (Typ
, Related_Type
(Node
(AI_Tag_Comp
)), Suffix_Index
);
7032 Typ_Name
:= Name_Find
;
7034 -- Declare variables to store copy of the C++ secondary tags
7037 Make_Defining_Identifier
(Loc
,
7038 Chars
=> New_External_Name
(Typ_Name
, 'P'));
7039 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7040 Set_Ekind
(Iface_DT_Ptr
, E_Variable
);
7041 Set_Is_Tag
(Iface_DT_Ptr
);
7043 Set_Has_Thunks
(Iface_DT_Ptr
);
7045 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7046 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7049 Make_Object_Declaration
(Loc
,
7050 Defining_Identifier
=> Iface_DT_Ptr
,
7051 Object_Definition
=> New_Occurrence_Of
7052 (RTE
(RE_Interface_Tag
), Loc
),
7054 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
7055 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))));
7057 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7058 Is_Library_Level_Tagged_Type
(Typ
));
7060 Next_Elmt
(AI_Tag_Comp
);
7063 -- This is not a CPP_Class type
7066 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
7067 while Present
(AI_Tag_Comp
) loop
7068 Get_Secondary_DT_External_Name
7069 (Typ
, Related_Type
(Node
(AI_Tag_Comp
)), Suffix_Index
);
7070 Typ_Name
:= Name_Find
;
7072 if Building_Static_DT
(Typ
) then
7074 Make_Defining_Identifier
(Loc
,
7075 Chars
=> New_External_Name
(Typ_Name
, 'T'));
7077 (Tag_Typ
=> Related_Type
(Node
(AI_Tag_Comp
)),
7079 Is_Secondary_DT
=> True);
7082 -- Secondary dispatch table referencing thunks to user-defined
7083 -- primitives covered by this interface.
7086 Make_Defining_Identifier
(Loc
,
7087 Chars
=> New_External_Name
(Typ_Name
, 'P'));
7088 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7089 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
7090 Set_Is_Tag
(Iface_DT_Ptr
);
7091 Set_Has_Thunks
(Iface_DT_Ptr
);
7092 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7093 Is_Library_Level_Tagged_Type
(Typ
));
7094 Set_Is_True_Constant
(Iface_DT_Ptr
);
7096 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7097 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7099 if Building_Static_DT
(Typ
) then
7101 Make_Object_Declaration
(Loc
,
7102 Defining_Identifier
=> Iface_DT_Ptr
,
7103 Constant_Present
=> True,
7104 Object_Definition
=> New_Occurrence_Of
7105 (RTE
(RE_Interface_Tag
), Loc
),
7107 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
7108 Make_Attribute_Reference
(Loc
,
7110 Make_Selected_Component
(Loc
,
7112 New_Occurrence_Of
(Iface_DT
, Loc
),
7115 (RTE_Record_Component
(RE_Prims_Ptr
),
7117 Attribute_Name
=> Name_Address
))));
7120 -- Secondary dispatch table referencing thunks to predefined
7124 Make_Defining_Identifier
(Loc
,
7125 Chars
=> New_External_Name
(Typ_Name
, 'Y'));
7126 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Address
));
7127 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
7128 Set_Is_Tag
(Iface_DT_Ptr
);
7129 Set_Has_Thunks
(Iface_DT_Ptr
);
7130 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7131 Is_Library_Level_Tagged_Type
(Typ
));
7132 Set_Is_True_Constant
(Iface_DT_Ptr
);
7134 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7135 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7137 -- Secondary dispatch table referencing user-defined primitives
7138 -- covered by this interface.
7141 Make_Defining_Identifier
(Loc
,
7142 Chars
=> New_External_Name
(Typ_Name
, 'D'));
7143 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
7144 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
7145 Set_Is_Tag
(Iface_DT_Ptr
);
7146 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7147 Is_Library_Level_Tagged_Type
(Typ
));
7148 Set_Is_True_Constant
(Iface_DT_Ptr
);
7150 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7151 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7153 -- Secondary dispatch table referencing predefined primitives
7156 Make_Defining_Identifier
(Loc
,
7157 Chars
=> New_External_Name
(Typ_Name
, 'Z'));
7158 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Address
));
7159 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
7160 Set_Is_Tag
(Iface_DT_Ptr
);
7161 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
7162 Is_Library_Level_Tagged_Type
(Typ
));
7163 Set_Is_True_Constant
(Iface_DT_Ptr
);
7165 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
7166 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
7168 Next_Elmt
(AI_Tag_Comp
);
7173 -- 3) At the end of Access_Disp_Table, if the type has user-defined
7174 -- primitives, we add the entity of an access type declaration that
7175 -- is used by Build_Get_Prim_Op_Address to expand dispatching calls
7176 -- through the primary dispatch table.
7178 if UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Typ
))) = 0 then
7179 Analyze_List
(Result
);
7182 -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
7183 -- type Typ_DT_Acc is access Typ_DT;
7187 Name_DT_Prims
: constant Name_Id
:=
7188 New_External_Name
(Tname
, 'G');
7189 Name_DT_Prims_Acc
: constant Name_Id
:=
7190 New_External_Name
(Tname
, 'H');
7191 DT_Prims
: constant Entity_Id
:=
7192 Make_Defining_Identifier
(Loc
,
7194 DT_Prims_Acc
: constant Entity_Id
:=
7195 Make_Defining_Identifier
(Loc
,
7199 Make_Full_Type_Declaration
(Loc
,
7200 Defining_Identifier
=> DT_Prims
,
7202 Make_Constrained_Array_Definition
(Loc
,
7203 Discrete_Subtype_Definitions
=> New_List
(
7205 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
7206 High_Bound
=> Make_Integer_Literal
(Loc
,
7208 (First_Tag_Component
(Typ
))))),
7209 Component_Definition
=>
7210 Make_Component_Definition
(Loc
,
7211 Subtype_Indication
=>
7212 New_Occurrence_Of
(RTE
(RE_Prim_Ptr
), Loc
)))));
7215 Make_Full_Type_Declaration
(Loc
,
7216 Defining_Identifier
=> DT_Prims_Acc
,
7218 Make_Access_To_Object_Definition
(Loc
,
7219 Subtype_Indication
=>
7220 New_Occurrence_Of
(DT_Prims
, Loc
))));
7222 Append_Elmt
(DT_Prims_Acc
, Access_Disp_Table
(Typ
));
7224 -- Analyze the resulting list and suppress the generation of the
7225 -- Init_Proc associated with the above array declaration because
7226 -- this type is never used in object declarations. It is only used
7227 -- to simplify the expansion associated with dispatching calls.
7229 Analyze_List
(Result
);
7230 Set_Suppress_Initialization
(Base_Type
(DT_Prims
));
7232 -- Disable backend optimizations based on assumptions about the
7233 -- aliasing status of objects designated by the access to the
7234 -- dispatch table. Required to handle dispatch tables imported
7237 Set_No_Strict_Aliasing
(Base_Type
(DT_Prims_Acc
));
7239 -- Add the freezing nodes of these declarations; required to avoid
7240 -- generating these freezing nodes in wrong scopes (for example in
7241 -- the IC routine of a derivation of Typ).
7243 -- What is an "IC routine"? Is "init_proc" meant here???
7245 Append_List_To
(Result
, Freeze_Entity
(DT_Prims
, Typ
));
7246 Append_List_To
(Result
, Freeze_Entity
(DT_Prims_Acc
, Typ
));
7248 -- Mark entity of dispatch table. Required by the back end to
7249 -- handle them properly.
7251 Set_Is_Dispatch_Table_Entity
(DT_Prims
);
7255 -- Mark entities of dispatch table. Required by the back end to handle
7258 if Present
(DT
) then
7259 Set_Is_Dispatch_Table_Entity
(DT
);
7260 Set_Is_Dispatch_Table_Entity
(Etype
(DT
));
7263 if Present
(Iface_DT
) then
7264 Set_Is_Dispatch_Table_Entity
(Iface_DT
);
7265 Set_Is_Dispatch_Table_Entity
(Etype
(Iface_DT
));
7268 if Is_CPP_Class
(Root_Type
(Typ
)) then
7269 Set_Ekind
(DT_Ptr
, E_Variable
);
7271 Set_Ekind
(DT_Ptr
, E_Constant
);
7274 Set_Is_Tag
(DT_Ptr
);
7275 Set_Related_Type
(DT_Ptr
, Typ
);
7284 function New_Value
(From
: Node_Id
) return Node_Id
is
7285 Res
: constant Node_Id
:= Duplicate_Subexpr
(From
);
7287 if Is_Access_Type
(Etype
(From
)) then
7288 return Make_Explicit_Dereference
(Sloc
(From
), Prefix
=> Res
);
7294 -----------------------------------
7295 -- Original_View_In_Visible_Part --
7296 -----------------------------------
7298 function Original_View_In_Visible_Part
(Typ
: Entity_Id
) return Boolean is
7299 Scop
: constant Entity_Id
:= Scope
(Typ
);
7302 -- The scope must be a package
7304 if not Is_Package_Or_Generic_Package
(Scop
) then
7308 -- A type with a private declaration has a private view declared in
7309 -- the visible part.
7311 if Has_Private_Declaration
(Typ
) then
7315 return List_Containing
(Parent
(Typ
)) =
7316 Visible_Declarations
(Package_Specification
(Scop
));
7317 end Original_View_In_Visible_Part
;
7323 function Prim_Op_Kind
7325 Typ
: Entity_Id
) return Node_Id
7327 Full_Typ
: Entity_Id
:= Typ
;
7328 Loc
: constant Source_Ptr
:= Sloc
(Prim
);
7329 Prim_Op
: Entity_Id
;
7332 -- Retrieve the original primitive operation
7334 Prim_Op
:= Ultimate_Alias
(Prim
);
7336 if Ekind
(Typ
) = E_Record_Type
7337 and then Present
(Corresponding_Concurrent_Type
(Typ
))
7339 Full_Typ
:= Corresponding_Concurrent_Type
(Typ
);
7342 -- When a private tagged type is completed by a concurrent type,
7343 -- retrieve the full view.
7345 if Is_Private_Type
(Full_Typ
) then
7346 Full_Typ
:= Full_View
(Full_Typ
);
7349 if Ekind
(Prim_Op
) = E_Function
then
7351 -- Protected function
7353 if Ekind
(Full_Typ
) = E_Protected_Type
then
7354 return New_Occurrence_Of
(RTE
(RE_POK_Protected_Function
), Loc
);
7358 elsif Ekind
(Full_Typ
) = E_Task_Type
then
7359 return New_Occurrence_Of
(RTE
(RE_POK_Task_Function
), Loc
);
7364 return New_Occurrence_Of
(RTE
(RE_POK_Function
), Loc
);
7368 pragma Assert
(Ekind
(Prim_Op
) = E_Procedure
);
7370 if Ekind
(Full_Typ
) = E_Protected_Type
then
7374 if Is_Primitive_Wrapper
(Prim_Op
)
7375 and then Ekind
(Wrapped_Entity
(Prim_Op
)) = E_Entry
7377 return New_Occurrence_Of
(RTE
(RE_POK_Protected_Entry
), Loc
);
7379 -- Protected procedure
7383 New_Occurrence_Of
(RTE
(RE_POK_Protected_Procedure
), Loc
);
7386 elsif Ekind
(Full_Typ
) = E_Task_Type
then
7390 if Is_Primitive_Wrapper
(Prim_Op
)
7391 and then Ekind
(Wrapped_Entity
(Prim_Op
)) = E_Entry
7393 return New_Occurrence_Of
(RTE
(RE_POK_Task_Entry
), Loc
);
7395 -- Task "procedure". These are the internally Expander-generated
7396 -- procedures (task body for instance).
7399 return New_Occurrence_Of
(RTE
(RE_POK_Task_Procedure
), Loc
);
7402 -- Regular procedure
7405 return New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
);
7410 ------------------------
7411 -- Register_Primitive --
7412 ------------------------
7414 function Register_Primitive
7416 Prim
: Entity_Id
) return List_Id
7419 Iface_Prim
: Entity_Id
;
7420 Iface_Typ
: Entity_Id
;
7421 Iface_DT_Ptr
: Entity_Id
;
7422 Iface_DT_Elmt
: Elmt_Id
;
7423 L
: constant List_Id
:= New_List
;
7426 Tag_Typ
: Entity_Id
;
7427 Thunk_Id
: Entity_Id
;
7428 Thunk_Code
: Node_Id
;
7431 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
7433 -- Do not register in the dispatch table eliminated primitives
7435 if not RTE_Available
(RE_Tag
)
7436 or else Is_Eliminated
(Ultimate_Alias
(Prim
))
7437 or else Generate_SCIL
7442 if not Present
(Interface_Alias
(Prim
)) then
7443 Tag_Typ
:= Scope
(DTC_Entity
(Prim
));
7444 Pos
:= DT_Position
(Prim
);
7445 Tag
:= First_Tag_Component
(Tag_Typ
);
7447 if Is_Predefined_Dispatching_Operation
(Prim
)
7448 or else Is_Predefined_Dispatching_Alias
(Prim
)
7451 Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Tag_Typ
))));
7454 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7455 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7458 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7459 Make_Attribute_Reference
(Loc
,
7460 Prefix
=> New_Occurrence_Of
(Prim
, Loc
),
7461 Attribute_Name
=> Name_Unrestricted_Access
))));
7463 -- Register copy of the pointer to the 'size primitive in the TSD
7465 if Chars
(Prim
) = Name_uSize
7466 and then RTE_Record_Component_Available
(RE_Size_Func
)
7468 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Tag_Typ
)));
7470 Build_Set_Size_Function
(Loc
,
7471 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7472 Size_Func
=> Prim
));
7476 pragma Assert
(Pos
/= Uint_0
and then Pos
<= DT_Entry_Count
(Tag
));
7478 -- Skip registration of primitives located in the C++ part of the
7479 -- dispatch table. Their slot is set by the IC routine.
7481 if not Is_CPP_Class
(Root_Type
(Tag_Typ
))
7482 or else Pos
> CPP_Num_Prims
(Tag_Typ
)
7484 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Tag_Typ
)));
7486 Build_Set_Prim_Op_Address
(Loc
,
7488 Tag_Node
=> New_Occurrence_Of
(DT_Ptr
, Loc
),
7491 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7492 Make_Attribute_Reference
(Loc
,
7493 Prefix
=> New_Occurrence_Of
(Prim
, Loc
),
7494 Attribute_Name
=> Name_Unrestricted_Access
))));
7498 -- Ada 2005 (AI-251): Primitive associated with an interface type
7500 -- Generate the code of the thunk only if the interface type is not an
7501 -- immediate ancestor of Typ; otherwise the dispatch table associated
7502 -- with the interface is the primary dispatch table and we have nothing
7506 Tag_Typ
:= Find_Dispatching_Type
(Alias
(Prim
));
7507 Iface_Typ
:= Find_Dispatching_Type
(Interface_Alias
(Prim
));
7509 pragma Assert
(Is_Interface
(Iface_Typ
));
7511 -- No action needed for interfaces that are ancestors of Typ because
7512 -- their primitives are located in the primary dispatch table.
7514 if Is_Ancestor
(Iface_Typ
, Tag_Typ
, Use_Full_View
=> True) then
7517 -- No action needed for primitives located in the C++ part of the
7518 -- dispatch table. Their slot is set by the IC routine.
7520 elsif Is_CPP_Class
(Root_Type
(Tag_Typ
))
7521 and then DT_Position
(Alias
(Prim
)) <= CPP_Num_Prims
(Tag_Typ
)
7522 and then not Is_Predefined_Dispatching_Operation
(Prim
)
7523 and then not Is_Predefined_Dispatching_Alias
(Prim
)
7528 Expand_Interface_Thunk
(Prim
, Thunk_Id
, Thunk_Code
);
7530 if not Is_Ancestor
(Iface_Typ
, Tag_Typ
, Use_Full_View
=> True)
7531 and then Present
(Thunk_Code
)
7533 -- Generate the code necessary to fill the appropriate entry of
7534 -- the secondary dispatch table of Prim's controlling type with
7535 -- Thunk_Id's address.
7537 Iface_DT_Elmt
:= Find_Interface_ADT
(Tag_Typ
, Iface_Typ
);
7538 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7539 pragma Assert
(Has_Thunks
(Iface_DT_Ptr
));
7541 Iface_Prim
:= Interface_Alias
(Prim
);
7542 Pos
:= DT_Position
(Iface_Prim
);
7543 Tag
:= First_Tag_Component
(Iface_Typ
);
7545 Prepend_To
(L
, Thunk_Code
);
7547 if Is_Predefined_Dispatching_Operation
(Prim
)
7548 or else Is_Predefined_Dispatching_Alias
(Prim
)
7551 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7553 New_Occurrence_Of
(Node
(Next_Elmt
(Iface_DT_Elmt
)), Loc
),
7556 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7557 Make_Attribute_Reference
(Loc
,
7558 Prefix
=> New_Occurrence_Of
(Thunk_Id
, Loc
),
7559 Attribute_Name
=> Name_Unrestricted_Access
))));
7561 Next_Elmt
(Iface_DT_Elmt
);
7562 Next_Elmt
(Iface_DT_Elmt
);
7563 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7564 pragma Assert
(not Has_Thunks
(Iface_DT_Ptr
));
7567 Build_Set_Predefined_Prim_Op_Address
(Loc
,
7569 New_Occurrence_Of
(Node
(Next_Elmt
(Iface_DT_Elmt
)), Loc
),
7572 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7573 Make_Attribute_Reference
(Loc
,
7575 New_Occurrence_Of
(Alias
(Prim
), Loc
),
7576 Attribute_Name
=> Name_Unrestricted_Access
))));
7579 pragma Assert
(Pos
/= Uint_0
7580 and then Pos
<= DT_Entry_Count
(Tag
));
7583 Build_Set_Prim_Op_Address
(Loc
,
7585 Tag_Node
=> New_Occurrence_Of
(Iface_DT_Ptr
, Loc
),
7588 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7589 Make_Attribute_Reference
(Loc
,
7590 Prefix
=> New_Occurrence_Of
(Thunk_Id
, Loc
),
7591 Attribute_Name
=> Name_Unrestricted_Access
))));
7593 Next_Elmt
(Iface_DT_Elmt
);
7594 Next_Elmt
(Iface_DT_Elmt
);
7595 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
7596 pragma Assert
(not Has_Thunks
(Iface_DT_Ptr
));
7599 Build_Set_Prim_Op_Address
(Loc
,
7601 Tag_Node
=> New_Occurrence_Of
(Iface_DT_Ptr
, Loc
),
7604 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
7605 Make_Attribute_Reference
(Loc
,
7607 New_Occurrence_Of
(Alias
(Prim
), Loc
),
7608 Attribute_Name
=> Name_Unrestricted_Access
))));
7615 end Register_Primitive
;
7617 -------------------------
7618 -- Set_All_DT_Position --
7619 -------------------------
7621 procedure Set_All_DT_Position
(Typ
: Entity_Id
) is
7623 function In_Predef_Prims_DT
(Prim
: Entity_Id
) return Boolean;
7624 -- Returns True if Prim is located in the dispatch table of
7625 -- predefined primitives
7627 procedure Validate_Position
(Prim
: Entity_Id
);
7628 -- Check that position assigned to Prim is completely safe (it has not
7629 -- been assigned to a previously defined primitive operation of Typ).
7631 ------------------------
7632 -- In_Predef_Prims_DT --
7633 ------------------------
7635 function In_Predef_Prims_DT
(Prim
: Entity_Id
) return Boolean is
7637 -- Predefined primitives
7639 if Is_Predefined_Dispatching_Operation
(Prim
) then
7642 -- Renamings of predefined primitives
7644 elsif Present
(Alias
(Prim
))
7645 and then Is_Predefined_Dispatching_Operation
(Ultimate_Alias
(Prim
))
7647 if Chars
(Ultimate_Alias
(Prim
)) /= Name_Op_Eq
then
7650 -- An overriding operation that is a user-defined renaming of
7651 -- predefined equality inherits its slot from the overridden
7652 -- operation. Otherwise it is treated as a predefined op and
7653 -- occupies the same predefined slot as equality. A call to it is
7654 -- transformed into a call to its alias, which is the predefined
7655 -- equality op. A dispatching call thus uses the proper slot if
7656 -- operation is further inherited and called with class-wide
7661 not Comes_From_Source
(Prim
)
7662 or else No
(Overridden_Operation
(Prim
));
7665 -- User-defined primitives
7670 end In_Predef_Prims_DT
;
7672 -----------------------
7673 -- Validate_Position --
7674 -----------------------
7676 procedure Validate_Position
(Prim
: Entity_Id
) is
7681 -- Aliased primitives are safe
7683 if Present
(Alias
(Prim
)) then
7687 Op_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
7688 while Present
(Op_Elmt
) loop
7689 Op
:= Node
(Op_Elmt
);
7691 -- No need to check against itself
7696 -- Primitive operations covering abstract interfaces are
7699 elsif Present
(Interface_Alias
(Op
)) then
7702 -- Predefined dispatching operations are completely safe. They
7703 -- are allocated at fixed positions in a separate table.
7705 elsif Is_Predefined_Dispatching_Operation
(Op
)
7706 or else Is_Predefined_Dispatching_Alias
(Op
)
7710 -- Aliased subprograms are safe
7712 elsif Present
(Alias
(Op
)) then
7715 elsif DT_Position
(Op
) = DT_Position
(Prim
)
7716 and then not Is_Predefined_Dispatching_Operation
(Op
)
7717 and then not Is_Predefined_Dispatching_Operation
(Prim
)
7718 and then not Is_Predefined_Dispatching_Alias
(Op
)
7719 and then not Is_Predefined_Dispatching_Alias
(Prim
)
7721 -- Handle aliased subprograms
7730 if Present
(Overridden_Operation
(Op_1
)) then
7731 Op_1
:= Overridden_Operation
(Op_1
);
7732 elsif Present
(Alias
(Op_1
)) then
7733 Op_1
:= Alias
(Op_1
);
7741 if Present
(Overridden_Operation
(Op_2
)) then
7742 Op_2
:= Overridden_Operation
(Op_2
);
7743 elsif Present
(Alias
(Op_2
)) then
7744 Op_2
:= Alias
(Op_2
);
7750 if Op_1
/= Op_2
then
7751 raise Program_Error
;
7756 Next_Elmt
(Op_Elmt
);
7758 end Validate_Position
;
7762 Parent_Typ
: constant Entity_Id
:= Etype
(Typ
);
7763 First_Prim
: constant Elmt_Id
:= First_Elmt
(Primitive_Operations
(Typ
));
7764 The_Tag
: constant Entity_Id
:= First_Tag_Component
(Typ
);
7766 Adjusted
: Boolean := False;
7767 Finalized
: Boolean := False;
7773 Prim_Elmt
: Elmt_Id
;
7775 -- Start of processing for Set_All_DT_Position
7778 pragma Assert
(Present
(First_Tag_Component
(Typ
)));
7780 -- Set the DT_Position for each primitive operation. Perform some sanity
7781 -- checks to avoid building inconsistent dispatch tables.
7783 -- First stage: Set DTC entity of all the primitive operations. This is
7784 -- required to properly read the DT_Position attribute in latter stages.
7786 Prim_Elmt
:= First_Prim
;
7788 while Present
(Prim_Elmt
) loop
7789 Prim
:= Node
(Prim_Elmt
);
7791 -- Predefined primitives have a separate dispatch table
7793 if not In_Predef_Prims_DT
(Prim
) then
7794 Count_Prim
:= Count_Prim
+ 1;
7797 Set_DTC_Entity_Value
(Typ
, Prim
);
7799 -- Clear any previous value of the DT_Position attribute. In this
7800 -- way we ensure that the final position of all the primitives is
7801 -- established by the following stages of this algorithm.
7803 Set_DT_Position_Value
(Prim
, No_Uint
);
7805 Next_Elmt
(Prim_Elmt
);
7809 Fixed_Prim
: array (Int
range 0 .. Count_Prim
) of Boolean :=
7814 procedure Handle_Inherited_Private_Subprograms
(Typ
: Entity_Id
);
7815 -- Called if Typ is declared in a nested package or a public child
7816 -- package to handle inherited primitives that were inherited by Typ
7817 -- in the visible part, but whose declaration was deferred because
7818 -- the parent operation was private and not visible at that point.
7820 procedure Set_Fixed_Prim
(Pos
: Nat
);
7821 -- Sets to true an element of the Fixed_Prim table to indicate
7822 -- that this entry of the dispatch table of Typ is occupied.
7824 ------------------------------------------
7825 -- Handle_Inherited_Private_Subprograms --
7826 ------------------------------------------
7828 procedure Handle_Inherited_Private_Subprograms
(Typ
: Entity_Id
) is
7831 Op_Elmt_2
: Elmt_Id
;
7832 Prim_Op
: Entity_Id
;
7833 Parent_Subp
: Entity_Id
;
7836 Op_List
:= Primitive_Operations
(Typ
);
7838 Op_Elmt
:= First_Elmt
(Op_List
);
7839 while Present
(Op_Elmt
) loop
7840 Prim_Op
:= Node
(Op_Elmt
);
7842 -- Search primitives that are implicit operations with an
7843 -- internal name whose parent operation has a normal name.
7845 if Present
(Alias
(Prim_Op
))
7846 and then Find_Dispatching_Type
(Alias
(Prim_Op
)) /= Typ
7847 and then not Comes_From_Source
(Prim_Op
)
7848 and then Is_Internal_Name
(Chars
(Prim_Op
))
7849 and then not Is_Internal_Name
(Chars
(Alias
(Prim_Op
)))
7851 Parent_Subp
:= Alias
(Prim_Op
);
7853 -- Check if the type has an explicit overriding for this
7856 Op_Elmt_2
:= Next_Elmt
(Op_Elmt
);
7857 while Present
(Op_Elmt_2
) loop
7858 if Chars
(Node
(Op_Elmt_2
)) = Chars
(Parent_Subp
)
7859 and then Type_Conformant
(Prim_Op
, Node
(Op_Elmt_2
))
7861 Set_DT_Position_Value
(Prim_Op
,
7862 DT_Position
(Parent_Subp
));
7863 Set_DT_Position_Value
(Node
(Op_Elmt_2
),
7864 DT_Position
(Parent_Subp
));
7865 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(Prim_Op
)));
7867 goto Next_Primitive
;
7870 Next_Elmt
(Op_Elmt_2
);
7875 Next_Elmt
(Op_Elmt
);
7877 end Handle_Inherited_Private_Subprograms
;
7879 --------------------
7880 -- Set_Fixed_Prim --
7881 --------------------
7883 procedure Set_Fixed_Prim
(Pos
: Nat
) is
7885 pragma Assert
(Pos
<= Count_Prim
);
7886 Fixed_Prim
(Pos
) := True;
7888 when Constraint_Error
=>
7889 raise Program_Error
;
7893 -- In case of nested packages and public child package it may be
7894 -- necessary a special management on inherited subprograms so that
7895 -- the dispatch table is properly filled.
7897 if Ekind
(Scope
(Scope
(Typ
))) = E_Package
7898 and then Scope
(Scope
(Typ
)) /= Standard_Standard
7899 and then ((Is_Derived_Type
(Typ
) and then not Is_Private_Type
(Typ
))
7901 (Nkind
(Parent
(Typ
)) = N_Private_Extension_Declaration
7902 and then Is_Generic_Type
(Typ
)))
7903 and then In_Open_Scopes
(Scope
(Etype
(Typ
)))
7904 and then Is_Base_Type
(Typ
)
7906 Handle_Inherited_Private_Subprograms
(Typ
);
7909 -- Second stage: Register fixed entries
7912 Prim_Elmt
:= First_Prim
;
7913 while Present
(Prim_Elmt
) loop
7914 Prim
:= Node
(Prim_Elmt
);
7916 -- Predefined primitives have a separate table and all its
7917 -- entries are at predefined fixed positions.
7919 if In_Predef_Prims_DT
(Prim
) then
7920 if Is_Predefined_Dispatching_Operation
(Prim
) then
7921 Set_DT_Position_Value
(Prim
,
7922 Default_Prim_Op_Position
(Prim
));
7924 else pragma Assert
(Present
(Alias
(Prim
)));
7925 Set_DT_Position_Value
(Prim
,
7926 Default_Prim_Op_Position
(Ultimate_Alias
(Prim
)));
7929 -- Overriding primitives of ancestor abstract interfaces
7931 elsif Present
(Interface_Alias
(Prim
))
7932 and then Is_Ancestor
7933 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
7934 Use_Full_View
=> True)
7936 pragma Assert
(DT_Position
(Prim
) = No_Uint
7937 and then Present
(DTC_Entity
(Interface_Alias
(Prim
))));
7939 E
:= Interface_Alias
(Prim
);
7940 Set_DT_Position_Value
(Prim
, DT_Position
(E
));
7943 (DT_Position
(Alias
(Prim
)) = No_Uint
7944 or else DT_Position
(Alias
(Prim
)) = DT_Position
(E
));
7945 Set_DT_Position_Value
(Alias
(Prim
), DT_Position
(E
));
7946 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(Prim
)));
7948 -- Overriding primitives must use the same entry as the overridden
7949 -- primitive. Note that the Alias of the operation is set when the
7950 -- operation is declared by a renaming, in which case it is not
7951 -- overriding. If it renames another primitive it will use the
7952 -- same dispatch table slot, but if it renames an operation in a
7953 -- nested package it's a new primitive and will have its own slot.
7955 elsif not Present
(Interface_Alias
(Prim
))
7956 and then Present
(Alias
(Prim
))
7957 and then Chars
(Prim
) = Chars
(Alias
(Prim
))
7958 and then Nkind
(Unit_Declaration_Node
(Prim
)) /=
7959 N_Subprogram_Renaming_Declaration
7962 Par_Type
: constant Entity_Id
:=
7963 Find_Dispatching_Type
(Alias
(Prim
));
7966 if Present
(Par_Type
)
7967 and then Par_Type
/= Typ
7968 and then Is_Ancestor
(Par_Type
, Typ
, Use_Full_View
=> True)
7969 and then Present
(DTC_Entity
(Alias
(Prim
)))
7972 Set_DT_Position_Value
(Prim
, DT_Position
(E
));
7974 if not Is_Predefined_Dispatching_Alias
(E
) then
7975 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(E
)));
7981 Next_Elmt
(Prim_Elmt
);
7984 -- Third stage: Fix the position of all the new primitives. Entries
7985 -- associated with primitives covering interfaces are handled in a
7988 Prim_Elmt
:= First_Prim
;
7989 while Present
(Prim_Elmt
) loop
7990 Prim
:= Node
(Prim_Elmt
);
7992 -- Skip primitives previously set entries
7994 if DT_Position
(Prim
) /= No_Uint
then
7997 -- Primitives covering interface primitives are handled later
7999 elsif Present
(Interface_Alias
(Prim
)) then
8003 -- Take the next available position in the DT
8006 Nb_Prim
:= Nb_Prim
+ 1;
8007 pragma Assert
(Nb_Prim
<= Count_Prim
);
8008 exit when not Fixed_Prim
(Nb_Prim
);
8011 Set_DT_Position_Value
(Prim
, UI_From_Int
(Nb_Prim
));
8012 Set_Fixed_Prim
(Nb_Prim
);
8015 Next_Elmt
(Prim_Elmt
);
8019 -- Fourth stage: Complete the decoration of primitives covering
8020 -- interfaces (that is, propagate the DT_Position attribute from
8021 -- the aliased primitive)
8023 Prim_Elmt
:= First_Prim
;
8024 while Present
(Prim_Elmt
) loop
8025 Prim
:= Node
(Prim_Elmt
);
8027 if DT_Position
(Prim
) = No_Uint
8028 and then Present
(Interface_Alias
(Prim
))
8030 pragma Assert
(Present
(Alias
(Prim
))
8031 and then Find_Dispatching_Type
(Alias
(Prim
)) = Typ
);
8033 -- Check if this entry will be placed in the primary DT
8036 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
,
8037 Use_Full_View
=> True)
8039 pragma Assert
(DT_Position
(Alias
(Prim
)) /= No_Uint
);
8040 Set_DT_Position_Value
(Prim
, DT_Position
(Alias
(Prim
)));
8042 -- Otherwise it will be placed in the secondary DT
8046 (DT_Position
(Interface_Alias
(Prim
)) /= No_Uint
);
8047 Set_DT_Position_Value
(Prim
,
8048 DT_Position
(Interface_Alias
(Prim
)));
8052 Next_Elmt
(Prim_Elmt
);
8055 -- Generate listing showing the contents of the dispatch tables. This
8056 -- action is done before some further static checks because in case of
8057 -- critical errors caused by a wrong dispatch table we need to see the
8058 -- contents of such table.
8060 if Debug_Flag_ZZ
then
8064 -- Final stage: Ensure that the table is correct plus some further
8065 -- verifications concerning the primitives.
8067 Prim_Elmt
:= First_Prim
;
8069 while Present
(Prim_Elmt
) loop
8070 Prim
:= Node
(Prim_Elmt
);
8072 -- At this point all the primitives MUST have a position in the
8075 if DT_Position
(Prim
) = No_Uint
then
8076 raise Program_Error
;
8079 -- Calculate real size of the dispatch table
8081 if not In_Predef_Prims_DT
(Prim
)
8082 and then UI_To_Int
(DT_Position
(Prim
)) > DT_Length
8084 DT_Length
:= UI_To_Int
(DT_Position
(Prim
));
8087 -- Ensure that the assigned position to non-predefined dispatching
8088 -- operations in the dispatch table is correct.
8090 if not Is_Predefined_Dispatching_Operation
(Prim
)
8091 and then not Is_Predefined_Dispatching_Alias
(Prim
)
8093 Validate_Position
(Prim
);
8096 if Chars
(Prim
) = Name_Finalize
then
8100 if Chars
(Prim
) = Name_Adjust
then
8104 -- An abstract operation cannot be declared in the private part for a
8105 -- visible abstract type, because it can't be overridden outside this
8106 -- package hierarchy. For explicit declarations this is checked at
8107 -- the point of declaration, but for inherited operations it must be
8108 -- done when building the dispatch table.
8110 -- Ada 2005 (AI-251): Primitives associated with interfaces are
8111 -- excluded from this check because interfaces must be visible in
8112 -- the public and private part (RM 7.3 (7.3/2))
8114 -- We disable this check in Relaxed_RM_Semantics mode, to accommodate
8117 if not Relaxed_RM_Semantics
8118 and then Is_Abstract_Type
(Typ
)
8119 and then Is_Abstract_Subprogram
(Prim
)
8120 and then Present
(Alias
(Prim
))
8121 and then not Is_Interface
8122 (Find_Dispatching_Type
(Ultimate_Alias
(Prim
)))
8123 and then not Present
(Interface_Alias
(Prim
))
8124 and then Is_Derived_Type
(Typ
)
8125 and then In_Private_Part
(Current_Scope
)
8127 List_Containing
(Parent
(Prim
)) =
8128 Private_Declarations
(Package_Specification
(Current_Scope
))
8129 and then Original_View_In_Visible_Part
(Typ
)
8131 -- We exclude Input and Output stream operations because
8132 -- Limited_Controlled inherits useless Input and Output stream
8133 -- operations from Root_Controlled, which can never be overridden.
8135 if not Is_TSS
(Prim
, TSS_Stream_Input
)
8137 not Is_TSS
(Prim
, TSS_Stream_Output
)
8140 ("abstract inherited private operation&" &
8141 " must be overridden (RM 3.9.3(10))",
8142 Parent
(Typ
), Prim
);
8146 Next_Elmt
(Prim_Elmt
);
8151 if Is_Controlled
(Typ
) then
8152 if not Finalized
then
8154 ("controlled type has no explicit Finalize method??", Typ
);
8156 elsif not Adjusted
then
8158 ("controlled type has no explicit Adjust method??", Typ
);
8162 -- Set the final size of the Dispatch Table
8164 Set_DT_Entry_Count
(The_Tag
, UI_From_Int
(DT_Length
));
8166 -- The derived type must have at least as many components as its parent
8167 -- (for root types Etype points to itself and the test cannot fail).
8169 if DT_Entry_Count
(The_Tag
) <
8170 DT_Entry_Count
(First_Tag_Component
(Parent_Typ
))
8172 raise Program_Error
;
8174 end Set_All_DT_Position
;
8176 --------------------------
8177 -- Set_CPP_Constructors --
8178 --------------------------
8180 procedure Set_CPP_Constructors
(Typ
: Entity_Id
) is
8182 function Gen_Parameters_Profile
(E
: Entity_Id
) return List_Id
;
8183 -- Duplicate the parameters profile of the imported C++ constructor
8184 -- adding an access to the object as an additional parameter.
8186 ----------------------------
8187 -- Gen_Parameters_Profile --
8188 ----------------------------
8190 function Gen_Parameters_Profile
(E
: Entity_Id
) return List_Id
is
8191 Loc
: constant Source_Ptr
:= Sloc
(E
);
8198 Make_Parameter_Specification
(Loc
,
8199 Defining_Identifier
=>
8200 Make_Defining_Identifier
(Loc
, Name_uInit
),
8201 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
8203 if Present
(Parameter_Specifications
(Parent
(E
))) then
8204 P
:= First
(Parameter_Specifications
(Parent
(E
)));
8205 while Present
(P
) loop
8207 Make_Parameter_Specification
(Loc
,
8208 Defining_Identifier
=>
8209 Make_Defining_Identifier
(Loc
,
8210 Chars
=> Chars
(Defining_Identifier
(P
))),
8211 Parameter_Type
=> New_Copy_Tree
(Parameter_Type
(P
)),
8212 Expression
=> New_Copy_Tree
(Expression
(P
))));
8218 end Gen_Parameters_Profile
;
8224 Found
: Boolean := False;
8230 Covers_Default_Constructor
: Entity_Id
:= Empty
;
8232 -- Start of processing for Set_CPP_Constructor
8235 pragma Assert
(Is_CPP_Class
(Typ
));
8237 -- Look for the constructor entities
8239 E
:= Next_Entity
(Typ
);
8240 while Present
(E
) loop
8241 if Ekind
(E
) = E_Function
8242 and then Is_Constructor
(E
)
8246 Parms
:= Gen_Parameters_Profile
(E
);
8248 Make_Defining_Identifier
(Loc
,
8249 Chars
=> Make_Init_Proc_Name
(Typ
));
8251 -- Case 1: Constructor of untagged type
8253 -- If the C++ class has no virtual methods then the matching Ada
8254 -- type is an untagged record type. In such case there is no need
8255 -- to generate a wrapper of the C++ constructor because the _tag
8256 -- component is not available.
8258 if not Is_Tagged_Type
(Typ
) then
8260 (Make_Subprogram_Declaration
(Loc
,
8262 Make_Procedure_Specification
(Loc
,
8263 Defining_Unit_Name
=> IP
,
8264 Parameter_Specifications
=> Parms
)));
8266 Set_Init_Proc
(Typ
, IP
);
8267 Set_Is_Imported
(IP
);
8268 Set_Is_Constructor
(IP
);
8269 Set_Interface_Name
(IP
, Interface_Name
(E
));
8270 Set_Convention
(IP
, Convention_CPP
);
8272 Set_Has_Completion
(IP
);
8274 -- Case 2: Constructor of a tagged type
8276 -- In this case we generate the IP as a wrapper of the the
8277 -- C++ constructor because IP must also save copy of the _tag
8278 -- generated in the C++ side. The copy of the _tag is used by
8279 -- Build_CPP_Init_Procedure to elaborate derivations of C++ types.
8282 -- procedure IP (_init : Typ; ...) is
8283 -- procedure ConstructorP (_init : Typ; ...);
8284 -- pragma Import (ConstructorP);
8286 -- ConstructorP (_init, ...);
8287 -- if Typ._tag = null then
8288 -- Typ._tag := _init._tag;
8294 Body_Stmts
: constant List_Id
:= New_List
;
8295 Constructor_Id
: Entity_Id
;
8296 Constructor_Decl_Node
: Node_Id
;
8297 Init_Tags_List
: List_Id
;
8300 Constructor_Id
:= Make_Temporary
(Loc
, 'P');
8302 Constructor_Decl_Node
:=
8303 Make_Subprogram_Declaration
(Loc
,
8304 Make_Procedure_Specification
(Loc
,
8305 Defining_Unit_Name
=> Constructor_Id
,
8306 Parameter_Specifications
=> Parms
));
8308 Set_Is_Imported
(Constructor_Id
);
8309 Set_Is_Constructor
(Constructor_Id
);
8310 Set_Interface_Name
(Constructor_Id
, Interface_Name
(E
));
8311 Set_Convention
(Constructor_Id
, Convention_CPP
);
8312 Set_Is_Public
(Constructor_Id
);
8313 Set_Has_Completion
(Constructor_Id
);
8315 -- Build the init procedure as a wrapper of this constructor
8317 Parms
:= Gen_Parameters_Profile
(E
);
8319 -- Invoke the C++ constructor
8322 Actuals
: constant List_Id
:= New_List
;
8326 while Present
(P
) loop
8328 New_Occurrence_Of
(Defining_Identifier
(P
), Loc
));
8332 Append_To
(Body_Stmts
,
8333 Make_Procedure_Call_Statement
(Loc
,
8334 Name
=> New_Occurrence_Of
(Constructor_Id
, Loc
),
8335 Parameter_Associations
=> Actuals
));
8338 -- Initialize copies of C++ primary and secondary tags
8340 Init_Tags_List
:= New_List
;
8347 Tag_Elmt
:= First_Elmt
(Access_Disp_Table
(Typ
));
8348 Tag_Comp
:= First_Tag_Component
(Typ
);
8350 while Present
(Tag_Elmt
)
8351 and then Is_Tag
(Node
(Tag_Elmt
))
8353 -- Skip the following assertion with primary tags
8354 -- because Related_Type is not set on primary tag
8358 (Tag_Comp
= First_Tag_Component
(Typ
)
8359 or else Related_Type
(Node
(Tag_Elmt
))
8360 = Related_Type
(Tag_Comp
));
8362 Append_To
(Init_Tags_List
,
8363 Make_Assignment_Statement
(Loc
,
8365 New_Occurrence_Of
(Node
(Tag_Elmt
), Loc
),
8367 Make_Selected_Component
(Loc
,
8369 Make_Identifier
(Loc
, Name_uInit
),
8371 New_Occurrence_Of
(Tag_Comp
, Loc
))));
8373 Tag_Comp
:= Next_Tag_Component
(Tag_Comp
);
8374 Next_Elmt
(Tag_Elmt
);
8378 Append_To
(Body_Stmts
,
8379 Make_If_Statement
(Loc
,
8384 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))),
8387 Unchecked_Convert_To
(RTE
(RE_Tag
),
8388 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
))),
8389 Then_Statements
=> Init_Tags_List
));
8392 Make_Subprogram_Body
(Loc
,
8394 Make_Procedure_Specification
(Loc
,
8395 Defining_Unit_Name
=> IP
,
8396 Parameter_Specifications
=> Parms
),
8397 Declarations
=> New_List
(Constructor_Decl_Node
),
8398 Handled_Statement_Sequence
=>
8399 Make_Handled_Sequence_Of_Statements
(Loc
,
8400 Statements
=> Body_Stmts
,
8401 Exception_Handlers
=> No_List
));
8403 Discard_Node
(IP_Body
);
8404 Set_Init_Proc
(Typ
, IP
);
8408 -- If this constructor has parameters and all its parameters have
8409 -- defaults then it covers the default constructor. The semantic
8410 -- analyzer ensures that only one constructor with defaults covers
8411 -- the default constructor.
8413 if Present
(Parameter_Specifications
(Parent
(E
)))
8414 and then Needs_No_Actuals
(E
)
8416 Covers_Default_Constructor
:= IP
;
8423 -- If there are no constructors, mark the type as abstract since we
8424 -- won't be able to declare objects of that type.
8427 Set_Is_Abstract_Type
(Typ
);
8430 -- Handle constructor that has all its parameters with defaults and
8431 -- hence it covers the default constructor. We generate a wrapper IP
8432 -- which calls the covering constructor.
8434 if Present
(Covers_Default_Constructor
) then
8436 Body_Stmts
: List_Id
;
8439 Loc
:= Sloc
(Covers_Default_Constructor
);
8441 Body_Stmts
:= New_List
(
8442 Make_Procedure_Call_Statement
(Loc
,
8444 New_Occurrence_Of
(Covers_Default_Constructor
, Loc
),
8445 Parameter_Associations
=> New_List
(
8446 Make_Identifier
(Loc
, Name_uInit
))));
8448 IP
:= Make_Defining_Identifier
(Loc
, Make_Init_Proc_Name
(Typ
));
8451 Make_Subprogram_Body
(Loc
,
8453 Make_Procedure_Specification
(Loc
,
8454 Defining_Unit_Name
=> IP
,
8455 Parameter_Specifications
=> New_List
(
8456 Make_Parameter_Specification
(Loc
,
8457 Defining_Identifier
=>
8458 Make_Defining_Identifier
(Loc
, Name_uInit
),
8459 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)))),
8461 Declarations
=> No_List
,
8463 Handled_Statement_Sequence
=>
8464 Make_Handled_Sequence_Of_Statements
(Loc
,
8465 Statements
=> Body_Stmts
,
8466 Exception_Handlers
=> No_List
));
8468 Discard_Node
(IP_Body
);
8469 Set_Init_Proc
(Typ
, IP
);
8473 -- If the CPP type has constructors then it must import also the default
8474 -- C++ constructor. It is required for default initialization of objects
8475 -- of the type. It is also required to elaborate objects of Ada types
8476 -- that are defined as derivations of this CPP type.
8478 if Has_CPP_Constructors
(Typ
)
8479 and then No
(Init_Proc
(Typ
))
8481 Error_Msg_N
("??default constructor must be imported from C++", Typ
);
8483 end Set_CPP_Constructors
;
8485 ---------------------------
8486 -- Set_DT_Position_Value --
8487 ---------------------------
8489 procedure Set_DT_Position_Value
(Prim
: Entity_Id
; Value
: Uint
) is
8491 Set_DT_Position
(Prim
, Value
);
8493 -- Propagate the value to the wrapped subprogram (if one is present)
8495 if Ekind_In
(Prim
, E_Function
, E_Procedure
)
8496 and then Is_Primitive_Wrapper
(Prim
)
8497 and then Present
(Wrapped_Entity
(Prim
))
8498 and then Is_Dispatching_Operation
(Wrapped_Entity
(Prim
))
8500 Set_DT_Position
(Wrapped_Entity
(Prim
), Value
);
8502 end Set_DT_Position_Value
;
8504 --------------------------
8505 -- Set_DTC_Entity_Value --
8506 --------------------------
8508 procedure Set_DTC_Entity_Value
8509 (Tagged_Type
: Entity_Id
;
8513 if Present
(Interface_Alias
(Prim
))
8514 and then Is_Interface
8515 (Find_Dispatching_Type
(Interface_Alias
(Prim
)))
8517 Set_DTC_Entity
(Prim
,
8520 Iface
=> Find_Dispatching_Type
(Interface_Alias
(Prim
))));
8522 Set_DTC_Entity
(Prim
,
8523 First_Tag_Component
(Tagged_Type
));
8526 -- Propagate the value to the wrapped subprogram (if one is present)
8528 if Ekind_In
(Prim
, E_Function
, E_Procedure
)
8529 and then Is_Primitive_Wrapper
(Prim
)
8530 and then Present
(Wrapped_Entity
(Prim
))
8531 and then Is_Dispatching_Operation
(Wrapped_Entity
(Prim
))
8533 Set_DTC_Entity
(Wrapped_Entity
(Prim
), DTC_Entity
(Prim
));
8535 end Set_DTC_Entity_Value
;
8541 function Tagged_Kind
(T
: Entity_Id
) return Node_Id
is
8542 Conc_Typ
: Entity_Id
;
8543 Loc
: constant Source_Ptr
:= Sloc
(T
);
8547 (Is_Tagged_Type
(T
) and then RTE_Available
(RE_Tagged_Kind
));
8551 if Is_Abstract_Type
(T
) then
8552 if Is_Limited_Record
(T
) then
8553 return New_Occurrence_Of
8554 (RTE
(RE_TK_Abstract_Limited_Tagged
), Loc
);
8556 return New_Occurrence_Of
8557 (RTE
(RE_TK_Abstract_Tagged
), Loc
);
8562 elsif Is_Concurrent_Record_Type
(T
) then
8563 Conc_Typ
:= Corresponding_Concurrent_Type
(T
);
8565 if Present
(Full_View
(Conc_Typ
)) then
8566 Conc_Typ
:= Full_View
(Conc_Typ
);
8569 if Ekind
(Conc_Typ
) = E_Protected_Type
then
8570 return New_Occurrence_Of
(RTE
(RE_TK_Protected
), Loc
);
8572 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
8573 return New_Occurrence_Of
(RTE
(RE_TK_Task
), Loc
);
8576 -- Regular tagged kinds
8579 if Is_Limited_Record
(T
) then
8580 return New_Occurrence_Of
(RTE
(RE_TK_Limited_Tagged
), Loc
);
8582 return New_Occurrence_Of
(RTE
(RE_TK_Tagged
), Loc
);
8591 procedure Write_DT
(Typ
: Entity_Id
) is
8596 -- Protect this procedure against wrong usage. Required because it will
8597 -- be used directly from GDB
8599 if not (Typ
<= Last_Node_Id
)
8600 or else not Is_Tagged_Type
(Typ
)
8602 Write_Str
("wrong usage: Write_DT must be used with tagged types");
8607 Write_Int
(Int
(Typ
));
8609 Write_Name
(Chars
(Typ
));
8611 if Is_Interface
(Typ
) then
8612 Write_Str
(" is interface");
8617 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
8618 while Present
(Elmt
) loop
8619 Prim
:= Node
(Elmt
);
8622 -- Indicate if this primitive will be allocated in the primary
8623 -- dispatch table or in a secondary dispatch table associated
8624 -- with an abstract interface type
8626 if Present
(DTC_Entity
(Prim
)) then
8627 if Etype
(DTC_Entity
(Prim
)) = RTE
(RE_Tag
) then
8634 -- Output the node of this primitive operation and its name
8636 Write_Int
(Int
(Prim
));
8639 if Is_Predefined_Dispatching_Operation
(Prim
) then
8640 Write_Str
("(predefined) ");
8643 -- Prefix the name of the primitive with its corresponding tagged
8644 -- type to facilitate seeing inherited primitives.
8646 if Present
(Alias
(Prim
)) then
8648 (Chars
(Find_Dispatching_Type
(Ultimate_Alias
(Prim
))));
8650 Write_Name
(Chars
(Typ
));
8654 Write_Name
(Chars
(Prim
));
8656 -- Indicate if this primitive has an aliased primitive
8658 if Present
(Alias
(Prim
)) then
8659 Write_Str
(" (alias = ");
8660 Write_Int
(Int
(Alias
(Prim
)));
8662 -- If the DTC_Entity attribute is already set we can also output
8663 -- the name of the interface covered by this primitive (if any).
8665 if Ekind_In
(Alias
(Prim
), E_Function
, E_Procedure
)
8666 and then Present
(DTC_Entity
(Alias
(Prim
)))
8667 and then Is_Interface
(Scope
(DTC_Entity
(Alias
(Prim
))))
8669 Write_Str
(" from interface ");
8670 Write_Name
(Chars
(Scope
(DTC_Entity
(Alias
(Prim
)))));
8673 if Present
(Interface_Alias
(Prim
)) then
8674 Write_Str
(", AI_Alias of ");
8676 if Is_Null_Interface_Primitive
(Interface_Alias
(Prim
)) then
8677 Write_Str
("null primitive ");
8681 (Chars
(Find_Dispatching_Type
(Interface_Alias
(Prim
))));
8683 Write_Int
(Int
(Interface_Alias
(Prim
)));
8689 -- Display the final position of this primitive in its associated
8690 -- (primary or secondary) dispatch table.
8692 if Present
(DTC_Entity
(Prim
))
8693 and then DT_Position
(Prim
) /= No_Uint
8695 Write_Str
(" at #");
8696 Write_Int
(UI_To_Int
(DT_Position
(Prim
)));
8699 if Is_Abstract_Subprogram
(Prim
) then
8700 Write_Str
(" is abstract;");
8702 -- Check if this is a null primitive
8704 elsif Comes_From_Source
(Prim
)
8705 and then Ekind
(Prim
) = E_Procedure
8706 and then Null_Present
(Parent
(Prim
))
8708 Write_Str
(" is null;");
8711 if Is_Eliminated
(Ultimate_Alias
(Prim
)) then
8712 Write_Str
(" (eliminated)");
8715 if Is_Imported
(Prim
)
8716 and then Convention
(Prim
) = Convention_CPP
8718 Write_Str
(" (C++)");