1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Exp_Ch7
; use Exp_Ch7
;
33 with Exp_Tss
; use Exp_Tss
;
34 with Exp_Util
; use Exp_Util
;
35 with Fname
; use Fname
;
36 with Itypes
; use Itypes
;
38 with Nlists
; use Nlists
;
39 with Nmake
; use Nmake
;
41 with Rtsfind
; use Rtsfind
;
42 with Sem_Disp
; use Sem_Disp
;
43 with Sem_Res
; use Sem_Res
;
44 with Sem_Util
; use Sem_Util
;
45 with Sinfo
; use Sinfo
;
46 with Snames
; use Snames
;
47 with Stand
; use Stand
;
48 with Tbuild
; use Tbuild
;
49 with Uintp
; use Uintp
;
51 package body Exp_Disp
is
53 Ada_Actions
: constant array (DT_Access_Action
) of RE_Id
:=
54 (CW_Membership
=> RE_CW_Membership
,
55 DT_Entry_Size
=> RE_DT_Entry_Size
,
56 DT_Prologue_Size
=> RE_DT_Prologue_Size
,
57 Get_Expanded_Name
=> RE_Get_Expanded_Name
,
58 Get_External_Tag
=> RE_Get_External_Tag
,
59 Get_Prim_Op_Address
=> RE_Get_Prim_Op_Address
,
60 Get_RC_Offset
=> RE_Get_RC_Offset
,
61 Get_Remotely_Callable
=> RE_Get_Remotely_Callable
,
62 Get_TSD
=> RE_Get_TSD
,
63 Inherit_DT
=> RE_Inherit_DT
,
64 Inherit_TSD
=> RE_Inherit_TSD
,
65 Register_Tag
=> RE_Register_Tag
,
66 Set_Expanded_Name
=> RE_Set_Expanded_Name
,
67 Set_External_Tag
=> RE_Set_External_Tag
,
68 Set_Prim_Op_Address
=> RE_Set_Prim_Op_Address
,
69 Set_RC_Offset
=> RE_Set_RC_Offset
,
70 Set_Remotely_Callable
=> RE_Set_Remotely_Callable
,
71 Set_TSD
=> RE_Set_TSD
,
72 TSD_Entry_Size
=> RE_TSD_Entry_Size
,
73 TSD_Prologue_Size
=> RE_TSD_Prologue_Size
);
75 CPP_Actions
: constant array (DT_Access_Action
) of RE_Id
:=
76 (CW_Membership
=> RE_CPP_CW_Membership
,
77 DT_Entry_Size
=> RE_CPP_DT_Entry_Size
,
78 DT_Prologue_Size
=> RE_CPP_DT_Prologue_Size
,
79 Get_Expanded_Name
=> RE_CPP_Get_Expanded_Name
,
80 Get_External_Tag
=> RE_CPP_Get_External_Tag
,
81 Get_Prim_Op_Address
=> RE_CPP_Get_Prim_Op_Address
,
82 Get_RC_Offset
=> RE_CPP_Get_RC_Offset
,
83 Get_Remotely_Callable
=> RE_CPP_Get_Remotely_Callable
,
84 Get_TSD
=> RE_CPP_Get_TSD
,
85 Inherit_DT
=> RE_CPP_Inherit_DT
,
86 Inherit_TSD
=> RE_CPP_Inherit_TSD
,
87 Register_Tag
=> RE_CPP_Register_Tag
,
88 Set_Expanded_Name
=> RE_CPP_Set_Expanded_Name
,
89 Set_External_Tag
=> RE_CPP_Set_External_Tag
,
90 Set_Prim_Op_Address
=> RE_CPP_Set_Prim_Op_Address
,
91 Set_RC_Offset
=> RE_CPP_Set_RC_Offset
,
92 Set_Remotely_Callable
=> RE_CPP_Set_Remotely_Callable
,
93 Set_TSD
=> RE_CPP_Set_TSD
,
94 TSD_Entry_Size
=> RE_CPP_TSD_Entry_Size
,
95 TSD_Prologue_Size
=> RE_CPP_TSD_Prologue_Size
);
97 Action_Is_Proc
: constant array (DT_Access_Action
) of Boolean :=
98 (CW_Membership
=> False,
99 DT_Entry_Size
=> False,
100 DT_Prologue_Size
=> False,
101 Get_Expanded_Name
=> False,
102 Get_External_Tag
=> False,
103 Get_Prim_Op_Address
=> False,
104 Get_Remotely_Callable
=> False,
105 Get_RC_Offset
=> False,
109 Register_Tag
=> True,
110 Set_Expanded_Name
=> True,
111 Set_External_Tag
=> True,
112 Set_Prim_Op_Address
=> True,
113 Set_RC_Offset
=> True,
114 Set_Remotely_Callable
=> True,
116 TSD_Entry_Size
=> False,
117 TSD_Prologue_Size
=> False);
119 Action_Nb_Arg
: constant array (DT_Access_Action
) of Int
:=
122 DT_Prologue_Size
=> 0,
123 Get_Expanded_Name
=> 1,
124 Get_External_Tag
=> 1,
125 Get_Prim_Op_Address
=> 2,
127 Get_Remotely_Callable
=> 1,
132 Set_Expanded_Name
=> 2,
133 Set_External_Tag
=> 2,
134 Set_Prim_Op_Address
=> 3,
136 Set_Remotely_Callable
=> 2,
139 TSD_Prologue_Size
=> 0);
141 function Original_View_In_Visible_Part
(Typ
: Entity_Id
) return Boolean;
142 -- Check if the type has a private view or if the public view appears
143 -- in the visible part of a package spec.
145 --------------------------
146 -- Expand_Dispatch_Call --
147 --------------------------
149 procedure Expand_Dispatch_Call
(Call_Node
: Node_Id
) is
150 Loc
: constant Source_Ptr
:= Sloc
(Call_Node
);
151 Call_Typ
: constant Entity_Id
:= Etype
(Call_Node
);
153 Ctrl_Arg
: constant Node_Id
:= Controlling_Argument
(Call_Node
);
154 Param_List
: constant List_Id
:= Parameter_Associations
(Call_Node
);
155 Subp
: Entity_Id
:= Entity
(Name
(Call_Node
));
159 New_Call_Name
: Node_Id
;
160 New_Params
: List_Id
:= No_List
;
163 Subp_Ptr_Typ
: Entity_Id
;
164 Subp_Typ
: Entity_Id
;
166 Eq_Prim_Op
: Entity_Id
:= Empty
;
168 function New_Value
(From
: Node_Id
) return Node_Id
;
169 -- From is the original Expression. New_Value is equivalent to a call
170 -- to Duplicate_Subexpr with an explicit dereference when From is an
177 function New_Value
(From
: Node_Id
) return Node_Id
is
178 Res
: constant Node_Id
:= Duplicate_Subexpr
(From
);
181 if Is_Access_Type
(Etype
(From
)) then
182 return Make_Explicit_Dereference
(Sloc
(From
), Res
);
188 -- Start of processing for Expand_Dispatch_Call
191 -- If this is an inherited operation that was overriden, the body
192 -- that is being called is its alias.
194 if Present
(Alias
(Subp
))
195 and then Is_Inherited_Operation
(Subp
)
196 and then No
(DTC_Entity
(Subp
))
198 Subp
:= Alias
(Subp
);
201 -- Expand_Dispatch is called directly from the semantics, so we need
202 -- a check to see whether expansion is active before proceeding
204 if not Expander_Active
then
208 -- Definition of the ClassWide Type and the Tagged type
210 if Is_Access_Type
(Etype
(Ctrl_Arg
)) then
211 CW_Typ
:= Designated_Type
(Etype
(Ctrl_Arg
));
213 CW_Typ
:= Etype
(Ctrl_Arg
);
216 Typ
:= Root_Type
(CW_Typ
);
218 if not Is_Limited_Type
(Typ
) then
219 Eq_Prim_Op
:= Find_Prim_Op
(Typ
, Name_Op_Eq
);
222 if Is_CPP_Class
(Root_Type
(Typ
)) then
224 -- Create a new parameter list with the displaced 'this'
226 New_Params
:= New_List
;
227 Param
:= First_Actual
(Call_Node
);
228 while Present
(Param
) loop
230 -- We assume that dispatching through the main dispatch table
231 -- (referenced by Tag_Component) doesn't require a displacement
232 -- so the expansion below is only done when dispatching on
233 -- another vtable pointer, in which case the first argument
234 -- is expanded into :
236 -- typ!(Displaced_This (Address!(Param)))
239 and then DTC_Entity
(Subp
) /= Tag_Component
(Typ
)
241 Append_To
(New_Params
,
243 Unchecked_Convert_To
(Etype
(Param
),
244 Make_Function_Call
(Loc
,
245 Name
=> New_Reference_To
(RTE
(RE_Displaced_This
), Loc
),
246 Parameter_Associations
=> New_List
(
250 Make_Unchecked_Type_Conversion
(Loc
,
252 New_Reference_To
(RTE
(RE_Address
), Loc
),
253 Expression
=> Relocate_Node
(Param
)),
257 Make_Selected_Component
(Loc
,
258 Prefix
=> Duplicate_Subexpr
(Ctrl_Arg
),
260 New_Reference_To
(DTC_Entity
(Subp
), Loc
)),
264 Make_Integer_Literal
(Loc
, DT_Position
(Subp
))))));
267 Append_To
(New_Params
, Relocate_Node
(Param
));
273 elsif Present
(Param_List
) then
275 -- Generate the Tag checks when appropriate
277 New_Params
:= New_List
;
279 Param
:= First_Actual
(Call_Node
);
280 while Present
(Param
) loop
282 -- No tag check with itself
284 if Param
= Ctrl_Arg
then
285 Append_To
(New_Params
,
286 Duplicate_Subexpr_Move_Checks
(Param
));
288 -- No tag check for parameter whose type is neither tagged nor
289 -- access to tagged (for access parameters)
291 elsif No
(Find_Controlling_Arg
(Param
)) then
292 Append_To
(New_Params
, Relocate_Node
(Param
));
294 -- No tag check for function dispatching on result it the
295 -- Tag given by the context is this one
297 elsif Find_Controlling_Arg
(Param
) = Ctrl_Arg
then
298 Append_To
(New_Params
, Relocate_Node
(Param
));
300 -- "=" is the only dispatching operation allowed to get
301 -- operands with incompatible tags (it just returns false).
302 -- We use Duplicate_Subexpr_Move_Checks instead of calling
303 -- Relocate_Node because the value will be duplicated to
306 elsif Subp
= Eq_Prim_Op
then
307 Append_To
(New_Params
,
308 Duplicate_Subexpr_Move_Checks
(Param
));
310 -- No check in presence of suppress flags
312 elsif Tag_Checks_Suppressed
(Etype
(Param
))
313 or else (Is_Access_Type
(Etype
(Param
))
314 and then Tag_Checks_Suppressed
315 (Designated_Type
(Etype
(Param
))))
317 Append_To
(New_Params
, Relocate_Node
(Param
));
319 -- Optimization: no tag checks if the parameters are identical
321 elsif Is_Entity_Name
(Param
)
322 and then Is_Entity_Name
(Ctrl_Arg
)
323 and then Entity
(Param
) = Entity
(Ctrl_Arg
)
325 Append_To
(New_Params
, Relocate_Node
(Param
));
327 -- Now we need to generate the Tag check
330 -- Generate code for tag equality check
331 -- Perhaps should have Checks.Apply_Tag_Equality_Check???
333 Insert_Action
(Ctrl_Arg
,
334 Make_Implicit_If_Statement
(Call_Node
,
338 Make_Selected_Component
(Loc
,
339 Prefix
=> New_Value
(Ctrl_Arg
),
341 New_Reference_To
(Tag_Component
(Typ
), Loc
)),
344 Make_Selected_Component
(Loc
,
346 Unchecked_Convert_To
(Typ
, New_Value
(Param
)),
348 New_Reference_To
(Tag_Component
(Typ
), Loc
))),
351 New_List
(New_Constraint_Error
(Loc
))));
353 Append_To
(New_Params
, Relocate_Node
(Param
));
360 -- Generate the appropriate subprogram pointer type
362 if Etype
(Subp
) = Typ
then
365 Res_Typ
:= Etype
(Subp
);
368 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, Call_Node
);
369 Subp_Ptr_Typ
:= Create_Itype
(E_Access_Subprogram_Type
, Call_Node
);
370 Set_Etype
(Subp_Typ
, Res_Typ
);
371 Init_Size_Align
(Subp_Ptr_Typ
);
372 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
374 -- Create a new list of parameters which is a copy of the old formal
375 -- list including the creation of a new set of matching entities.
378 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
379 New_Formal
: Entity_Id
;
383 if Present
(Old_Formal
) then
384 New_Formal
:= New_Copy
(Old_Formal
);
385 Set_First_Entity
(Subp_Typ
, New_Formal
);
386 Param
:= First_Actual
(Call_Node
);
389 Set_Scope
(New_Formal
, Subp_Typ
);
391 -- Change all the controlling argument types to be class-wide
392 -- to avoid a recursion in dispatching
394 if Is_Controlling_Actual
(Param
) then
395 Set_Etype
(New_Formal
, Etype
(Param
));
398 if Is_Itype
(Etype
(New_Formal
)) then
399 Extra
:= New_Copy
(Etype
(New_Formal
));
401 if Ekind
(Extra
) = E_Record_Subtype
402 or else Ekind
(Extra
) = E_Class_Wide_Subtype
404 Set_Cloned_Subtype
(Extra
, Etype
(New_Formal
));
407 Set_Etype
(New_Formal
, Extra
);
408 Set_Scope
(Etype
(New_Formal
), Subp_Typ
);
412 Next_Formal
(Old_Formal
);
413 exit when No
(Old_Formal
);
415 Set_Next_Entity
(New_Formal
, New_Copy
(Old_Formal
));
416 Next_Entity
(New_Formal
);
419 Set_Last_Entity
(Subp_Typ
, Extra
);
421 -- Copy extra formals
423 New_Formal
:= First_Entity
(Subp_Typ
);
424 while Present
(New_Formal
) loop
425 if Present
(Extra_Constrained
(New_Formal
)) then
426 Set_Extra_Formal
(Extra
,
427 New_Copy
(Extra_Constrained
(New_Formal
)));
428 Extra
:= Extra_Formal
(Extra
);
429 Set_Extra_Constrained
(New_Formal
, Extra
);
431 elsif Present
(Extra_Accessibility
(New_Formal
)) then
432 Set_Extra_Formal
(Extra
,
433 New_Copy
(Extra_Accessibility
(New_Formal
)));
434 Extra
:= Extra_Formal
(Extra
);
435 Set_Extra_Accessibility
(New_Formal
, Extra
);
438 Next_Formal
(New_Formal
);
443 Set_Etype
(Subp_Ptr_Typ
, Subp_Ptr_Typ
);
444 Set_Directly_Designated_Type
(Subp_Ptr_Typ
, Subp_Typ
);
447 -- Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos));
450 Unchecked_Convert_To
(Subp_Ptr_Typ
,
451 Make_DT_Access_Action
(Typ
,
452 Action
=> Get_Prim_Op_Address
,
457 Make_Selected_Component
(Loc
,
458 Prefix
=> Duplicate_Subexpr_Move_Checks
(Ctrl_Arg
),
459 Selector_Name
=> New_Reference_To
(DTC_Entity
(Subp
), Loc
)),
463 Make_Integer_Literal
(Loc
, DT_Position
(Subp
)))));
465 if Nkind
(Call_Node
) = N_Function_Call
then
467 Make_Function_Call
(Loc
,
468 Name
=> New_Call_Name
,
469 Parameter_Associations
=> New_Params
);
471 -- if this is a dispatching "=", we must first compare the tags so
472 -- we generate: x.tag = y.tag and then x = y
474 if Subp
= Eq_Prim_Op
then
476 Param
:= First_Actual
(Call_Node
);
482 Make_Selected_Component
(Loc
,
483 Prefix
=> New_Value
(Param
),
485 New_Reference_To
(Tag_Component
(Typ
), Loc
)),
488 Make_Selected_Component
(Loc
,
490 Unchecked_Convert_To
(Typ
,
491 New_Value
(Next_Actual
(Param
))),
493 New_Reference_To
(Tag_Component
(Typ
), Loc
))),
495 Right_Opnd
=> New_Call
);
500 Make_Procedure_Call_Statement
(Loc
,
501 Name
=> New_Call_Name
,
502 Parameter_Associations
=> New_Params
);
505 Rewrite
(Call_Node
, New_Call
);
506 Analyze_And_Resolve
(Call_Node
, Call_Typ
);
507 end Expand_Dispatch_Call
;
513 function Fill_DT_Entry
518 Typ
: constant Entity_Id
:= Scope
(DTC_Entity
(Prim
));
519 DT_Ptr
: constant Entity_Id
:= Access_Disp_Table
(Typ
);
523 Make_DT_Access_Action
(Typ
,
524 Action
=> Set_Prim_Op_Address
,
526 New_Reference_To
(DT_Ptr
, Loc
), -- DTptr
528 Make_Integer_Literal
(Loc
, DT_Position
(Prim
)), -- Position
530 Make_Attribute_Reference
(Loc
, -- Value
531 Prefix
=> New_Reference_To
(Prim
, Loc
),
532 Attribute_Name
=> Name_Address
)));
535 ---------------------------
536 -- Get_Remotely_Callable --
537 ---------------------------
539 function Get_Remotely_Callable
(Obj
: Node_Id
) return Node_Id
is
540 Loc
: constant Source_Ptr
:= Sloc
(Obj
);
543 return Make_DT_Access_Action
545 Action
=> Get_Remotely_Callable
,
547 Make_Selected_Component
(Loc
,
549 Selector_Name
=> Make_Identifier
(Loc
, Name_uTag
))));
550 end Get_Remotely_Callable
;
556 function Make_DT
(Typ
: Entity_Id
) return List_Id
is
557 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
559 Result
: constant List_Id
:= New_List
;
560 Elab_Code
: constant List_Id
:= New_List
;
562 Tname
: constant Name_Id
:= Chars
(Typ
);
563 Name_DT
: constant Name_Id
:= New_External_Name
(Tname
, 'T');
564 Name_DT_Ptr
: constant Name_Id
:= New_External_Name
(Tname
, 'P');
565 Name_TSD
: constant Name_Id
:= New_External_Name
(Tname
, 'B');
566 Name_Exname
: constant Name_Id
:= New_External_Name
(Tname
, 'E');
567 Name_No_Reg
: constant Name_Id
:= New_External_Name
(Tname
, 'F');
569 DT
: constant Node_Id
:= Make_Defining_Identifier
(Loc
, Name_DT
);
570 DT_Ptr
: constant Node_Id
:= Make_Defining_Identifier
(Loc
, Name_DT_Ptr
);
571 TSD
: constant Node_Id
:= Make_Defining_Identifier
(Loc
, Name_TSD
);
572 Exname
: constant Node_Id
:= Make_Defining_Identifier
(Loc
, Name_Exname
);
573 No_Reg
: constant Node_Id
:= Make_Defining_Identifier
(Loc
, Name_No_Reg
);
576 Generalized_Tag
: Entity_Id
;
577 Size_Expr_Node
: Node_Id
;
582 if not RTE_Available
(RE_Tag
) then
583 Error_Msg_CRT
("tagged types", Typ
);
587 if Is_CPP_Class
(Root_Type
(Typ
)) then
588 Generalized_Tag
:= RTE
(RE_Vtable_Ptr
);
590 Generalized_Tag
:= RTE
(RE_Tag
);
593 -- Dispatch table and related entities are allocated statically
595 Set_Ekind
(DT
, E_Variable
);
596 Set_Is_Statically_Allocated
(DT
);
598 Set_Ekind
(DT_Ptr
, E_Variable
);
599 Set_Is_Statically_Allocated
(DT_Ptr
);
601 Set_Ekind
(TSD
, E_Variable
);
602 Set_Is_Statically_Allocated
(TSD
);
604 Set_Ekind
(Exname
, E_Variable
);
605 Set_Is_Statically_Allocated
(Exname
);
607 Set_Ekind
(No_Reg
, E_Variable
);
608 Set_Is_Statically_Allocated
(No_Reg
);
610 -- Generate code to create the storage for the Dispatch_Table object:
612 -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
613 -- for DT'Alignment use Address'Alignment
617 Left_Opnd
=> Make_DT_Access_Action
(Typ
, DT_Prologue_Size
, No_List
),
619 Make_Op_Multiply
(Loc
,
621 Make_DT_Access_Action
(Typ
, DT_Entry_Size
, No_List
),
623 Make_Integer_Literal
(Loc
,
624 DT_Entry_Count
(Tag_Component
(Typ
)))));
627 Make_Object_Declaration
(Loc
,
628 Defining_Identifier
=> DT
,
629 Aliased_Present
=> True,
631 Make_Subtype_Indication
(Loc
,
632 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Storage_Array
), Loc
),
633 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
634 Constraints
=> New_List
(
636 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
637 High_Bound
=> Size_Expr_Node
))))));
640 Make_Attribute_Definition_Clause
(Loc
,
641 Name
=> New_Reference_To
(DT
, Loc
),
642 Chars
=> Name_Alignment
,
644 Make_Attribute_Reference
(Loc
,
645 Prefix
=> New_Reference_To
(RTE
(RE_Integer_Address
), Loc
),
646 Attribute_Name
=> Name_Alignment
)));
648 -- Generate code to create the pointer to the dispatch table
650 -- DT_Ptr : Tag := Tag!(DT'Address); Ada case
652 -- DT_Ptr : Vtable_Ptr := Vtable_Ptr!(DT'Address); CPP case
655 Make_Object_Declaration
(Loc
,
656 Defining_Identifier
=> DT_Ptr
,
657 Constant_Present
=> True,
658 Object_Definition
=> New_Reference_To
(Generalized_Tag
, Loc
),
660 Unchecked_Convert_To
(Generalized_Tag
,
661 Make_Attribute_Reference
(Loc
,
662 Prefix
=> New_Reference_To
(DT
, Loc
),
663 Attribute_Name
=> Name_Address
))));
665 -- Generate code to define the boolean that controls registration, in
666 -- order to avoid multiple registrations for tagged types defined in
667 -- multiple-called scopes
670 Make_Object_Declaration
(Loc
,
671 Defining_Identifier
=> No_Reg
,
672 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
),
673 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
675 -- Set Access_Disp_Table field to be the dispatch table pointer
677 Set_Access_Disp_Table
(Typ
, DT_Ptr
);
679 -- Count ancestors to compute the inheritance depth. For private
680 -- extensions, always go to the full view in order to compute the real
681 -- inheritance depth.
684 Parent_Type
: Entity_Id
:= Typ
;
691 P
:= Etype
(Parent_Type
);
693 if Is_Private_Type
(P
) then
694 P
:= Full_View
(Base_Type
(P
));
697 exit when P
= Parent_Type
;
699 I_Depth
:= I_Depth
+ 1;
704 -- Generate code to create the storage for the type specific data object
706 -- TSD: Storage_Array (1..TSD_Prologue_Size+(1+Idepth)*TSD_Entry_Size);
707 -- for TSD'Alignment use Address'Alignment
712 Make_DT_Access_Action
(Typ
, TSD_Prologue_Size
, No_List
),
714 Make_Op_Multiply
(Loc
,
716 Make_DT_Access_Action
(Typ
, TSD_Entry_Size
, No_List
),
719 Left_Opnd
=> Make_Integer_Literal
(Loc
, 1),
721 Make_Integer_Literal
(Loc
, I_Depth
))));
724 Make_Object_Declaration
(Loc
,
725 Defining_Identifier
=> TSD
,
726 Aliased_Present
=> True,
728 Make_Subtype_Indication
(Loc
,
729 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Storage_Array
), Loc
),
730 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
731 Constraints
=> New_List
(
733 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
734 High_Bound
=> Size_Expr_Node
))))));
737 Make_Attribute_Definition_Clause
(Loc
,
738 Name
=> New_Reference_To
(TSD
, Loc
),
739 Chars
=> Name_Alignment
,
741 Make_Attribute_Reference
(Loc
,
742 Prefix
=> New_Reference_To
(RTE
(RE_Integer_Address
), Loc
),
743 Attribute_Name
=> Name_Alignment
)));
745 -- Generate code to put the Address of the TSD in the dispatch table
746 -- Set_TSD (DT_Ptr, TSD);
748 Append_To
(Elab_Code
,
749 Make_DT_Access_Action
(Typ
,
752 New_Reference_To
(DT_Ptr
, Loc
), -- DTptr
753 Make_Attribute_Reference
(Loc
, -- Value
754 Prefix
=> New_Reference_To
(TSD
, Loc
),
755 Attribute_Name
=> Name_Address
))));
758 or else Is_CPP_Class
(Etype
(Typ
))
761 Unchecked_Convert_To
(Generalized_Tag
,
762 Make_Integer_Literal
(Loc
, 0));
765 Unchecked_Convert_To
(RTE
(RE_Address
),
766 Make_Integer_Literal
(Loc
, 0));
769 Old_Tag
:= New_Reference_To
(Access_Disp_Table
(Etype
(Typ
)), Loc
);
771 Make_DT_Access_Action
(Typ
,
774 New_Reference_To
(Access_Disp_Table
(Etype
(Typ
)), Loc
)));
777 -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
779 Append_To
(Elab_Code
,
780 Make_DT_Access_Action
(Typ
,
781 Action
=> Inherit_DT
,
784 Node2
=> New_Reference_To
(DT_Ptr
, Loc
),
785 Node3
=> Make_Integer_Literal
(Loc
,
786 DT_Entry_Count
(Tag_Component
(Etype
(Typ
)))))));
788 -- Generate: Inherit_TSD (Get_TSD (parent), DT_Ptr);
790 Append_To
(Elab_Code
,
791 Make_DT_Access_Action
(Typ
,
792 Action
=> Inherit_TSD
,
795 Node2
=> New_Reference_To
(DT_Ptr
, Loc
))));
797 -- Generate: Exname : constant String := full_qualified_name (typ);
798 -- The type itself may be an anonymous parent type, so use the first
799 -- subtype to have a user-recognizable name.
802 Make_Object_Declaration
(Loc
,
803 Defining_Identifier
=> Exname
,
804 Constant_Present
=> True,
805 Object_Definition
=> New_Reference_To
(Standard_String
, Loc
),
807 Make_String_Literal
(Loc
,
808 Full_Qualified_Name
(First_Subtype
(Typ
)))));
810 -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address);
812 Append_To
(Elab_Code
,
813 Make_DT_Access_Action
(Typ
,
814 Action
=> Set_Expanded_Name
,
816 Node1
=> New_Reference_To
(DT_Ptr
, Loc
),
818 Make_Attribute_Reference
(Loc
,
819 Prefix
=> New_Reference_To
(Exname
, Loc
),
820 Attribute_Name
=> Name_Address
))));
822 -- for types with no controlled components
823 -- Generate: Set_RC_Offset (DT_Ptr, 0);
824 -- for simple types with controlled components
825 -- Generate: Set_RC_Offset (DT_Ptr, type._record_controller'position);
826 -- for complex types with controlled components where the position
827 -- of the record controller is not statically computable, if there are
828 -- controlled components at this level
829 -- Generate: Set_RC_Offset (DT_Ptr, -1);
830 -- to indicate that the _controller field is right after the _parent or
831 -- if there are no controlled components at this level,
832 -- Generate: Set_RC_Offset (DT_Ptr, -2);
833 -- to indicate that we need to get the position from the parent.
839 if not Has_Controlled_Component
(Typ
) then
840 Position
:= Make_Integer_Literal
(Loc
, 0);
842 elsif Etype
(Typ
) /= Typ
and then Has_Discriminants
(Etype
(Typ
)) then
843 if Has_New_Controlled_Component
(Typ
) then
844 Position
:= Make_Integer_Literal
(Loc
, -1);
846 Position
:= Make_Integer_Literal
(Loc
, -2);
850 Make_Attribute_Reference
(Loc
,
852 Make_Selected_Component
(Loc
,
853 Prefix
=> New_Reference_To
(Typ
, Loc
),
855 New_Reference_To
(Controller_Component
(Typ
), Loc
)),
856 Attribute_Name
=> Name_Position
);
858 -- This is not proper Ada code to use the attribute 'Position
859 -- on something else than an object but this is supported by
860 -- the back end (see comment on the Bit_Component attribute in
861 -- sem_attr). So we avoid semantic checking here.
863 Set_Analyzed
(Position
);
864 Set_Etype
(Prefix
(Position
), RTE
(RE_Record_Controller
));
865 Set_Etype
(Prefix
(Prefix
(Position
)), Typ
);
866 Set_Etype
(Selector_Name
(Prefix
(Position
)),
867 RTE
(RE_Record_Controller
));
868 Set_Etype
(Position
, RTE
(RE_Storage_Offset
));
871 Append_To
(Elab_Code
,
872 Make_DT_Access_Action
(Typ
,
873 Action
=> Set_RC_Offset
,
875 Node1
=> New_Reference_To
(DT_Ptr
, Loc
),
876 Node2
=> Position
)));
879 -- Generate: Set_Remotely_Callable (DT_Ptr, Status);
880 -- where Status is described in E.4 (18)
889 or else Is_Shared_Passive
(Typ
)
891 ((Is_Remote_Types
(Typ
)
892 or else Is_Remote_Call_Interface
(Typ
))
893 and then Original_View_In_Visible_Part
(Typ
))
894 or else not Comes_From_Source
(Typ
));
896 Append_To
(Elab_Code
,
897 Make_DT_Access_Action
(Typ
,
898 Action
=> Set_Remotely_Callable
,
900 New_Occurrence_Of
(DT_Ptr
, Loc
),
901 New_Occurrence_Of
(Status
, Loc
))));
904 -- Generate: Set_External_Tag (DT_Ptr, exname'Address);
905 -- Should be the external name not the qualified name???
907 if not Has_External_Tag_Rep_Clause
(Typ
) then
908 Append_To
(Elab_Code
,
909 Make_DT_Access_Action
(Typ
,
910 Action
=> Set_External_Tag
,
912 Node1
=> New_Reference_To
(DT_Ptr
, Loc
),
914 Make_Attribute_Reference
(Loc
,
915 Prefix
=> New_Reference_To
(Exname
, Loc
),
916 Attribute_Name
=> Name_Address
))));
918 -- Generate code to register the Tag in the External_Tag hash
919 -- table for the pure Ada type only.
921 -- Register_Tag (Dt_Ptr);
923 -- Skip this if routine not available, or in No_Run_Time mode
925 if RTE_Available
(RE_Register_Tag
)
926 and then Is_RTE
(Generalized_Tag
, RE_Tag
)
927 and then not No_Run_Time_Mode
929 Append_To
(Elab_Code
,
930 Make_Procedure_Call_Statement
(Loc
,
931 Name
=> New_Reference_To
(RTE
(RE_Register_Tag
), Loc
),
932 Parameter_Associations
=>
933 New_List
(New_Reference_To
(DT_Ptr
, Loc
))));
943 Append_To
(Elab_Code
,
944 Make_Assignment_Statement
(Loc
,
945 Name
=> New_Reference_To
(No_Reg
, Loc
),
946 Expression
=> New_Reference_To
(Standard_False
, Loc
)));
949 Make_Implicit_If_Statement
(Typ
,
950 Condition
=> New_Reference_To
(No_Reg
, Loc
),
951 Then_Statements
=> Elab_Code
));
956 ---------------------------
957 -- Make_DT_Access_Action --
958 ---------------------------
960 function Make_DT_Access_Action
962 Action
: DT_Access_Action
;
966 Action_Name
: Entity_Id
;
970 if Is_CPP_Class
(Root_Type
(Typ
)) then
971 Action_Name
:= RTE
(CPP_Actions
(Action
));
973 Action_Name
:= RTE
(Ada_Actions
(Action
));
978 -- This is a constant
980 return New_Reference_To
(Action_Name
, Sloc
(Typ
));
983 pragma Assert
(List_Length
(Args
) = Action_Nb_Arg
(Action
));
985 Loc
:= Sloc
(First
(Args
));
987 if Action_Is_Proc
(Action
) then
989 Make_Procedure_Call_Statement
(Loc
,
990 Name
=> New_Reference_To
(Action_Name
, Loc
),
991 Parameter_Associations
=> Args
);
995 Make_Function_Call
(Loc
,
996 Name
=> New_Reference_To
(Action_Name
, Loc
),
997 Parameter_Associations
=> Args
);
999 end Make_DT_Access_Action
;
1001 -----------------------------------
1002 -- Original_View_In_Visible_Part --
1003 -----------------------------------
1005 function Original_View_In_Visible_Part
(Typ
: Entity_Id
) return Boolean is
1006 Scop
: constant Entity_Id
:= Scope
(Typ
);
1009 -- The scope must be a package
1011 if Ekind
(Scop
) /= E_Package
1012 and then Ekind
(Scop
) /= E_Generic_Package
1017 -- A type with a private declaration has a private view declared in
1018 -- the visible part.
1020 if Has_Private_Declaration
(Typ
) then
1024 return List_Containing
(Parent
(Typ
)) =
1025 Visible_Declarations
(Specification
(Unit_Declaration_Node
(Scop
)));
1026 end Original_View_In_Visible_Part
;
1028 -------------------------
1029 -- Set_All_DT_Position --
1030 -------------------------
1032 procedure Set_All_DT_Position
(Typ
: Entity_Id
) is
1033 Parent_Typ
: constant Entity_Id
:= Etype
(Typ
);
1034 Root_Typ
: constant Entity_Id
:= Root_Type
(Typ
);
1035 First_Prim
: constant Elmt_Id
:= First_Elmt
(Primitive_Operations
(Typ
));
1036 The_Tag
: constant Entity_Id
:= Tag_Component
(Typ
);
1037 Adjusted
: Boolean := False;
1038 Finalized
: Boolean := False;
1042 Prim_Elmt
: Elmt_Id
;
1046 -- Get Entry_Count of the parent
1048 if Parent_Typ
/= Typ
1049 and then DT_Entry_Count
(Tag_Component
(Parent_Typ
)) /= No_Uint
1051 Parent_EC
:= UI_To_Int
(DT_Entry_Count
(Tag_Component
(Parent_Typ
)));
1056 -- C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable
1057 -- give a coherent set of information
1059 if Is_CPP_Class
(Root_Typ
) then
1061 -- Compute the number of primitive operations in the main Vtable
1062 -- Set their position:
1063 -- - where it was set if overriden or inherited
1064 -- - after the end of the parent vtable otherwise
1066 Prim_Elmt
:= First_Prim
;
1068 while Present
(Prim_Elmt
) loop
1069 Prim
:= Node
(Prim_Elmt
);
1071 if not Is_CPP_Class
(Typ
) then
1072 Set_DTC_Entity
(Prim
, The_Tag
);
1074 elsif Present
(Alias
(Prim
)) then
1075 Set_DTC_Entity
(Prim
, DTC_Entity
(Alias
(Prim
)));
1076 Set_DT_Position
(Prim
, DT_Position
(Alias
(Prim
)));
1078 elsif No
(DTC_Entity
(Prim
)) and then Is_CPP_Class
(Typ
) then
1079 Error_Msg_NE
("is a primitive operation of&," &
1080 " pragma Cpp_Virtual required", Prim
, Typ
);
1083 if DTC_Entity
(Prim
) = The_Tag
then
1085 -- Get the slot from the parent subprogram if any
1088 H
: Entity_Id
:= Homonym
(Prim
);
1091 while Present
(H
) loop
1092 if Present
(DTC_Entity
(H
))
1093 and then Root_Type
(Scope
(DTC_Entity
(H
))) = Root_Typ
1095 Set_DT_Position
(Prim
, DT_Position
(H
));
1103 -- Otherwise take the canonical slot after the end of the
1106 if DT_Position
(Prim
) = No_Uint
then
1107 Nb_Prim
:= Nb_Prim
+ 1;
1108 Set_DT_Position
(Prim
, UI_From_Int
(Parent_EC
+ Nb_Prim
));
1110 elsif UI_To_Int
(DT_Position
(Prim
)) > Parent_EC
then
1111 Nb_Prim
:= Nb_Prim
+ 1;
1115 Next_Elmt
(Prim_Elmt
);
1118 -- Check that the declared size of the Vtable is bigger or equal
1119 -- than the number of primitive operations (if bigger it means that
1120 -- some of the c++ virtual functions were not imported, that is
1123 if DT_Entry_Count
(The_Tag
) = No_Uint
1124 or else not Is_CPP_Class
(Typ
)
1126 Set_DT_Entry_Count
(The_Tag
, UI_From_Int
(Parent_EC
+ Nb_Prim
));
1128 elsif UI_To_Int
(DT_Entry_Count
(The_Tag
)) < Parent_EC
+ Nb_Prim
then
1129 Error_Msg_N
("not enough room in the Vtable for all virtual"
1130 & " functions", The_Tag
);
1133 -- Check that Positions are not duplicate nor outside the range of
1137 Size
: constant Int
:= UI_To_Int
(DT_Entry_Count
(The_Tag
));
1139 Prim_Pos_Table
: array (1 .. Size
) of Entity_Id
:=
1143 Prim_Elmt
:= First_Prim
;
1144 while Present
(Prim_Elmt
) loop
1145 Prim
:= Node
(Prim_Elmt
);
1147 if DTC_Entity
(Prim
) = The_Tag
then
1148 Pos
:= UI_To_Int
(DT_Position
(Prim
));
1150 if Pos
not in Prim_Pos_Table
'Range then
1152 ("position not in range of virtual table", Prim
);
1154 elsif Present
(Prim_Pos_Table
(Pos
)) then
1155 Error_Msg_NE
("cannot be at the same position in the"
1156 & " vtable than&", Prim
, Prim_Pos_Table
(Pos
));
1159 Prim_Pos_Table
(Pos
) := Prim
;
1163 Next_Elmt
(Prim_Elmt
);
1167 -- For regular Ada tagged types, just set the DT_Position for
1168 -- each primitive operation. Perform some sanity checks to avoid
1169 -- to build completely inconsistant dispatch tables.
1171 -- Note that the _Size primitive is always set at position 1 in order
1172 -- to comply with the needs of Ada.Tags.Parent_Size (see documentation
1177 Prim_Elmt
:= First_Prim
;
1178 while Present
(Prim_Elmt
) loop
1179 Nb_Prim
:= Nb_Prim
+ 1;
1180 Prim
:= Node
(Prim_Elmt
);
1181 Set_DTC_Entity
(Prim
, The_Tag
);
1183 if Chars
(Prim
) = Name_uSize
then
1184 Set_DT_Position
(Prim
, Uint_1
);
1185 Nb_Prim
:= Nb_Prim
- 1;
1187 Set_DT_Position
(Prim
, UI_From_Int
(Nb_Prim
));
1190 if Chars
(Prim
) = Name_Finalize
1192 (Is_Predefined_File_Name
(Unit_File_Name
(Current_Sem_Unit
))
1193 or else not Is_Predefined_File_Name
1194 (Unit_File_Name
(Get_Source_Unit
(Prim
))))
1199 if Chars
(Prim
) = Name_Adjust
then
1203 -- An abstract operation cannot be declared in the private part
1204 -- for a visible abstract type, because it could never be over-
1205 -- ridden. For explicit declarations this is checked at the point
1206 -- of declaration, but for inherited operations it must be done
1207 -- when building the dispatch table. Input is excluded because
1209 if Is_Abstract
(Typ
)
1210 and then Is_Abstract
(Prim
)
1211 and then Present
(Alias
(Prim
))
1212 and then Is_Derived_Type
(Typ
)
1213 and then In_Private_Part
(Current_Scope
)
1214 and then List_Containing
(Parent
(Prim
))
1215 = Private_Declarations
1216 (Specification
(Unit_Declaration_Node
(Current_Scope
)))
1217 and then Original_View_In_Visible_Part
(Typ
)
1219 -- We exclude Input and Output stream operations because
1220 -- Limited_Controlled inherits useless Input and Output
1221 -- stream operations from Root_Controlled, which can
1222 -- never be overridden.
1224 if not Is_TSS
(Prim
, TSS_Stream_Input
)
1226 not Is_TSS
(Prim
, TSS_Stream_Output
)
1229 ("abstract inherited private operation&" &
1230 " must be overridden ('R'M 3.9.3(10))",
1231 Parent
(Typ
), Prim
);
1234 Next_Elmt
(Prim_Elmt
);
1237 if Is_Controlled
(Typ
) then
1238 if not Finalized
then
1240 ("controlled type has no explicit Finalize method?", Typ
);
1242 elsif not Adjusted
then
1244 ("controlled type has no explicit Adjust method?", Typ
);
1248 Set_DT_Entry_Count
(The_Tag
, UI_From_Int
(Nb_Prim
));
1250 -- The derived type must have at least as many components as its
1251 -- parent (for root types, the Etype points back to itself
1252 -- and the test should not fail)
1255 DT_Entry_Count
(The_Tag
) >=
1256 DT_Entry_Count
(Tag_Component
(Parent_Typ
)));
1258 end Set_All_DT_Position
;
1260 -----------------------------
1261 -- Set_Default_Constructor --
1262 -----------------------------
1264 procedure Set_Default_Constructor
(Typ
: Entity_Id
) is
1271 -- Look for the default constructor entity. For now only the
1272 -- default constructor has the flag Is_Constructor.
1274 E
:= Next_Entity
(Typ
);
1276 and then (Ekind
(E
) /= E_Function
or else not Is_Constructor
(E
))
1281 -- Create the init procedure
1285 Init
:= Make_Defining_Identifier
(Loc
, Make_Init_Proc_Name
(Typ
));
1286 Param
:= Make_Defining_Identifier
(Loc
, Name_X
);
1289 Make_Subprogram_Declaration
(Loc
,
1290 Make_Procedure_Specification
(Loc
,
1291 Defining_Unit_Name
=> Init
,
1292 Parameter_Specifications
=> New_List
(
1293 Make_Parameter_Specification
(Loc
,
1294 Defining_Identifier
=> Param
,
1295 Parameter_Type
=> New_Reference_To
(Typ
, Loc
))))));
1297 Set_Init_Proc
(Typ
, Init
);
1298 Set_Is_Imported
(Init
);
1299 Set_Interface_Name
(Init
, Interface_Name
(E
));
1300 Set_Convention
(Init
, Convention_C
);
1301 Set_Is_Public
(Init
);
1302 Set_Has_Completion
(Init
);
1304 -- If there are no constructors, mark the type as abstract since we
1305 -- won't be able to declare objects of that type.
1308 Set_Is_Abstract
(Typ
);
1310 end Set_Default_Constructor
;