1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 ------------------------------------------------------------------------------
28 with Atree
; use Atree
;
29 with Checks
; use Checks
;
30 with Einfo
; use Einfo
;
31 with Elists
; use Elists
;
32 with Errout
; use Errout
;
33 with Exp_Ch7
; use Exp_Ch7
;
34 with Exp_Tss
; use Exp_Tss
;
35 with Exp_Util
; use Exp_Util
;
36 with Fname
; use Fname
;
37 with Itypes
; use Itypes
;
39 with Nlists
; use Nlists
;
40 with Nmake
; use Nmake
;
42 with Rtsfind
; use Rtsfind
;
43 with Sem_Disp
; use Sem_Disp
;
44 with Sem_Res
; use Sem_Res
;
45 with Sem_Util
; use Sem_Util
;
46 with Sinfo
; use Sinfo
;
47 with Snames
; use Snames
;
48 with Stand
; use Stand
;
49 with Tbuild
; use Tbuild
;
50 with Uintp
; use Uintp
;
52 package body Exp_Disp
is
54 Ada_Actions
: constant array (DT_Access_Action
) of RE_Id
:=
55 (CW_Membership
=> RE_CW_Membership
,
56 DT_Entry_Size
=> RE_DT_Entry_Size
,
57 DT_Prologue_Size
=> RE_DT_Prologue_Size
,
58 Get_Expanded_Name
=> RE_Get_Expanded_Name
,
59 Get_External_Tag
=> RE_Get_External_Tag
,
60 Get_Prim_Op_Address
=> RE_Get_Prim_Op_Address
,
61 Get_RC_Offset
=> RE_Get_RC_Offset
,
62 Get_Remotely_Callable
=> RE_Get_Remotely_Callable
,
63 Get_TSD
=> RE_Get_TSD
,
64 Inherit_DT
=> RE_Inherit_DT
,
65 Inherit_TSD
=> RE_Inherit_TSD
,
66 Register_Tag
=> RE_Register_Tag
,
67 Set_Expanded_Name
=> RE_Set_Expanded_Name
,
68 Set_External_Tag
=> RE_Set_External_Tag
,
69 Set_Prim_Op_Address
=> RE_Set_Prim_Op_Address
,
70 Set_RC_Offset
=> RE_Set_RC_Offset
,
71 Set_Remotely_Callable
=> RE_Set_Remotely_Callable
,
72 Set_TSD
=> RE_Set_TSD
,
73 TSD_Entry_Size
=> RE_TSD_Entry_Size
,
74 TSD_Prologue_Size
=> RE_TSD_Prologue_Size
);
76 CPP_Actions
: constant array (DT_Access_Action
) of RE_Id
:=
77 (CW_Membership
=> RE_CPP_CW_Membership
,
78 DT_Entry_Size
=> RE_CPP_DT_Entry_Size
,
79 DT_Prologue_Size
=> RE_CPP_DT_Prologue_Size
,
80 Get_Expanded_Name
=> RE_CPP_Get_Expanded_Name
,
81 Get_External_Tag
=> RE_CPP_Get_External_Tag
,
82 Get_Prim_Op_Address
=> RE_CPP_Get_Prim_Op_Address
,
83 Get_RC_Offset
=> RE_CPP_Get_RC_Offset
,
84 Get_Remotely_Callable
=> RE_CPP_Get_Remotely_Callable
,
85 Get_TSD
=> RE_CPP_Get_TSD
,
86 Inherit_DT
=> RE_CPP_Inherit_DT
,
87 Inherit_TSD
=> RE_CPP_Inherit_TSD
,
88 Register_Tag
=> RE_CPP_Register_Tag
,
89 Set_Expanded_Name
=> RE_CPP_Set_Expanded_Name
,
90 Set_External_Tag
=> RE_CPP_Set_External_Tag
,
91 Set_Prim_Op_Address
=> RE_CPP_Set_Prim_Op_Address
,
92 Set_RC_Offset
=> RE_CPP_Set_RC_Offset
,
93 Set_Remotely_Callable
=> RE_CPP_Set_Remotely_Callable
,
94 Set_TSD
=> RE_CPP_Set_TSD
,
95 TSD_Entry_Size
=> RE_CPP_TSD_Entry_Size
,
96 TSD_Prologue_Size
=> RE_CPP_TSD_Prologue_Size
);
98 Action_Is_Proc
: constant array (DT_Access_Action
) of Boolean :=
99 (CW_Membership
=> False,
100 DT_Entry_Size
=> False,
101 DT_Prologue_Size
=> False,
102 Get_Expanded_Name
=> False,
103 Get_External_Tag
=> False,
104 Get_Prim_Op_Address
=> False,
105 Get_Remotely_Callable
=> False,
106 Get_RC_Offset
=> False,
110 Register_Tag
=> True,
111 Set_Expanded_Name
=> True,
112 Set_External_Tag
=> True,
113 Set_Prim_Op_Address
=> True,
114 Set_RC_Offset
=> True,
115 Set_Remotely_Callable
=> True,
117 TSD_Entry_Size
=> False,
118 TSD_Prologue_Size
=> False);
120 Action_Nb_Arg
: constant array (DT_Access_Action
) of Int
:=
123 DT_Prologue_Size
=> 0,
124 Get_Expanded_Name
=> 1,
125 Get_External_Tag
=> 1,
126 Get_Prim_Op_Address
=> 2,
128 Get_Remotely_Callable
=> 1,
133 Set_Expanded_Name
=> 2,
134 Set_External_Tag
=> 2,
135 Set_Prim_Op_Address
=> 3,
137 Set_Remotely_Callable
=> 2,
140 TSD_Prologue_Size
=> 0);
142 function Original_View_In_Visible_Part
(Typ
: Entity_Id
) return Boolean;
143 -- Check if the type has a private view or if the public view appears
144 -- in the visible part of a package spec.
146 --------------------------
147 -- Expand_Dispatch_Call --
148 --------------------------
150 procedure Expand_Dispatch_Call
(Call_Node
: Node_Id
) is
151 Loc
: constant Source_Ptr
:= Sloc
(Call_Node
);
152 Call_Typ
: constant Entity_Id
:= Etype
(Call_Node
);
154 Ctrl_Arg
: constant Node_Id
:= Controlling_Argument
(Call_Node
);
155 Param_List
: constant List_Id
:= Parameter_Associations
(Call_Node
);
156 Subp
: Entity_Id
:= Entity
(Name
(Call_Node
));
160 New_Call_Name
: Node_Id
;
161 New_Params
: List_Id
:= No_List
;
164 Subp_Ptr_Typ
: Entity_Id
;
165 Subp_Typ
: Entity_Id
;
167 Eq_Prim_Op
: Entity_Id
:= Empty
;
169 function New_Value
(From
: Node_Id
) return Node_Id
;
170 -- From is the original Expression. New_Value is equivalent to
171 -- Duplicate_Subexpr with an explicit dereference when From is an
174 function New_Value
(From
: Node_Id
) return Node_Id
is
175 Res
: constant Node_Id
:= Duplicate_Subexpr
(From
);
178 if Is_Access_Type
(Etype
(From
)) then
179 return Make_Explicit_Dereference
(Sloc
(From
), Res
);
185 -- Start of processing for Expand_Dispatch_Call
188 -- If this is an inherited operation that was overriden, the body
189 -- that is being called is its alias.
191 if Present
(Alias
(Subp
))
192 and then Is_Inherited_Operation
(Subp
)
193 and then No
(DTC_Entity
(Subp
))
195 Subp
:= Alias
(Subp
);
198 -- Expand_Dispatch is called directly from the semantics, so we need
199 -- a check to see whether expansion is active before proceeding
201 if not Expander_Active
then
205 -- Definition of the ClassWide Type and the Tagged type
207 if Is_Access_Type
(Etype
(Ctrl_Arg
)) then
208 CW_Typ
:= Designated_Type
(Etype
(Ctrl_Arg
));
210 CW_Typ
:= Etype
(Ctrl_Arg
);
213 Typ
:= Root_Type
(CW_Typ
);
215 if not Is_Limited_Type
(Typ
) then
216 Eq_Prim_Op
:= Find_Prim_Op
(Typ
, Name_Op_Eq
);
219 if Is_CPP_Class
(Root_Type
(Typ
)) then
221 -- Create a new parameter list with the displaced 'this'
223 New_Params
:= New_List
;
224 Param
:= First_Actual
(Call_Node
);
225 while Present
(Param
) loop
227 -- We assume that dispatching through the main dispatch table
228 -- (referenced by Tag_Component) doesn't require a displacement
229 -- so the expansion below is only done when dispatching on
230 -- another vtable pointer, in which case the first argument
231 -- is expanded into :
233 -- typ!(Displaced_This (Address!(Param)))
236 and then DTC_Entity
(Subp
) /= Tag_Component
(Typ
)
238 Append_To
(New_Params
,
240 Unchecked_Convert_To
(Etype
(Param
),
241 Make_Function_Call
(Loc
,
242 Name
=> New_Reference_To
(RTE
(RE_Displaced_This
), Loc
),
243 Parameter_Associations
=> New_List
(
247 Make_Unchecked_Type_Conversion
(Loc
,
249 New_Reference_To
(RTE
(RE_Address
), Loc
),
250 Expression
=> Relocate_Node
(Param
)),
254 Make_Selected_Component
(Loc
,
255 Prefix
=> Duplicate_Subexpr
(Ctrl_Arg
),
257 New_Reference_To
(DTC_Entity
(Subp
), Loc
)),
261 Make_Integer_Literal
(Loc
, DT_Position
(Subp
))))));
264 Append_To
(New_Params
, Relocate_Node
(Param
));
270 elsif Present
(Param_List
) then
272 -- Generate the Tag checks when appropriate
274 New_Params
:= New_List
;
276 Param
:= First_Actual
(Call_Node
);
277 while Present
(Param
) loop
279 -- No tag check with itself
281 if Param
= Ctrl_Arg
then
282 Append_To
(New_Params
, Duplicate_Subexpr
(Param
));
284 -- No tag check for parameter whose type is neither tagged nor
285 -- access to tagged (for access parameters)
287 elsif No
(Find_Controlling_Arg
(Param
)) then
288 Append_To
(New_Params
, Relocate_Node
(Param
));
290 -- No tag check for function dispatching on result it the
291 -- Tag given by the context is this one
293 elsif Find_Controlling_Arg
(Param
) = Ctrl_Arg
then
294 Append_To
(New_Params
, Relocate_Node
(Param
));
296 -- "=" is the only dispatching operation allowed to get
297 -- operands with incompatible tags (it just returns false).
298 -- We use Duplicate_subexpr instead of relocate_node because
299 -- the value will be duplicated to check the tags.
301 elsif Subp
= Eq_Prim_Op
then
302 Append_To
(New_Params
, Duplicate_Subexpr
(Param
));
304 -- No check in presence of suppress flags
306 elsif Tag_Checks_Suppressed
(Etype
(Param
))
307 or else (Is_Access_Type
(Etype
(Param
))
308 and then Tag_Checks_Suppressed
309 (Designated_Type
(Etype
(Param
))))
311 Append_To
(New_Params
, Relocate_Node
(Param
));
313 -- Optimization: no tag checks if the parameters are identical
315 elsif Is_Entity_Name
(Param
)
316 and then Is_Entity_Name
(Ctrl_Arg
)
317 and then Entity
(Param
) = Entity
(Ctrl_Arg
)
319 Append_To
(New_Params
, Relocate_Node
(Param
));
321 -- Now we need to generate the Tag check
324 -- Generate code for tag equality check
325 -- Perhaps should have Checks.Apply_Tag_Equality_Check???
327 Insert_Action
(Ctrl_Arg
,
328 Make_Implicit_If_Statement
(Call_Node
,
332 Make_Selected_Component
(Loc
,
333 Prefix
=> New_Value
(Ctrl_Arg
),
335 New_Reference_To
(Tag_Component
(Typ
), Loc
)),
338 Make_Selected_Component
(Loc
,
340 Unchecked_Convert_To
(Typ
, New_Value
(Param
)),
342 New_Reference_To
(Tag_Component
(Typ
), Loc
))),
345 New_List
(New_Constraint_Error
(Loc
))));
347 Append_To
(New_Params
, Relocate_Node
(Param
));
354 -- Generate the appropriate subprogram pointer type
356 if Etype
(Subp
) = Typ
then
359 Res_Typ
:= Etype
(Subp
);
362 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, Call_Node
);
363 Subp_Ptr_Typ
:= Create_Itype
(E_Access_Subprogram_Type
, Call_Node
);
364 Set_Etype
(Subp_Typ
, Res_Typ
);
365 Init_Size_Align
(Subp_Ptr_Typ
);
366 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
368 -- Create a new list of parameters which is a copy of the old formal
369 -- list including the creation of a new set of matching entities.
372 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
373 New_Formal
: Entity_Id
;
377 if Present
(Old_Formal
) then
378 New_Formal
:= New_Copy
(Old_Formal
);
379 Set_First_Entity
(Subp_Typ
, New_Formal
);
380 Param
:= First_Actual
(Call_Node
);
383 Set_Scope
(New_Formal
, Subp_Typ
);
385 -- Change all the controlling argument types to be class-wide
386 -- to avoid a recursion in dispatching
388 if Is_Controlling_Actual
(Param
) then
389 Set_Etype
(New_Formal
, Etype
(Param
));
392 if Is_Itype
(Etype
(New_Formal
)) then
393 Extra
:= New_Copy
(Etype
(New_Formal
));
395 if Ekind
(Extra
) = E_Record_Subtype
396 or else Ekind
(Extra
) = E_Class_Wide_Subtype
398 Set_Cloned_Subtype
(Extra
, Etype
(New_Formal
));
401 Set_Etype
(New_Formal
, Extra
);
402 Set_Scope
(Etype
(New_Formal
), Subp_Typ
);
406 Next_Formal
(Old_Formal
);
407 exit when No
(Old_Formal
);
409 Set_Next_Entity
(New_Formal
, New_Copy
(Old_Formal
));
410 Next_Entity
(New_Formal
);
413 Set_Last_Entity
(Subp_Typ
, Extra
);
415 -- Copy extra formals
417 New_Formal
:= First_Entity
(Subp_Typ
);
418 while Present
(New_Formal
) loop
419 if Present
(Extra_Constrained
(New_Formal
)) then
420 Set_Extra_Formal
(Extra
,
421 New_Copy
(Extra_Constrained
(New_Formal
)));
422 Extra
:= Extra_Formal
(Extra
);
423 Set_Extra_Constrained
(New_Formal
, Extra
);
425 elsif Present
(Extra_Accessibility
(New_Formal
)) then
426 Set_Extra_Formal
(Extra
,
427 New_Copy
(Extra_Accessibility
(New_Formal
)));
428 Extra
:= Extra_Formal
(Extra
);
429 Set_Extra_Accessibility
(New_Formal
, Extra
);
432 Next_Formal
(New_Formal
);
437 Set_Etype
(Subp_Ptr_Typ
, Subp_Ptr_Typ
);
438 Set_Directly_Designated_Type
(Subp_Ptr_Typ
, Subp_Typ
);
441 -- Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos));
444 Unchecked_Convert_To
(Subp_Ptr_Typ
,
445 Make_DT_Access_Action
(Typ
,
446 Action
=> Get_Prim_Op_Address
,
451 Make_Selected_Component
(Loc
,
452 Prefix
=> Duplicate_Subexpr
(Ctrl_Arg
),
453 Selector_Name
=> New_Reference_To
(DTC_Entity
(Subp
), Loc
)),
457 Make_Integer_Literal
(Loc
, DT_Position
(Subp
)))));
459 if Nkind
(Call_Node
) = N_Function_Call
then
461 Make_Function_Call
(Loc
,
462 Name
=> New_Call_Name
,
463 Parameter_Associations
=> New_Params
);
465 -- if this is a dispatching "=", we must first compare the tags so
466 -- we generate: x.tag = y.tag and then x = y
468 if Subp
= Eq_Prim_Op
then
470 Param
:= First_Actual
(Call_Node
);
476 Make_Selected_Component
(Loc
,
477 Prefix
=> New_Value
(Param
),
479 New_Reference_To
(Tag_Component
(Typ
), Loc
)),
482 Make_Selected_Component
(Loc
,
484 Unchecked_Convert_To
(Typ
,
485 New_Value
(Next_Actual
(Param
))),
487 New_Reference_To
(Tag_Component
(Typ
), Loc
))),
489 Right_Opnd
=> New_Call
);
494 Make_Procedure_Call_Statement
(Loc
,
495 Name
=> New_Call_Name
,
496 Parameter_Associations
=> New_Params
);
499 Rewrite
(Call_Node
, New_Call
);
500 Analyze_And_Resolve
(Call_Node
, Call_Typ
);
501 end Expand_Dispatch_Call
;
507 function Fill_DT_Entry
512 Typ
: constant Entity_Id
:= Scope
(DTC_Entity
(Prim
));
513 DT_Ptr
: constant Entity_Id
:= Access_Disp_Table
(Typ
);
517 Make_DT_Access_Action
(Typ
,
518 Action
=> Set_Prim_Op_Address
,
520 New_Reference_To
(DT_Ptr
, Loc
), -- DTptr
522 Make_Integer_Literal
(Loc
, DT_Position
(Prim
)), -- Position
524 Make_Attribute_Reference
(Loc
, -- Value
525 Prefix
=> New_Reference_To
(Prim
, Loc
),
526 Attribute_Name
=> Name_Address
)));
529 ---------------------------
530 -- Get_Remotely_Callable --
531 ---------------------------
533 function Get_Remotely_Callable
(Obj
: Node_Id
) return Node_Id
is
534 Loc
: constant Source_Ptr
:= Sloc
(Obj
);
537 return Make_DT_Access_Action
539 Action
=> Get_Remotely_Callable
,
541 Make_Selected_Component
(Loc
,
543 Selector_Name
=> Make_Identifier
(Loc
, Name_uTag
))));
544 end Get_Remotely_Callable
;
550 function Make_DT
(Typ
: Entity_Id
) return List_Id
is
551 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
553 Result
: constant List_Id
:= New_List
;
554 Elab_Code
: constant List_Id
:= New_List
;
556 Tname
: constant Name_Id
:= Chars
(Typ
);
557 Name_DT
: constant Name_Id
:= New_External_Name
(Tname
, 'T');
558 Name_DT_Ptr
: constant Name_Id
:= New_External_Name
(Tname
, 'P');
559 Name_TSD
: constant Name_Id
:= New_External_Name
(Tname
, 'B');
560 Name_Exname
: constant Name_Id
:= New_External_Name
(Tname
, 'E');
561 Name_No_Reg
: constant Name_Id
:= New_External_Name
(Tname
, 'F');
563 DT
: constant Node_Id
:= Make_Defining_Identifier
(Loc
, Name_DT
);
564 DT_Ptr
: constant Node_Id
:= Make_Defining_Identifier
(Loc
, Name_DT_Ptr
);
565 TSD
: constant Node_Id
:= Make_Defining_Identifier
(Loc
, Name_TSD
);
566 Exname
: constant Node_Id
:= Make_Defining_Identifier
(Loc
, Name_Exname
);
567 No_Reg
: constant Node_Id
:= Make_Defining_Identifier
(Loc
, Name_No_Reg
);
570 Generalized_Tag
: Entity_Id
;
571 Size_Expr_Node
: Node_Id
;
576 if Is_CPP_Class
(Root_Type
(Typ
)) then
577 Generalized_Tag
:= RTE
(RE_Vtable_Ptr
);
579 Generalized_Tag
:= RTE
(RE_Tag
);
582 -- Dispatch table and related entities are allocated statically
584 Set_Ekind
(DT
, E_Variable
);
585 Set_Is_Statically_Allocated
(DT
);
587 Set_Ekind
(DT_Ptr
, E_Variable
);
588 Set_Is_Statically_Allocated
(DT_Ptr
);
590 Set_Ekind
(TSD
, E_Variable
);
591 Set_Is_Statically_Allocated
(TSD
);
593 Set_Ekind
(Exname
, E_Variable
);
594 Set_Is_Statically_Allocated
(Exname
);
596 Set_Ekind
(No_Reg
, E_Variable
);
597 Set_Is_Statically_Allocated
(No_Reg
);
599 -- Generate code to create the storage for the Dispatch_Table object:
601 -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
602 -- for DT'Alignment use Address'Alignment
606 Left_Opnd
=> Make_DT_Access_Action
(Typ
, DT_Prologue_Size
, No_List
),
608 Make_Op_Multiply
(Loc
,
610 Make_DT_Access_Action
(Typ
, DT_Entry_Size
, No_List
),
612 Make_Integer_Literal
(Loc
,
613 DT_Entry_Count
(Tag_Component
(Typ
)))));
616 Make_Object_Declaration
(Loc
,
617 Defining_Identifier
=> DT
,
618 Aliased_Present
=> True,
620 Make_Subtype_Indication
(Loc
,
621 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Storage_Array
), Loc
),
622 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
623 Constraints
=> New_List
(
625 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
626 High_Bound
=> Size_Expr_Node
))))));
629 Make_Attribute_Definition_Clause
(Loc
,
630 Name
=> New_Reference_To
(DT
, Loc
),
631 Chars
=> Name_Alignment
,
633 Make_Attribute_Reference
(Loc
,
634 Prefix
=> New_Reference_To
(RTE
(RE_Integer_Address
), Loc
),
635 Attribute_Name
=> Name_Alignment
)));
637 -- Generate code to create the pointer to the dispatch table
639 -- DT_Ptr : Tag := Tag!(DT'Address); Ada case
641 -- DT_Ptr : Vtable_Ptr := Vtable_Ptr!(DT'Address); CPP case
644 Make_Object_Declaration
(Loc
,
645 Defining_Identifier
=> DT_Ptr
,
646 Constant_Present
=> True,
647 Object_Definition
=> New_Reference_To
(Generalized_Tag
, Loc
),
649 Unchecked_Convert_To
(Generalized_Tag
,
650 Make_Attribute_Reference
(Loc
,
651 Prefix
=> New_Reference_To
(DT
, Loc
),
652 Attribute_Name
=> Name_Address
))));
654 -- Generate code to define the boolean that controls registration, in
655 -- order to avoid multiple registrations for tagged types defined in
656 -- multiple-called scopes
659 Make_Object_Declaration
(Loc
,
660 Defining_Identifier
=> No_Reg
,
661 Object_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
),
662 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
664 -- Set Access_Disp_Table field to be the dispatch table pointer
666 Set_Access_Disp_Table
(Typ
, DT_Ptr
);
668 -- Count ancestors to compute the inheritance depth. For private
669 -- extensions, always go to the full view in order to compute the real
670 -- inheritance depth.
673 Parent_Type
: Entity_Id
:= Typ
;
680 P
:= Etype
(Parent_Type
);
682 if Is_Private_Type
(P
) then
683 P
:= Full_View
(Base_Type
(P
));
686 exit when P
= Parent_Type
;
688 I_Depth
:= I_Depth
+ 1;
693 -- Generate code to create the storage for the type specific data object
695 -- TSD: Storage_Array (1..TSD_Prologue_Size+(1+Idepth)*TSD_Entry_Size);
696 -- for TSD'Alignment use Address'Alignment
701 Make_DT_Access_Action
(Typ
, TSD_Prologue_Size
, No_List
),
703 Make_Op_Multiply
(Loc
,
705 Make_DT_Access_Action
(Typ
, TSD_Entry_Size
, No_List
),
708 Left_Opnd
=> Make_Integer_Literal
(Loc
, 1),
710 Make_Integer_Literal
(Loc
, I_Depth
))));
713 Make_Object_Declaration
(Loc
,
714 Defining_Identifier
=> TSD
,
715 Aliased_Present
=> True,
717 Make_Subtype_Indication
(Loc
,
718 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Storage_Array
), Loc
),
719 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
720 Constraints
=> New_List
(
722 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
723 High_Bound
=> Size_Expr_Node
))))));
726 Make_Attribute_Definition_Clause
(Loc
,
727 Name
=> New_Reference_To
(TSD
, Loc
),
728 Chars
=> Name_Alignment
,
730 Make_Attribute_Reference
(Loc
,
731 Prefix
=> New_Reference_To
(RTE
(RE_Integer_Address
), Loc
),
732 Attribute_Name
=> Name_Alignment
)));
734 -- Generate code to put the Address of the TSD in the dispatch table
735 -- Set_TSD (DT_Ptr, TSD);
737 Append_To
(Elab_Code
,
738 Make_DT_Access_Action
(Typ
,
741 New_Reference_To
(DT_Ptr
, Loc
), -- DTptr
742 Make_Attribute_Reference
(Loc
, -- Value
743 Prefix
=> New_Reference_To
(TSD
, Loc
),
744 Attribute_Name
=> Name_Address
))));
747 or else Is_CPP_Class
(Etype
(Typ
))
750 Unchecked_Convert_To
(Generalized_Tag
,
751 Make_Integer_Literal
(Loc
, 0));
754 Unchecked_Convert_To
(RTE
(RE_Address
),
755 Make_Integer_Literal
(Loc
, 0));
758 Old_Tag
:= New_Reference_To
(Access_Disp_Table
(Etype
(Typ
)), Loc
);
760 Make_DT_Access_Action
(Typ
,
763 New_Reference_To
(Access_Disp_Table
(Etype
(Typ
)), Loc
)));
766 -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
768 Append_To
(Elab_Code
,
769 Make_DT_Access_Action
(Typ
,
770 Action
=> Inherit_DT
,
773 Node2
=> New_Reference_To
(DT_Ptr
, Loc
),
774 Node3
=> Make_Integer_Literal
(Loc
,
775 DT_Entry_Count
(Tag_Component
(Etype
(Typ
)))))));
777 -- Generate: Inherit_TSD (Get_TSD (parent), DT_Ptr);
779 Append_To
(Elab_Code
,
780 Make_DT_Access_Action
(Typ
,
781 Action
=> Inherit_TSD
,
784 Node2
=> New_Reference_To
(DT_Ptr
, Loc
))));
786 -- Generate: Exname : constant String := full_qualified_name (typ);
787 -- The type itself may be an anonymous parent type, so use the first
788 -- subtype to have a user-recognizable name.
791 Make_Object_Declaration
(Loc
,
792 Defining_Identifier
=> Exname
,
793 Constant_Present
=> True,
794 Object_Definition
=> New_Reference_To
(Standard_String
, Loc
),
796 Make_String_Literal
(Loc
,
797 Full_Qualified_Name
(First_Subtype
(Typ
)))));
799 -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address);
801 Append_To
(Elab_Code
,
802 Make_DT_Access_Action
(Typ
,
803 Action
=> Set_Expanded_Name
,
805 Node1
=> New_Reference_To
(DT_Ptr
, Loc
),
807 Make_Attribute_Reference
(Loc
,
808 Prefix
=> New_Reference_To
(Exname
, Loc
),
809 Attribute_Name
=> Name_Address
))));
811 -- for types with no controlled components
812 -- Generate: Set_RC_Offset (DT_Ptr, 0);
813 -- for simple types with controlled components
814 -- Generate: Set_RC_Offset (DT_Ptr, type._record_controller'position);
815 -- for complex types with controlled components where the position
816 -- of the record controller
817 -- Generate: Set_RC_Offset (DT_Ptr, -1);
823 if not Has_Controlled_Component
(Typ
) then
824 Position
:= Make_Integer_Literal
(Loc
, 0);
826 elsif Etype
(Typ
) /= Typ
and then Has_Discriminants
(Etype
(Typ
)) then
827 Position
:= Make_Integer_Literal
(Loc
, -1);
831 Make_Attribute_Reference
(Loc
,
833 Make_Selected_Component
(Loc
,
834 Prefix
=> New_Reference_To
(Typ
, Loc
),
836 New_Reference_To
(Controller_Component
(Typ
), Loc
)),
837 Attribute_Name
=> Name_Position
);
839 -- This is not proper Ada code to use the attribute component
840 -- on something else than an object but this is supported by
841 -- the back end (see comment on the Bit_Component attribute in
842 -- sem_attr). So we avoid semantic checking here.
844 Set_Analyzed
(Position
);
845 Set_Etype
(Prefix
(Position
), RTE
(RE_Record_Controller
));
846 Set_Etype
(Prefix
(Prefix
(Position
)), Typ
);
847 Set_Etype
(Selector_Name
(Prefix
(Position
)),
848 RTE
(RE_Record_Controller
));
849 Set_Etype
(Position
, RTE
(RE_Storage_Offset
));
853 Append_To
(Elab_Code
,
854 Make_DT_Access_Action
(Typ
,
855 Action
=> Set_RC_Offset
,
857 Node1
=> New_Reference_To
(DT_Ptr
, Loc
),
858 Node2
=> Position
)));
861 -- Generate: Set_Remotely_Callable (DT_Ptr, status);
862 -- where status is described in E.4 (18)
869 or else Is_Shared_Passive
(Typ
)
871 ((Is_Remote_Types
(Typ
) or else Is_Remote_Call_Interface
(Typ
))
872 and then Original_View_In_Visible_Part
(Typ
))
873 or else not Comes_From_Source
(Typ
)
875 Status
:= Standard_True
;
877 Status
:= Standard_False
;
880 Append_To
(Elab_Code
,
881 Make_DT_Access_Action
(Typ
,
882 Action
=> Set_Remotely_Callable
,
884 New_Occurrence_Of
(DT_Ptr
, Loc
),
885 New_Occurrence_Of
(Status
, Loc
))));
888 -- Generate: Set_External_Tag (DT_Ptr, exname'Address);
889 -- Should be the external name not the qualified name???
891 if not Has_External_Tag_Rep_Clause
(Typ
) then
892 Append_To
(Elab_Code
,
893 Make_DT_Access_Action
(Typ
,
894 Action
=> Set_External_Tag
,
896 Node1
=> New_Reference_To
(DT_Ptr
, Loc
),
898 Make_Attribute_Reference
(Loc
,
899 Prefix
=> New_Reference_To
(Exname
, Loc
),
900 Attribute_Name
=> Name_Address
))));
902 -- Generate code to register the Tag in the External_Tag hash
903 -- table for the pure Ada type only. We skip this in No_Run_Time
904 -- mode where the External_Tag attribute is not allowed anyway.
906 -- Register_Tag (Dt_Ptr);
908 if Is_RTE
(Generalized_Tag
, RE_Tag
)
909 and then not No_Run_Time
911 Append_To
(Elab_Code
,
912 Make_Procedure_Call_Statement
(Loc
,
913 Name
=> New_Reference_To
(RTE
(RE_Register_Tag
), Loc
),
914 Parameter_Associations
=>
915 New_List
(New_Reference_To
(DT_Ptr
, Loc
))));
925 Append_To
(Elab_Code
,
926 Make_Assignment_Statement
(Loc
,
927 Name
=> New_Reference_To
(No_Reg
, Loc
),
928 Expression
=> New_Reference_To
(Standard_False
, Loc
)));
931 Make_Implicit_If_Statement
(Typ
,
932 Condition
=> New_Reference_To
(No_Reg
, Loc
),
933 Then_Statements
=> Elab_Code
));
938 ---------------------------
939 -- Make_DT_Access_Action --
940 ---------------------------
942 function Make_DT_Access_Action
944 Action
: DT_Access_Action
;
948 Action_Name
: Entity_Id
;
952 if Is_CPP_Class
(Root_Type
(Typ
)) then
953 Action_Name
:= RTE
(CPP_Actions
(Action
));
955 Action_Name
:= RTE
(Ada_Actions
(Action
));
960 -- This is a constant
962 return New_Reference_To
(Action_Name
, Sloc
(Typ
));
965 pragma Assert
(List_Length
(Args
) = Action_Nb_Arg
(Action
));
967 Loc
:= Sloc
(First
(Args
));
969 if Action_Is_Proc
(Action
) then
971 Make_Procedure_Call_Statement
(Loc
,
972 Name
=> New_Reference_To
(Action_Name
, Loc
),
973 Parameter_Associations
=> Args
);
977 Make_Function_Call
(Loc
,
978 Name
=> New_Reference_To
(Action_Name
, Loc
),
979 Parameter_Associations
=> Args
);
981 end Make_DT_Access_Action
;
983 -----------------------------------
984 -- Original_View_In_Visible_Part --
985 -----------------------------------
987 function Original_View_In_Visible_Part
(Typ
: Entity_Id
) return Boolean is
988 Scop
: constant Entity_Id
:= Scope
(Typ
);
991 -- The scope must be a package
993 if Ekind
(Scop
) /= E_Package
994 and then Ekind
(Scop
) /= E_Generic_Package
999 -- A type with a private declaration has a private view declared in
1000 -- the visible part.
1002 if Has_Private_Declaration
(Typ
) then
1006 return List_Containing
(Parent
(Typ
)) =
1007 Visible_Declarations
(Specification
(Unit_Declaration_Node
(Scop
)));
1008 end Original_View_In_Visible_Part
;
1010 -------------------------
1011 -- Set_All_DT_Position --
1012 -------------------------
1014 procedure Set_All_DT_Position
(Typ
: Entity_Id
) is
1015 Parent_Typ
: constant Entity_Id
:= Etype
(Typ
);
1016 Root_Typ
: constant Entity_Id
:= Root_Type
(Typ
);
1017 First_Prim
: constant Elmt_Id
:= First_Elmt
(Primitive_Operations
(Typ
));
1018 The_Tag
: constant Entity_Id
:= Tag_Component
(Typ
);
1019 Adjusted
: Boolean := False;
1020 Finalized
: Boolean := False;
1024 Prim_Elmt
: Elmt_Id
;
1028 -- Get Entry_Count of the parent
1030 if Parent_Typ
/= Typ
1031 and then DT_Entry_Count
(Tag_Component
(Parent_Typ
)) /= No_Uint
1033 Parent_EC
:= UI_To_Int
(DT_Entry_Count
(Tag_Component
(Parent_Typ
)));
1038 -- C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable
1039 -- give a coherent set of information
1041 if Is_CPP_Class
(Root_Typ
) then
1043 -- Compute the number of primitive operations in the main Vtable
1044 -- Set their position:
1045 -- - where it was set if overriden or inherited
1046 -- - after the end of the parent vtable otherwise
1048 Prim_Elmt
:= First_Prim
;
1050 while Present
(Prim_Elmt
) loop
1051 Prim
:= Node
(Prim_Elmt
);
1053 if not Is_CPP_Class
(Typ
) then
1054 Set_DTC_Entity
(Prim
, The_Tag
);
1056 elsif Present
(Alias
(Prim
)) then
1057 Set_DTC_Entity
(Prim
, DTC_Entity
(Alias
(Prim
)));
1058 Set_DT_Position
(Prim
, DT_Position
(Alias
(Prim
)));
1060 elsif No
(DTC_Entity
(Prim
)) and then Is_CPP_Class
(Typ
) then
1061 Error_Msg_NE
("is a primitive operation of&," &
1062 " pragma Cpp_Virtual required", Prim
, Typ
);
1065 if DTC_Entity
(Prim
) = The_Tag
then
1067 -- Get the slot from the parent subprogram if any
1070 H
: Entity_Id
:= Homonym
(Prim
);
1073 while Present
(H
) loop
1074 if Present
(DTC_Entity
(H
))
1075 and then Root_Type
(Scope
(DTC_Entity
(H
))) = Root_Typ
1077 Set_DT_Position
(Prim
, DT_Position
(H
));
1085 -- Otherwise take the canonical slot after the end of the
1088 if DT_Position
(Prim
) = No_Uint
then
1089 Nb_Prim
:= Nb_Prim
+ 1;
1090 Set_DT_Position
(Prim
, UI_From_Int
(Parent_EC
+ Nb_Prim
));
1092 elsif UI_To_Int
(DT_Position
(Prim
)) > Parent_EC
then
1093 Nb_Prim
:= Nb_Prim
+ 1;
1097 Next_Elmt
(Prim_Elmt
);
1100 -- Check that the declared size of the Vtable is bigger or equal
1101 -- than the number of primitive operations (if bigger it means that
1102 -- some of the c++ virtual functions were not imported, that is
1105 if DT_Entry_Count
(The_Tag
) = No_Uint
1106 or else not Is_CPP_Class
(Typ
)
1108 Set_DT_Entry_Count
(The_Tag
, UI_From_Int
(Parent_EC
+ Nb_Prim
));
1110 elsif UI_To_Int
(DT_Entry_Count
(The_Tag
)) < Parent_EC
+ Nb_Prim
then
1111 Error_Msg_N
("not enough room in the Vtable for all virtual"
1112 & " functions", The_Tag
);
1115 -- Check that Positions are not duplicate nor outside the range of
1119 Size
: constant Int
:= UI_To_Int
(DT_Entry_Count
(The_Tag
));
1121 Prim_Pos_Table
: array (1 .. Size
) of Entity_Id
:=
1125 Prim_Elmt
:= First_Prim
;
1126 while Present
(Prim_Elmt
) loop
1127 Prim
:= Node
(Prim_Elmt
);
1129 if DTC_Entity
(Prim
) = The_Tag
then
1130 Pos
:= UI_To_Int
(DT_Position
(Prim
));
1132 if Pos
not in Prim_Pos_Table
'Range then
1134 ("position not in range of virtual table", Prim
);
1136 elsif Present
(Prim_Pos_Table
(Pos
)) then
1137 Error_Msg_NE
("cannot be at the same position in the"
1138 & " vtable than&", Prim
, Prim_Pos_Table
(Pos
));
1141 Prim_Pos_Table
(Pos
) := Prim
;
1145 Next_Elmt
(Prim_Elmt
);
1149 -- For regular Ada tagged types, just set the DT_Position for
1150 -- each primitive operation. Perform some sanity checks to avoid
1151 -- to build completely inconsistant dispatch tables.
1156 Prim_Elmt
:= First_Prim
;
1157 while Present
(Prim_Elmt
) loop
1158 Nb_Prim
:= Nb_Prim
+ 1;
1159 Prim
:= Node
(Prim_Elmt
);
1160 Set_DTC_Entity
(Prim
, The_Tag
);
1161 Set_DT_Position
(Prim
, UI_From_Int
(Nb_Prim
));
1163 if Chars
(Prim
) = Name_Finalize
1164 and then (Is_Predefined_File_Name
1165 (Unit_File_Name
(Current_Sem_Unit
))
1167 not Is_Predefined_File_Name
1168 (Unit_File_Name
(Get_Source_Unit
(Prim
))))
1173 if Chars
(Prim
) = Name_Adjust
then
1177 -- An abstract operation cannot be declared in the private part
1178 -- for a visible abstract type, because it could never be over-
1179 -- ridden. For explicit declarations this is checked at the point
1180 -- of declaration, but for inherited operations it must be done
1181 -- when building the dispatch table. Input is excluded because
1182 -- Limited_Controlled inherits a useless Input stream operation
1183 -- from Root_Controlled, which cannot be overridden.
1185 if Is_Abstract
(Typ
)
1186 and then Is_Abstract
(Prim
)
1187 and then Present
(Alias
(Prim
))
1188 and then Is_Derived_Type
(Typ
)
1189 and then In_Private_Part
(Current_Scope
)
1190 and then List_Containing
(Parent
(Prim
))
1191 = Private_Declarations
1192 (Specification
(Unit_Declaration_Node
(Current_Scope
)))
1193 and then Original_View_In_Visible_Part
(Typ
)
1194 and then Chars
(Prim
) /= Name_uInput
1196 Error_Msg_NE
("abstract inherited private operation&"
1197 & " must be overriden", Parent
(Typ
), Prim
);
1199 Next_Elmt
(Prim_Elmt
);
1202 if Is_Controlled
(Typ
) then
1203 if not Finalized
then
1205 ("controlled type has no explicit Finalize method?", Typ
);
1207 elsif not Adjusted
then
1209 ("controlled type has no explicit Adjust method?", Typ
);
1213 Set_DT_Entry_Count
(The_Tag
, UI_From_Int
(Nb_Prim
));
1215 -- The derived type must have at least as many components than
1216 -- its parent (for root types, the etype points back to itself
1217 -- and the test should not fail)
1220 DT_Entry_Count
(The_Tag
) >=
1221 DT_Entry_Count
(Tag_Component
(Parent_Typ
)));
1223 end Set_All_DT_Position
;
1225 -----------------------------
1226 -- Set_Default_Constructor --
1227 -----------------------------
1229 procedure Set_Default_Constructor
(Typ
: Entity_Id
) is
1237 -- Look for the default constructor entity. For now only the
1238 -- default constructor has the flag Is_Constructor.
1240 E
:= Next_Entity
(Typ
);
1242 and then (Ekind
(E
) /= E_Function
or else not Is_Constructor
(E
))
1247 -- Create the init procedure
1251 Init
:= Make_Defining_Identifier
(Loc
, Name_uInit_Proc
);
1252 Param
:= Make_Defining_Identifier
(Loc
, Name_X
);
1254 Make_Subprogram_Declaration
(Loc
,
1255 Make_Procedure_Specification
(Loc
,
1256 Defining_Unit_Name
=> Init
,
1257 Parameter_Specifications
=> New_List
(
1258 Make_Parameter_Specification
(Loc
,
1259 Defining_Identifier
=> Param
,
1260 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)))));
1262 Set_Init_Proc
(Typ
, Init
);
1263 Set_Is_Imported
(Init
);
1264 Set_Interface_Name
(Init
, Interface_Name
(E
));
1265 Set_Convention
(Init
, Convention_C
);
1266 Set_Is_Public
(Init
);
1267 Set_Has_Completion
(Init
);
1269 -- if there are no constructors, mark the type as abstract since we
1270 -- won't be able to declare objects of that type.
1273 Set_Is_Abstract
(Typ
);
1275 end Set_Default_Constructor
;