1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, 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 Exp_Atag
; use Exp_Atag
;
33 with Exp_Ch7
; use Exp_Ch7
;
34 with Exp_Dbug
; use Exp_Dbug
;
35 with Exp_Tss
; use Exp_Tss
;
36 with Exp_Util
; use Exp_Util
;
37 with Freeze
; use Freeze
;
38 with Itypes
; use Itypes
;
39 with Nlists
; use Nlists
;
40 with Nmake
; use Nmake
;
41 with Namet
; use Namet
;
43 with Output
; use Output
;
44 with Restrict
; use Restrict
;
45 with Rident
; use Rident
;
46 with Rtsfind
; use Rtsfind
;
48 with Sem_Ch6
; use Sem_Ch6
;
49 with Sem_Ch7
; use Sem_Ch7
;
50 with Sem_Ch8
; use Sem_Ch8
;
51 with Sem_Disp
; use Sem_Disp
;
52 with Sem_Eval
; use Sem_Eval
;
53 with Sem_Res
; use Sem_Res
;
54 with Sem_Type
; use Sem_Type
;
55 with Sem_Util
; use Sem_Util
;
56 with Sinfo
; use Sinfo
;
57 with Snames
; use Snames
;
58 with Stand
; use Stand
;
59 with Stringt
; use Stringt
;
60 with Targparm
; use Targparm
;
61 with Tbuild
; use Tbuild
;
62 with Uintp
; use Uintp
;
64 package body Exp_Disp
is
66 -----------------------
67 -- Local Subprograms --
68 -----------------------
70 function Default_Prim_Op_Position
(E
: Entity_Id
) return Uint
;
71 -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
72 -- of the default primitive operations.
74 function Has_DT
(Typ
: Entity_Id
) return Boolean;
75 pragma Inline
(Has_DT
);
76 -- Returns true if we generate a dispatch table for tagged type Typ
78 function Is_Predefined_Dispatching_Alias
(Prim
: Entity_Id
) return Boolean;
79 -- Returns true if Prim is not a predefined dispatching primitive but it is
80 -- an alias of a predefined dispatching primitive (i.e. through a renaming)
82 function Original_View_In_Visible_Part
(Typ
: Entity_Id
) return Boolean;
83 -- Check if the type has a private view or if the public view appears
84 -- in the visible part of a package spec.
88 Typ
: Entity_Id
) return Node_Id
;
89 -- Ada 2005 (AI-345): Determine the primitive operation kind of Prim
90 -- according to its type Typ. Return a reference to an RE_Prim_Op_Kind
93 function Tagged_Kind
(T
: Entity_Id
) return Node_Id
;
94 -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
95 -- to an RE_Tagged_Kind enumeration value.
97 ------------------------
98 -- Building_Static_DT --
99 ------------------------
101 function Building_Static_DT
(Typ
: Entity_Id
) return Boolean is
102 Root_Typ
: Entity_Id
:= Root_Type
(Typ
);
105 -- Handle private types
107 if Present
(Full_View
(Root_Typ
)) then
108 Root_Typ
:= Full_View
(Root_Typ
);
111 return Static_Dispatch_Tables
112 and then Is_Library_Level_Tagged_Type
(Typ
)
114 -- If the type is derived from a CPP class we cannot statically
115 -- build the dispatch tables because we must inherit primitives
116 -- from the CPP side.
118 and then not Is_CPP_Class
(Root_Typ
);
119 end Building_Static_DT
;
121 ----------------------------------
122 -- Build_Static_Dispatch_Tables --
123 ----------------------------------
125 procedure Build_Static_Dispatch_Tables
(N
: Entity_Id
) is
126 Target_List
: List_Id
;
128 procedure Build_Dispatch_Tables
(List
: List_Id
);
129 -- Build the static dispatch table of tagged types found in the list of
130 -- declarations. The generated nodes are added at the end of Target_List
132 procedure Build_Package_Dispatch_Tables
(N
: Node_Id
);
133 -- Build static dispatch tables associated with package declaration N
135 ---------------------------
136 -- Build_Dispatch_Tables --
137 ---------------------------
139 procedure Build_Dispatch_Tables
(List
: List_Id
) is
144 while Present
(D
) loop
146 -- Handle nested packages and package bodies recursively. The
147 -- generated code is placed on the Target_List established for
148 -- the enclosing compilation unit.
150 if Nkind
(D
) = N_Package_Declaration
then
151 Build_Package_Dispatch_Tables
(D
);
153 elsif Nkind
(D
) = N_Package_Body
then
154 Build_Dispatch_Tables
(Declarations
(D
));
156 elsif Nkind
(D
) = N_Package_Body_Stub
157 and then Present
(Library_Unit
(D
))
159 Build_Dispatch_Tables
160 (Declarations
(Proper_Body
(Unit
(Library_Unit
(D
)))));
162 -- Handle full type declarations and derivations of library
163 -- level tagged types
165 elsif (Nkind
(D
) = N_Full_Type_Declaration
166 or else Nkind
(D
) = N_Derived_Type_Definition
)
167 and then Is_Library_Level_Tagged_Type
(Defining_Entity
(D
))
168 and then Ekind
(Defining_Entity
(D
)) /= E_Record_Subtype
169 and then not Is_Private_Type
(Defining_Entity
(D
))
171 Insert_List_After_And_Analyze
(Last
(Target_List
),
172 Make_DT
(Defining_Entity
(D
)));
174 -- Handle private types of library level tagged types. We must
175 -- exchange the private and full-view to ensure the correct
176 -- expansion. If the full view is a synchronized type ignore
177 -- the type because the table will be built for the corresponding
178 -- record type, that has its own declaration.
180 elsif (Nkind
(D
) = N_Private_Type_Declaration
181 or else Nkind
(D
) = N_Private_Extension_Declaration
)
182 and then Present
(Full_View
(Defining_Entity
(D
)))
185 E1
: constant Entity_Id
:= Defining_Entity
(D
);
186 E2
: constant Entity_Id
:= Full_View
(E1
);
189 if Is_Library_Level_Tagged_Type
(E2
)
190 and then Ekind
(E2
) /= E_Record_Subtype
191 and then not Is_Concurrent_Type
(E2
)
193 Exchange_Declarations
(E1
);
194 Insert_List_After_And_Analyze
(Last
(Target_List
),
196 Exchange_Declarations
(E2
);
203 end Build_Dispatch_Tables
;
205 -----------------------------------
206 -- Build_Package_Dispatch_Tables --
207 -----------------------------------
209 procedure Build_Package_Dispatch_Tables
(N
: Node_Id
) is
210 Spec
: constant Node_Id
:= Specification
(N
);
211 Id
: constant Entity_Id
:= Defining_Entity
(N
);
212 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
213 Priv_Decls
: constant List_Id
:= Private_Declarations
(Spec
);
218 if Present
(Priv_Decls
) then
219 Build_Dispatch_Tables
(Vis_Decls
);
220 Build_Dispatch_Tables
(Priv_Decls
);
222 elsif Present
(Vis_Decls
) then
223 Build_Dispatch_Tables
(Vis_Decls
);
227 end Build_Package_Dispatch_Tables
;
229 -- Start of processing for Build_Static_Dispatch_Tables
232 if not Expander_Active
233 or else VM_Target
/= No_VM
238 if Nkind
(N
) = N_Package_Declaration
then
240 Spec
: constant Node_Id
:= Specification
(N
);
241 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
242 Priv_Decls
: constant List_Id
:= Private_Declarations
(Spec
);
245 if Present
(Priv_Decls
)
246 and then Is_Non_Empty_List
(Priv_Decls
)
248 Target_List
:= Priv_Decls
;
250 elsif not Present
(Vis_Decls
) then
251 Target_List
:= New_List
;
252 Set_Private_Declarations
(Spec
, Target_List
);
254 Target_List
:= Vis_Decls
;
257 Build_Package_Dispatch_Tables
(N
);
260 else pragma Assert
(Nkind
(N
) = N_Package_Body
);
261 Target_List
:= Declarations
(N
);
262 Build_Dispatch_Tables
(Target_List
);
264 end Build_Static_Dispatch_Tables
;
266 ------------------------------
267 -- Default_Prim_Op_Position --
268 ------------------------------
270 function Default_Prim_Op_Position
(E
: Entity_Id
) return Uint
is
271 TSS_Name
: TSS_Name_Type
;
274 Get_Name_String
(Chars
(E
));
277 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
279 if Chars
(E
) = Name_uSize
then
282 elsif Chars
(E
) = Name_uAlignment
then
285 elsif TSS_Name
= TSS_Stream_Read
then
288 elsif TSS_Name
= TSS_Stream_Write
then
291 elsif TSS_Name
= TSS_Stream_Input
then
294 elsif TSS_Name
= TSS_Stream_Output
then
297 elsif Chars
(E
) = Name_Op_Eq
then
300 elsif Chars
(E
) = Name_uAssign
then
303 elsif TSS_Name
= TSS_Deep_Adjust
then
306 elsif TSS_Name
= TSS_Deep_Finalize
then
309 elsif Ada_Version
>= Ada_05
then
310 if Chars
(E
) = Name_uDisp_Asynchronous_Select
then
313 elsif Chars
(E
) = Name_uDisp_Conditional_Select
then
316 elsif Chars
(E
) = Name_uDisp_Get_Prim_Op_Kind
then
319 elsif Chars
(E
) = Name_uDisp_Get_Task_Id
then
322 elsif Chars
(E
) = Name_uDisp_Requeue
then
325 elsif Chars
(E
) = Name_uDisp_Timed_Select
then
331 end Default_Prim_Op_Position
;
333 -----------------------------
334 -- Expand_Dispatching_Call --
335 -----------------------------
337 procedure Expand_Dispatching_Call
(Call_Node
: Node_Id
) is
338 Loc
: constant Source_Ptr
:= Sloc
(Call_Node
);
339 Call_Typ
: constant Entity_Id
:= Etype
(Call_Node
);
341 Ctrl_Arg
: constant Node_Id
:= Controlling_Argument
(Call_Node
);
342 Ctrl_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Ctrl_Arg
));
343 Param_List
: constant List_Id
:= Parameter_Associations
(Call_Node
);
348 New_Call_Name
: Node_Id
;
349 New_Params
: List_Id
:= No_List
;
352 Subp_Ptr_Typ
: Entity_Id
;
353 Subp_Typ
: Entity_Id
;
355 Eq_Prim_Op
: Entity_Id
:= Empty
;
356 Controlling_Tag
: Node_Id
;
358 function New_Value
(From
: Node_Id
) return Node_Id
;
359 -- From is the original Expression. New_Value is equivalent to a call
360 -- to Duplicate_Subexpr with an explicit dereference when From is an
367 function New_Value
(From
: Node_Id
) return Node_Id
is
368 Res
: constant Node_Id
:= Duplicate_Subexpr
(From
);
370 if Is_Access_Type
(Etype
(From
)) then
372 Make_Explicit_Dereference
(Sloc
(From
),
379 -- Start of processing for Expand_Dispatching_Call
382 if No_Run_Time_Mode
then
383 Error_Msg_CRT
("tagged types", Call_Node
);
387 -- Expand_Dispatching_Call is called directly from the semantics,
388 -- so we need a check to see whether expansion is active before
389 -- proceeding. In addition, there is no need to expand the call
390 -- if we are compiling under restriction No_Dispatching_Calls;
391 -- the semantic analyzer has previously notified the violation
392 -- of this restriction.
394 if not Expander_Active
395 or else Restriction_Active
(No_Dispatching_Calls
)
400 -- Set subprogram. If this is an inherited operation that was
401 -- overridden, the body that is being called is its alias.
403 Subp
:= Entity
(Name
(Call_Node
));
405 if Present
(Alias
(Subp
))
406 and then Is_Inherited_Operation
(Subp
)
407 and then No
(DTC_Entity
(Subp
))
409 Subp
:= Alias
(Subp
);
412 -- Definition of the class-wide type and the tagged type
414 -- If the controlling argument is itself a tag rather than a tagged
415 -- object, then use the class-wide type associated with the subprogram's
416 -- controlling type. This case can occur when a call to an inherited
417 -- primitive has an actual that originated from a default parameter
418 -- given by a tag-indeterminate call and when there is no other
419 -- controlling argument providing the tag (AI-239 requires dispatching).
420 -- This capability of dispatching directly by tag is also needed by the
421 -- implementation of AI-260 (for the generic dispatching constructors).
423 if Ctrl_Typ
= RTE
(RE_Tag
)
424 or else (RTE_Available
(RE_Interface_Tag
)
425 and then Ctrl_Typ
= RTE
(RE_Interface_Tag
))
427 CW_Typ
:= Class_Wide_Type
(Find_Dispatching_Type
(Subp
));
429 -- Class_Wide_Type is applied to the expressions used to initialize
430 -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
431 -- there are cases where the controlling type is resolved to a specific
432 -- type (such as for designated types of arguments such as CW'Access).
434 elsif Is_Access_Type
(Ctrl_Typ
) then
435 CW_Typ
:= Class_Wide_Type
(Designated_Type
(Ctrl_Typ
));
438 CW_Typ
:= Class_Wide_Type
(Ctrl_Typ
);
441 Typ
:= Root_Type
(CW_Typ
);
443 if Ekind
(Typ
) = E_Incomplete_Type
then
444 Typ
:= Non_Limited_View
(Typ
);
447 if not Is_Limited_Type
(Typ
) then
448 Eq_Prim_Op
:= Find_Prim_Op
(Typ
, Name_Op_Eq
);
451 -- Dispatching call to C++ primitive. Create a new parameter list
452 -- with no tag checks.
454 if Is_CPP_Class
(Typ
) then
455 New_Params
:= New_List
;
456 Param
:= First_Actual
(Call_Node
);
457 while Present
(Param
) loop
458 Append_To
(New_Params
, Relocate_Node
(Param
));
462 -- Dispatching call to Ada primitive
464 elsif Present
(Param_List
) then
466 -- Generate the Tag checks when appropriate
468 New_Params
:= New_List
;
469 Param
:= First_Actual
(Call_Node
);
470 while Present
(Param
) loop
472 -- No tag check with itself
474 if Param
= Ctrl_Arg
then
475 Append_To
(New_Params
,
476 Duplicate_Subexpr_Move_Checks
(Param
));
478 -- No tag check for parameter whose type is neither tagged nor
479 -- access to tagged (for access parameters)
481 elsif No
(Find_Controlling_Arg
(Param
)) then
482 Append_To
(New_Params
, Relocate_Node
(Param
));
484 -- No tag check for function dispatching on result if the
485 -- Tag given by the context is this one
487 elsif Find_Controlling_Arg
(Param
) = Ctrl_Arg
then
488 Append_To
(New_Params
, Relocate_Node
(Param
));
490 -- "=" is the only dispatching operation allowed to get
491 -- operands with incompatible tags (it just returns false).
492 -- We use Duplicate_Subexpr_Move_Checks instead of calling
493 -- Relocate_Node because the value will be duplicated to
496 elsif Subp
= Eq_Prim_Op
then
497 Append_To
(New_Params
,
498 Duplicate_Subexpr_Move_Checks
(Param
));
500 -- No check in presence of suppress flags
502 elsif Tag_Checks_Suppressed
(Etype
(Param
))
503 or else (Is_Access_Type
(Etype
(Param
))
504 and then Tag_Checks_Suppressed
505 (Designated_Type
(Etype
(Param
))))
507 Append_To
(New_Params
, Relocate_Node
(Param
));
509 -- Optimization: no tag checks if the parameters are identical
511 elsif Is_Entity_Name
(Param
)
512 and then Is_Entity_Name
(Ctrl_Arg
)
513 and then Entity
(Param
) = Entity
(Ctrl_Arg
)
515 Append_To
(New_Params
, Relocate_Node
(Param
));
517 -- Now we need to generate the Tag check
520 -- Generate code for tag equality check
521 -- Perhaps should have Checks.Apply_Tag_Equality_Check???
523 Insert_Action
(Ctrl_Arg
,
524 Make_Implicit_If_Statement
(Call_Node
,
528 Make_Selected_Component
(Loc
,
529 Prefix
=> New_Value
(Ctrl_Arg
),
532 (First_Tag_Component
(Typ
), Loc
)),
535 Make_Selected_Component
(Loc
,
537 Unchecked_Convert_To
(Typ
, New_Value
(Param
)),
540 (First_Tag_Component
(Typ
), Loc
))),
543 New_List
(New_Constraint_Error
(Loc
))));
545 Append_To
(New_Params
, Relocate_Node
(Param
));
552 -- Generate the appropriate subprogram pointer type
554 if Etype
(Subp
) = Typ
then
557 Res_Typ
:= Etype
(Subp
);
560 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, Call_Node
);
561 Subp_Ptr_Typ
:= Create_Itype
(E_Access_Subprogram_Type
, Call_Node
);
562 Set_Etype
(Subp_Typ
, Res_Typ
);
563 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
565 -- Create a new list of parameters which is a copy of the old formal
566 -- list including the creation of a new set of matching entities.
569 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
570 New_Formal
: Entity_Id
;
571 Extra
: Entity_Id
:= Empty
;
574 if Present
(Old_Formal
) then
575 New_Formal
:= New_Copy
(Old_Formal
);
576 Set_First_Entity
(Subp_Typ
, New_Formal
);
577 Param
:= First_Actual
(Call_Node
);
580 Set_Scope
(New_Formal
, Subp_Typ
);
582 -- Change all the controlling argument types to be class-wide
583 -- to avoid a recursion in dispatching.
585 if Is_Controlling_Formal
(New_Formal
) then
586 Set_Etype
(New_Formal
, Etype
(Param
));
589 -- If the type of the formal is an itype, there was code here
590 -- introduced in 1998 in revision 1.46, to create a new itype
591 -- by copy. This seems useless, and in fact leads to semantic
592 -- errors when the itype is the completion of a type derived
593 -- from a private type.
596 Next_Formal
(Old_Formal
);
597 exit when No
(Old_Formal
);
599 Set_Next_Entity
(New_Formal
, New_Copy
(Old_Formal
));
600 Next_Entity
(New_Formal
);
604 Set_Next_Entity
(New_Formal
, Empty
);
605 Set_Last_Entity
(Subp_Typ
, Extra
);
608 -- Now that the explicit formals have been duplicated, any extra
609 -- formals needed by the subprogram must be created.
611 if Present
(Extra
) then
612 Set_Extra_Formal
(Extra
, Empty
);
615 Create_Extra_Formals
(Subp_Typ
);
618 Set_Etype
(Subp_Ptr_Typ
, Subp_Ptr_Typ
);
619 Set_Directly_Designated_Type
(Subp_Ptr_Typ
, Subp_Typ
);
620 Set_Convention
(Subp_Ptr_Typ
, Convention
(Subp_Typ
));
622 -- If the controlling argument is a value of type Ada.Tag or an abstract
623 -- interface class-wide type then use it directly. Otherwise, the tag
624 -- must be extracted from the controlling object.
626 if Ctrl_Typ
= RTE
(RE_Tag
)
627 or else (RTE_Available
(RE_Interface_Tag
)
628 and then Ctrl_Typ
= RTE
(RE_Interface_Tag
))
630 Controlling_Tag
:= Duplicate_Subexpr
(Ctrl_Arg
);
632 -- Extract the tag from an unchecked type conversion. Done to avoid
633 -- the expansion of additional code just to obtain the value of such
634 -- tag because the current management of interface type conversions
635 -- generates in some cases this unchecked type conversion with the
636 -- tag of the object (see Expand_Interface_Conversion).
638 elsif Nkind
(Ctrl_Arg
) = N_Unchecked_Type_Conversion
640 (Etype
(Expression
(Ctrl_Arg
)) = RTE
(RE_Tag
)
642 (RTE_Available
(RE_Interface_Tag
)
644 Etype
(Expression
(Ctrl_Arg
)) = RTE
(RE_Interface_Tag
)))
646 Controlling_Tag
:= Duplicate_Subexpr
(Expression
(Ctrl_Arg
));
648 -- Ada 2005 (AI-251): Abstract interface class-wide type
650 elsif Is_Interface
(Ctrl_Typ
)
651 and then Is_Class_Wide_Type
(Ctrl_Typ
)
653 Controlling_Tag
:= Duplicate_Subexpr
(Ctrl_Arg
);
657 Make_Selected_Component
(Loc
,
658 Prefix
=> Duplicate_Subexpr_Move_Checks
(Ctrl_Arg
),
659 Selector_Name
=> New_Reference_To
(DTC_Entity
(Subp
), Loc
));
662 -- Handle dispatching calls to predefined primitives
664 if Is_Predefined_Dispatching_Operation
(Subp
)
665 or else Is_Predefined_Dispatching_Alias
(Subp
)
668 Unchecked_Convert_To
(Subp_Ptr_Typ
,
669 Build_Get_Predefined_Prim_Op_Address
(Loc
,
670 Tag_Node
=> Controlling_Tag
,
671 Position
=> DT_Position
(Subp
)));
673 -- Handle dispatching calls to user-defined primitives
677 Unchecked_Convert_To
(Subp_Ptr_Typ
,
678 Build_Get_Prim_Op_Address
(Loc
,
679 Typ
=> Find_Dispatching_Type
(Subp
),
680 Tag_Node
=> Controlling_Tag
,
681 Position
=> DT_Position
(Subp
)));
684 if Nkind
(Call_Node
) = N_Function_Call
then
687 Make_Function_Call
(Loc
,
688 Name
=> New_Call_Name
,
689 Parameter_Associations
=> New_Params
);
691 -- If this is a dispatching "=", we must first compare the tags so
692 -- we generate: x.tag = y.tag and then x = y
694 if Subp
= Eq_Prim_Op
then
695 Param
:= First_Actual
(Call_Node
);
701 Make_Selected_Component
(Loc
,
702 Prefix
=> New_Value
(Param
),
704 New_Reference_To
(First_Tag_Component
(Typ
),
708 Make_Selected_Component
(Loc
,
710 Unchecked_Convert_To
(Typ
,
711 New_Value
(Next_Actual
(Param
))),
713 New_Reference_To
(First_Tag_Component
(Typ
),
715 Right_Opnd
=> New_Call
);
720 Make_Procedure_Call_Statement
(Loc
,
721 Name
=> New_Call_Name
,
722 Parameter_Associations
=> New_Params
);
725 Rewrite
(Call_Node
, New_Call
);
727 -- Suppress all checks during the analysis of the expanded code
728 -- to avoid the generation of spurious warnings under ZFP run-time.
730 Analyze_And_Resolve
(Call_Node
, Call_Typ
, Suppress
=> All_Checks
);
731 end Expand_Dispatching_Call
;
733 ---------------------------------
734 -- Expand_Interface_Conversion --
735 ---------------------------------
737 procedure Expand_Interface_Conversion
739 Is_Static
: Boolean := True)
741 Loc
: constant Source_Ptr
:= Sloc
(N
);
742 Etyp
: constant Entity_Id
:= Etype
(N
);
743 Operand
: constant Node_Id
:= Expression
(N
);
744 Operand_Typ
: Entity_Id
:= Etype
(Operand
);
746 Iface_Typ
: Entity_Id
:= Etype
(N
);
747 Iface_Tag
: Entity_Id
;
750 -- Ada 2005 (AI-345): Handle synchronized interface type derivations
752 if Is_Concurrent_Type
(Operand_Typ
) then
753 Operand_Typ
:= Base_Type
(Corresponding_Record_Type
(Operand_Typ
));
756 -- Handle access to class-wide interface types
758 if Is_Access_Type
(Iface_Typ
) then
759 Iface_Typ
:= Etype
(Directly_Designated_Type
(Iface_Typ
));
762 -- Handle class-wide interface types. This conversion can appear
763 -- explicitly in the source code. Example: I'Class (Obj)
765 if Is_Class_Wide_Type
(Iface_Typ
) then
766 Iface_Typ
:= Root_Type
(Iface_Typ
);
769 -- If the target type is a tagged synchronized type, the dispatch table
770 -- info is in the corresponding record type.
772 if Is_Concurrent_Type
(Iface_Typ
) then
773 Iface_Typ
:= Corresponding_Record_Type
(Iface_Typ
);
776 -- Freeze the entity associated with the target interface to have
777 -- available the attribute Access_Disp_Table.
779 Freeze_Before
(N
, Iface_Typ
);
781 pragma Assert
(not Is_Static
782 or else (not Is_Class_Wide_Type
(Iface_Typ
)
783 and then Is_Interface
(Iface_Typ
)));
785 if VM_Target
/= No_VM
then
787 -- For VM, just do a conversion ???
789 Rewrite
(N
, Unchecked_Convert_To
(Etype
(N
), N
));
794 if not Is_Static
then
796 -- Give error if configurable run time and Displace not available
798 if not RTE_Available
(RE_Displace
) then
799 Error_Msg_CRT
("dynamic interface conversion", N
);
803 -- Handle conversion of access-to-class-wide interface types. Target
804 -- can be an access to an object or an access to another class-wide
805 -- interface (see -1- and -2- in the following example):
807 -- type Iface1_Ref is access all Iface1'Class;
808 -- type Iface2_Ref is access all Iface1'Class;
810 -- Acc1 : Iface1_Ref := new ...
811 -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1
812 -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
814 if Is_Access_Type
(Operand_Typ
) then
816 Unchecked_Convert_To
(Etype
(N
),
817 Make_Function_Call
(Loc
,
818 Name
=> New_Reference_To
(RTE
(RE_Displace
), Loc
),
819 Parameter_Associations
=> New_List
(
821 Unchecked_Convert_To
(RTE
(RE_Address
),
822 Relocate_Node
(Expression
(N
))),
825 (Node
(First_Elmt
(Access_Disp_Table
(Iface_Typ
))),
833 Make_Function_Call
(Loc
,
834 Name
=> New_Reference_To
(RTE
(RE_Displace
), Loc
),
835 Parameter_Associations
=> New_List
(
836 Make_Attribute_Reference
(Loc
,
837 Prefix
=> Relocate_Node
(Expression
(N
)),
838 Attribute_Name
=> Name_Address
),
841 (Node
(First_Elmt
(Access_Disp_Table
(Iface_Typ
))),
846 -- If the target is a class-wide interface we change the type of the
847 -- data returned by IW_Convert to indicate that this is a dispatching
851 New_Itype
: Entity_Id
;
854 New_Itype
:= Create_Itype
(E_Anonymous_Access_Type
, N
);
855 Set_Etype
(New_Itype
, New_Itype
);
856 Set_Directly_Designated_Type
(New_Itype
, Etyp
);
859 Make_Explicit_Dereference
(Loc
,
861 Unchecked_Convert_To
(New_Itype
, Relocate_Node
(N
))));
863 Freeze_Itype
(New_Itype
, N
);
869 Iface_Tag
:= Find_Interface_Tag
(Operand_Typ
, Iface_Typ
);
870 pragma Assert
(Iface_Tag
/= Empty
);
872 -- Keep separate access types to interfaces because one internal
873 -- function is used to handle the null value (see following comment)
875 if not Is_Access_Type
(Etype
(N
)) then
877 Unchecked_Convert_To
(Etype
(N
),
878 Make_Selected_Component
(Loc
,
879 Prefix
=> Relocate_Node
(Expression
(N
)),
881 New_Occurrence_Of
(Iface_Tag
, Loc
))));
884 -- Build internal function to handle the case in which the
885 -- actual is null. If the actual is null returns null because
886 -- no displacement is required; otherwise performs a type
887 -- conversion that will be expanded in the code that returns
888 -- the value of the displaced actual. That is:
890 -- function Func (O : Address) return Iface_Typ is
891 -- type Op_Typ is access all Operand_Typ;
892 -- Aux : Op_Typ := To_Op_Typ (O);
894 -- if O = Null_Address then
897 -- return Iface_Typ!(Aux.Iface_Tag'Address);
902 Desig_Typ
: Entity_Id
;
904 New_Typ_Decl
: Node_Id
;
908 Desig_Typ
:= Etype
(Expression
(N
));
910 if Is_Access_Type
(Desig_Typ
) then
911 Desig_Typ
:= Directly_Designated_Type
(Desig_Typ
);
914 if Is_Concurrent_Type
(Desig_Typ
) then
915 Desig_Typ
:= Base_Type
(Corresponding_Record_Type
(Desig_Typ
));
919 Make_Full_Type_Declaration
(Loc
,
920 Defining_Identifier
=>
921 Make_Defining_Identifier
(Loc
, New_Internal_Name
('T')),
923 Make_Access_To_Object_Definition
(Loc
,
925 Null_Exclusion_Present
=> False,
926 Constant_Present
=> False,
927 Subtype_Indication
=>
928 New_Reference_To
(Desig_Typ
, Loc
)));
931 Make_Simple_Return_Statement
(Loc
,
932 Unchecked_Convert_To
(Etype
(N
),
933 Make_Attribute_Reference
(Loc
,
935 Make_Selected_Component
(Loc
,
938 (Defining_Identifier
(New_Typ_Decl
),
939 Make_Identifier
(Loc
, Name_uO
)),
941 New_Occurrence_Of
(Iface_Tag
, Loc
)),
942 Attribute_Name
=> Name_Address
))));
944 -- If the type is null-excluding, no need for the null branch.
945 -- Otherwise we need to check for it and return null.
947 if not Can_Never_Be_Null
(Etype
(N
)) then
949 Make_If_Statement
(Loc
,
952 Left_Opnd
=> Make_Identifier
(Loc
, Name_uO
),
953 Right_Opnd
=> New_Reference_To
954 (RTE
(RE_Null_Address
), Loc
)),
956 Then_Statements
=> New_List
(
957 Make_Simple_Return_Statement
(Loc
,
959 Else_Statements
=> Stats
));
963 Make_Defining_Identifier
(Loc
,
964 New_Internal_Name
('F'));
967 Make_Subprogram_Body
(Loc
,
969 Make_Function_Specification
(Loc
,
970 Defining_Unit_Name
=> Fent
,
972 Parameter_Specifications
=> New_List
(
973 Make_Parameter_Specification
(Loc
,
974 Defining_Identifier
=>
975 Make_Defining_Identifier
(Loc
, Name_uO
),
977 New_Reference_To
(RTE
(RE_Address
), Loc
))),
980 New_Reference_To
(Etype
(N
), Loc
)),
982 Declarations
=> New_List
(New_Typ_Decl
),
984 Handled_Statement_Sequence
=>
985 Make_Handled_Sequence_Of_Statements
(Loc
, Stats
));
987 -- Place function body before the expression containing the
988 -- conversion. We suppress all checks because the body of the
989 -- internally generated function already takes care of the case
990 -- in which the actual is null; therefore there is no need to
991 -- double check that the pointer is not null when the program
992 -- executes the alternative that performs the type conversion).
994 Insert_Action
(N
, Func
, Suppress
=> All_Checks
);
996 if Is_Access_Type
(Etype
(Expression
(N
))) then
998 -- Generate: Func (Address!(Expression))
1001 Make_Function_Call
(Loc
,
1002 Name
=> New_Reference_To
(Fent
, Loc
),
1003 Parameter_Associations
=> New_List
(
1004 Unchecked_Convert_To
(RTE
(RE_Address
),
1005 Relocate_Node
(Expression
(N
))))));
1008 -- Generate: Func (Operand_Typ!(Expression)'Address)
1011 Make_Function_Call
(Loc
,
1012 Name
=> New_Reference_To
(Fent
, Loc
),
1013 Parameter_Associations
=> New_List
(
1014 Make_Attribute_Reference
(Loc
,
1015 Prefix
=> Unchecked_Convert_To
(Operand_Typ
,
1016 Relocate_Node
(Expression
(N
))),
1017 Attribute_Name
=> Name_Address
))));
1023 end Expand_Interface_Conversion
;
1025 ------------------------------
1026 -- Expand_Interface_Actuals --
1027 ------------------------------
1029 procedure Expand_Interface_Actuals
(Call_Node
: Node_Id
) is
1031 Actual_Dup
: Node_Id
;
1032 Actual_Typ
: Entity_Id
;
1034 Conversion
: Node_Id
;
1036 Formal_Typ
: Entity_Id
;
1038 Formal_DDT
: Entity_Id
;
1039 Actual_DDT
: Entity_Id
;
1042 -- This subprogram is called directly from the semantics, so we need a
1043 -- check to see whether expansion is active before proceeding.
1045 if not Expander_Active
then
1049 -- Call using access to subprogram with explicit dereference
1051 if Nkind
(Name
(Call_Node
)) = N_Explicit_Dereference
then
1052 Subp
:= Etype
(Name
(Call_Node
));
1054 -- Call using selected component
1056 elsif Nkind
(Name
(Call_Node
)) = N_Selected_Component
then
1057 Subp
:= Entity
(Selector_Name
(Name
(Call_Node
)));
1059 -- Call using direct name
1062 Subp
:= Entity
(Name
(Call_Node
));
1065 -- Ada 2005 (AI-251): Look for interface type formals to force "this"
1068 Formal
:= First_Formal
(Subp
);
1069 Actual
:= First_Actual
(Call_Node
);
1070 while Present
(Formal
) loop
1071 Formal_Typ
:= Etype
(Formal
);
1073 if Ekind
(Formal_Typ
) = E_Record_Type_With_Private
then
1074 Formal_Typ
:= Full_View
(Formal_Typ
);
1077 if Is_Access_Type
(Formal_Typ
) then
1078 Formal_DDT
:= Directly_Designated_Type
(Formal_Typ
);
1081 Actual_Typ
:= Etype
(Actual
);
1083 if Is_Access_Type
(Actual_Typ
) then
1084 Actual_DDT
:= Directly_Designated_Type
(Actual_Typ
);
1087 if Is_Interface
(Formal_Typ
)
1088 and then Is_Class_Wide_Type
(Formal_Typ
)
1090 -- No need to displace the pointer if the type of the actual
1091 -- coindices with the type of the formal.
1093 if Actual_Typ
= Formal_Typ
then
1096 -- No need to displace the pointer if the interface type is
1097 -- a parent of the type of the actual because in this case the
1098 -- interface primitives are located in the primary dispatch table.
1100 elsif Is_Ancestor
(Formal_Typ
, Actual_Typ
) then
1103 -- Implicit conversion to the class-wide formal type to force
1104 -- the displacement of the pointer.
1107 Conversion
:= Convert_To
(Formal_Typ
, Relocate_Node
(Actual
));
1108 Rewrite
(Actual
, Conversion
);
1109 Analyze_And_Resolve
(Actual
, Formal_Typ
);
1112 -- Access to class-wide interface type
1114 elsif Is_Access_Type
(Formal_Typ
)
1115 and then Is_Interface
(Formal_DDT
)
1116 and then Is_Class_Wide_Type
(Formal_DDT
)
1117 and then Interface_Present_In_Ancestor
1119 Iface
=> Etype
(Formal_DDT
))
1121 -- Handle attributes 'Access and 'Unchecked_Access
1123 if Nkind
(Actual
) = N_Attribute_Reference
1125 (Attribute_Name
(Actual
) = Name_Access
1126 or else Attribute_Name
(Actual
) = Name_Unchecked_Access
)
1128 -- This case must have been handled by the analysis and
1129 -- expansion of 'Access. The only exception is when types
1130 -- match and no further expansion is required.
1132 pragma Assert
(Base_Type
(Etype
(Prefix
(Actual
)))
1133 = Base_Type
(Formal_DDT
));
1136 -- No need to displace the pointer if the type of the actual
1137 -- coincides with the type of the formal.
1139 elsif Actual_DDT
= Formal_DDT
then
1142 -- No need to displace the pointer if the interface type is
1143 -- a parent of the type of the actual because in this case the
1144 -- interface primitives are located in the primary dispatch table.
1146 elsif Is_Ancestor
(Formal_DDT
, Actual_DDT
) then
1150 Actual_Dup
:= Relocate_Node
(Actual
);
1152 if From_With_Type
(Actual_Typ
) then
1154 -- If the type of the actual parameter comes from a limited
1155 -- with-clause and the non-limited view is already available
1156 -- we replace the anonymous access type by a duplicate
1157 -- declaration whose designated type is the non-limited view
1159 if Ekind
(Actual_DDT
) = E_Incomplete_Type
1160 and then Present
(Non_Limited_View
(Actual_DDT
))
1162 Anon
:= New_Copy
(Actual_Typ
);
1164 if Is_Itype
(Anon
) then
1165 Set_Scope
(Anon
, Current_Scope
);
1168 Set_Directly_Designated_Type
(Anon
,
1169 Non_Limited_View
(Actual_DDT
));
1170 Set_Etype
(Actual_Dup
, Anon
);
1172 elsif Is_Class_Wide_Type
(Actual_DDT
)
1173 and then Ekind
(Etype
(Actual_DDT
)) = E_Incomplete_Type
1174 and then Present
(Non_Limited_View
(Etype
(Actual_DDT
)))
1176 Anon
:= New_Copy
(Actual_Typ
);
1178 if Is_Itype
(Anon
) then
1179 Set_Scope
(Anon
, Current_Scope
);
1182 Set_Directly_Designated_Type
(Anon
,
1183 New_Copy
(Actual_DDT
));
1184 Set_Class_Wide_Type
(Directly_Designated_Type
(Anon
),
1185 New_Copy
(Class_Wide_Type
(Actual_DDT
)));
1186 Set_Etype
(Directly_Designated_Type
(Anon
),
1187 Non_Limited_View
(Etype
(Actual_DDT
)));
1189 Class_Wide_Type
(Directly_Designated_Type
(Anon
)),
1190 Non_Limited_View
(Etype
(Actual_DDT
)));
1191 Set_Etype
(Actual_Dup
, Anon
);
1195 Conversion
:= Convert_To
(Formal_Typ
, Actual_Dup
);
1196 Rewrite
(Actual
, Conversion
);
1197 Analyze_And_Resolve
(Actual
, Formal_Typ
);
1201 Next_Actual
(Actual
);
1202 Next_Formal
(Formal
);
1204 end Expand_Interface_Actuals
;
1206 ----------------------------
1207 -- Expand_Interface_Thunk --
1208 ----------------------------
1210 procedure Expand_Interface_Thunk
1212 Thunk_Id
: out Entity_Id
;
1213 Thunk_Code
: out Node_Id
)
1215 Loc
: constant Source_Ptr
:= Sloc
(Prim
);
1216 Actuals
: constant List_Id
:= New_List
;
1217 Decl
: constant List_Id
:= New_List
;
1218 Formals
: constant List_Id
:= New_List
;
1220 Controlling_Typ
: Entity_Id
;
1225 Offset_To_Top
: Node_Id
;
1227 Target_Formal
: Entity_Id
;
1231 Thunk_Code
:= Empty
;
1233 -- Traverse the list of alias to find the final target
1236 while Present
(Alias
(Target
)) loop
1237 Target
:= Alias
(Target
);
1240 -- In case of primitives that are functions without formals and
1241 -- a controlling result there is no need to build the thunk.
1243 if not Present
(First_Formal
(Target
)) then
1244 pragma Assert
(Ekind
(Target
) = E_Function
1245 and then Has_Controlling_Result
(Target
));
1249 -- Duplicate the formals
1251 Formal
:= First_Formal
(Target
);
1252 while Present
(Formal
) loop
1254 Make_Parameter_Specification
(Loc
,
1255 Defining_Identifier
=>
1256 Make_Defining_Identifier
(Sloc
(Formal
),
1257 Chars
=> Chars
(Formal
)),
1258 In_Present
=> In_Present
(Parent
(Formal
)),
1259 Out_Present
=> Out_Present
(Parent
(Formal
)),
1261 New_Reference_To
(Etype
(Formal
), Loc
),
1262 Expression
=> New_Copy_Tree
(Expression
(Parent
(Formal
)))));
1264 Next_Formal
(Formal
);
1267 Controlling_Typ
:= Find_Dispatching_Type
(Target
);
1269 Target_Formal
:= First_Formal
(Target
);
1270 Formal
:= First
(Formals
);
1271 while Present
(Formal
) loop
1272 if Ekind
(Target_Formal
) = E_In_Parameter
1273 and then Ekind
(Etype
(Target_Formal
)) = E_Anonymous_Access_Type
1274 and then Directly_Designated_Type
(Etype
(Target_Formal
))
1279 -- type T is access all <<type of the target formal>>
1280 -- S : Storage_Offset := Storage_Offset!(Formal)
1281 -- - Offset_To_Top (address!(Formal))
1284 Make_Full_Type_Declaration
(Loc
,
1285 Defining_Identifier
=>
1286 Make_Defining_Identifier
(Loc
,
1287 New_Internal_Name
('T')),
1289 Make_Access_To_Object_Definition
(Loc
,
1290 All_Present
=> True,
1291 Null_Exclusion_Present
=> False,
1292 Constant_Present
=> False,
1293 Subtype_Indication
=>
1295 (Directly_Designated_Type
1296 (Etype
(Target_Formal
)), Loc
)));
1299 Unchecked_Convert_To
(RTE
(RE_Address
),
1300 New_Reference_To
(Defining_Identifier
(Formal
), Loc
));
1302 if not RTE_Available
(RE_Offset_To_Top
) then
1304 Build_Offset_To_Top
(Loc
, New_Arg
);
1307 Make_Function_Call
(Loc
,
1308 Name
=> New_Reference_To
(RTE
(RE_Offset_To_Top
), Loc
),
1309 Parameter_Associations
=> New_List
(New_Arg
));
1313 Make_Object_Declaration
(Loc
,
1314 Defining_Identifier
=>
1315 Make_Defining_Identifier
(Loc
,
1316 New_Internal_Name
('S')),
1317 Constant_Present
=> True,
1318 Object_Definition
=>
1319 New_Reference_To
(RTE
(RE_Storage_Offset
), Loc
),
1321 Make_Op_Subtract
(Loc
,
1323 Unchecked_Convert_To
1324 (RTE
(RE_Storage_Offset
),
1325 New_Reference_To
(Defining_Identifier
(Formal
), Loc
)),
1329 Append_To
(Decl
, Decl_2
);
1330 Append_To
(Decl
, Decl_1
);
1332 -- Reference the new actual. Generate:
1336 Unchecked_Convert_To
1337 (Defining_Identifier
(Decl_2
),
1338 New_Reference_To
(Defining_Identifier
(Decl_1
), Loc
)));
1340 elsif Etype
(Target_Formal
) = Controlling_Typ
then
1343 -- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
1344 -- - Offset_To_Top (Formal'Address)
1345 -- S2 : Addr_Ptr := Addr_Ptr!(S1)
1348 Make_Attribute_Reference
(Loc
,
1350 New_Reference_To
(Defining_Identifier
(Formal
), Loc
),
1354 if not RTE_Available
(RE_Offset_To_Top
) then
1356 Build_Offset_To_Top
(Loc
, New_Arg
);
1359 Make_Function_Call
(Loc
,
1360 Name
=> New_Reference_To
(RTE
(RE_Offset_To_Top
), Loc
),
1361 Parameter_Associations
=> New_List
(New_Arg
));
1365 Make_Object_Declaration
(Loc
,
1366 Defining_Identifier
=>
1367 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S')),
1368 Constant_Present
=> True,
1369 Object_Definition
=>
1370 New_Reference_To
(RTE
(RE_Storage_Offset
), Loc
),
1372 Make_Op_Subtract
(Loc
,
1374 Unchecked_Convert_To
1375 (RTE
(RE_Storage_Offset
),
1376 Make_Attribute_Reference
(Loc
,
1379 (Defining_Identifier
(Formal
), Loc
),
1380 Attribute_Name
=> Name_Address
)),
1385 Make_Object_Declaration
(Loc
,
1386 Defining_Identifier
=>
1387 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S')),
1388 Constant_Present
=> True,
1389 Object_Definition
=> New_Reference_To
(RTE
(RE_Addr_Ptr
), Loc
),
1391 Unchecked_Convert_To
1393 New_Reference_To
(Defining_Identifier
(Decl_1
), Loc
)));
1395 Append_To
(Decl
, Decl_1
);
1396 Append_To
(Decl
, Decl_2
);
1398 -- Reference the new actual. Generate:
1399 -- Target_Formal (S2.all)
1402 Unchecked_Convert_To
1403 (Etype
(Target_Formal
),
1404 Make_Explicit_Dereference
(Loc
,
1405 New_Reference_To
(Defining_Identifier
(Decl_2
), Loc
))));
1407 -- No special management required for this actual
1411 New_Reference_To
(Defining_Identifier
(Formal
), Loc
));
1414 Next_Formal
(Target_Formal
);
1419 Make_Defining_Identifier
(Loc
,
1420 Chars
=> New_Internal_Name
('T'));
1422 Set_Is_Thunk
(Thunk_Id
);
1424 if Ekind
(Target
) = E_Procedure
then
1426 Make_Subprogram_Body
(Loc
,
1428 Make_Procedure_Specification
(Loc
,
1429 Defining_Unit_Name
=> Thunk_Id
,
1430 Parameter_Specifications
=> Formals
),
1431 Declarations
=> Decl
,
1432 Handled_Statement_Sequence
=>
1433 Make_Handled_Sequence_Of_Statements
(Loc
,
1434 Statements
=> New_List
(
1435 Make_Procedure_Call_Statement
(Loc
,
1436 Name
=> New_Occurrence_Of
(Target
, Loc
),
1437 Parameter_Associations
=> Actuals
))));
1439 else pragma Assert
(Ekind
(Target
) = E_Function
);
1442 Make_Subprogram_Body
(Loc
,
1444 Make_Function_Specification
(Loc
,
1445 Defining_Unit_Name
=> Thunk_Id
,
1446 Parameter_Specifications
=> Formals
,
1447 Result_Definition
=>
1448 New_Copy
(Result_Definition
(Parent
(Target
)))),
1449 Declarations
=> Decl
,
1450 Handled_Statement_Sequence
=>
1451 Make_Handled_Sequence_Of_Statements
(Loc
,
1452 Statements
=> New_List
(
1453 Make_Simple_Return_Statement
(Loc
,
1454 Make_Function_Call
(Loc
,
1455 Name
=> New_Occurrence_Of
(Target
, Loc
),
1456 Parameter_Associations
=> Actuals
)))));
1458 end Expand_Interface_Thunk
;
1464 function Has_DT
(Typ
: Entity_Id
) return Boolean is
1466 return not Is_Interface
(Typ
)
1467 and then not Restriction_Active
(No_Dispatching_Calls
);
1470 -----------------------------------------
1471 -- Is_Predefined_Dispatching_Operation --
1472 -----------------------------------------
1474 function Is_Predefined_Dispatching_Operation
1475 (E
: Entity_Id
) return Boolean
1477 TSS_Name
: TSS_Name_Type
;
1480 if not Is_Dispatching_Operation
(E
) then
1484 Get_Name_String
(Chars
(E
));
1486 -- Most predefined primitives have internally generated names. Equality
1487 -- must be treated differently; the predefined operation is recognized
1488 -- as a homogeneous binary operator that returns Boolean.
1490 if Name_Len
> TSS_Name_Type
'Last then
1491 TSS_Name
:= TSS_Name_Type
(Name_Buffer
(Name_Len
- TSS_Name
'Length + 1
1493 if Chars
(E
) = Name_uSize
1494 or else Chars
(E
) = Name_uAlignment
1495 or else TSS_Name
= TSS_Stream_Read
1496 or else TSS_Name
= TSS_Stream_Write
1497 or else TSS_Name
= TSS_Stream_Input
1498 or else TSS_Name
= TSS_Stream_Output
1500 (Chars
(E
) = Name_Op_Eq
1501 and then Etype
(First_Entity
(E
)) = Etype
(Last_Entity
(E
)))
1502 or else Chars
(E
) = Name_uAssign
1503 or else TSS_Name
= TSS_Deep_Adjust
1504 or else TSS_Name
= TSS_Deep_Finalize
1505 or else Is_Predefined_Interface_Primitive
(E
)
1512 end Is_Predefined_Dispatching_Operation
;
1514 -------------------------------------
1515 -- Is_Predefined_Dispatching_Alias --
1516 -------------------------------------
1518 function Is_Predefined_Dispatching_Alias
(Prim
: Entity_Id
) return Boolean
1523 if not Is_Predefined_Dispatching_Operation
(Prim
)
1524 and then Present
(Alias
(Prim
))
1527 while Present
(Alias
(E
)) loop
1531 if Is_Predefined_Dispatching_Operation
(E
) then
1537 end Is_Predefined_Dispatching_Alias
;
1539 ---------------------------------------
1540 -- Is_Predefined_Interface_Primitive --
1541 ---------------------------------------
1543 function Is_Predefined_Interface_Primitive
(E
: Entity_Id
) return Boolean is
1545 return Ada_Version
>= Ada_05
1546 and then (Chars
(E
) = Name_uDisp_Asynchronous_Select
or else
1547 Chars
(E
) = Name_uDisp_Conditional_Select
or else
1548 Chars
(E
) = Name_uDisp_Get_Prim_Op_Kind
or else
1549 Chars
(E
) = Name_uDisp_Get_Task_Id
or else
1550 Chars
(E
) = Name_uDisp_Requeue
or else
1551 Chars
(E
) = Name_uDisp_Timed_Select
);
1552 end Is_Predefined_Interface_Primitive
;
1554 ----------------------------------------
1555 -- Make_Disp_Asynchronous_Select_Body --
1556 ----------------------------------------
1558 -- For interface types, generate:
1560 -- procedure _Disp_Asynchronous_Select
1561 -- (T : in out <Typ>;
1563 -- P : System.Address;
1564 -- B : out System.Storage_Elements.Dummy_Communication_Block;
1569 -- end _Disp_Asynchronous_Select;
1571 -- For protected types, generate:
1573 -- procedure _Disp_Asynchronous_Select
1574 -- (T : in out <Typ>;
1576 -- P : System.Address;
1577 -- B : out System.Storage_Elements.Dummy_Communication_Block;
1581 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
1582 -- Bnn : System.Tasking.Protected_Objects.Operations.
1583 -- Communication_Block;
1585 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
1586 -- (T._object'Access,
1587 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
1589 -- System.Tasking.Asynchronous_Call,
1591 -- B := System.Storage_Elements.Dummy_Communication_Block (Bnn);
1592 -- end _Disp_Asynchronous_Select;
1594 -- For task types, generate:
1596 -- procedure _Disp_Asynchronous_Select
1597 -- (T : in out <Typ>;
1599 -- P : System.Address;
1600 -- B : out System.Storage_Elements.Dummy_Communication_Block;
1604 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
1606 -- System.Tasking.Rendezvous.Task_Entry_Call
1608 -- System.Tasking.Task_Entry_Index (I),
1610 -- System.Tasking.Asynchronous_Call,
1612 -- end _Disp_Asynchronous_Select;
1614 function Make_Disp_Asynchronous_Select_Body
1615 (Typ
: Entity_Id
) return Node_Id
1617 Com_Block
: Entity_Id
;
1618 Conc_Typ
: Entity_Id
:= Empty
;
1619 Decls
: constant List_Id
:= New_List
;
1621 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
1623 Stmts
: constant List_Id
:= New_List
;
1626 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
1628 -- Null body is generated for interface types
1630 if Is_Interface
(Typ
) then
1632 Make_Subprogram_Body
(Loc
,
1634 Make_Disp_Asynchronous_Select_Spec
(Typ
),
1637 Handled_Statement_Sequence
=>
1638 Make_Handled_Sequence_Of_Statements
(Loc
,
1639 New_List
(Make_Null_Statement
(Loc
))));
1642 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
1644 if Is_Concurrent_Record_Type
(Typ
) then
1645 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
1649 -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
1651 -- where I will be used to capture the entry index of the primitive
1652 -- wrapper at position S.
1655 Make_Object_Declaration
(Loc
,
1656 Defining_Identifier
=>
1657 Make_Defining_Identifier
(Loc
, Name_uI
),
1658 Object_Definition
=>
1659 New_Reference_To
(Standard_Integer
, Loc
),
1661 Make_Function_Call
(Loc
,
1663 New_Reference_To
(RTE
(RE_Get_Entry_Index
), Loc
),
1664 Parameter_Associations
=>
1666 Unchecked_Convert_To
(RTE
(RE_Tag
),
1667 New_Reference_To
(DT_Ptr
, Loc
)),
1668 Make_Identifier
(Loc
, Name_uS
)))));
1670 if Ekind
(Conc_Typ
) = E_Protected_Type
then
1673 -- Bnn : Communication_Block;
1676 Make_Defining_Identifier
(Loc
, New_Internal_Name
('B'));
1679 Make_Object_Declaration
(Loc
,
1680 Defining_Identifier
=>
1682 Object_Definition
=>
1683 New_Reference_To
(RTE
(RE_Communication_Block
), Loc
)));
1685 -- Build T._object'Access for calls below
1688 Make_Attribute_Reference
(Loc
,
1689 Attribute_Name
=> Name_Unchecked_Access
,
1691 Make_Selected_Component
(Loc
,
1692 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
1693 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
1695 case Corresponding_Runtime_Package
(Conc_Typ
) is
1696 when System_Tasking_Protected_Objects_Entries
=>
1699 -- Protected_Entry_Call
1700 -- (T._object'Access, -- Object
1701 -- Protected_Entry_Index! (I), -- E
1702 -- P, -- Uninterpreted_Data
1703 -- Asynchronous_Call, -- Mode
1704 -- Bnn); -- Communication_Block
1706 -- where T is the protected object, I is the entry index, P
1707 -- is the wrapped parameters and B is the name of the
1708 -- communication block.
1711 Make_Procedure_Call_Statement
(Loc
,
1713 New_Reference_To
(RTE
(RE_Protected_Entry_Call
), Loc
),
1714 Parameter_Associations
=>
1718 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
1721 (RTE
(RE_Protected_Entry_Index
), Loc
),
1722 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
1724 Make_Identifier
(Loc
, Name_uP
), -- parameter block
1725 New_Reference_To
( -- Asynchronous_Call
1726 RTE
(RE_Asynchronous_Call
), Loc
),
1728 New_Reference_To
(Com_Block
, Loc
)))); -- comm block
1730 when System_Tasking_Protected_Objects_Single_Entry
=>
1733 -- procedure Protected_Single_Entry_Call
1734 -- (Object : Protection_Entry_Access;
1735 -- Uninterpreted_Data : System.Address;
1736 -- Mode : Call_Modes);
1739 Make_Procedure_Call_Statement
(Loc
,
1742 (RTE
(RE_Protected_Single_Entry_Call
), Loc
),
1743 Parameter_Associations
=>
1747 Make_Attribute_Reference
(Loc
,
1748 Prefix
=> Make_Identifier
(Loc
, Name_uP
),
1749 Attribute_Name
=> Name_Address
),
1752 (RTE
(RE_Asynchronous_Call
), Loc
))));
1755 raise Program_Error
;
1759 -- B := Dummy_Communication_Block (Bnn);
1762 Make_Assignment_Statement
(Loc
,
1764 Make_Identifier
(Loc
, Name_uB
),
1766 Make_Unchecked_Type_Conversion
(Loc
,
1769 RTE
(RE_Dummy_Communication_Block
), Loc
),
1771 New_Reference_To
(Com_Block
, Loc
))));
1774 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
1778 -- (T._task_id, -- Acceptor
1779 -- Task_Entry_Index! (I), -- E
1780 -- P, -- Uninterpreted_Data
1781 -- Asynchronous_Call, -- Mode
1782 -- F); -- Rendezvous_Successful
1784 -- where T is the task object, I is the entry index, P is the
1785 -- wrapped parameters and F is the status flag.
1788 Make_Procedure_Call_Statement
(Loc
,
1790 New_Reference_To
(RTE
(RE_Task_Entry_Call
), Loc
),
1791 Parameter_Associations
=>
1793 Make_Selected_Component
(Loc
, -- T._task_id
1795 Make_Identifier
(Loc
, Name_uT
),
1797 Make_Identifier
(Loc
, Name_uTask_Id
)),
1799 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
1801 New_Reference_To
(RTE
(RE_Task_Entry_Index
), Loc
),
1803 Make_Identifier
(Loc
, Name_uI
)),
1805 Make_Identifier
(Loc
, Name_uP
), -- parameter block
1806 New_Reference_To
( -- Asynchronous_Call
1807 RTE
(RE_Asynchronous_Call
), Loc
),
1808 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
1813 Make_Subprogram_Body
(Loc
,
1815 Make_Disp_Asynchronous_Select_Spec
(Typ
),
1818 Handled_Statement_Sequence
=>
1819 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
1820 end Make_Disp_Asynchronous_Select_Body
;
1822 ----------------------------------------
1823 -- Make_Disp_Asynchronous_Select_Spec --
1824 ----------------------------------------
1826 function Make_Disp_Asynchronous_Select_Spec
1827 (Typ
: Entity_Id
) return Node_Id
1829 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
1830 Def_Id
: constant Node_Id
:=
1831 Make_Defining_Identifier
(Loc
,
1832 Name_uDisp_Asynchronous_Select
);
1833 Params
: constant List_Id
:= New_List
;
1836 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
1838 -- T : in out Typ; -- Object parameter
1839 -- S : Integer; -- Primitive operation slot
1840 -- P : Address; -- Wrapped parameters
1841 -- B : out Dummy_Communication_Block; -- Communication block dummy
1842 -- F : out Boolean; -- Status flag
1844 Append_List_To
(Params
, New_List
(
1846 Make_Parameter_Specification
(Loc
,
1847 Defining_Identifier
=>
1848 Make_Defining_Identifier
(Loc
, Name_uT
),
1850 New_Reference_To
(Typ
, Loc
),
1852 Out_Present
=> True),
1854 Make_Parameter_Specification
(Loc
,
1855 Defining_Identifier
=>
1856 Make_Defining_Identifier
(Loc
, Name_uS
),
1858 New_Reference_To
(Standard_Integer
, Loc
)),
1860 Make_Parameter_Specification
(Loc
,
1861 Defining_Identifier
=>
1862 Make_Defining_Identifier
(Loc
, Name_uP
),
1864 New_Reference_To
(RTE
(RE_Address
), Loc
)),
1866 Make_Parameter_Specification
(Loc
,
1867 Defining_Identifier
=>
1868 Make_Defining_Identifier
(Loc
, Name_uB
),
1870 New_Reference_To
(RTE
(RE_Dummy_Communication_Block
), Loc
),
1871 Out_Present
=> True),
1873 Make_Parameter_Specification
(Loc
,
1874 Defining_Identifier
=>
1875 Make_Defining_Identifier
(Loc
, Name_uF
),
1877 New_Reference_To
(Standard_Boolean
, Loc
),
1878 Out_Present
=> True)));
1881 Make_Procedure_Specification
(Loc
,
1882 Defining_Unit_Name
=> Def_Id
,
1883 Parameter_Specifications
=> Params
);
1884 end Make_Disp_Asynchronous_Select_Spec
;
1886 ---------------------------------------
1887 -- Make_Disp_Conditional_Select_Body --
1888 ---------------------------------------
1890 -- For interface types, generate:
1892 -- procedure _Disp_Conditional_Select
1893 -- (T : in out <Typ>;
1895 -- P : System.Address;
1896 -- C : out Ada.Tags.Prim_Op_Kind;
1901 -- end _Disp_Conditional_Select;
1903 -- For protected types, generate:
1905 -- procedure _Disp_Conditional_Select
1906 -- (T : in out <Typ>;
1908 -- P : System.Address;
1909 -- C : out Ada.Tags.Prim_Op_Kind;
1913 -- Bnn : System.Tasking.Protected_Objects.Operations.
1914 -- Communication_Block;
1917 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S));
1919 -- if C = Ada.Tags.POK_Procedure
1920 -- or else C = Ada.Tags.POK_Protected_Procedure
1921 -- or else C = Ada.Tags.POK_Task_Procedure
1927 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
1928 -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
1929 -- (T.object'Access,
1930 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
1932 -- System.Tasking.Conditional_Call,
1934 -- F := not Cancelled (Bnn);
1935 -- end _Disp_Conditional_Select;
1937 -- For task types, generate:
1939 -- procedure _Disp_Conditional_Select
1940 -- (T : in out <Typ>;
1942 -- P : System.Address;
1943 -- C : out Ada.Tags.Prim_Op_Kind;
1949 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
1950 -- System.Tasking.Rendezvous.Task_Entry_Call
1952 -- System.Tasking.Task_Entry_Index (I),
1954 -- System.Tasking.Conditional_Call,
1956 -- end _Disp_Conditional_Select;
1958 function Make_Disp_Conditional_Select_Body
1959 (Typ
: Entity_Id
) return Node_Id
1961 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
1962 Blk_Nam
: Entity_Id
;
1963 Conc_Typ
: Entity_Id
:= Empty
;
1964 Decls
: constant List_Id
:= New_List
;
1967 Stmts
: constant List_Id
:= New_List
;
1970 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
1972 -- Null body is generated for interface types
1974 if Is_Interface
(Typ
) then
1976 Make_Subprogram_Body
(Loc
,
1978 Make_Disp_Conditional_Select_Spec
(Typ
),
1981 Handled_Statement_Sequence
=>
1982 Make_Handled_Sequence_Of_Statements
(Loc
,
1983 New_List
(Make_Null_Statement
(Loc
))));
1986 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
1988 if Is_Concurrent_Record_Type
(Typ
) then
1989 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
1994 -- where I will be used to capture the entry index of the primitive
1995 -- wrapper at position S.
1998 Make_Object_Declaration
(Loc
,
1999 Defining_Identifier
=>
2000 Make_Defining_Identifier
(Loc
, Name_uI
),
2001 Object_Definition
=>
2002 New_Reference_To
(Standard_Integer
, Loc
)));
2005 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S);
2007 -- if C = POK_Procedure
2008 -- or else C = POK_Protected_Procedure
2009 -- or else C = POK_Task_Procedure;
2015 Build_Common_Dispatching_Select_Statements
(Loc
, DT_Ptr
, Stmts
);
2018 -- Bnn : Communication_Block;
2020 -- where Bnn is the name of the communication block used in the
2021 -- call to Protected_Entry_Call.
2023 Blk_Nam
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('B'));
2026 Make_Object_Declaration
(Loc
,
2027 Defining_Identifier
=>
2029 Object_Definition
=>
2030 New_Reference_To
(RTE
(RE_Communication_Block
), Loc
)));
2033 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2035 -- I is the entry index and S is the dispatch table slot
2038 Make_Assignment_Statement
(Loc
,
2040 Make_Identifier
(Loc
, Name_uI
),
2042 Make_Function_Call
(Loc
,
2044 New_Reference_To
(RTE
(RE_Get_Entry_Index
), Loc
),
2045 Parameter_Associations
=>
2047 Unchecked_Convert_To
(RTE
(RE_Tag
),
2048 New_Reference_To
(DT_Ptr
, Loc
)),
2049 Make_Identifier
(Loc
, Name_uS
)))));
2051 if Ekind
(Conc_Typ
) = E_Protected_Type
then
2053 Obj_Ref
:= -- T._object'Access
2054 Make_Attribute_Reference
(Loc
,
2055 Attribute_Name
=> Name_Unchecked_Access
,
2057 Make_Selected_Component
(Loc
,
2058 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2059 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
2061 case Corresponding_Runtime_Package
(Conc_Typ
) is
2062 when System_Tasking_Protected_Objects_Entries
=>
2065 -- Protected_Entry_Call
2066 -- (T._object'Access, -- Object
2067 -- Protected_Entry_Index! (I), -- E
2068 -- P, -- Uninterpreted_Data
2069 -- Conditional_Call, -- Mode
2072 -- where T is the protected object, I is the entry index, P
2073 -- are the wrapped parameters and Bnn is the name of the
2074 -- communication block.
2077 Make_Procedure_Call_Statement
(Loc
,
2079 New_Reference_To
(RTE
(RE_Protected_Entry_Call
), Loc
),
2080 Parameter_Associations
=>
2084 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2087 (RTE
(RE_Protected_Entry_Index
), Loc
),
2088 Expression
=> Make_Identifier
(Loc
, Name_uI
)),
2090 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2092 New_Reference_To
( -- Conditional_Call
2093 RTE
(RE_Conditional_Call
), Loc
),
2094 New_Reference_To
( -- Bnn
2097 when System_Tasking_Protected_Objects_Single_Entry
=>
2099 -- If we are compiling for a restricted run-time, the call
2100 -- uses the simpler form.
2103 Make_Procedure_Call_Statement
(Loc
,
2106 (RTE
(RE_Protected_Single_Entry_Call
), Loc
),
2107 Parameter_Associations
=>
2111 Make_Attribute_Reference
(Loc
,
2112 Prefix
=> Make_Identifier
(Loc
, Name_uP
),
2113 Attribute_Name
=> Name_Address
),
2116 (RTE
(RE_Conditional_Call
), Loc
))));
2118 raise Program_Error
;
2122 -- F := not Cancelled (Bnn);
2124 -- where F is the success flag. The status of Cancelled is negated
2125 -- in order to match the behaviour of the version for task types.
2128 Make_Assignment_Statement
(Loc
,
2130 Make_Identifier
(Loc
, Name_uF
),
2134 Make_Function_Call
(Loc
,
2136 New_Reference_To
(RTE
(RE_Cancelled
), Loc
),
2137 Parameter_Associations
=>
2139 New_Reference_To
(Blk_Nam
, Loc
))))));
2141 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
2145 -- (T._task_id, -- Acceptor
2146 -- Task_Entry_Index! (I), -- E
2147 -- P, -- Uninterpreted_Data
2148 -- Conditional_Call, -- Mode
2149 -- F); -- Rendezvous_Successful
2151 -- where T is the task object, I is the entry index, P are the
2152 -- wrapped parameters and F is the status flag.
2155 Make_Procedure_Call_Statement
(Loc
,
2157 New_Reference_To
(RTE
(RE_Task_Entry_Call
), Loc
),
2158 Parameter_Associations
=>
2161 Make_Selected_Component
(Loc
, -- T._task_id
2163 Make_Identifier
(Loc
, Name_uT
),
2165 Make_Identifier
(Loc
, Name_uTask_Id
)),
2167 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2169 New_Reference_To
(RTE
(RE_Task_Entry_Index
), Loc
),
2171 Make_Identifier
(Loc
, Name_uI
)),
2173 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2174 New_Reference_To
( -- Conditional_Call
2175 RTE
(RE_Conditional_Call
), Loc
),
2176 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
2181 Make_Subprogram_Body
(Loc
,
2183 Make_Disp_Conditional_Select_Spec
(Typ
),
2186 Handled_Statement_Sequence
=>
2187 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
2188 end Make_Disp_Conditional_Select_Body
;
2190 ---------------------------------------
2191 -- Make_Disp_Conditional_Select_Spec --
2192 ---------------------------------------
2194 function Make_Disp_Conditional_Select_Spec
2195 (Typ
: Entity_Id
) return Node_Id
2197 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2198 Def_Id
: constant Node_Id
:=
2199 Make_Defining_Identifier
(Loc
,
2200 Name_uDisp_Conditional_Select
);
2201 Params
: constant List_Id
:= New_List
;
2204 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2206 -- T : in out Typ; -- Object parameter
2207 -- S : Integer; -- Primitive operation slot
2208 -- P : Address; -- Wrapped parameters
2209 -- C : out Prim_Op_Kind; -- Call kind
2210 -- F : out Boolean; -- Status flag
2212 Append_List_To
(Params
, New_List
(
2214 Make_Parameter_Specification
(Loc
,
2215 Defining_Identifier
=>
2216 Make_Defining_Identifier
(Loc
, Name_uT
),
2218 New_Reference_To
(Typ
, Loc
),
2220 Out_Present
=> True),
2222 Make_Parameter_Specification
(Loc
,
2223 Defining_Identifier
=>
2224 Make_Defining_Identifier
(Loc
, Name_uS
),
2226 New_Reference_To
(Standard_Integer
, Loc
)),
2228 Make_Parameter_Specification
(Loc
,
2229 Defining_Identifier
=>
2230 Make_Defining_Identifier
(Loc
, Name_uP
),
2232 New_Reference_To
(RTE
(RE_Address
), Loc
)),
2234 Make_Parameter_Specification
(Loc
,
2235 Defining_Identifier
=>
2236 Make_Defining_Identifier
(Loc
, Name_uC
),
2238 New_Reference_To
(RTE
(RE_Prim_Op_Kind
), Loc
),
2239 Out_Present
=> True),
2241 Make_Parameter_Specification
(Loc
,
2242 Defining_Identifier
=>
2243 Make_Defining_Identifier
(Loc
, Name_uF
),
2245 New_Reference_To
(Standard_Boolean
, Loc
),
2246 Out_Present
=> True)));
2249 Make_Procedure_Specification
(Loc
,
2250 Defining_Unit_Name
=> Def_Id
,
2251 Parameter_Specifications
=> Params
);
2252 end Make_Disp_Conditional_Select_Spec
;
2254 -------------------------------------
2255 -- Make_Disp_Get_Prim_Op_Kind_Body --
2256 -------------------------------------
2258 function Make_Disp_Get_Prim_Op_Kind_Body
2259 (Typ
: Entity_Id
) return Node_Id
2261 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2265 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2267 if Is_Interface
(Typ
) then
2269 Make_Subprogram_Body
(Loc
,
2271 Make_Disp_Get_Prim_Op_Kind_Spec
(Typ
),
2274 Handled_Statement_Sequence
=>
2275 Make_Handled_Sequence_Of_Statements
(Loc
,
2276 New_List
(Make_Null_Statement
(Loc
))));
2279 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
2282 -- C := get_prim_op_kind (tag! (<type>VP), S);
2284 -- where C is the out parameter capturing the call kind and S is the
2285 -- dispatch table slot number.
2288 Make_Subprogram_Body
(Loc
,
2290 Make_Disp_Get_Prim_Op_Kind_Spec
(Typ
),
2293 Handled_Statement_Sequence
=>
2294 Make_Handled_Sequence_Of_Statements
(Loc
,
2296 Make_Assignment_Statement
(Loc
,
2298 Make_Identifier
(Loc
, Name_uC
),
2300 Make_Function_Call
(Loc
,
2302 New_Reference_To
(RTE
(RE_Get_Prim_Op_Kind
), Loc
),
2303 Parameter_Associations
=> New_List
(
2304 Unchecked_Convert_To
(RTE
(RE_Tag
),
2305 New_Reference_To
(DT_Ptr
, Loc
)),
2306 Make_Identifier
(Loc
, Name_uS
)))))));
2307 end Make_Disp_Get_Prim_Op_Kind_Body
;
2309 -------------------------------------
2310 -- Make_Disp_Get_Prim_Op_Kind_Spec --
2311 -------------------------------------
2313 function Make_Disp_Get_Prim_Op_Kind_Spec
2314 (Typ
: Entity_Id
) return Node_Id
2316 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2317 Def_Id
: constant Node_Id
:=
2318 Make_Defining_Identifier
(Loc
,
2319 Name_uDisp_Get_Prim_Op_Kind
);
2320 Params
: constant List_Id
:= New_List
;
2323 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2325 -- T : in out Typ; -- Object parameter
2326 -- S : Integer; -- Primitive operation slot
2327 -- C : out Prim_Op_Kind; -- Call kind
2329 Append_List_To
(Params
, New_List
(
2331 Make_Parameter_Specification
(Loc
,
2332 Defining_Identifier
=>
2333 Make_Defining_Identifier
(Loc
, Name_uT
),
2335 New_Reference_To
(Typ
, Loc
),
2337 Out_Present
=> True),
2339 Make_Parameter_Specification
(Loc
,
2340 Defining_Identifier
=>
2341 Make_Defining_Identifier
(Loc
, Name_uS
),
2343 New_Reference_To
(Standard_Integer
, Loc
)),
2345 Make_Parameter_Specification
(Loc
,
2346 Defining_Identifier
=>
2347 Make_Defining_Identifier
(Loc
, Name_uC
),
2349 New_Reference_To
(RTE
(RE_Prim_Op_Kind
), Loc
),
2350 Out_Present
=> True)));
2353 Make_Procedure_Specification
(Loc
,
2354 Defining_Unit_Name
=> Def_Id
,
2355 Parameter_Specifications
=> Params
);
2356 end Make_Disp_Get_Prim_Op_Kind_Spec
;
2358 --------------------------------
2359 -- Make_Disp_Get_Task_Id_Body --
2360 --------------------------------
2362 function Make_Disp_Get_Task_Id_Body
2363 (Typ
: Entity_Id
) return Node_Id
2365 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2369 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2371 if Is_Concurrent_Record_Type
(Typ
)
2372 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) = E_Task_Type
2375 -- return To_Address (_T._task_id);
2378 Make_Simple_Return_Statement
(Loc
,
2380 Make_Unchecked_Type_Conversion
(Loc
,
2382 New_Reference_To
(RTE
(RE_Address
), Loc
),
2384 Make_Selected_Component
(Loc
,
2386 Make_Identifier
(Loc
, Name_uT
),
2388 Make_Identifier
(Loc
, Name_uTask_Id
))));
2390 -- A null body is constructed for non-task types
2394 -- return Null_Address;
2397 Make_Simple_Return_Statement
(Loc
,
2399 New_Reference_To
(RTE
(RE_Null_Address
), Loc
));
2403 Make_Subprogram_Body
(Loc
,
2405 Make_Disp_Get_Task_Id_Spec
(Typ
),
2408 Handled_Statement_Sequence
=>
2409 Make_Handled_Sequence_Of_Statements
(Loc
,
2411 end Make_Disp_Get_Task_Id_Body
;
2413 --------------------------------
2414 -- Make_Disp_Get_Task_Id_Spec --
2415 --------------------------------
2417 function Make_Disp_Get_Task_Id_Spec
2418 (Typ
: Entity_Id
) return Node_Id
2420 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2423 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2426 Make_Function_Specification
(Loc
,
2427 Defining_Unit_Name
=>
2428 Make_Defining_Identifier
(Loc
, Name_uDisp_Get_Task_Id
),
2429 Parameter_Specifications
=> New_List
(
2430 Make_Parameter_Specification
(Loc
,
2431 Defining_Identifier
=>
2432 Make_Defining_Identifier
(Loc
, Name_uT
),
2434 New_Reference_To
(Typ
, Loc
))),
2435 Result_Definition
=>
2436 New_Reference_To
(RTE
(RE_Address
), Loc
));
2437 end Make_Disp_Get_Task_Id_Spec
;
2439 ----------------------------
2440 -- Make_Disp_Requeue_Body --
2441 ----------------------------
2443 function Make_Disp_Requeue_Body
2444 (Typ
: Entity_Id
) return Node_Id
2446 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2447 Conc_Typ
: Entity_Id
:= Empty
;
2448 Stmts
: constant List_Id
:= New_List
;
2451 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2453 -- Null body is generated for interface types and non-concurrent
2456 if Is_Interface
(Typ
)
2457 or else not Is_Concurrent_Record_Type
(Typ
)
2460 Make_Subprogram_Body
(Loc
,
2462 Make_Disp_Requeue_Spec
(Typ
),
2465 Handled_Statement_Sequence
=>
2466 Make_Handled_Sequence_Of_Statements
(Loc
,
2467 New_List
(Make_Null_Statement
(Loc
))));
2470 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
2472 if Ekind
(Conc_Typ
) = E_Protected_Type
then
2474 -- Generate statements:
2476 -- System.Tasking.Protected_Objects.Operations.
2477 -- Requeue_Protected_Entry
2478 -- (Protection_Entries_Access (P),
2479 -- O._object'Unchecked_Access,
2480 -- Protected_Entry_Index (I),
2483 -- System.Tasking.Protected_Objects.Operations.
2484 -- Requeue_Task_To_Protected_Entry
2485 -- (O._object'Unchecked_Access,
2486 -- Protected_Entry_Index (I),
2490 if Restriction_Active
(No_Entry_Queue
) then
2491 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
2494 Make_If_Statement
(Loc
,
2496 Make_Identifier
(Loc
, Name_uF
),
2501 -- Call to Requeue_Protected_Entry
2503 Make_Procedure_Call_Statement
(Loc
,
2506 RTE
(RE_Requeue_Protected_Entry
), Loc
),
2507 Parameter_Associations
=>
2510 Make_Unchecked_Type_Conversion
(Loc
, -- PEA (P)
2513 RTE
(RE_Protection_Entries_Access
), Loc
),
2515 Make_Identifier
(Loc
, Name_uP
)),
2517 Make_Attribute_Reference
(Loc
, -- O._object'Acc
2519 Name_Unchecked_Access
,
2521 Make_Selected_Component
(Loc
,
2523 Make_Identifier
(Loc
, Name_uO
),
2525 Make_Identifier
(Loc
, Name_uObject
))),
2527 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2530 RTE
(RE_Protected_Entry_Index
), Loc
),
2532 Make_Identifier
(Loc
, Name_uI
)),
2534 Make_Identifier
(Loc
, Name_uA
)))), -- abort status
2539 -- Call to Requeue_Task_To_Protected_Entry
2541 Make_Procedure_Call_Statement
(Loc
,
2544 RTE
(RE_Requeue_Task_To_Protected_Entry
), Loc
),
2545 Parameter_Associations
=>
2548 Make_Attribute_Reference
(Loc
, -- O._object'Acc
2550 Name_Unchecked_Access
,
2552 Make_Selected_Component
(Loc
,
2554 Make_Identifier
(Loc
, Name_uO
),
2556 Make_Identifier
(Loc
, Name_uObject
))),
2558 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2561 RTE
(RE_Protected_Entry_Index
), Loc
),
2563 Make_Identifier
(Loc
, Name_uI
)),
2565 Make_Identifier
(Loc
, Name_uA
)))))); -- abort status
2568 pragma Assert
(Is_Task_Type
(Conc_Typ
));
2572 -- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry
2573 -- (Protection_Entries_Access (P),
2575 -- Task_Entry_Index (I),
2578 -- System.Tasking.Rendezvous.Requeue_Task_Entry
2580 -- Task_Entry_Index (I),
2585 Make_If_Statement
(Loc
,
2587 Make_Identifier
(Loc
, Name_uF
),
2592 -- Call to Requeue_Protected_To_Task_Entry
2594 Make_Procedure_Call_Statement
(Loc
,
2597 RTE
(RE_Requeue_Protected_To_Task_Entry
), Loc
),
2599 Parameter_Associations
=>
2602 Make_Unchecked_Type_Conversion
(Loc
, -- PEA (P)
2605 RTE
(RE_Protection_Entries_Access
), Loc
),
2607 Make_Identifier
(Loc
, Name_uP
)),
2609 Make_Selected_Component
(Loc
, -- O._task_id
2611 Make_Identifier
(Loc
, Name_uO
),
2613 Make_Identifier
(Loc
, Name_uTask_Id
)),
2615 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2618 RTE
(RE_Task_Entry_Index
), Loc
),
2620 Make_Identifier
(Loc
, Name_uI
)),
2622 Make_Identifier
(Loc
, Name_uA
)))), -- abort status
2627 -- Call to Requeue_Task_Entry
2629 Make_Procedure_Call_Statement
(Loc
,
2631 New_Reference_To
(RTE
(RE_Requeue_Task_Entry
), Loc
),
2633 Parameter_Associations
=>
2636 Make_Selected_Component
(Loc
, -- O._task_id
2638 Make_Identifier
(Loc
, Name_uO
),
2640 Make_Identifier
(Loc
, Name_uTask_Id
)),
2642 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2645 RTE
(RE_Task_Entry_Index
), Loc
),
2647 Make_Identifier
(Loc
, Name_uI
)),
2649 Make_Identifier
(Loc
, Name_uA
)))))); -- abort status
2652 -- Even though no declarations are needed in both cases, we allocate
2653 -- a list for entities added by Freeze.
2656 Make_Subprogram_Body
(Loc
,
2658 Make_Disp_Requeue_Spec
(Typ
),
2661 Handled_Statement_Sequence
=>
2662 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
2663 end Make_Disp_Requeue_Body
;
2665 ----------------------------
2666 -- Make_Disp_Requeue_Spec --
2667 ----------------------------
2669 function Make_Disp_Requeue_Spec
2670 (Typ
: Entity_Id
) return Node_Id
2672 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2675 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2677 -- O : in out Typ; - Object parameter
2678 -- F : Boolean; - Protected (True) / task (False) flag
2679 -- P : Address; - Protection_Entries_Access value
2680 -- I : Entry_Index - Index of entry call
2681 -- A : Boolean - Abort flag
2683 -- Note that the Protection_Entries_Access value is represented as a
2684 -- System.Address in order to avoid dragging in the tasking runtime
2685 -- when compiling sources without tasking constructs.
2688 Make_Procedure_Specification
(Loc
,
2689 Defining_Unit_Name
=>
2690 Make_Defining_Identifier
(Loc
, Name_uDisp_Requeue
),
2692 Parameter_Specifications
=>
2695 Make_Parameter_Specification
(Loc
, -- O
2696 Defining_Identifier
=>
2697 Make_Defining_Identifier
(Loc
, Name_uO
),
2699 New_Reference_To
(Typ
, Loc
),
2701 Out_Present
=> True),
2703 Make_Parameter_Specification
(Loc
, -- F
2704 Defining_Identifier
=>
2705 Make_Defining_Identifier
(Loc
, Name_uF
),
2707 New_Reference_To
(Standard_Boolean
, Loc
)),
2709 Make_Parameter_Specification
(Loc
, -- P
2710 Defining_Identifier
=>
2711 Make_Defining_Identifier
(Loc
, Name_uP
),
2713 New_Reference_To
(RTE
(RE_Address
), Loc
)),
2715 Make_Parameter_Specification
(Loc
, -- I
2716 Defining_Identifier
=>
2717 Make_Defining_Identifier
(Loc
, Name_uI
),
2719 New_Reference_To
(Standard_Integer
, Loc
)),
2721 Make_Parameter_Specification
(Loc
, -- A
2722 Defining_Identifier
=>
2723 Make_Defining_Identifier
(Loc
, Name_uA
),
2725 New_Reference_To
(Standard_Boolean
, Loc
))));
2726 end Make_Disp_Requeue_Spec
;
2728 ---------------------------------
2729 -- Make_Disp_Timed_Select_Body --
2730 ---------------------------------
2732 -- For interface types, generate:
2734 -- procedure _Disp_Timed_Select
2735 -- (T : in out <Typ>;
2737 -- P : System.Address;
2740 -- C : out Ada.Tags.Prim_Op_Kind;
2745 -- end _Disp_Timed_Select;
2747 -- For protected types, generate:
2749 -- procedure _Disp_Timed_Select
2750 -- (T : in out <Typ>;
2752 -- P : System.Address;
2755 -- C : out Ada.Tags.Prim_Op_Kind;
2761 -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S);
2763 -- if C = Ada.Tags.POK_Procedure
2764 -- or else C = Ada.Tags.POK_Protected_Procedure
2765 -- or else C = Ada.Tags.POK_Task_Procedure
2771 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
2772 -- System.Tasking.Protected_Objects.Operations.
2773 -- Timed_Protected_Entry_Call
2774 -- (T._object'Access,
2775 -- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2780 -- end _Disp_Timed_Select;
2782 -- For task types, generate:
2784 -- procedure _Disp_Timed_Select
2785 -- (T : in out <Typ>;
2787 -- P : System.Address;
2790 -- C : out Ada.Tags.Prim_Op_Kind;
2796 -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
2797 -- System.Tasking.Rendezvous.Timed_Task_Entry_Call
2799 -- System.Tasking.Task_Entry_Index (I),
2804 -- end _Disp_Time_Select;
2806 function Make_Disp_Timed_Select_Body
2807 (Typ
: Entity_Id
) return Node_Id
2809 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2810 Conc_Typ
: Entity_Id
:= Empty
;
2811 Decls
: constant List_Id
:= New_List
;
2814 Stmts
: constant List_Id
:= New_List
;
2817 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
2819 -- Null body is generated for interface types
2821 if Is_Interface
(Typ
) then
2823 Make_Subprogram_Body
(Loc
,
2825 Make_Disp_Timed_Select_Spec
(Typ
),
2828 Handled_Statement_Sequence
=>
2829 Make_Handled_Sequence_Of_Statements
(Loc
,
2830 New_List
(Make_Null_Statement
(Loc
))));
2833 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
2835 if Is_Concurrent_Record_Type
(Typ
) then
2836 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
2841 -- where I will be used to capture the entry index of the primitive
2842 -- wrapper at position S.
2845 Make_Object_Declaration
(Loc
,
2846 Defining_Identifier
=>
2847 Make_Defining_Identifier
(Loc
, Name_uI
),
2848 Object_Definition
=>
2849 New_Reference_To
(Standard_Integer
, Loc
)));
2852 -- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
2854 -- if C = POK_Procedure
2855 -- or else C = POK_Protected_Procedure
2856 -- or else C = POK_Task_Procedure;
2862 Build_Common_Dispatching_Select_Statements
(Loc
, DT_Ptr
, Stmts
);
2865 -- I := Get_Entry_Index (tag! (<type>VP), S);
2867 -- I is the entry index and S is the dispatch table slot
2870 Make_Assignment_Statement
(Loc
,
2872 Make_Identifier
(Loc
, Name_uI
),
2874 Make_Function_Call
(Loc
,
2876 New_Reference_To
(RTE
(RE_Get_Entry_Index
), Loc
),
2877 Parameter_Associations
=>
2879 Unchecked_Convert_To
(RTE
(RE_Tag
),
2880 New_Reference_To
(DT_Ptr
, Loc
)),
2881 Make_Identifier
(Loc
, Name_uS
)))));
2885 if Ekind
(Conc_Typ
) = E_Protected_Type
then
2887 -- Build T._object'Access
2890 Make_Attribute_Reference
(Loc
,
2891 Attribute_Name
=> Name_Unchecked_Access
,
2893 Make_Selected_Component
(Loc
,
2894 Prefix
=> Make_Identifier
(Loc
, Name_uT
),
2895 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)));
2897 -- Normal case, No_Entry_Queue restriction not active. In this
2898 -- case we generate:
2900 -- Timed_Protected_Entry_Call
2901 -- (T._object'access,
2902 -- Protected_Entry_Index! (I),
2905 -- where T is the protected object, I is the entry index, P are
2906 -- the wrapped parameters, D is the delay amount, M is the delay
2907 -- mode and F is the status flag.
2909 case Corresponding_Runtime_Package
(Conc_Typ
) is
2910 when System_Tasking_Protected_Objects_Entries
=>
2912 Make_Procedure_Call_Statement
(Loc
,
2915 (RTE
(RE_Timed_Protected_Entry_Call
), Loc
),
2916 Parameter_Associations
=>
2920 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2923 (RTE
(RE_Protected_Entry_Index
), Loc
),
2925 Make_Identifier
(Loc
, Name_uI
)),
2927 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2928 Make_Identifier
(Loc
, Name_uD
), -- delay
2929 Make_Identifier
(Loc
, Name_uM
), -- delay mode
2930 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
2932 when System_Tasking_Protected_Objects_Single_Entry
=>
2935 -- Timed_Protected_Single_Entry_Call
2936 -- (T._object'access, P, D, M, F);
2938 -- where T is the protected object, P is the wrapped
2939 -- parameters, D is the delay amount, M is the delay mode, F
2940 -- is the status flag.
2943 Make_Procedure_Call_Statement
(Loc
,
2946 (RTE
(RE_Timed_Protected_Single_Entry_Call
), Loc
),
2947 Parameter_Associations
=>
2950 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2951 Make_Identifier
(Loc
, Name_uD
), -- delay
2952 Make_Identifier
(Loc
, Name_uM
), -- delay mode
2953 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
2956 raise Program_Error
;
2962 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
2965 -- Timed_Task_Entry_Call (
2967 -- Task_Entry_Index! (I),
2973 -- where T is the task object, I is the entry index, P are the
2974 -- wrapped parameters, D is the delay amount, M is the delay
2975 -- mode and F is the status flag.
2978 Make_Procedure_Call_Statement
(Loc
,
2980 New_Reference_To
(RTE
(RE_Timed_Task_Entry_Call
), Loc
),
2981 Parameter_Associations
=>
2984 Make_Selected_Component
(Loc
, -- T._task_id
2986 Make_Identifier
(Loc
, Name_uT
),
2988 Make_Identifier
(Loc
, Name_uTask_Id
)),
2990 Make_Unchecked_Type_Conversion
(Loc
, -- entry index
2992 New_Reference_To
(RTE
(RE_Task_Entry_Index
), Loc
),
2994 Make_Identifier
(Loc
, Name_uI
)),
2996 Make_Identifier
(Loc
, Name_uP
), -- parameter block
2997 Make_Identifier
(Loc
, Name_uD
), -- delay
2998 Make_Identifier
(Loc
, Name_uM
), -- delay mode
2999 Make_Identifier
(Loc
, Name_uF
)))); -- status flag
3004 Make_Subprogram_Body
(Loc
,
3006 Make_Disp_Timed_Select_Spec
(Typ
),
3009 Handled_Statement_Sequence
=>
3010 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
3011 end Make_Disp_Timed_Select_Body
;
3013 ---------------------------------
3014 -- Make_Disp_Timed_Select_Spec --
3015 ---------------------------------
3017 function Make_Disp_Timed_Select_Spec
3018 (Typ
: Entity_Id
) return Node_Id
3020 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3021 Def_Id
: constant Node_Id
:=
3022 Make_Defining_Identifier
(Loc
,
3023 Name_uDisp_Timed_Select
);
3024 Params
: constant List_Id
:= New_List
;
3027 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
3029 -- T : in out Typ; -- Object parameter
3030 -- S : Integer; -- Primitive operation slot
3031 -- P : Address; -- Wrapped parameters
3032 -- D : Duration; -- Delay
3033 -- M : Integer; -- Delay Mode
3034 -- C : out Prim_Op_Kind; -- Call kind
3035 -- F : out Boolean; -- Status flag
3037 Append_List_To
(Params
, New_List
(
3039 Make_Parameter_Specification
(Loc
,
3040 Defining_Identifier
=>
3041 Make_Defining_Identifier
(Loc
, Name_uT
),
3043 New_Reference_To
(Typ
, Loc
),
3045 Out_Present
=> True),
3047 Make_Parameter_Specification
(Loc
,
3048 Defining_Identifier
=>
3049 Make_Defining_Identifier
(Loc
, Name_uS
),
3051 New_Reference_To
(Standard_Integer
, Loc
)),
3053 Make_Parameter_Specification
(Loc
,
3054 Defining_Identifier
=>
3055 Make_Defining_Identifier
(Loc
, Name_uP
),
3057 New_Reference_To
(RTE
(RE_Address
), Loc
)),
3059 Make_Parameter_Specification
(Loc
,
3060 Defining_Identifier
=>
3061 Make_Defining_Identifier
(Loc
, Name_uD
),
3063 New_Reference_To
(Standard_Duration
, Loc
)),
3065 Make_Parameter_Specification
(Loc
,
3066 Defining_Identifier
=>
3067 Make_Defining_Identifier
(Loc
, Name_uM
),
3069 New_Reference_To
(Standard_Integer
, Loc
)),
3071 Make_Parameter_Specification
(Loc
,
3072 Defining_Identifier
=>
3073 Make_Defining_Identifier
(Loc
, Name_uC
),
3075 New_Reference_To
(RTE
(RE_Prim_Op_Kind
), Loc
),
3076 Out_Present
=> True)));
3079 Make_Parameter_Specification
(Loc
,
3080 Defining_Identifier
=>
3081 Make_Defining_Identifier
(Loc
, Name_uF
),
3083 New_Reference_To
(Standard_Boolean
, Loc
),
3084 Out_Present
=> True));
3087 Make_Procedure_Specification
(Loc
,
3088 Defining_Unit_Name
=> Def_Id
,
3089 Parameter_Specifications
=> Params
);
3090 end Make_Disp_Timed_Select_Spec
;
3096 -- The frontend supports two models for expanding dispatch tables
3097 -- associated with library-level defined tagged types: statically
3098 -- and non-statically allocated dispatch tables. In the former case
3099 -- the object containing the dispatch table is constant and it is
3100 -- initialized by means of a positional aggregate. In the latter case,
3101 -- the object containing the dispatch table is a variable which is
3102 -- initialized by means of assignments.
3104 -- In case of locally defined tagged types, the object containing the
3105 -- object containing the dispatch table is always a variable (instead
3106 -- of a constant). This is currently required to give support to late
3107 -- overriding of primitives. For example:
3109 -- procedure Example is
3111 -- type T1 is tagged null record;
3112 -- procedure Prim (O : T1);
3115 -- type T2 is new Pkg.T1 with null record;
3116 -- procedure Prim (X : T2) is -- late overriding
3122 function Make_DT
(Typ
: Entity_Id
; N
: Node_Id
:= Empty
) return List_Id
is
3123 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3125 Max_Predef_Prims
: constant Int
:=
3129 (Parent
(RTE
(RE_Max_Predef_Prims
)))));
3131 DT_Decl
: constant Elist_Id
:= New_Elmt_List
;
3132 DT_Aggr
: constant Elist_Id
:= New_Elmt_List
;
3133 -- Entities marked with attribute Is_Dispatch_Table_Entity
3135 procedure Check_Premature_Freezing
(Subp
: Entity_Id
; Typ
: Entity_Id
);
3136 -- Verify that all non-tagged types in the profile of a subprogram
3137 -- are frozen at the point the subprogram is frozen. This enforces
3138 -- the rule on RM 13.14 (14) as modified by AI05-019. At the point a
3139 -- subprogram is frozen, enough must be known about it to build the
3140 -- activation record for it, which requires at least that the size of
3141 -- all parameters be known. Controlling arguments are by-reference,
3142 -- and therefore the rule only applies to non-tagged types.
3143 -- Typical violation of the rule involves an object declaration that
3144 -- freezes a tagged type, when one of its primitive operations has a
3145 -- type in its profile whose full view has not been analyzed yet.
3147 procedure Export_DT
(Typ
: Entity_Id
; DT
: Entity_Id
);
3148 -- Export the dispatch table entity DT of tagged type Typ. Required to
3149 -- generate forward references and statically allocate the table.
3151 procedure Make_Secondary_DT
3154 Num_Iface_Prims
: Nat
;
3155 Iface_DT_Ptr
: Entity_Id
;
3156 Predef_Prims_Ptr
: Entity_Id
;
3157 Build_Thunks
: Boolean;
3159 -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch
3160 -- Table of Typ associated with Iface. Each abstract interface of Typ
3161 -- has two secondary dispatch tables: one containing pointers to thunks
3162 -- and another containing pointers to the primitives covering the
3163 -- interface primitives. The former secondary table is generated when
3164 -- Build_Thunks is True, and provides common support for dispatching
3165 -- calls through interface types; the latter secondary table is
3166 -- generated when Build_Thunks is False, and provides support for
3167 -- Generic Dispatching Constructors that dispatch calls through
3170 ------------------------------
3171 -- Check_Premature_Freezing --
3172 ------------------------------
3174 procedure Check_Premature_Freezing
(Subp
: Entity_Id
; Typ
: Entity_Id
) is
3177 and then Is_Private_Type
(Typ
)
3178 and then No
(Full_View
(Typ
))
3179 and then not Is_Generic_Type
(Typ
)
3180 and then not Is_Tagged_Type
(Typ
)
3181 and then not Is_Frozen
(Typ
)
3183 Error_Msg_Sloc
:= Sloc
(Subp
);
3185 ("declaration must appear after completion of type &", N
, Typ
);
3187 ("\which is an untagged type in the profile of"
3188 & " primitive operation & declared#",
3191 end Check_Premature_Freezing
;
3197 procedure Export_DT
(Typ
: Entity_Id
; DT
: Entity_Id
) is
3199 Set_Is_Statically_Allocated
(DT
);
3200 Set_Is_True_Constant
(DT
);
3201 Set_Is_Exported
(DT
);
3203 pragma Assert
(Present
(Dispatch_Table_Wrapper
(Typ
)));
3204 Get_External_Name
(Dispatch_Table_Wrapper
(Typ
), True);
3205 Set_Interface_Name
(DT
,
3206 Make_String_Literal
(Loc
,
3207 Strval
=> String_From_Name_Buffer
));
3209 -- Ensure proper Sprint output of this implicit importation
3211 Set_Is_Internal
(DT
);
3215 -----------------------
3216 -- Make_Secondary_DT --
3217 -----------------------
3219 procedure Make_Secondary_DT
3222 Num_Iface_Prims
: Nat
;
3223 Iface_DT_Ptr
: Entity_Id
;
3224 Predef_Prims_Ptr
: Entity_Id
;
3225 Build_Thunks
: Boolean;
3228 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3229 Name_DT
: constant Name_Id
:= New_Internal_Name
('T');
3230 Iface_DT
: constant Entity_Id
:=
3231 Make_Defining_Identifier
(Loc
, Name_DT
);
3232 Name_Predef_Prims
: constant Name_Id
:= New_Internal_Name
('R');
3233 Predef_Prims
: constant Entity_Id
:=
3234 Make_Defining_Identifier
(Loc
,
3236 DT_Constr_List
: List_Id
;
3237 DT_Aggr_List
: List_Id
;
3238 Empty_DT
: Boolean := False;
3239 Nb_Predef_Prims
: Nat
:= 0;
3243 OSD_Aggr_List
: List_Id
;
3246 Prim_Elmt
: Elmt_Id
;
3247 Prim_Ops_Aggr_List
: List_Id
;
3250 -- Handle cases in which we do not generate statically allocated
3253 if not Building_Static_DT
(Typ
) then
3254 Set_Ekind
(Predef_Prims
, E_Variable
);
3255 Set_Ekind
(Iface_DT
, E_Variable
);
3257 -- Statically allocated dispatch tables and related entities are
3261 Set_Ekind
(Predef_Prims
, E_Constant
);
3262 Set_Is_Statically_Allocated
(Predef_Prims
);
3263 Set_Is_True_Constant
(Predef_Prims
);
3265 Set_Ekind
(Iface_DT
, E_Constant
);
3266 Set_Is_Statically_Allocated
(Iface_DT
);
3267 Set_Is_True_Constant
(Iface_DT
);
3270 -- Generate code to create the storage for the Dispatch_Table object.
3271 -- If the number of primitives of Typ is 0 we reserve a dummy single
3272 -- entry for its DT because at run-time the pointer to this dummy
3273 -- entry will be used as the tag.
3275 if Num_Iface_Prims
= 0 then
3279 Nb_Prim
:= Num_Iface_Prims
;
3284 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
3285 -- (predef-prim-op-thunk-1'address,
3286 -- predef-prim-op-thunk-2'address,
3288 -- predef-prim-op-thunk-n'address);
3289 -- for Predef_Prims'Alignment use Address'Alignment
3291 -- Stage 1: Calculate the number of predefined primitives
3293 if not Building_Static_DT
(Typ
) then
3294 Nb_Predef_Prims
:= Max_Predef_Prims
;
3296 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
3297 while Present
(Prim_Elmt
) loop
3298 Prim
:= Node
(Prim_Elmt
);
3300 if Is_Predefined_Dispatching_Operation
(Prim
)
3301 and then not Is_Abstract_Subprogram
(Prim
)
3303 Pos
:= UI_To_Int
(DT_Position
(Prim
));
3305 if Pos
> Nb_Predef_Prims
then
3306 Nb_Predef_Prims
:= Pos
;
3310 Next_Elmt
(Prim_Elmt
);
3314 -- Stage 2: Create the thunks associated with the predefined
3315 -- primitives and save their entity to fill the aggregate.
3318 Prim_Table
: array (Nat
range 1 .. Nb_Predef_Prims
) of Entity_Id
;
3320 Thunk_Id
: Entity_Id
;
3321 Thunk_Code
: Node_Id
;
3324 Prim_Ops_Aggr_List
:= New_List
;
3325 Prim_Table
:= (others => Empty
);
3327 if Building_Static_DT
(Typ
) then
3328 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
3329 while Present
(Prim_Elmt
) loop
3330 Prim
:= Node
(Prim_Elmt
);
3332 if Is_Predefined_Dispatching_Operation
(Prim
)
3333 and then not Is_Abstract_Subprogram
(Prim
)
3334 and then not Present
(Prim_Table
3335 (UI_To_Int
(DT_Position
(Prim
))))
3337 if not Build_Thunks
then
3338 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) :=
3342 while Present
(Alias
(Prim
)) loop
3343 Prim
:= Alias
(Prim
);
3346 Expand_Interface_Thunk
(Prim
, Thunk_Id
, Thunk_Code
);
3348 if Present
(Thunk_Id
) then
3349 Append_To
(Result
, Thunk_Code
);
3350 Prim_Table
(UI_To_Int
(DT_Position
(Prim
)))
3356 Next_Elmt
(Prim_Elmt
);
3360 for J
in Prim_Table
'Range loop
3361 if Present
(Prim_Table
(J
)) then
3363 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
3364 Make_Attribute_Reference
(Loc
,
3365 Prefix
=> New_Reference_To
(Prim_Table
(J
), Loc
),
3366 Attribute_Name
=> Name_Unrestricted_Access
));
3368 New_Node
:= Make_Null
(Loc
);
3371 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
3375 Make_Aggregate
(Loc
,
3376 Expressions
=> Prim_Ops_Aggr_List
);
3378 -- Remember aggregates initializing dispatch tables
3380 Append_Elmt
(New_Node
, DT_Aggr
);
3383 Make_Subtype_Declaration
(Loc
,
3384 Defining_Identifier
=>
3385 Make_Defining_Identifier
(Loc
,
3386 New_Internal_Name
('S')),
3387 Subtype_Indication
=>
3388 New_Reference_To
(RTE
(RE_Address_Array
), Loc
));
3390 Append_To
(Result
, Decl
);
3393 Make_Object_Declaration
(Loc
,
3394 Defining_Identifier
=> Predef_Prims
,
3395 Constant_Present
=> Building_Static_DT
(Typ
),
3396 Aliased_Present
=> True,
3397 Object_Definition
=> New_Reference_To
3398 (Defining_Identifier
(Decl
), Loc
),
3399 Expression
=> New_Node
));
3402 Make_Attribute_Definition_Clause
(Loc
,
3403 Name
=> New_Reference_To
(Predef_Prims
, Loc
),
3404 Chars
=> Name_Alignment
,
3406 Make_Attribute_Reference
(Loc
,
3408 New_Reference_To
(RTE
(RE_Integer_Address
), Loc
),
3409 Attribute_Name
=> Name_Alignment
)));
3414 -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
3415 -- (OSD_Table => (1 => <value>,
3419 -- Iface_DT : Dispatch_Table (Nb_Prims) :=
3420 -- ([ Signature => <sig-value> ],
3421 -- Tag_Kind => <tag_kind-value>,
3422 -- Predef_Prims => Predef_Prims'Address,
3423 -- Offset_To_Top => 0,
3424 -- OSD => OSD'Address,
3425 -- Prims_Ptr => (prim-op-1'address,
3426 -- prim-op-2'address,
3428 -- prim-op-n'address));
3430 -- Stage 3: Initialize the discriminant and the record components
3432 DT_Constr_List
:= New_List
;
3433 DT_Aggr_List
:= New_List
;
3435 -- Nb_Prim. If the tagged type has no primitives we add a dummy
3436 -- slot whose address will be the tag of this type.
3439 New_Node
:= Make_Integer_Literal
(Loc
, 1);
3441 New_Node
:= Make_Integer_Literal
(Loc
, Nb_Prim
);
3444 Append_To
(DT_Constr_List
, New_Node
);
3445 Append_To
(DT_Aggr_List
, New_Copy
(New_Node
));
3449 if RTE_Record_Component_Available
(RE_Signature
) then
3450 Append_To
(DT_Aggr_List
,
3451 New_Reference_To
(RTE
(RE_Secondary_DT
), Loc
));
3456 if RTE_Record_Component_Available
(RE_Tag_Kind
) then
3457 Append_To
(DT_Aggr_List
, Tagged_Kind
(Typ
));
3462 Append_To
(DT_Aggr_List
,
3463 Make_Attribute_Reference
(Loc
,
3464 Prefix
=> New_Reference_To
(Predef_Prims
, Loc
),
3465 Attribute_Name
=> Name_Address
));
3467 -- Note: The correct value of Offset_To_Top will be set by the init
3470 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
3472 -- Generate the Object Specific Data table required to dispatch calls
3473 -- through synchronized interfaces.
3476 or else Is_Abstract_Type
(Typ
)
3477 or else Is_Controlled
(Typ
)
3478 or else Restriction_Active
(No_Dispatching_Calls
)
3479 or else not Is_Limited_Type
(Typ
)
3480 or else not Has_Interfaces
(Typ
)
3481 or else not Build_Thunks
3483 -- No OSD table required
3485 Append_To
(DT_Aggr_List
,
3486 New_Reference_To
(RTE
(RE_Null_Address
), Loc
));
3489 OSD_Aggr_List
:= New_List
;
3492 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
3494 Prim_Alias
: Entity_Id
;
3495 Prim_Elmt
: Elmt_Id
;
3501 Prim_Table
:= (others => Empty
);
3502 Prim_Alias
:= Empty
;
3504 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
3505 while Present
(Prim_Elmt
) loop
3506 Prim
:= Node
(Prim_Elmt
);
3508 if Present
(Interface_Alias
(Prim
))
3509 and then Find_Dispatching_Type
3510 (Interface_Alias
(Prim
)) = Iface
3512 Prim_Alias
:= Interface_Alias
(Prim
);
3515 while Present
(Alias
(E
)) loop
3519 Pos
:= UI_To_Int
(DT_Position
(Prim_Alias
));
3521 if Present
(Prim_Table
(Pos
)) then
3522 pragma Assert
(Prim_Table
(Pos
) = E
);
3526 Prim_Table
(Pos
) := E
;
3528 Append_To
(OSD_Aggr_List
,
3529 Make_Component_Association
(Loc
,
3530 Choices
=> New_List
(
3531 Make_Integer_Literal
(Loc
,
3532 DT_Position
(Prim_Alias
))),
3534 Make_Integer_Literal
(Loc
,
3535 DT_Position
(Alias
(Prim
)))));
3541 Next_Elmt
(Prim_Elmt
);
3543 pragma Assert
(Count
= Nb_Prim
);
3546 OSD
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('I'));
3549 Make_Object_Declaration
(Loc
,
3550 Defining_Identifier
=> OSD
,
3551 Object_Definition
=>
3552 Make_Subtype_Indication
(Loc
,
3554 New_Reference_To
(RTE
(RE_Object_Specific_Data
), Loc
),
3556 Make_Index_Or_Discriminant_Constraint
(Loc
,
3557 Constraints
=> New_List
(
3558 Make_Integer_Literal
(Loc
, Nb_Prim
)))),
3559 Expression
=> Make_Aggregate
(Loc
,
3560 Component_Associations
=> New_List
(
3561 Make_Component_Association
(Loc
,
3562 Choices
=> New_List
(
3564 (RTE_Record_Component
(RE_OSD_Num_Prims
), Loc
)),
3566 Make_Integer_Literal
(Loc
, Nb_Prim
)),
3568 Make_Component_Association
(Loc
,
3569 Choices
=> New_List
(
3571 (RTE_Record_Component
(RE_OSD_Table
), Loc
)),
3572 Expression
=> Make_Aggregate
(Loc
,
3573 Component_Associations
=> OSD_Aggr_List
))))));
3576 Make_Attribute_Definition_Clause
(Loc
,
3577 Name
=> New_Reference_To
(OSD
, Loc
),
3578 Chars
=> Name_Alignment
,
3580 Make_Attribute_Reference
(Loc
,
3582 New_Reference_To
(RTE
(RE_Integer_Address
), Loc
),
3583 Attribute_Name
=> Name_Alignment
)));
3585 -- In secondary dispatch tables the Typeinfo component contains
3586 -- the address of the Object Specific Data (see a-tags.ads)
3588 Append_To
(DT_Aggr_List
,
3589 Make_Attribute_Reference
(Loc
,
3590 Prefix
=> New_Reference_To
(OSD
, Loc
),
3591 Attribute_Name
=> Name_Address
));
3594 -- Initialize the table of primitive operations
3596 Prim_Ops_Aggr_List
:= New_List
;
3599 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
3601 elsif Is_Abstract_Type
(Typ
)
3602 or else not Building_Static_DT
(Typ
)
3604 for J
in 1 .. Nb_Prim
loop
3605 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
3610 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
3612 Thunk_Code
: Node_Id
;
3613 Thunk_Id
: Entity_Id
;
3616 Prim_Table
:= (others => Empty
);
3618 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
3619 while Present
(Prim_Elmt
) loop
3620 Prim
:= Node
(Prim_Elmt
);
3622 if not Is_Predefined_Dispatching_Operation
(Prim
)
3623 and then Present
(Interface_Alias
(Prim
))
3624 and then not Is_Abstract_Subprogram
(Alias
(Prim
))
3625 and then not Is_Imported
(Alias
(Prim
))
3626 and then Find_Dispatching_Type
3627 (Interface_Alias
(Prim
)) = Iface
3629 -- Generate the code of the thunk only if the abstract
3630 -- interface type is not an immediate ancestor of
3631 -- Tagged_Type; otherwise the DT associated with the
3632 -- interface is the primary DT.
3634 and then not Is_Ancestor
(Iface
, Typ
)
3636 if not Build_Thunks
then
3638 UI_To_Int
(DT_Position
(Interface_Alias
(Prim
)));
3639 Prim_Table
(Pos
) := Alias
(Prim
);
3641 Expand_Interface_Thunk
(Prim
, Thunk_Id
, Thunk_Code
);
3643 if Present
(Thunk_Id
) then
3645 UI_To_Int
(DT_Position
(Interface_Alias
(Prim
)));
3647 Prim_Table
(Pos
) := Thunk_Id
;
3648 Append_To
(Result
, Thunk_Code
);
3653 Next_Elmt
(Prim_Elmt
);
3656 for J
in Prim_Table
'Range loop
3657 if Present
(Prim_Table
(J
)) then
3659 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
3660 Make_Attribute_Reference
(Loc
,
3661 Prefix
=> New_Reference_To
(Prim_Table
(J
), Loc
),
3662 Attribute_Name
=> Name_Unrestricted_Access
));
3664 New_Node
:= Make_Null
(Loc
);
3667 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
3673 Make_Aggregate
(Loc
,
3674 Expressions
=> Prim_Ops_Aggr_List
);
3676 Append_To
(DT_Aggr_List
, New_Node
);
3678 -- Remember aggregates initializing dispatch tables
3680 Append_Elmt
(New_Node
, DT_Aggr
);
3683 Make_Object_Declaration
(Loc
,
3684 Defining_Identifier
=> Iface_DT
,
3685 Aliased_Present
=> True,
3686 Object_Definition
=>
3687 Make_Subtype_Indication
(Loc
,
3688 Subtype_Mark
=> New_Reference_To
3689 (RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
3690 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
3691 Constraints
=> DT_Constr_List
)),
3693 Expression
=> Make_Aggregate
(Loc
,
3694 Expressions
=> DT_Aggr_List
)));
3697 Make_Attribute_Definition_Clause
(Loc
,
3698 Name
=> New_Reference_To
(Iface_DT
, Loc
),
3699 Chars
=> Name_Alignment
,
3701 Make_Attribute_Reference
(Loc
,
3703 New_Reference_To
(RTE
(RE_Integer_Address
), Loc
),
3704 Attribute_Name
=> Name_Alignment
)));
3706 -- Generate code to create the pointer to the dispatch table
3708 -- Iface_DT_Ptr : Tag := Tag!(DT'Address);
3711 Make_Object_Declaration
(Loc
,
3712 Defining_Identifier
=> Iface_DT_Ptr
,
3713 Constant_Present
=> True,
3714 Object_Definition
=>
3715 New_Reference_To
(RTE
(RE_Interface_Tag
), Loc
),
3717 Unchecked_Convert_To
(RTE
(RE_Interface_Tag
),
3718 Make_Attribute_Reference
(Loc
,
3720 Make_Selected_Component
(Loc
,
3721 Prefix
=> New_Reference_To
(Iface_DT
, Loc
),
3724 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
3725 Attribute_Name
=> Name_Address
))));
3728 Make_Object_Declaration
(Loc
,
3729 Defining_Identifier
=> Predef_Prims_Ptr
,
3730 Constant_Present
=> True,
3731 Object_Definition
=>
3732 New_Reference_To
(RTE
(RE_Address
), Loc
),
3734 Make_Attribute_Reference
(Loc
,
3736 Make_Selected_Component
(Loc
,
3737 Prefix
=> New_Reference_To
(Iface_DT
, Loc
),
3740 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
3741 Attribute_Name
=> Name_Address
)));
3743 -- Remember entities containing dispatch tables
3745 Append_Elmt
(Predef_Prims
, DT_Decl
);
3746 Append_Elmt
(Iface_DT
, DT_Decl
);
3747 end Make_Secondary_DT
;
3751 Elab_Code
: constant List_Id
:= New_List
;
3752 Result
: constant List_Id
:= New_List
;
3753 Tname
: constant Name_Id
:= Chars
(Typ
);
3755 AI_Tag_Elmt
: Elmt_Id
;
3756 AI_Tag_Comp
: Elmt_Id
;
3757 DT_Aggr_List
: List_Id
;
3758 DT_Constr_List
: List_Id
;
3762 Iface_Table_Node
: Node_Id
;
3763 Name_ITable
: Name_Id
;
3764 Nb_Predef_Prims
: Nat
:= 0;
3767 Num_Ifaces
: Nat
:= 0;
3768 Parent_Typ
: Entity_Id
;
3770 Prim_Elmt
: Elmt_Id
;
3771 Prim_Ops_Aggr_List
: List_Id
;
3773 Typ_Comps
: Elist_Id
;
3774 Typ_Ifaces
: Elist_Id
;
3775 TSD_Aggr_List
: List_Id
;
3776 TSD_Tags_List
: List_Id
;
3778 -- The following name entries are used by Make_DT to generate a number
3779 -- of entities related to a tagged type. These entities may be generated
3780 -- in a scope other than that of the tagged type declaration, and if
3781 -- the entities for two tagged types with the same name happen to be
3782 -- generated in the same scope, we have to take care to use different
3783 -- names. This is achieved by means of a unique serial number appended
3784 -- to each generated entity name.
3786 Name_DT
: constant Name_Id
:=
3787 New_External_Name
(Tname
, 'T', Suffix_Index
=> -1);
3788 Name_Exname
: constant Name_Id
:=
3789 New_External_Name
(Tname
, 'E', Suffix_Index
=> -1);
3790 Name_HT_Link
: constant Name_Id
:=
3791 New_External_Name
(Tname
, 'H', Suffix_Index
=> -1);
3792 Name_Predef_Prims
: constant Name_Id
:=
3793 New_External_Name
(Tname
, 'R', Suffix_Index
=> -1);
3794 Name_SSD
: constant Name_Id
:=
3795 New_External_Name
(Tname
, 'S', Suffix_Index
=> -1);
3796 Name_TSD
: constant Name_Id
:=
3797 New_External_Name
(Tname
, 'B', Suffix_Index
=> -1);
3799 -- Entities built with above names
3801 DT
: constant Entity_Id
:=
3802 Make_Defining_Identifier
(Loc
, Name_DT
);
3803 Exname
: constant Entity_Id
:=
3804 Make_Defining_Identifier
(Loc
, Name_Exname
);
3805 HT_Link
: constant Entity_Id
:=
3806 Make_Defining_Identifier
(Loc
, Name_HT_Link
);
3807 Predef_Prims
: constant Entity_Id
:=
3808 Make_Defining_Identifier
(Loc
, Name_Predef_Prims
);
3809 SSD
: constant Entity_Id
:=
3810 Make_Defining_Identifier
(Loc
, Name_SSD
);
3811 TSD
: constant Entity_Id
:=
3812 Make_Defining_Identifier
(Loc
, Name_TSD
);
3814 -- Start of processing for Make_DT
3817 pragma Assert
(Is_Frozen
(Typ
));
3819 -- Handle cases in which there is no need to build the dispatch table
3821 if Has_Dispatch_Table
(Typ
)
3822 or else No
(Access_Disp_Table
(Typ
))
3823 or else Is_CPP_Class
(Typ
)
3827 elsif No_Run_Time_Mode
then
3828 Error_Msg_CRT
("tagged types", Typ
);
3831 elsif not RTE_Available
(RE_Tag
) then
3833 Make_Object_Declaration
(Loc
,
3834 Defining_Identifier
=> Node
(First_Elmt
3835 (Access_Disp_Table
(Typ
))),
3836 Object_Definition
=> New_Reference_To
(RTE
(RE_Tag
), Loc
),
3837 Constant_Present
=> True,
3839 Unchecked_Convert_To
(RTE
(RE_Tag
),
3840 New_Reference_To
(RTE
(RE_Null_Address
), Loc
))));
3842 Analyze_List
(Result
, Suppress
=> All_Checks
);
3843 Error_Msg_CRT
("tagged types", Typ
);
3847 -- Ensure that the value of Max_Predef_Prims defined in a-tags is
3848 -- correct. Valid values are 10 under configurable runtime or 16
3849 -- with full runtime.
3851 if RTE_Available
(RE_Interface_Data
) then
3852 if Max_Predef_Prims
/= 16 then
3853 Error_Msg_N
("run-time library configuration error", Typ
);
3857 if Max_Predef_Prims
/= 10 then
3858 Error_Msg_N
("run-time library configuration error", Typ
);
3859 Error_Msg_CRT
("tagged types", Typ
);
3864 -- Initialize Parent_Typ handling private types
3866 Parent_Typ
:= Etype
(Typ
);
3868 if Present
(Full_View
(Parent_Typ
)) then
3869 Parent_Typ
:= Full_View
(Parent_Typ
);
3872 -- Ensure that all the primitives are frozen. This is only required when
3873 -- building static dispatch tables --- the primitives must be frozen to
3874 -- be referenced (otherwise we have problems with the backend). It is
3875 -- not a requirement with nonstatic dispatch tables because in this case
3876 -- we generate now an empty dispatch table; the extra code required to
3877 -- register the primitives in the slots will be generated later --- when
3878 -- each primitive is frozen (see Freeze_Subprogram).
3880 if Building_Static_DT
(Typ
)
3881 and then not Is_CPP_Class
(Typ
)
3884 Save
: constant Boolean := Freezing_Library_Level_Tagged_Type
;
3885 Prim_Elmt
: Elmt_Id
;
3889 Freezing_Library_Level_Tagged_Type
:= True;
3890 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
3891 while Present
(Prim_Elmt
) loop
3892 Frnodes
:= Freeze_Entity
(Node
(Prim_Elmt
), Loc
);
3895 Subp
: constant Entity_Id
:= Node
(Prim_Elmt
);
3899 F
:= First_Formal
(Subp
);
3900 while Present
(F
) loop
3901 Check_Premature_Freezing
(Subp
, Etype
(F
));
3905 Check_Premature_Freezing
(Subp
, Etype
(Subp
));
3908 if Present
(Frnodes
) then
3909 Append_List_To
(Result
, Frnodes
);
3912 Next_Elmt
(Prim_Elmt
);
3914 Freezing_Library_Level_Tagged_Type
:= Save
;
3918 -- Ada 2005 (AI-251): Build the secondary dispatch tables
3920 if Has_Interfaces
(Typ
) then
3921 Collect_Interface_Components
(Typ
, Typ_Comps
);
3925 Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
3927 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
3928 while Present
(AI_Tag_Comp
) loop
3930 -- Build the secondary table containing pointers to thunks
3934 Iface
=> Base_Type
(Related_Type
(Node
(AI_Tag_Comp
))),
3935 Num_Iface_Prims
=> UI_To_Int
3936 (DT_Entry_Count
(Node
(AI_Tag_Comp
))),
3937 Iface_DT_Ptr
=> Node
(AI_Tag_Elmt
),
3938 Predef_Prims_Ptr
=> Node
(Next_Elmt
(AI_Tag_Elmt
)),
3939 Build_Thunks
=> True,
3941 Next_Elmt
(AI_Tag_Elmt
);
3943 -- Skip the secondary dispatch table of predefined primitives
3945 Next_Elmt
(AI_Tag_Elmt
);
3947 -- Build the secondary table containing pointers to primitives
3948 -- (used to give support to Generic Dispatching Constructors).
3952 Iface
=> Base_Type
(Related_Type
(Node
(AI_Tag_Comp
))),
3953 Num_Iface_Prims
=> UI_To_Int
3954 (DT_Entry_Count
(Node
(AI_Tag_Comp
))),
3955 Iface_DT_Ptr
=> Node
(AI_Tag_Elmt
),
3956 Predef_Prims_Ptr
=> Node
(Next_Elmt
(AI_Tag_Elmt
)),
3957 Build_Thunks
=> False,
3959 Next_Elmt
(AI_Tag_Elmt
);
3961 -- Skip the secondary dispatch table of predefined primitives
3963 Next_Elmt
(AI_Tag_Elmt
);
3965 Suffix_Index
:= Suffix_Index
+ 1;
3966 Next_Elmt
(AI_Tag_Comp
);
3970 -- Get the _tag entity and the number of primitives of its dispatch
3973 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
3974 Nb_Prim
:= UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Typ
)));
3976 Set_Is_Statically_Allocated
(DT
, Is_Library_Level_Tagged_Type
(Typ
));
3977 Set_Is_Statically_Allocated
(SSD
, Is_Library_Level_Tagged_Type
(Typ
));
3978 Set_Is_Statically_Allocated
(TSD
, Is_Library_Level_Tagged_Type
(Typ
));
3979 Set_Is_Statically_Allocated
(Predef_Prims
,
3980 Is_Library_Level_Tagged_Type
(Typ
));
3982 -- In case of locally defined tagged type we declare the object
3983 -- containing the dispatch table by means of a variable. Its
3984 -- initialization is done later by means of an assignment. This is
3985 -- required to generate its External_Tag.
3987 if not Building_Static_DT
(Typ
) then
3990 -- DT : No_Dispatch_Table_Wrapper;
3991 -- for DT'Alignment use Address'Alignment;
3992 -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
3994 if not Has_DT
(Typ
) then
3996 Make_Object_Declaration
(Loc
,
3997 Defining_Identifier
=> DT
,
3998 Aliased_Present
=> True,
3999 Constant_Present
=> False,
4000 Object_Definition
=>
4002 (RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
)));
4005 Make_Attribute_Definition_Clause
(Loc
,
4006 Name
=> New_Reference_To
(DT
, Loc
),
4007 Chars
=> Name_Alignment
,
4009 Make_Attribute_Reference
(Loc
,
4011 New_Reference_To
(RTE
(RE_Integer_Address
), Loc
),
4012 Attribute_Name
=> Name_Alignment
)));
4015 Make_Object_Declaration
(Loc
,
4016 Defining_Identifier
=> DT_Ptr
,
4017 Object_Definition
=> New_Reference_To
(RTE
(RE_Tag
), Loc
),
4018 Constant_Present
=> True,
4020 Unchecked_Convert_To
(RTE
(RE_Tag
),
4021 Make_Attribute_Reference
(Loc
,
4023 Make_Selected_Component
(Loc
,
4024 Prefix
=> New_Reference_To
(DT
, Loc
),
4027 (RTE_Record_Component
(RE_NDT_Prims_Ptr
), Loc
)),
4028 Attribute_Name
=> Name_Address
))));
4031 -- DT : Dispatch_Table_Wrapper (Nb_Prim);
4032 -- for DT'Alignment use Address'Alignment;
4033 -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
4036 -- If the tagged type has no primitives we add a dummy slot
4037 -- whose address will be the tag of this type.
4041 New_List
(Make_Integer_Literal
(Loc
, 1));
4044 New_List
(Make_Integer_Literal
(Loc
, Nb_Prim
));
4048 Make_Object_Declaration
(Loc
,
4049 Defining_Identifier
=> DT
,
4050 Aliased_Present
=> True,
4051 Constant_Present
=> False,
4052 Object_Definition
=>
4053 Make_Subtype_Indication
(Loc
,
4055 New_Reference_To
(RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
4056 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
4057 Constraints
=> DT_Constr_List
))));
4060 Make_Attribute_Definition_Clause
(Loc
,
4061 Name
=> New_Reference_To
(DT
, Loc
),
4062 Chars
=> Name_Alignment
,
4064 Make_Attribute_Reference
(Loc
,
4066 New_Reference_To
(RTE
(RE_Integer_Address
), Loc
),
4067 Attribute_Name
=> Name_Alignment
)));
4070 Make_Object_Declaration
(Loc
,
4071 Defining_Identifier
=> DT_Ptr
,
4072 Object_Definition
=> New_Reference_To
(RTE
(RE_Tag
), Loc
),
4073 Constant_Present
=> True,
4075 Unchecked_Convert_To
(RTE
(RE_Tag
),
4076 Make_Attribute_Reference
(Loc
,
4078 Make_Selected_Component
(Loc
,
4079 Prefix
=> New_Reference_To
(DT
, Loc
),
4082 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
4083 Attribute_Name
=> Name_Address
))));
4086 Make_Object_Declaration
(Loc
,
4087 Defining_Identifier
=>
4088 Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
)))),
4089 Constant_Present
=> True,
4090 Object_Definition
=> New_Reference_To
4091 (RTE
(RE_Address
), Loc
),
4093 Make_Attribute_Reference
(Loc
,
4095 Make_Selected_Component
(Loc
,
4096 Prefix
=> New_Reference_To
(DT
, Loc
),
4099 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
4100 Attribute_Name
=> Name_Address
)));
4104 -- Generate: Exname : constant String := full_qualified_name (typ);
4105 -- The type itself may be an anonymous parent type, so use the first
4106 -- subtype to have a user-recognizable name.
4109 Make_Object_Declaration
(Loc
,
4110 Defining_Identifier
=> Exname
,
4111 Constant_Present
=> True,
4112 Object_Definition
=> New_Reference_To
(Standard_String
, Loc
),
4114 Make_String_Literal
(Loc
,
4115 Full_Qualified_Name
(First_Subtype
(Typ
)))));
4117 Set_Is_Statically_Allocated
(Exname
);
4118 Set_Is_True_Constant
(Exname
);
4120 -- Declare the object used by Ada.Tags.Register_Tag
4122 if RTE_Available
(RE_Register_Tag
) then
4124 Make_Object_Declaration
(Loc
,
4125 Defining_Identifier
=> HT_Link
,
4126 Object_Definition
=> New_Reference_To
(RTE
(RE_Tag
), Loc
)));
4129 -- Generate code to create the storage for the type specific data object
4130 -- with enough space to store the tags of the ancestors plus the tags
4131 -- of all the implemented interfaces (as described in a-tags.adb).
4133 -- TSD : Type_Specific_Data (I_Depth) :=
4134 -- (Idepth => I_Depth,
4135 -- Access_Level => Type_Access_Level (Typ),
4136 -- Expanded_Name => Cstring_Ptr!(Exname'Address))
4137 -- External_Tag => Cstring_Ptr!(Exname'Address))
4138 -- HT_Link => HT_Link'Address,
4139 -- Transportable => <<boolean-value>>,
4140 -- RC_Offset => <<integer-value>>,
4141 -- [ Size_Func => Size_Prim'Access ]
4142 -- [ Interfaces_Table => <<access-value>> ]
4143 -- [ SSD => SSD_Table'Address ]
4144 -- Tags_Table => (0 => null,
4147 -- for TSD'Alignment use Address'Alignment
4149 TSD_Aggr_List
:= New_List
;
4151 -- Idepth: Count ancestors to compute the inheritance depth. For private
4152 -- extensions, always go to the full view in order to compute the real
4153 -- inheritance depth.
4156 Current_Typ
: Entity_Id
;
4157 Parent_Typ
: Entity_Id
;
4163 Parent_Typ
:= Etype
(Current_Typ
);
4165 if Is_Private_Type
(Parent_Typ
) then
4166 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
4169 exit when Parent_Typ
= Current_Typ
;
4171 I_Depth
:= I_Depth
+ 1;
4172 Current_Typ
:= Parent_Typ
;
4176 Append_To
(TSD_Aggr_List
,
4177 Make_Integer_Literal
(Loc
, I_Depth
));
4181 Append_To
(TSD_Aggr_List
,
4182 Make_Integer_Literal
(Loc
, Type_Access_Level
(Typ
)));
4186 Append_To
(TSD_Aggr_List
,
4187 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
4188 Make_Attribute_Reference
(Loc
,
4189 Prefix
=> New_Reference_To
(Exname
, Loc
),
4190 Attribute_Name
=> Name_Address
)));
4192 -- External_Tag of a local tagged type
4194 -- <typ>A : constant String :=
4195 -- "Internal tag at 16#tag-addr#: <full-name-of-typ>";
4197 -- The reason we generate this strange name is that we do not want to
4198 -- enter local tagged types in the global hash table used to compute
4199 -- the Internal_Tag attribute for two reasons:
4201 -- 1. It is hard to avoid a tasking race condition for entering the
4202 -- entry into the hash table.
4204 -- 2. It would cause a storage leak, unless we rig up considerable
4205 -- mechanism to remove the entry from the hash table on exit.
4207 -- So what we do is to generate the above external tag name, where the
4208 -- hex address is the address of the local dispatch table (i.e. exactly
4209 -- the value we want if Internal_Tag is computed from this string).
4211 -- Of course this value will only be valid if the tagged type is still
4212 -- in scope, but it clearly must be erroneous to compute the internal
4213 -- tag of a tagged type that is out of scope!
4215 -- We don't do this processing if an explicit external tag has been
4216 -- specified. That's an odd case for which we have already issued a
4217 -- warning, where we will not be able to compute the internal tag.
4219 if not Is_Library_Level_Entity
(Typ
)
4220 and then not Has_External_Tag_Rep_Clause
(Typ
)
4223 Exname
: constant Entity_Id
:=
4224 Make_Defining_Identifier
(Loc
,
4225 New_External_Name
(Tname
, 'A'));
4227 Full_Name
: constant String_Id
:=
4228 Full_Qualified_Name
(First_Subtype
(Typ
));
4229 Str1_Id
: String_Id
;
4230 Str2_Id
: String_Id
;
4234 -- Str1 = "Internal tag at 16#";
4237 Store_String_Chars
("Internal tag at 16#");
4238 Str1_Id
:= End_String
;
4241 -- Str2 = "#: <type-full-name>";
4244 Store_String_Chars
("#: ");
4245 Store_String_Chars
(Full_Name
);
4246 Str2_Id
:= End_String
;
4249 -- Exname : constant String :=
4250 -- Str1 & Address_Image (Tag) & Str2;
4252 if RTE_Available
(RE_Address_Image
) then
4254 Make_Object_Declaration
(Loc
,
4255 Defining_Identifier
=> Exname
,
4256 Constant_Present
=> True,
4257 Object_Definition
=> New_Reference_To
4258 (Standard_String
, Loc
),
4260 Make_Op_Concat
(Loc
,
4262 Make_String_Literal
(Loc
, Str1_Id
),
4264 Make_Op_Concat
(Loc
,
4266 Make_Function_Call
(Loc
,
4269 (RTE
(RE_Address_Image
), Loc
),
4270 Parameter_Associations
=> New_List
(
4271 Unchecked_Convert_To
(RTE
(RE_Address
),
4272 New_Reference_To
(DT_Ptr
, Loc
)))),
4274 Make_String_Literal
(Loc
, Str2_Id
)))));
4278 Make_Object_Declaration
(Loc
,
4279 Defining_Identifier
=> Exname
,
4280 Constant_Present
=> True,
4281 Object_Definition
=> New_Reference_To
4282 (Standard_String
, Loc
),
4284 Make_Op_Concat
(Loc
,
4286 Make_String_Literal
(Loc
, Str1_Id
),
4288 Make_String_Literal
(Loc
, Str2_Id
))));
4292 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
4293 Make_Attribute_Reference
(Loc
,
4294 Prefix
=> New_Reference_To
(Exname
, Loc
),
4295 Attribute_Name
=> Name_Address
));
4298 -- External tag of a library-level tagged type: Check for a definition
4299 -- of External_Tag. The clause is considered only if it applies to this
4300 -- specific tagged type, as opposed to one of its ancestors.
4301 -- If the type is an unconstrained type extension, we are building the
4302 -- dispatch table of its anonymous base type, so the external tag, if
4303 -- any was specified, must be retrieved from the first subtype.
4307 Def
: constant Node_Id
:= Get_Attribute_Definition_Clause
4308 (First_Subtype
(Typ
),
4309 Attribute_External_Tag
);
4311 Old_Val
: String_Id
;
4312 New_Val
: String_Id
;
4316 if not Present
(Def
)
4317 or else Entity
(Name
(Def
)) /= First_Subtype
(Typ
)
4320 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
4321 Make_Attribute_Reference
(Loc
,
4322 Prefix
=> New_Reference_To
(Exname
, Loc
),
4323 Attribute_Name
=> Name_Address
));
4325 Old_Val
:= Strval
(Expr_Value_S
(Expression
(Def
)));
4327 -- For the rep clause "for <typ>'external_tag use y" generate:
4329 -- <typ>A : constant string := y;
4331 -- <typ>A'Address is used to set the External_Tag component
4334 -- Create a new nul terminated string if it is not already
4336 if String_Length
(Old_Val
) > 0
4338 Get_String_Char
(Old_Val
, String_Length
(Old_Val
)) = 0
4342 Start_String
(Old_Val
);
4343 Store_String_Char
(Get_Char_Code
(ASCII
.NUL
));
4344 New_Val
:= End_String
;
4347 E
:= Make_Defining_Identifier
(Loc
,
4348 New_External_Name
(Chars
(Typ
), 'A'));
4351 Make_Object_Declaration
(Loc
,
4352 Defining_Identifier
=> E
,
4353 Constant_Present
=> True,
4354 Object_Definition
=>
4355 New_Reference_To
(Standard_String
, Loc
),
4357 Make_String_Literal
(Loc
, New_Val
)));
4360 Unchecked_Convert_To
(RTE
(RE_Cstring_Ptr
),
4361 Make_Attribute_Reference
(Loc
,
4362 Prefix
=> New_Reference_To
(E
, Loc
),
4363 Attribute_Name
=> Name_Address
));
4368 Append_To
(TSD_Aggr_List
, New_Node
);
4372 if RTE_Available
(RE_Register_Tag
) then
4373 Append_To
(TSD_Aggr_List
,
4374 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
4375 Make_Attribute_Reference
(Loc
,
4376 Prefix
=> New_Reference_To
(HT_Link
, Loc
),
4377 Attribute_Name
=> Name_Address
)));
4379 Append_To
(TSD_Aggr_List
,
4380 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
4381 New_Reference_To
(RTE
(RE_Null_Address
), Loc
)));
4384 -- Transportable: Set for types that can be used in remote calls
4385 -- with respect to E.4(18) legality rules.
4388 Transportable
: Entity_Id
;
4394 or else Is_Shared_Passive
(Typ
)
4396 ((Is_Remote_Types
(Typ
)
4397 or else Is_Remote_Call_Interface
(Typ
))
4398 and then Original_View_In_Visible_Part
(Typ
))
4399 or else not Comes_From_Source
(Typ
));
4401 Append_To
(TSD_Aggr_List
,
4402 New_Occurrence_Of
(Transportable
, Loc
));
4405 -- RC_Offset: These are the valid values and their meaning:
4407 -- >0: For simple types with controlled components is
4408 -- type._record_controller'position
4410 -- 0: For types with no controlled components
4412 -- -1: For complex types with controlled components where the position
4413 -- of the record controller is not statically computable but there
4414 -- are controlled components at this level. The _Controller field
4415 -- is available right after the _parent.
4417 -- -2: There are no controlled components at this level. We need to
4418 -- get the position from the parent.
4421 RC_Offset_Node
: Node_Id
;
4424 if not Has_Controlled_Component
(Typ
) then
4425 RC_Offset_Node
:= Make_Integer_Literal
(Loc
, 0);
4427 elsif Etype
(Typ
) /= Typ
4428 and then Has_Discriminants
(Parent_Typ
)
4430 if Has_New_Controlled_Component
(Typ
) then
4431 RC_Offset_Node
:= Make_Integer_Literal
(Loc
, -1);
4433 RC_Offset_Node
:= Make_Integer_Literal
(Loc
, -2);
4437 Make_Attribute_Reference
(Loc
,
4439 Make_Selected_Component
(Loc
,
4440 Prefix
=> New_Reference_To
(Typ
, Loc
),
4442 New_Reference_To
(Controller_Component
(Typ
), Loc
)),
4443 Attribute_Name
=> Name_Position
);
4445 -- This is not proper Ada code to use the attribute 'Position
4446 -- on something else than an object but this is supported by
4447 -- the back end (see comment on the Bit_Component attribute in
4448 -- sem_attr). So we avoid semantic checking here.
4450 -- Is this documented in sinfo.ads??? it should be!
4452 Set_Analyzed
(RC_Offset_Node
);
4453 Set_Etype
(Prefix
(RC_Offset_Node
), RTE
(RE_Record_Controller
));
4454 Set_Etype
(Prefix
(Prefix
(RC_Offset_Node
)), Typ
);
4455 Set_Etype
(Selector_Name
(Prefix
(RC_Offset_Node
)),
4456 RTE
(RE_Record_Controller
));
4457 Set_Etype
(RC_Offset_Node
, RTE
(RE_Storage_Offset
));
4460 Append_To
(TSD_Aggr_List
, RC_Offset_Node
);
4465 if RTE_Record_Component_Available
(RE_Size_Func
) then
4466 if not Building_Static_DT
(Typ
)
4467 or else Is_Interface
(Typ
)
4469 Append_To
(TSD_Aggr_List
,
4470 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
4471 New_Reference_To
(RTE
(RE_Null_Address
), Loc
)));
4475 Prim_Elmt
: Elmt_Id
;
4479 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4480 while Present
(Prim_Elmt
) loop
4481 Prim
:= Node
(Prim_Elmt
);
4483 if Chars
(Prim
) = Name_uSize
then
4484 while Present
(Alias
(Prim
)) loop
4485 Prim
:= Alias
(Prim
);
4488 if Is_Abstract_Subprogram
(Prim
) then
4489 Append_To
(TSD_Aggr_List
,
4490 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
4491 New_Reference_To
(RTE
(RE_Null_Address
), Loc
)));
4493 Append_To
(TSD_Aggr_List
,
4494 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
4495 Make_Attribute_Reference
(Loc
,
4496 Prefix
=> New_Reference_To
(Prim
, Loc
),
4497 Attribute_Name
=> Name_Unrestricted_Access
)));
4503 Next_Elmt
(Prim_Elmt
);
4509 -- Interfaces_Table (required for AI-405)
4511 if RTE_Record_Component_Available
(RE_Interfaces_Table
) then
4513 -- Count the number of interface types implemented by Typ
4515 Collect_Interfaces
(Typ
, Typ_Ifaces
);
4517 AI
:= First_Elmt
(Typ_Ifaces
);
4518 while Present
(AI
) loop
4519 Num_Ifaces
:= Num_Ifaces
+ 1;
4523 if Num_Ifaces
= 0 then
4524 Iface_Table_Node
:= Make_Null
(Loc
);
4526 -- Generate the Interface_Table object
4530 TSD_Ifaces_List
: constant List_Id
:= New_List
;
4532 Sec_DT_Tag
: Node_Id
;
4535 AI
:= First_Elmt
(Typ_Ifaces
);
4536 while Present
(AI
) loop
4537 if Is_Ancestor
(Node
(AI
), Typ
) then
4539 New_Reference_To
(DT_Ptr
, Loc
);
4543 (Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
4544 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
4546 while Ekind
(Node
(Elmt
)) = E_Constant
4548 Is_Ancestor
(Node
(AI
), Related_Type
(Node
(Elmt
)))
4550 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
4552 pragma Assert
(Has_Thunks
(Node
(Elmt
)));
4554 pragma Assert
(not Has_Thunks
(Node
(Elmt
)));
4556 pragma Assert
(not Has_Thunks
(Node
(Elmt
)));
4560 pragma Assert
(Ekind
(Node
(Elmt
)) = E_Constant
4562 Has_Thunks
(Node
(Next_Elmt
(Next_Elmt
(Elmt
)))));
4564 New_Reference_To
(Node
(Next_Elmt
(Next_Elmt
(Elmt
))),
4568 Append_To
(TSD_Ifaces_List
,
4569 Make_Aggregate
(Loc
,
4570 Expressions
=> New_List
(
4574 Unchecked_Convert_To
(RTE
(RE_Tag
),
4576 (Node
(First_Elmt
(Access_Disp_Table
(Node
(AI
)))),
4579 -- Static_Offset_To_Top
4581 New_Reference_To
(Standard_True
, Loc
),
4583 -- Offset_To_Top_Value
4585 Make_Integer_Literal
(Loc
, 0),
4587 -- Offset_To_Top_Func
4593 Unchecked_Convert_To
(RTE
(RE_Tag
), Sec_DT_Tag
)
4600 Name_ITable
:= New_External_Name
(Tname
, 'I');
4601 ITable
:= Make_Defining_Identifier
(Loc
, Name_ITable
);
4602 Set_Is_Statically_Allocated
(ITable
,
4603 Is_Library_Level_Tagged_Type
(Typ
));
4605 -- The table of interfaces is not constant; its slots are
4606 -- filled at run-time by the IP routine using attribute
4607 -- 'Position to know the location of the tag components
4608 -- (and this attribute cannot be safely used before the
4609 -- object is initialized).
4612 Make_Object_Declaration
(Loc
,
4613 Defining_Identifier
=> ITable
,
4614 Aliased_Present
=> True,
4615 Constant_Present
=> False,
4616 Object_Definition
=>
4617 Make_Subtype_Indication
(Loc
,
4619 New_Reference_To
(RTE
(RE_Interface_Data
), Loc
),
4620 Constraint
=> Make_Index_Or_Discriminant_Constraint
4622 Constraints
=> New_List
(
4623 Make_Integer_Literal
(Loc
, Num_Ifaces
)))),
4625 Expression
=> Make_Aggregate
(Loc
,
4626 Expressions
=> New_List
(
4627 Make_Integer_Literal
(Loc
, Num_Ifaces
),
4628 Make_Aggregate
(Loc
,
4629 Expressions
=> TSD_Ifaces_List
)))));
4632 Make_Attribute_Definition_Clause
(Loc
,
4633 Name
=> New_Reference_To
(ITable
, Loc
),
4634 Chars
=> Name_Alignment
,
4636 Make_Attribute_Reference
(Loc
,
4638 New_Reference_To
(RTE
(RE_Integer_Address
), Loc
),
4639 Attribute_Name
=> Name_Alignment
)));
4642 Make_Attribute_Reference
(Loc
,
4643 Prefix
=> New_Reference_To
(ITable
, Loc
),
4644 Attribute_Name
=> Name_Unchecked_Access
);
4648 Append_To
(TSD_Aggr_List
, Iface_Table_Node
);
4651 -- Generate the Select Specific Data table for synchronized types that
4652 -- implement synchronized interfaces. The size of the table is
4653 -- constrained by the number of non-predefined primitive operations.
4655 if RTE_Record_Component_Available
(RE_SSD
) then
4656 if Ada_Version
>= Ada_05
4657 and then Has_DT
(Typ
)
4658 and then Is_Concurrent_Record_Type
(Typ
)
4659 and then Has_Interfaces
(Typ
)
4660 and then Nb_Prim
> 0
4661 and then not Is_Abstract_Type
(Typ
)
4662 and then not Is_Controlled
(Typ
)
4663 and then not Restriction_Active
(No_Dispatching_Calls
)
4666 Make_Object_Declaration
(Loc
,
4667 Defining_Identifier
=> SSD
,
4668 Aliased_Present
=> True,
4669 Object_Definition
=>
4670 Make_Subtype_Indication
(Loc
,
4671 Subtype_Mark
=> New_Reference_To
(
4672 RTE
(RE_Select_Specific_Data
), Loc
),
4674 Make_Index_Or_Discriminant_Constraint
(Loc
,
4675 Constraints
=> New_List
(
4676 Make_Integer_Literal
(Loc
, Nb_Prim
))))));
4679 Make_Attribute_Definition_Clause
(Loc
,
4680 Name
=> New_Reference_To
(SSD
, Loc
),
4681 Chars
=> Name_Alignment
,
4683 Make_Attribute_Reference
(Loc
,
4685 New_Reference_To
(RTE
(RE_Integer_Address
), Loc
),
4686 Attribute_Name
=> Name_Alignment
)));
4688 -- This table is initialized by Make_Select_Specific_Data_Table,
4689 -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
4691 Append_To
(TSD_Aggr_List
,
4692 Make_Attribute_Reference
(Loc
,
4693 Prefix
=> New_Reference_To
(SSD
, Loc
),
4694 Attribute_Name
=> Name_Unchecked_Access
));
4696 Append_To
(TSD_Aggr_List
, Make_Null
(Loc
));
4700 -- Initialize the table of ancestor tags. In case of interface types
4701 -- this table is not needed.
4703 TSD_Tags_List
:= New_List
;
4705 -- If we are not statically allocating the dispatch table then we must
4706 -- fill position 0 with null because we still have not generated the
4709 if not Building_Static_DT
(Typ
)
4710 or else Is_Interface
(Typ
)
4712 Append_To
(TSD_Tags_List
,
4713 Unchecked_Convert_To
(RTE
(RE_Tag
),
4714 New_Reference_To
(RTE
(RE_Null_Address
), Loc
)));
4716 -- Otherwise we can safely reference the tag
4719 Append_To
(TSD_Tags_List
,
4720 New_Reference_To
(DT_Ptr
, Loc
));
4723 -- Fill the rest of the table with the tags of the ancestors
4726 Current_Typ
: Entity_Id
;
4727 Parent_Typ
: Entity_Id
;
4735 Parent_Typ
:= Etype
(Current_Typ
);
4737 if Is_Private_Type
(Parent_Typ
) then
4738 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
4741 exit when Parent_Typ
= Current_Typ
;
4743 if Is_CPP_Class
(Parent_Typ
)
4744 or else Is_Interface
(Typ
)
4746 -- The tags defined in the C++ side will be inherited when
4747 -- the object is constructed (Exp_Ch3.Build_Init_Procedure)
4749 Append_To
(TSD_Tags_List
,
4750 Unchecked_Convert_To
(RTE
(RE_Tag
),
4751 New_Reference_To
(RTE
(RE_Null_Address
), Loc
)));
4753 Append_To
(TSD_Tags_List
,
4755 (Node
(First_Elmt
(Access_Disp_Table
(Parent_Typ
))),
4760 Current_Typ
:= Parent_Typ
;
4763 pragma Assert
(Pos
= I_Depth
+ 1);
4766 Append_To
(TSD_Aggr_List
,
4767 Make_Aggregate
(Loc
,
4768 Expressions
=> TSD_Tags_List
));
4770 -- Build the TSD object
4773 Make_Object_Declaration
(Loc
,
4774 Defining_Identifier
=> TSD
,
4775 Aliased_Present
=> True,
4776 Constant_Present
=> Building_Static_DT
(Typ
),
4777 Object_Definition
=>
4778 Make_Subtype_Indication
(Loc
,
4779 Subtype_Mark
=> New_Reference_To
(
4780 RTE
(RE_Type_Specific_Data
), Loc
),
4782 Make_Index_Or_Discriminant_Constraint
(Loc
,
4783 Constraints
=> New_List
(
4784 Make_Integer_Literal
(Loc
, I_Depth
)))),
4786 Expression
=> Make_Aggregate
(Loc
,
4787 Expressions
=> TSD_Aggr_List
)));
4789 Set_Is_True_Constant
(TSD
, Building_Static_DT
(Typ
));
4792 Make_Attribute_Definition_Clause
(Loc
,
4793 Name
=> New_Reference_To
(TSD
, Loc
),
4794 Chars
=> Name_Alignment
,
4796 Make_Attribute_Reference
(Loc
,
4797 Prefix
=> New_Reference_To
(RTE
(RE_Integer_Address
), Loc
),
4798 Attribute_Name
=> Name_Alignment
)));
4800 -- Initialize or declare the dispatch table object
4802 if not Has_DT
(Typ
) then
4803 DT_Constr_List
:= New_List
;
4804 DT_Aggr_List
:= New_List
;
4809 Make_Attribute_Reference
(Loc
,
4810 Prefix
=> New_Reference_To
(TSD
, Loc
),
4811 Attribute_Name
=> Name_Address
);
4813 Append_To
(DT_Constr_List
, New_Node
);
4814 Append_To
(DT_Aggr_List
, New_Copy
(New_Node
));
4815 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
4817 -- In case of locally defined tagged types we have already declared
4818 -- and uninitialized object for the dispatch table, which is now
4819 -- initialized by means of the following assignment:
4821 -- DT := (TSD'Address, 0);
4823 if not Building_Static_DT
(Typ
) then
4825 Make_Assignment_Statement
(Loc
,
4826 Name
=> New_Reference_To
(DT
, Loc
),
4827 Expression
=> Make_Aggregate
(Loc
,
4828 Expressions
=> DT_Aggr_List
)));
4830 -- In case of library level tagged types we declare and export now
4831 -- the constant object containing the dummy dispatch table. There
4832 -- is no need to declare the tag here because it has been previously
4833 -- declared by Make_Tags
4835 -- DT : aliased constant No_Dispatch_Table :=
4836 -- (NDT_TSD => TSD'Address;
4837 -- NDT_Prims_Ptr => 0);
4838 -- for DT'Alignment use Address'Alignment;
4842 Make_Object_Declaration
(Loc
,
4843 Defining_Identifier
=> DT
,
4844 Aliased_Present
=> True,
4845 Constant_Present
=> True,
4846 Object_Definition
=>
4847 New_Reference_To
(RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
),
4848 Expression
=> Make_Aggregate
(Loc
,
4849 Expressions
=> DT_Aggr_List
)));
4852 Make_Attribute_Definition_Clause
(Loc
,
4853 Name
=> New_Reference_To
(DT
, Loc
),
4854 Chars
=> Name_Alignment
,
4856 Make_Attribute_Reference
(Loc
,
4858 New_Reference_To
(RTE
(RE_Integer_Address
), Loc
),
4859 Attribute_Name
=> Name_Alignment
)));
4861 Export_DT
(Typ
, DT
);
4864 -- Common case: Typ has a dispatch table
4868 -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
4869 -- (predef-prim-op-1'address,
4870 -- predef-prim-op-2'address,
4872 -- predef-prim-op-n'address);
4873 -- for Predef_Prims'Alignment use Address'Alignment
4875 -- DT : Dispatch_Table (Nb_Prims) :=
4876 -- (Signature => <sig-value>,
4877 -- Tag_Kind => <tag_kind-value>,
4878 -- Predef_Prims => Predef_Prims'First'Address,
4879 -- Offset_To_Top => 0,
4880 -- TSD => TSD'Address;
4881 -- Prims_Ptr => (prim-op-1'address,
4882 -- prim-op-2'address,
4884 -- prim-op-n'address));
4885 -- for DT'Alignment use Address'Alignment
4892 if not Building_Static_DT
(Typ
) then
4893 Nb_Predef_Prims
:= Max_Predef_Prims
;
4896 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4897 while Present
(Prim_Elmt
) loop
4898 Prim
:= Node
(Prim_Elmt
);
4900 if Is_Predefined_Dispatching_Operation
(Prim
)
4901 and then not Is_Abstract_Subprogram
(Prim
)
4903 Pos
:= UI_To_Int
(DT_Position
(Prim
));
4905 if Pos
> Nb_Predef_Prims
then
4906 Nb_Predef_Prims
:= Pos
;
4910 Next_Elmt
(Prim_Elmt
);
4916 (Nat
range 1 .. Nb_Predef_Prims
) of Entity_Id
;
4921 Prim_Ops_Aggr_List
:= New_List
;
4923 Prim_Table
:= (others => Empty
);
4925 if Building_Static_DT
(Typ
) then
4926 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4927 while Present
(Prim_Elmt
) loop
4928 Prim
:= Node
(Prim_Elmt
);
4930 if Is_Predefined_Dispatching_Operation
(Prim
)
4931 and then not Is_Abstract_Subprogram
(Prim
)
4932 and then not Present
(Prim_Table
4933 (UI_To_Int
(DT_Position
(Prim
))))
4936 while Present
(Alias
(E
)) loop
4940 pragma Assert
(not Is_Abstract_Subprogram
(E
));
4941 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) := E
;
4944 Next_Elmt
(Prim_Elmt
);
4948 for J
in Prim_Table
'Range loop
4949 if Present
(Prim_Table
(J
)) then
4951 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
4952 Make_Attribute_Reference
(Loc
,
4953 Prefix
=> New_Reference_To
(Prim_Table
(J
), Loc
),
4954 Attribute_Name
=> Name_Unrestricted_Access
));
4956 New_Node
:= Make_Null
(Loc
);
4959 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
4963 Make_Aggregate
(Loc
,
4964 Expressions
=> Prim_Ops_Aggr_List
);
4967 Make_Subtype_Declaration
(Loc
,
4968 Defining_Identifier
=>
4969 Make_Defining_Identifier
(Loc
,
4970 New_Internal_Name
('S')),
4971 Subtype_Indication
=>
4972 New_Reference_To
(RTE
(RE_Address_Array
), Loc
));
4974 Append_To
(Result
, Decl
);
4977 Make_Object_Declaration
(Loc
,
4978 Defining_Identifier
=> Predef_Prims
,
4979 Aliased_Present
=> True,
4980 Constant_Present
=> Building_Static_DT
(Typ
),
4981 Object_Definition
=> New_Reference_To
4982 (Defining_Identifier
(Decl
), Loc
),
4983 Expression
=> New_Node
));
4985 -- Remember aggregates initializing dispatch tables
4987 Append_Elmt
(New_Node
, DT_Aggr
);
4990 Make_Attribute_Definition_Clause
(Loc
,
4991 Name
=> New_Reference_To
(Predef_Prims
, Loc
),
4992 Chars
=> Name_Alignment
,
4994 Make_Attribute_Reference
(Loc
,
4996 New_Reference_To
(RTE
(RE_Integer_Address
), Loc
),
4997 Attribute_Name
=> Name_Alignment
)));
5001 -- Stage 1: Initialize the discriminant and the record components
5003 DT_Constr_List
:= New_List
;
5004 DT_Aggr_List
:= New_List
;
5006 -- Num_Prims. If the tagged type has no primitives we add a dummy
5007 -- slot whose address will be the tag of this type.
5010 New_Node
:= Make_Integer_Literal
(Loc
, 1);
5012 New_Node
:= Make_Integer_Literal
(Loc
, Nb_Prim
);
5015 Append_To
(DT_Constr_List
, New_Node
);
5016 Append_To
(DT_Aggr_List
, New_Copy
(New_Node
));
5020 if RTE_Record_Component_Available
(RE_Signature
) then
5021 Append_To
(DT_Aggr_List
,
5022 New_Reference_To
(RTE
(RE_Primary_DT
), Loc
));
5027 if RTE_Record_Component_Available
(RE_Tag_Kind
) then
5028 Append_To
(DT_Aggr_List
, Tagged_Kind
(Typ
));
5033 Append_To
(DT_Aggr_List
,
5034 Make_Attribute_Reference
(Loc
,
5035 Prefix
=> New_Reference_To
(Predef_Prims
, Loc
),
5036 Attribute_Name
=> Name_Address
));
5040 Append_To
(DT_Aggr_List
, Make_Integer_Literal
(Loc
, 0));
5044 Append_To
(DT_Aggr_List
,
5045 Make_Attribute_Reference
(Loc
,
5046 Prefix
=> New_Reference_To
(TSD
, Loc
),
5047 Attribute_Name
=> Name_Address
));
5049 -- Stage 2: Initialize the table of primitive operations
5051 Prim_Ops_Aggr_List
:= New_List
;
5054 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
5056 elsif not Building_Static_DT
(Typ
) then
5057 for J
in 1 .. Nb_Prim
loop
5058 Append_To
(Prim_Ops_Aggr_List
, Make_Null
(Loc
));
5063 Prim_Table
: array (Nat
range 1 .. Nb_Prim
) of Entity_Id
;
5066 Prim_Elmt
: Elmt_Id
;
5069 Prim_Table
:= (others => Empty
);
5071 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5072 while Present
(Prim_Elmt
) loop
5073 Prim
:= Node
(Prim_Elmt
);
5075 if Is_Imported
(Prim
)
5076 or else Present
(Interface_Alias
(Prim
))
5077 or else Is_Predefined_Dispatching_Operation
(Prim
)
5082 -- Traverse the list of aliased entities to handle
5083 -- renamings of predefined primitives.
5086 while Present
(Alias
(E
)) loop
5090 if not Is_Predefined_Dispatching_Operation
(E
)
5091 and then not Is_Abstract_Subprogram
(E
)
5092 and then not Present
(Interface_Alias
(E
))
5095 (UI_To_Int
(DT_Position
(Prim
)) <= Nb_Prim
);
5097 Prim_Table
(UI_To_Int
(DT_Position
(Prim
))) := E
;
5101 Next_Elmt
(Prim_Elmt
);
5104 for J
in Prim_Table
'Range loop
5105 if Present
(Prim_Table
(J
)) then
5107 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
5108 Make_Attribute_Reference
(Loc
,
5109 Prefix
=> New_Reference_To
(Prim_Table
(J
), Loc
),
5110 Attribute_Name
=> Name_Unrestricted_Access
));
5112 New_Node
:= Make_Null
(Loc
);
5115 Append_To
(Prim_Ops_Aggr_List
, New_Node
);
5121 Make_Aggregate
(Loc
,
5122 Expressions
=> Prim_Ops_Aggr_List
);
5124 Append_To
(DT_Aggr_List
, New_Node
);
5126 -- Remember aggregates initializing dispatch tables
5128 Append_Elmt
(New_Node
, DT_Aggr
);
5130 -- In case of locally defined tagged types we have already declared
5131 -- and uninitialized object for the dispatch table, which is now
5132 -- initialized by means of an assignment.
5134 if not Building_Static_DT
(Typ
) then
5136 Make_Assignment_Statement
(Loc
,
5137 Name
=> New_Reference_To
(DT
, Loc
),
5138 Expression
=> Make_Aggregate
(Loc
,
5139 Expressions
=> DT_Aggr_List
)));
5141 -- In case of library level tagged types we declare now and export
5142 -- the constant object containing the dispatch table.
5146 Make_Object_Declaration
(Loc
,
5147 Defining_Identifier
=> DT
,
5148 Aliased_Present
=> True,
5149 Constant_Present
=> True,
5150 Object_Definition
=>
5151 Make_Subtype_Indication
(Loc
,
5152 Subtype_Mark
=> New_Reference_To
5153 (RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
5154 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
5155 Constraints
=> DT_Constr_List
)),
5156 Expression
=> Make_Aggregate
(Loc
,
5157 Expressions
=> DT_Aggr_List
)));
5160 Make_Attribute_Definition_Clause
(Loc
,
5161 Name
=> New_Reference_To
(DT
, Loc
),
5162 Chars
=> Name_Alignment
,
5164 Make_Attribute_Reference
(Loc
,
5166 New_Reference_To
(RTE
(RE_Integer_Address
), Loc
),
5167 Attribute_Name
=> Name_Alignment
)));
5169 Export_DT
(Typ
, DT
);
5173 -- Initialize the table of ancestor tags
5175 if not Building_Static_DT
(Typ
)
5176 and then not Is_Interface
(Typ
)
5177 and then not Is_CPP_Class
(Typ
)
5180 Make_Assignment_Statement
(Loc
,
5182 Make_Indexed_Component
(Loc
,
5184 Make_Selected_Component
(Loc
,
5186 New_Reference_To
(TSD
, Loc
),
5189 (RTE_Record_Component
(RE_Tags_Table
), Loc
)),
5191 New_List
(Make_Integer_Literal
(Loc
, 0))),
5195 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
)));
5198 -- Inherit the dispatch tables of the parent
5200 -- There is no need to inherit anything from the parent when building
5201 -- static dispatch tables because the whole dispatch table (including
5202 -- inherited primitives) has been already built.
5204 if Building_Static_DT
(Typ
) then
5207 -- If the ancestor is a CPP_Class type we inherit the dispatch tables
5208 -- in the init proc, and we don't need to fill them in here.
5210 elsif Is_CPP_Class
(Parent_Typ
) then
5213 -- Otherwise we fill in the dispatch tables here
5216 if Typ
/= Parent_Typ
5217 and then not Is_Interface
(Typ
)
5218 and then not Restriction_Active
(No_Dispatching_Calls
)
5220 -- Inherit the dispatch table
5222 if not Is_Interface
(Typ
)
5223 and then not Is_Interface
(Parent_Typ
)
5224 and then not Is_CPP_Class
(Parent_Typ
)
5227 Nb_Prims
: constant Int
:=
5228 UI_To_Int
(DT_Entry_Count
5229 (First_Tag_Component
(Parent_Typ
)));
5232 Append_To
(Elab_Code
,
5233 Build_Inherit_Predefined_Prims
(Loc
,
5239 (Access_Disp_Table
(Parent_Typ
)))), Loc
),
5245 (Access_Disp_Table
(Typ
)))), Loc
)));
5247 if Nb_Prims
/= 0 then
5248 Append_To
(Elab_Code
,
5249 Build_Inherit_Prims
(Loc
,
5255 (Access_Disp_Table
(Parent_Typ
))), Loc
),
5256 New_Tag_Node
=> New_Reference_To
(DT_Ptr
, Loc
),
5257 Num_Prims
=> Nb_Prims
));
5262 -- Inherit the secondary dispatch tables of the ancestor
5264 if not Is_CPP_Class
(Parent_Typ
) then
5266 Sec_DT_Ancestor
: Elmt_Id
:=
5270 (Access_Disp_Table
(Parent_Typ
))));
5271 Sec_DT_Typ
: Elmt_Id
:=
5275 (Access_Disp_Table
(Typ
))));
5277 procedure Copy_Secondary_DTs
(Typ
: Entity_Id
);
5278 -- Local procedure required to climb through the ancestors
5279 -- and copy the contents of all their secondary dispatch
5282 ------------------------
5283 -- Copy_Secondary_DTs --
5284 ------------------------
5286 procedure Copy_Secondary_DTs
(Typ
: Entity_Id
) is
5291 -- Climb to the ancestor (if any) handling private types
5293 if Present
(Full_View
(Etype
(Typ
))) then
5294 if Full_View
(Etype
(Typ
)) /= Typ
then
5295 Copy_Secondary_DTs
(Full_View
(Etype
(Typ
)));
5298 elsif Etype
(Typ
) /= Typ
then
5299 Copy_Secondary_DTs
(Etype
(Typ
));
5302 if Present
(Interfaces
(Typ
))
5303 and then not Is_Empty_Elmt_List
(Interfaces
(Typ
))
5305 Iface
:= First_Elmt
(Interfaces
(Typ
));
5306 E
:= First_Entity
(Typ
);
5308 and then Present
(Node
(Sec_DT_Ancestor
))
5309 and then Ekind
(Node
(Sec_DT_Ancestor
)) = E_Constant
5311 if Is_Tag
(E
) and then Chars
(E
) /= Name_uTag
then
5313 Num_Prims
: constant Int
:=
5314 UI_To_Int
(DT_Entry_Count
(E
));
5317 if not Is_Interface
(Etype
(Typ
)) then
5319 -- Inherit first secondary dispatch table
5321 Append_To
(Elab_Code
,
5322 Build_Inherit_Predefined_Prims
(Loc
,
5324 Unchecked_Convert_To
(RTE
(RE_Tag
),
5327 (Next_Elmt
(Sec_DT_Ancestor
)),
5330 Unchecked_Convert_To
(RTE
(RE_Tag
),
5332 (Node
(Next_Elmt
(Sec_DT_Typ
)),
5335 if Num_Prims
/= 0 then
5336 Append_To
(Elab_Code
,
5337 Build_Inherit_Prims
(Loc
,
5338 Typ
=> Node
(Iface
),
5340 Unchecked_Convert_To
5343 (Node
(Sec_DT_Ancestor
),
5346 Unchecked_Convert_To
5349 (Node
(Sec_DT_Typ
), Loc
)),
5350 Num_Prims
=> Num_Prims
));
5354 Next_Elmt
(Sec_DT_Ancestor
);
5355 Next_Elmt
(Sec_DT_Typ
);
5357 -- Skip the secondary dispatch table of
5358 -- predefined primitives
5360 Next_Elmt
(Sec_DT_Ancestor
);
5361 Next_Elmt
(Sec_DT_Typ
);
5363 if not Is_Interface
(Etype
(Typ
)) then
5365 -- Inherit second secondary dispatch table
5367 Append_To
(Elab_Code
,
5368 Build_Inherit_Predefined_Prims
(Loc
,
5370 Unchecked_Convert_To
(RTE
(RE_Tag
),
5373 (Next_Elmt
(Sec_DT_Ancestor
)),
5376 Unchecked_Convert_To
(RTE
(RE_Tag
),
5378 (Node
(Next_Elmt
(Sec_DT_Typ
)),
5381 if Num_Prims
/= 0 then
5382 Append_To
(Elab_Code
,
5383 Build_Inherit_Prims
(Loc
,
5384 Typ
=> Node
(Iface
),
5386 Unchecked_Convert_To
5389 (Node
(Sec_DT_Ancestor
),
5392 Unchecked_Convert_To
5395 (Node
(Sec_DT_Typ
), Loc
)),
5396 Num_Prims
=> Num_Prims
));
5401 Next_Elmt
(Sec_DT_Ancestor
);
5402 Next_Elmt
(Sec_DT_Typ
);
5404 -- Skip the secondary dispatch table of
5405 -- predefined primitives
5407 Next_Elmt
(Sec_DT_Ancestor
);
5408 Next_Elmt
(Sec_DT_Typ
);
5416 end Copy_Secondary_DTs
;
5419 if Present
(Node
(Sec_DT_Ancestor
))
5420 and then Ekind
(Node
(Sec_DT_Ancestor
)) = E_Constant
5422 -- Handle private types
5424 if Present
(Full_View
(Typ
)) then
5425 Copy_Secondary_DTs
(Full_View
(Typ
));
5427 Copy_Secondary_DTs
(Typ
);
5435 -- Generate code to register the Tag in the External_Tag hash table for
5436 -- the pure Ada type only.
5438 -- Register_Tag (Dt_Ptr);
5440 -- Skip this action in the following cases:
5441 -- 1) if Register_Tag is not available.
5442 -- 2) in No_Run_Time mode.
5443 -- 3) if Typ is not defined at the library level (this is required
5444 -- to avoid adding concurrency control to the hash table used
5445 -- by the run-time to register the tags).
5447 if not No_Run_Time_Mode
5448 and then Is_Library_Level_Entity
(Typ
)
5449 and then RTE_Available
(RE_Register_Tag
)
5451 Append_To
(Elab_Code
,
5452 Make_Procedure_Call_Statement
(Loc
,
5453 Name
=> New_Reference_To
(RTE
(RE_Register_Tag
), Loc
),
5454 Parameter_Associations
=>
5455 New_List
(New_Reference_To
(DT_Ptr
, Loc
))));
5458 if not Is_Empty_List
(Elab_Code
) then
5459 Append_List_To
(Result
, Elab_Code
);
5462 -- Populate the two auxiliary tables used for dispatching
5463 -- asynchronous, conditional and timed selects for synchronized
5464 -- types that implement a limited interface.
5466 if Ada_Version
>= Ada_05
5467 and then Is_Concurrent_Record_Type
(Typ
)
5468 and then Has_Interfaces
(Typ
)
5470 Append_List_To
(Result
,
5471 Make_Select_Specific_Data_Table
(Typ
));
5474 -- Remember entities containing dispatch tables
5476 Append_Elmt
(Predef_Prims
, DT_Decl
);
5477 Append_Elmt
(DT
, DT_Decl
);
5479 Analyze_List
(Result
, Suppress
=> All_Checks
);
5480 Set_Has_Dispatch_Table
(Typ
);
5482 -- Mark entities containing dispatch tables. Required by the
5483 -- backend to handle them properly.
5485 if not Is_Interface
(Typ
) then
5490 -- Ensure that entities Prim_Ptr and Predef_Prims_Table_Ptr have
5491 -- the decoration required by the backend
5493 Set_Is_Dispatch_Table_Entity
(RTE
(RE_Prim_Ptr
));
5494 Set_Is_Dispatch_Table_Entity
(RTE
(RE_Predef_Prims_Table_Ptr
));
5496 -- Object declarations
5498 Elmt
:= First_Elmt
(DT_Decl
);
5499 while Present
(Elmt
) loop
5500 Set_Is_Dispatch_Table_Entity
(Node
(Elmt
));
5501 pragma Assert
(Ekind
(Etype
(Node
(Elmt
))) = E_Array_Subtype
5502 or else Ekind
(Etype
(Node
(Elmt
))) = E_Record_Subtype
);
5503 Set_Is_Dispatch_Table_Entity
(Etype
(Node
(Elmt
)));
5507 -- Aggregates initializing dispatch tables
5509 Elmt
:= First_Elmt
(DT_Aggr
);
5510 while Present
(Elmt
) loop
5511 Set_Is_Dispatch_Table_Entity
(Etype
(Node
(Elmt
)));
5520 -------------------------------------
5521 -- Make_Select_Specific_Data_Table --
5522 -------------------------------------
5524 function Make_Select_Specific_Data_Table
5525 (Typ
: Entity_Id
) return List_Id
5527 Assignments
: constant List_Id
:= New_List
;
5528 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5530 Conc_Typ
: Entity_Id
;
5534 Prim_Als
: Entity_Id
;
5535 Prim_Elmt
: Elmt_Id
;
5539 type Examined_Array
is array (Int
range <>) of Boolean;
5541 function Find_Entry_Index
(E
: Entity_Id
) return Uint
;
5542 -- Given an entry, find its index in the visible declarations of the
5543 -- corresponding concurrent type of Typ.
5545 ----------------------
5546 -- Find_Entry_Index --
5547 ----------------------
5549 function Find_Entry_Index
(E
: Entity_Id
) return Uint
is
5550 Index
: Uint
:= Uint_1
;
5551 Subp_Decl
: Entity_Id
;
5555 and then not Is_Empty_List
(Decls
)
5557 Subp_Decl
:= First
(Decls
);
5558 while Present
(Subp_Decl
) loop
5559 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
5560 if Defining_Identifier
(Subp_Decl
) = E
then
5572 end Find_Entry_Index
;
5574 -- Start of processing for Make_Select_Specific_Data_Table
5577 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
5579 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
5581 if Present
(Corresponding_Concurrent_Type
(Typ
)) then
5582 Conc_Typ
:= Corresponding_Concurrent_Type
(Typ
);
5584 if Present
(Full_View
(Conc_Typ
)) then
5585 Conc_Typ
:= Full_View
(Conc_Typ
);
5588 if Ekind
(Conc_Typ
) = E_Protected_Type
then
5589 Decls
:= Visible_Declarations
(Protected_Definition
(
5590 Parent
(Conc_Typ
)));
5592 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
5593 Decls
:= Visible_Declarations
(Task_Definition
(
5594 Parent
(Conc_Typ
)));
5598 -- Count the non-predefined primitive operations
5600 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5601 while Present
(Prim_Elmt
) loop
5602 Prim
:= Node
(Prim_Elmt
);
5604 if not (Is_Predefined_Dispatching_Operation
(Prim
)
5605 or else Is_Predefined_Dispatching_Alias
(Prim
))
5607 Nb_Prim
:= Nb_Prim
+ 1;
5610 Next_Elmt
(Prim_Elmt
);
5614 Examined
: Examined_Array
(1 .. Nb_Prim
) := (others => False);
5617 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5618 while Present
(Prim_Elmt
) loop
5619 Prim
:= Node
(Prim_Elmt
);
5621 -- Look for primitive overriding an abstract interface subprogram
5623 if Present
(Interface_Alias
(Prim
))
5624 and then not Examined
(UI_To_Int
(DT_Position
(Alias
(Prim
))))
5626 Prim_Pos
:= DT_Position
(Alias
(Prim
));
5627 pragma Assert
(UI_To_Int
(Prim_Pos
) <= Nb_Prim
);
5628 Examined
(UI_To_Int
(Prim_Pos
)) := True;
5630 -- Set the primitive operation kind regardless of subprogram
5632 -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
5634 Append_To
(Assignments
,
5635 Make_Procedure_Call_Statement
(Loc
,
5636 Name
=> New_Reference_To
(RTE
(RE_Set_Prim_Op_Kind
), Loc
),
5637 Parameter_Associations
=> New_List
(
5638 New_Reference_To
(DT_Ptr
, Loc
),
5639 Make_Integer_Literal
(Loc
, Prim_Pos
),
5640 Prim_Op_Kind
(Alias
(Prim
), Typ
))));
5642 -- Retrieve the root of the alias chain
5645 while Present
(Alias
(Prim_Als
)) loop
5646 Prim_Als
:= Alias
(Prim_Als
);
5649 -- In the case of an entry wrapper, set the entry index
5651 if Ekind
(Prim
) = E_Procedure
5652 and then Is_Primitive_Wrapper
(Prim_Als
)
5653 and then Ekind
(Wrapped_Entity
(Prim_Als
)) = E_Entry
5656 -- Ada.Tags.Set_Entry_Index
5657 -- (DT_Ptr, <position>, <index>);
5659 Append_To
(Assignments
,
5660 Make_Procedure_Call_Statement
(Loc
,
5662 New_Reference_To
(RTE
(RE_Set_Entry_Index
), Loc
),
5663 Parameter_Associations
=> New_List
(
5664 New_Reference_To
(DT_Ptr
, Loc
),
5665 Make_Integer_Literal
(Loc
, Prim_Pos
),
5666 Make_Integer_Literal
(Loc
,
5667 Find_Entry_Index
(Wrapped_Entity
(Prim_Als
))))));
5671 Next_Elmt
(Prim_Elmt
);
5676 end Make_Select_Specific_Data_Table
;
5682 function Make_Tags
(Typ
: Entity_Id
) return List_Id
is
5683 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5684 Tname
: constant Name_Id
:= Chars
(Typ
);
5685 Result
: constant List_Id
:= New_List
;
5686 AI_Tag_Comp
: Elmt_Id
;
5688 DT_Constr_List
: List_Id
;
5690 Predef_Prims_Ptr
: Node_Id
;
5691 Iface_DT_Ptr
: Node_Id
;
5695 Typ_Comps
: Elist_Id
;
5698 -- 1) Generate the primary and secondary tag entities
5700 -- Collect the components associated with secondary dispatch tables
5702 if Has_Interfaces
(Typ
) then
5703 Collect_Interface_Components
(Typ
, Typ_Comps
);
5706 -- 1) Generate the primary tag entities
5708 -- Primary dispatch table containing user-defined primitives
5710 DT_Ptr
:= Make_Defining_Identifier
(Loc
,
5711 New_External_Name
(Tname
, 'P'));
5712 Set_Etype
(DT_Ptr
, RTE
(RE_Tag
));
5714 -- Primary dispatch table containing predefined primitives
5717 Make_Defining_Identifier
(Loc
,
5718 Chars
=> New_External_Name
(Tname
, 'Y'));
5719 Set_Etype
(Predef_Prims_Ptr
, RTE
(RE_Address
));
5721 -- Import the forward declaration of the Dispatch Table wrapper record
5722 -- (Make_DT will take care of its exportation)
5724 if Building_Static_DT
(Typ
) then
5726 Make_Defining_Identifier
(Loc
,
5727 Chars
=> New_External_Name
(Tname
, 'T'));
5730 -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
5731 -- $pragma import (ada, DT);
5733 Set_Is_Imported
(DT
);
5735 -- The scope must be set now to call Get_External_Name
5737 Set_Scope
(DT
, Current_Scope
);
5739 Get_External_Name
(DT
, True);
5740 Set_Interface_Name
(DT
,
5741 Make_String_Literal
(Loc
,
5742 Strval
=> String_From_Name_Buffer
));
5744 -- Ensure proper Sprint output of this implicit importation
5746 Set_Is_Internal
(DT
);
5748 -- Save this entity to allow Make_DT to generate its exportation
5750 Set_Dispatch_Table_Wrapper
(Typ
, DT
);
5752 if Has_DT
(Typ
) then
5754 -- Calculate the number of primitives of the dispatch table and
5755 -- the size of the Type_Specific_Data record.
5757 Nb_Prim
:= UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Typ
)));
5759 -- If the tagged type has no primitives we add a dummy slot
5760 -- whose address will be the tag of this type.
5764 New_List
(Make_Integer_Literal
(Loc
, 1));
5767 New_List
(Make_Integer_Literal
(Loc
, Nb_Prim
));
5771 Make_Object_Declaration
(Loc
,
5772 Defining_Identifier
=> DT
,
5773 Aliased_Present
=> True,
5774 Constant_Present
=> True,
5775 Object_Definition
=>
5776 Make_Subtype_Indication
(Loc
,
5778 New_Reference_To
(RTE
(RE_Dispatch_Table_Wrapper
), Loc
),
5779 Constraint
=> Make_Index_Or_Discriminant_Constraint
(Loc
,
5780 Constraints
=> DT_Constr_List
))));
5783 Make_Object_Declaration
(Loc
,
5784 Defining_Identifier
=> DT_Ptr
,
5785 Constant_Present
=> True,
5786 Object_Definition
=> New_Reference_To
(RTE
(RE_Tag
), Loc
),
5788 Unchecked_Convert_To
(RTE
(RE_Tag
),
5789 Make_Attribute_Reference
(Loc
,
5791 Make_Selected_Component
(Loc
,
5792 Prefix
=> New_Reference_To
(DT
, Loc
),
5795 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
5796 Attribute_Name
=> Name_Address
))));
5799 Make_Object_Declaration
(Loc
,
5800 Defining_Identifier
=> Predef_Prims_Ptr
,
5801 Constant_Present
=> True,
5802 Object_Definition
=> New_Reference_To
5803 (RTE
(RE_Address
), Loc
),
5805 Make_Attribute_Reference
(Loc
,
5807 Make_Selected_Component
(Loc
,
5808 Prefix
=> New_Reference_To
(DT
, Loc
),
5811 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)),
5812 Attribute_Name
=> Name_Address
)));
5814 -- No dispatch table required
5818 Make_Object_Declaration
(Loc
,
5819 Defining_Identifier
=> DT
,
5820 Aliased_Present
=> True,
5821 Constant_Present
=> True,
5822 Object_Definition
=>
5823 New_Reference_To
(RTE
(RE_No_Dispatch_Table_Wrapper
), Loc
)));
5826 Make_Object_Declaration
(Loc
,
5827 Defining_Identifier
=> DT_Ptr
,
5828 Constant_Present
=> True,
5829 Object_Definition
=> New_Reference_To
(RTE
(RE_Tag
), Loc
),
5831 Unchecked_Convert_To
(RTE
(RE_Tag
),
5832 Make_Attribute_Reference
(Loc
,
5834 Make_Selected_Component
(Loc
,
5835 Prefix
=> New_Reference_To
(DT
, Loc
),
5838 (RTE_Record_Component
(RE_NDT_Prims_Ptr
), Loc
)),
5839 Attribute_Name
=> Name_Address
))));
5842 Set_Is_True_Constant
(DT_Ptr
);
5843 Set_Is_Statically_Allocated
(DT_Ptr
);
5846 pragma Assert
(No
(Access_Disp_Table
(Typ
)));
5847 Set_Access_Disp_Table
(Typ
, New_Elmt_List
);
5848 Append_Elmt
(DT_Ptr
, Access_Disp_Table
(Typ
));
5849 Append_Elmt
(Predef_Prims_Ptr
, Access_Disp_Table
(Typ
));
5851 -- 2) Generate the secondary tag entities
5853 if Has_Interfaces
(Typ
) then
5856 -- For each interface type we build an unique external name
5857 -- associated with its corresponding secondary dispatch table.
5858 -- This external name will be used to declare an object that
5859 -- references this secondary dispatch table, value that will be
5860 -- used for the elaboration of Typ's objects and also for the
5861 -- elaboration of objects of derivations of Typ that do not
5862 -- override the primitive operation of this interface type.
5864 AI_Tag_Comp
:= First_Elmt
(Typ_Comps
);
5865 while Present
(AI_Tag_Comp
) loop
5866 Get_Secondary_DT_External_Name
5867 (Typ
, Related_Type
(Node
(AI_Tag_Comp
)), Suffix_Index
);
5869 Typ_Name
:= Name_Find
;
5871 -- Secondary dispatch table referencing thunks to user-defined
5872 -- primitives covered by this interface.
5875 Make_Defining_Identifier
(Loc
,
5876 Chars
=> New_External_Name
(Typ_Name
, 'P'));
5877 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
5878 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
5879 Set_Is_Tag
(Iface_DT_Ptr
);
5880 Set_Has_Thunks
(Iface_DT_Ptr
);
5881 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
5882 Is_Library_Level_Tagged_Type
(Typ
));
5883 Set_Is_True_Constant
(Iface_DT_Ptr
);
5885 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
5886 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
5888 -- Secondary dispatch table referencing thunks to predefined
5892 Make_Defining_Identifier
(Loc
,
5893 Chars
=> New_External_Name
(Typ_Name
, 'Y'));
5894 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Address
));
5895 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
5896 Set_Is_Tag
(Iface_DT_Ptr
);
5897 Set_Has_Thunks
(Iface_DT_Ptr
);
5898 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
5899 Is_Library_Level_Tagged_Type
(Typ
));
5900 Set_Is_True_Constant
(Iface_DT_Ptr
);
5902 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
5903 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
5905 -- Secondary dispatch table referencing user-defined primitives
5906 -- covered by this interface.
5909 Make_Defining_Identifier
(Loc
,
5910 Chars
=> New_External_Name
(Typ_Name
, 'D'));
5911 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Interface_Tag
));
5912 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
5913 Set_Is_Tag
(Iface_DT_Ptr
);
5914 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
5915 Is_Library_Level_Tagged_Type
(Typ
));
5916 Set_Is_True_Constant
(Iface_DT_Ptr
);
5918 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
5919 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
5921 -- Secondary dispatch table referencing predefined primitives
5924 Make_Defining_Identifier
(Loc
,
5925 Chars
=> New_External_Name
(Typ_Name
, 'Z'));
5926 Set_Etype
(Iface_DT_Ptr
, RTE
(RE_Address
));
5927 Set_Ekind
(Iface_DT_Ptr
, E_Constant
);
5928 Set_Is_Tag
(Iface_DT_Ptr
);
5929 Set_Is_Statically_Allocated
(Iface_DT_Ptr
,
5930 Is_Library_Level_Tagged_Type
(Typ
));
5931 Set_Is_True_Constant
(Iface_DT_Ptr
);
5933 (Iface_DT_Ptr
, Related_Type
(Node
(AI_Tag_Comp
)));
5934 Append_Elmt
(Iface_DT_Ptr
, Access_Disp_Table
(Typ
));
5936 Next_Elmt
(AI_Tag_Comp
);
5940 -- 3) At the end of Access_Disp_Table we add the entity of an access
5941 -- type declaration. It is used by Build_Get_Prim_Op_Address to
5942 -- expand dispatching calls through the primary dispatch table.
5945 -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
5946 -- type Typ_DT_Acc is access Typ_DT;
5949 Name_DT_Prims
: constant Name_Id
:=
5950 New_External_Name
(Tname
, 'G');
5951 Name_DT_Prims_Acc
: constant Name_Id
:=
5952 New_External_Name
(Tname
, 'H');
5953 DT_Prims
: constant Entity_Id
:=
5954 Make_Defining_Identifier
(Loc
, Name_DT_Prims
);
5955 DT_Prims_Acc
: constant Entity_Id
:=
5956 Make_Defining_Identifier
(Loc
,
5960 Make_Full_Type_Declaration
(Loc
,
5961 Defining_Identifier
=> DT_Prims
,
5963 Make_Constrained_Array_Definition
(Loc
,
5964 Discrete_Subtype_Definitions
=> New_List
(
5966 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
5967 High_Bound
=> Make_Integer_Literal
(Loc
,
5969 (First_Tag_Component
(Typ
))))),
5970 Component_Definition
=>
5971 Make_Component_Definition
(Loc
,
5972 Subtype_Indication
=>
5973 New_Reference_To
(RTE
(RE_Prim_Ptr
), Loc
)))));
5976 Make_Full_Type_Declaration
(Loc
,
5977 Defining_Identifier
=> DT_Prims_Acc
,
5979 Make_Access_To_Object_Definition
(Loc
,
5980 Subtype_Indication
=>
5981 New_Occurrence_Of
(DT_Prims
, Loc
))));
5983 Append_Elmt
(DT_Prims_Acc
, Access_Disp_Table
(Typ
));
5985 -- Analyze the resulting list and suppress the generation of the
5986 -- Init_Proc associated with the above array declaration because
5987 -- we never use such type in object declarations; this type is only
5988 -- used to simplify the expansion associated with dispatching calls.
5990 Analyze_List
(Result
);
5991 Set_Suppress_Init_Proc
(Base_Type
(DT_Prims
));
5993 -- Mark entity of dispatch table. Required by the backend to handle
5996 Set_Is_Dispatch_Table_Entity
(DT_Prims
);
5999 Set_Ekind
(DT_Ptr
, E_Constant
);
6000 Set_Is_Tag
(DT_Ptr
);
6001 Set_Related_Type
(DT_Ptr
, Typ
);
6006 -----------------------------------
6007 -- Original_View_In_Visible_Part --
6008 -----------------------------------
6010 function Original_View_In_Visible_Part
(Typ
: Entity_Id
) return Boolean is
6011 Scop
: constant Entity_Id
:= Scope
(Typ
);
6014 -- The scope must be a package
6016 if not Is_Package_Or_Generic_Package
(Scop
) then
6020 -- A type with a private declaration has a private view declared in
6021 -- the visible part.
6023 if Has_Private_Declaration
(Typ
) then
6027 return List_Containing
(Parent
(Typ
)) =
6028 Visible_Declarations
(Specification
(Unit_Declaration_Node
(Scop
)));
6029 end Original_View_In_Visible_Part
;
6035 function Prim_Op_Kind
6037 Typ
: Entity_Id
) return Node_Id
6039 Full_Typ
: Entity_Id
:= Typ
;
6040 Loc
: constant Source_Ptr
:= Sloc
(Prim
);
6041 Prim_Op
: Entity_Id
;
6044 -- Retrieve the original primitive operation
6047 while Present
(Alias
(Prim_Op
)) loop
6048 Prim_Op
:= Alias
(Prim_Op
);
6051 if Ekind
(Typ
) = E_Record_Type
6052 and then Present
(Corresponding_Concurrent_Type
(Typ
))
6054 Full_Typ
:= Corresponding_Concurrent_Type
(Typ
);
6057 -- When a private tagged type is completed by a concurrent type,
6058 -- retrieve the full view.
6060 if Is_Private_Type
(Full_Typ
) then
6061 Full_Typ
:= Full_View
(Full_Typ
);
6064 if Ekind
(Prim_Op
) = E_Function
then
6066 -- Protected function
6068 if Ekind
(Full_Typ
) = E_Protected_Type
then
6069 return New_Reference_To
(RTE
(RE_POK_Protected_Function
), Loc
);
6073 elsif Ekind
(Full_Typ
) = E_Task_Type
then
6074 return New_Reference_To
(RTE
(RE_POK_Task_Function
), Loc
);
6079 return New_Reference_To
(RTE
(RE_POK_Function
), Loc
);
6083 pragma Assert
(Ekind
(Prim_Op
) = E_Procedure
);
6085 if Ekind
(Full_Typ
) = E_Protected_Type
then
6089 if Is_Primitive_Wrapper
(Prim_Op
)
6090 and then Ekind
(Wrapped_Entity
(Prim_Op
)) = E_Entry
6092 return New_Reference_To
(RTE
(RE_POK_Protected_Entry
), Loc
);
6094 -- Protected procedure
6097 return New_Reference_To
(RTE
(RE_POK_Protected_Procedure
), Loc
);
6100 elsif Ekind
(Full_Typ
) = E_Task_Type
then
6104 if Is_Primitive_Wrapper
(Prim_Op
)
6105 and then Ekind
(Wrapped_Entity
(Prim_Op
)) = E_Entry
6107 return New_Reference_To
(RTE
(RE_POK_Task_Entry
), Loc
);
6109 -- Task "procedure". These are the internally Expander-generated
6110 -- procedures (task body for instance).
6113 return New_Reference_To
(RTE
(RE_POK_Task_Procedure
), Loc
);
6116 -- Regular procedure
6119 return New_Reference_To
(RTE
(RE_POK_Procedure
), Loc
);
6124 ------------------------
6125 -- Register_Primitive --
6126 ------------------------
6128 procedure Register_Primitive
6134 Iface_Prim
: Entity_Id
;
6135 Iface_Typ
: Entity_Id
;
6136 Iface_DT_Ptr
: Entity_Id
;
6137 Iface_DT_Elmt
: Elmt_Id
;
6141 Tag_Typ
: Entity_Id
;
6142 Thunk_Id
: Entity_Id
;
6143 Thunk_Code
: Node_Id
;
6146 pragma Assert
(not Restriction_Active
(No_Dispatching_Calls
));
6148 if not RTE_Available
(RE_Tag
) then
6152 if not Present
(Interface_Alias
(Prim
)) then
6153 Tag_Typ
:= Scope
(DTC_Entity
(Prim
));
6154 Pos
:= DT_Position
(Prim
);
6155 Tag
:= First_Tag_Component
(Tag_Typ
);
6157 if Is_Predefined_Dispatching_Operation
(Prim
)
6158 or else Is_Predefined_Dispatching_Alias
(Prim
)
6161 Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Tag_Typ
))));
6163 Insert_After
(Ins_Nod
,
6164 Build_Set_Predefined_Prim_Op_Address
(Loc
,
6165 Tag_Node
=> New_Reference_To
(DT_Ptr
, Loc
),
6168 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
6169 Make_Attribute_Reference
(Loc
,
6170 Prefix
=> New_Reference_To
(Prim
, Loc
),
6171 Attribute_Name
=> Name_Unrestricted_Access
))));
6173 -- Register copy of the pointer to the 'size primitive in the TSD.
6175 if Chars
(Prim
) = Name_uSize
6176 and then RTE_Record_Component_Available
(RE_Size_Func
)
6178 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Tag_Typ
)));
6179 Insert_After
(Ins_Nod
,
6180 Build_Set_Size_Function
(Loc
,
6181 Tag_Node
=> New_Reference_To
(DT_Ptr
, Loc
),
6182 Size_Func
=> Prim
));
6186 pragma Assert
(Pos
/= Uint_0
and then Pos
<= DT_Entry_Count
(Tag
));
6188 DT_Ptr
:= Node
(First_Elmt
(Access_Disp_Table
(Tag_Typ
)));
6189 Insert_After
(Ins_Nod
,
6190 Build_Set_Prim_Op_Address
(Loc
,
6192 Tag_Node
=> New_Reference_To
(DT_Ptr
, Loc
),
6195 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
6196 Make_Attribute_Reference
(Loc
,
6197 Prefix
=> New_Reference_To
(Prim
, Loc
),
6198 Attribute_Name
=> Name_Unrestricted_Access
))));
6201 -- Ada 2005 (AI-251): Primitive associated with an interface type
6202 -- Generate the code of the thunk only if the interface type is not an
6203 -- immediate ancestor of Typ; otherwise the dispatch table associated
6204 -- with the interface is the primary dispatch table and we have nothing
6208 Tag_Typ
:= Find_Dispatching_Type
(Alias
(Prim
));
6209 Iface_Typ
:= Find_Dispatching_Type
(Interface_Alias
(Prim
));
6211 pragma Assert
(Is_Interface
(Iface_Typ
));
6213 Expand_Interface_Thunk
(Prim
, Thunk_Id
, Thunk_Code
);
6215 if not Is_Ancestor
(Iface_Typ
, Tag_Typ
)
6216 and then Present
(Thunk_Code
)
6218 -- Comment needed on why checks are suppressed. This is not just
6219 -- efficiency, but fundamental functionality (see 1.295 RH, which
6220 -- still does not answer this question) ???
6222 Insert_Action
(Ins_Nod
, Thunk_Code
, Suppress
=> All_Checks
);
6224 -- Generate the code necessary to fill the appropriate entry of
6225 -- the secondary dispatch table of Prim's controlling type with
6226 -- Thunk_Id's address.
6228 Iface_DT_Elmt
:= Find_Interface_ADT
(Tag_Typ
, Iface_Typ
);
6229 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
6230 pragma Assert
(Has_Thunks
(Iface_DT_Ptr
));
6232 Iface_Prim
:= Interface_Alias
(Prim
);
6233 Pos
:= DT_Position
(Iface_Prim
);
6234 Tag
:= First_Tag_Component
(Iface_Typ
);
6237 if Is_Predefined_Dispatching_Operation
(Prim
)
6238 or else Is_Predefined_Dispatching_Alias
(Prim
)
6241 Build_Set_Predefined_Prim_Op_Address
(Loc
,
6243 New_Reference_To
(Node
(Next_Elmt
(Iface_DT_Elmt
)), Loc
),
6246 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
6247 Make_Attribute_Reference
(Loc
,
6248 Prefix
=> New_Reference_To
(Thunk_Id
, Loc
),
6249 Attribute_Name
=> Name_Unrestricted_Access
))));
6251 Next_Elmt
(Iface_DT_Elmt
);
6252 Next_Elmt
(Iface_DT_Elmt
);
6253 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
6254 pragma Assert
(not Has_Thunks
(Iface_DT_Ptr
));
6257 Build_Set_Predefined_Prim_Op_Address
(Loc
,
6259 New_Reference_To
(Node
(Next_Elmt
(Iface_DT_Elmt
)), Loc
),
6262 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
6263 Make_Attribute_Reference
(Loc
,
6264 Prefix
=> New_Reference_To
(Alias
(Prim
), Loc
),
6265 Attribute_Name
=> Name_Unrestricted_Access
))));
6267 Insert_Actions_After
(Ins_Nod
, L
);
6270 pragma Assert
(Pos
/= Uint_0
6271 and then Pos
<= DT_Entry_Count
(Tag
));
6274 Build_Set_Prim_Op_Address
(Loc
,
6276 Tag_Node
=> New_Reference_To
(Iface_DT_Ptr
, Loc
),
6279 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
6280 Make_Attribute_Reference
(Loc
,
6281 Prefix
=> New_Reference_To
(Thunk_Id
, Loc
),
6282 Attribute_Name
=> Name_Unrestricted_Access
))));
6284 Next_Elmt
(Iface_DT_Elmt
);
6285 Next_Elmt
(Iface_DT_Elmt
);
6286 Iface_DT_Ptr
:= Node
(Iface_DT_Elmt
);
6287 pragma Assert
(not Has_Thunks
(Iface_DT_Ptr
));
6290 Build_Set_Prim_Op_Address
(Loc
,
6292 Tag_Node
=> New_Reference_To
(Iface_DT_Ptr
, Loc
),
6295 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
6296 Make_Attribute_Reference
(Loc
,
6297 Prefix
=> New_Reference_To
(Alias
(Prim
), Loc
),
6298 Attribute_Name
=> Name_Unrestricted_Access
))));
6300 Insert_Actions_After
(Ins_Nod
, L
);
6304 end Register_Primitive
;
6306 -------------------------
6307 -- Set_All_DT_Position --
6308 -------------------------
6310 procedure Set_All_DT_Position
(Typ
: Entity_Id
) is
6312 procedure Validate_Position
(Prim
: Entity_Id
);
6313 -- Check that the position assigned to Prim is completely safe
6314 -- (it has not been assigned to a previously defined primitive
6315 -- operation of Typ)
6317 -----------------------
6318 -- Validate_Position --
6319 -----------------------
6321 procedure Validate_Position
(Prim
: Entity_Id
) is
6326 -- Aliased primitives are safe
6328 if Present
(Alias
(Prim
)) then
6332 Op_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6333 while Present
(Op_Elmt
) loop
6334 Op
:= Node
(Op_Elmt
);
6336 -- No need to check against itself
6341 -- Primitive operations covering abstract interfaces are
6344 elsif Present
(Interface_Alias
(Op
)) then
6347 -- Predefined dispatching operations are completely safe. They
6348 -- are allocated at fixed positions in a separate table.
6350 elsif Is_Predefined_Dispatching_Operation
(Op
)
6351 or else Is_Predefined_Dispatching_Alias
(Op
)
6355 -- Aliased subprograms are safe
6357 elsif Present
(Alias
(Op
)) then
6360 elsif DT_Position
(Op
) = DT_Position
(Prim
)
6361 and then not Is_Predefined_Dispatching_Operation
(Op
)
6362 and then not Is_Predefined_Dispatching_Operation
(Prim
)
6363 and then not Is_Predefined_Dispatching_Alias
(Op
)
6364 and then not Is_Predefined_Dispatching_Alias
(Prim
)
6367 -- Handle aliased subprograms
6376 if Present
(Overridden_Operation
(Op_1
)) then
6377 Op_1
:= Overridden_Operation
(Op_1
);
6378 elsif Present
(Alias
(Op_1
)) then
6379 Op_1
:= Alias
(Op_1
);
6387 if Present
(Overridden_Operation
(Op_2
)) then
6388 Op_2
:= Overridden_Operation
(Op_2
);
6389 elsif Present
(Alias
(Op_2
)) then
6390 Op_2
:= Alias
(Op_2
);
6396 if Op_1
/= Op_2
then
6397 raise Program_Error
;
6402 Next_Elmt
(Op_Elmt
);
6404 end Validate_Position
;
6408 Parent_Typ
: constant Entity_Id
:= Etype
(Typ
);
6409 First_Prim
: constant Elmt_Id
:= First_Elmt
(Primitive_Operations
(Typ
));
6410 The_Tag
: constant Entity_Id
:= First_Tag_Component
(Typ
);
6412 Adjusted
: Boolean := False;
6413 Finalized
: Boolean := False;
6419 Prim_Elmt
: Elmt_Id
;
6421 -- Start of processing for Set_All_DT_Position
6424 pragma Assert
(Present
(First_Tag_Component
(Typ
)));
6426 -- Set the DT_Position for each primitive operation. Perform some
6427 -- sanity checks to avoid to build completely inconsistent dispatch
6430 -- First stage: Set the DTC entity of all the primitive operations
6431 -- This is required to properly read the DT_Position attribute in
6432 -- the latter stages.
6434 Prim_Elmt
:= First_Prim
;
6436 while Present
(Prim_Elmt
) loop
6437 Prim
:= Node
(Prim_Elmt
);
6439 -- Predefined primitives have a separate dispatch table
6441 if not (Is_Predefined_Dispatching_Operation
(Prim
)
6442 or else Is_Predefined_Dispatching_Alias
(Prim
))
6444 Count_Prim
:= Count_Prim
+ 1;
6447 Set_DTC_Entity_Value
(Typ
, Prim
);
6449 -- Clear any previous value of the DT_Position attribute. In this
6450 -- way we ensure that the final position of all the primitives is
6451 -- established by the following stages of this algorithm.
6453 Set_DT_Position
(Prim
, No_Uint
);
6455 Next_Elmt
(Prim_Elmt
);
6459 Fixed_Prim
: array (Int
range 0 .. Count_Prim
) of Boolean :=
6464 procedure Handle_Inherited_Private_Subprograms
(Typ
: Entity_Id
);
6465 -- Called if Typ is declared in a nested package or a public child
6466 -- package to handle inherited primitives that were inherited by Typ
6467 -- in the visible part, but whose declaration was deferred because
6468 -- the parent operation was private and not visible at that point.
6470 procedure Set_Fixed_Prim
(Pos
: Nat
);
6471 -- Sets to true an element of the Fixed_Prim table to indicate
6472 -- that this entry of the dispatch table of Typ is occupied.
6474 ------------------------------------------
6475 -- Handle_Inherited_Private_Subprograms --
6476 ------------------------------------------
6478 procedure Handle_Inherited_Private_Subprograms
(Typ
: Entity_Id
) is
6481 Op_Elmt_2
: Elmt_Id
;
6482 Prim_Op
: Entity_Id
;
6483 Parent_Subp
: Entity_Id
;
6486 Op_List
:= Primitive_Operations
(Typ
);
6488 Op_Elmt
:= First_Elmt
(Op_List
);
6489 while Present
(Op_Elmt
) loop
6490 Prim_Op
:= Node
(Op_Elmt
);
6492 -- Search primitives that are implicit operations with an
6493 -- internal name whose parent operation has a normal name.
6495 if Present
(Alias
(Prim_Op
))
6496 and then Find_Dispatching_Type
(Alias
(Prim_Op
)) /= Typ
6497 and then not Comes_From_Source
(Prim_Op
)
6498 and then Is_Internal_Name
(Chars
(Prim_Op
))
6499 and then not Is_Internal_Name
(Chars
(Alias
(Prim_Op
)))
6501 Parent_Subp
:= Alias
(Prim_Op
);
6503 -- Check if the type has an explicit overriding for this
6506 Op_Elmt_2
:= Next_Elmt
(Op_Elmt
);
6507 while Present
(Op_Elmt_2
) loop
6508 if Chars
(Node
(Op_Elmt_2
)) = Chars
(Parent_Subp
)
6509 and then Type_Conformant
(Prim_Op
, Node
(Op_Elmt_2
))
6511 Set_DT_Position
(Prim_Op
, DT_Position
(Parent_Subp
));
6512 Set_DT_Position
(Node
(Op_Elmt_2
),
6513 DT_Position
(Parent_Subp
));
6514 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(Prim_Op
)));
6516 goto Next_Primitive
;
6519 Next_Elmt
(Op_Elmt_2
);
6524 Next_Elmt
(Op_Elmt
);
6526 end Handle_Inherited_Private_Subprograms
;
6528 --------------------
6529 -- Set_Fixed_Prim --
6530 --------------------
6532 procedure Set_Fixed_Prim
(Pos
: Nat
) is
6534 pragma Assert
(Pos
>= 0 and then Pos
<= Count_Prim
);
6535 Fixed_Prim
(Pos
) := True;
6537 when Constraint_Error
=>
6538 raise Program_Error
;
6542 -- In case of nested packages and public child package it may be
6543 -- necessary a special management on inherited subprograms so that
6544 -- the dispatch table is properly filled.
6546 if Ekind
(Scope
(Scope
(Typ
))) = E_Package
6547 and then Scope
(Scope
(Typ
)) /= Standard_Standard
6548 and then ((Is_Derived_Type
(Typ
) and then not Is_Private_Type
(Typ
))
6550 (Nkind
(Parent
(Typ
)) = N_Private_Extension_Declaration
6551 and then Is_Generic_Type
(Typ
)))
6552 and then In_Open_Scopes
(Scope
(Etype
(Typ
)))
6553 and then Typ
= Base_Type
(Typ
)
6555 Handle_Inherited_Private_Subprograms
(Typ
);
6558 -- Second stage: Register fixed entries
6561 Prim_Elmt
:= First_Prim
;
6562 while Present
(Prim_Elmt
) loop
6563 Prim
:= Node
(Prim_Elmt
);
6565 -- Predefined primitives have a separate table and all its
6566 -- entries are at predefined fixed positions.
6568 if Is_Predefined_Dispatching_Operation
(Prim
) then
6569 Set_DT_Position
(Prim
, Default_Prim_Op_Position
(Prim
));
6571 elsif Is_Predefined_Dispatching_Alias
(Prim
) then
6573 while Present
(Alias
(E
)) loop
6577 Set_DT_Position
(Prim
, Default_Prim_Op_Position
(E
));
6579 -- Overriding primitives of ancestor abstract interfaces
6581 elsif Present
(Interface_Alias
(Prim
))
6582 and then Is_Ancestor
6583 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
)
6585 pragma Assert
(DT_Position
(Prim
) = No_Uint
6586 and then Present
(DTC_Entity
(Interface_Alias
(Prim
))));
6588 E
:= Interface_Alias
(Prim
);
6589 Set_DT_Position
(Prim
, DT_Position
(E
));
6592 (DT_Position
(Alias
(Prim
)) = No_Uint
6593 or else DT_Position
(Alias
(Prim
)) = DT_Position
(E
));
6594 Set_DT_Position
(Alias
(Prim
), DT_Position
(E
));
6595 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(Prim
)));
6597 -- Overriding primitives must use the same entry as the
6598 -- overridden primitive.
6600 elsif not Present
(Interface_Alias
(Prim
))
6601 and then Present
(Alias
(Prim
))
6602 and then Chars
(Prim
) = Chars
(Alias
(Prim
))
6603 and then Find_Dispatching_Type
(Alias
(Prim
)) /= Typ
6604 and then Is_Ancestor
6605 (Find_Dispatching_Type
(Alias
(Prim
)), Typ
)
6606 and then Present
(DTC_Entity
(Alias
(Prim
)))
6609 Set_DT_Position
(Prim
, DT_Position
(E
));
6611 if not Is_Predefined_Dispatching_Alias
(E
) then
6612 Set_Fixed_Prim
(UI_To_Int
(DT_Position
(E
)));
6616 Next_Elmt
(Prim_Elmt
);
6619 -- Third stage: Fix the position of all the new primitives
6620 -- Entries associated with primitives covering interfaces
6621 -- are handled in a latter round.
6623 Prim_Elmt
:= First_Prim
;
6624 while Present
(Prim_Elmt
) loop
6625 Prim
:= Node
(Prim_Elmt
);
6627 -- Skip primitives previously set entries
6629 if DT_Position
(Prim
) /= No_Uint
then
6632 -- Primitives covering interface primitives are handled later
6634 elsif Present
(Interface_Alias
(Prim
)) then
6638 -- Take the next available position in the DT
6641 Nb_Prim
:= Nb_Prim
+ 1;
6642 pragma Assert
(Nb_Prim
<= Count_Prim
);
6643 exit when not Fixed_Prim
(Nb_Prim
);
6646 Set_DT_Position
(Prim
, UI_From_Int
(Nb_Prim
));
6647 Set_Fixed_Prim
(Nb_Prim
);
6650 Next_Elmt
(Prim_Elmt
);
6654 -- Fourth stage: Complete the decoration of primitives covering
6655 -- interfaces (that is, propagate the DT_Position attribute
6656 -- from the aliased primitive)
6658 Prim_Elmt
:= First_Prim
;
6659 while Present
(Prim_Elmt
) loop
6660 Prim
:= Node
(Prim_Elmt
);
6662 if DT_Position
(Prim
) = No_Uint
6663 and then Present
(Interface_Alias
(Prim
))
6665 pragma Assert
(Present
(Alias
(Prim
))
6666 and then Find_Dispatching_Type
(Alias
(Prim
)) = Typ
);
6668 -- Check if this entry will be placed in the primary DT
6671 (Find_Dispatching_Type
(Interface_Alias
(Prim
)), Typ
)
6673 pragma Assert
(DT_Position
(Alias
(Prim
)) /= No_Uint
);
6674 Set_DT_Position
(Prim
, DT_Position
(Alias
(Prim
)));
6676 -- Otherwise it will be placed in the secondary DT
6680 (DT_Position
(Interface_Alias
(Prim
)) /= No_Uint
);
6681 Set_DT_Position
(Prim
,
6682 DT_Position
(Interface_Alias
(Prim
)));
6686 Next_Elmt
(Prim_Elmt
);
6689 -- Generate listing showing the contents of the dispatch tables.
6690 -- This action is done before some further static checks because
6691 -- in case of critical errors caused by a wrong dispatch table
6692 -- we need to see the contents of such table.
6694 if Debug_Flag_ZZ
then
6698 -- Final stage: Ensure that the table is correct plus some further
6699 -- verifications concerning the primitives.
6701 Prim_Elmt
:= First_Prim
;
6703 while Present
(Prim_Elmt
) loop
6704 Prim
:= Node
(Prim_Elmt
);
6706 -- At this point all the primitives MUST have a position
6707 -- in the dispatch table.
6709 if DT_Position
(Prim
) = No_Uint
then
6710 raise Program_Error
;
6713 -- Calculate real size of the dispatch table
6715 if not (Is_Predefined_Dispatching_Operation
(Prim
)
6716 or else Is_Predefined_Dispatching_Alias
(Prim
))
6717 and then UI_To_Int
(DT_Position
(Prim
)) > DT_Length
6719 DT_Length
:= UI_To_Int
(DT_Position
(Prim
));
6722 -- Ensure that the assigned position to non-predefined
6723 -- dispatching operations in the dispatch table is correct.
6725 if not (Is_Predefined_Dispatching_Operation
(Prim
)
6726 or else Is_Predefined_Dispatching_Alias
(Prim
))
6728 Validate_Position
(Prim
);
6731 if Chars
(Prim
) = Name_Finalize
then
6735 if Chars
(Prim
) = Name_Adjust
then
6739 -- An abstract operation cannot be declared in the private part
6740 -- for a visible abstract type, because it could never be over-
6741 -- ridden. For explicit declarations this is checked at the
6742 -- point of declaration, but for inherited operations it must
6743 -- be done when building the dispatch table.
6745 -- Ada 2005 (AI-251): Primitives associated with interfaces are
6746 -- excluded from this check because interfaces must be visible in
6747 -- the public and private part (RM 7.3 (7.3/2))
6749 if Is_Abstract_Type
(Typ
)
6750 and then Is_Abstract_Subprogram
(Prim
)
6751 and then Present
(Alias
(Prim
))
6752 and then not Is_Interface
6753 (Find_Dispatching_Type
(Ultimate_Alias
(Prim
)))
6754 and then not Present
(Interface_Alias
(Prim
))
6755 and then Is_Derived_Type
(Typ
)
6756 and then In_Private_Part
(Current_Scope
)
6758 List_Containing
(Parent
(Prim
)) =
6759 Private_Declarations
6760 (Specification
(Unit_Declaration_Node
(Current_Scope
)))
6761 and then Original_View_In_Visible_Part
(Typ
)
6763 -- We exclude Input and Output stream operations because
6764 -- Limited_Controlled inherits useless Input and Output
6765 -- stream operations from Root_Controlled, which can
6766 -- never be overridden.
6768 if not Is_TSS
(Prim
, TSS_Stream_Input
)
6770 not Is_TSS
(Prim
, TSS_Stream_Output
)
6773 ("abstract inherited private operation&" &
6774 " must be overridden (RM 3.9.3(10))",
6775 Parent
(Typ
), Prim
);
6779 Next_Elmt
(Prim_Elmt
);
6784 if Is_Controlled
(Typ
) then
6785 if not Finalized
then
6787 ("controlled type has no explicit Finalize method?", Typ
);
6789 elsif not Adjusted
then
6791 ("controlled type has no explicit Adjust method?", Typ
);
6795 -- Set the final size of the Dispatch Table
6797 Set_DT_Entry_Count
(The_Tag
, UI_From_Int
(DT_Length
));
6799 -- The derived type must have at least as many components as its parent
6800 -- (for root types Etype points to itself and the test cannot fail).
6802 if DT_Entry_Count
(The_Tag
) <
6803 DT_Entry_Count
(First_Tag_Component
(Parent_Typ
))
6805 raise Program_Error
;
6807 end Set_All_DT_Position
;
6809 -----------------------------
6810 -- Set_Default_Constructor --
6811 -----------------------------
6813 procedure Set_Default_Constructor
(Typ
: Entity_Id
) is
6820 -- Look for the default constructor entity. For now only the
6821 -- default constructor has the flag Is_Constructor.
6823 E
:= Next_Entity
(Typ
);
6825 and then (Ekind
(E
) /= E_Function
or else not Is_Constructor
(E
))
6830 -- Create the init procedure
6834 Init
:= Make_Defining_Identifier
(Loc
, Make_Init_Proc_Name
(Typ
));
6835 Param
:= Make_Defining_Identifier
(Loc
, Name_X
);
6838 Make_Subprogram_Declaration
(Loc
,
6839 Make_Procedure_Specification
(Loc
,
6840 Defining_Unit_Name
=> Init
,
6841 Parameter_Specifications
=> New_List
(
6842 Make_Parameter_Specification
(Loc
,
6843 Defining_Identifier
=> Param
,
6844 Parameter_Type
=> New_Reference_To
(Typ
, Loc
))))));
6846 Set_Init_Proc
(Typ
, Init
);
6847 Set_Is_Imported
(Init
);
6848 Set_Interface_Name
(Init
, Interface_Name
(E
));
6849 Set_Convention
(Init
, Convention_C
);
6850 Set_Is_Public
(Init
);
6851 Set_Has_Completion
(Init
);
6853 -- If there are no constructors, mark the type as abstract since we
6854 -- won't be able to declare objects of that type.
6857 Set_Is_Abstract_Type
(Typ
);
6859 end Set_Default_Constructor
;
6861 --------------------------
6862 -- Set_DTC_Entity_Value --
6863 --------------------------
6865 procedure Set_DTC_Entity_Value
6866 (Tagged_Type
: Entity_Id
;
6870 if Present
(Interface_Alias
(Prim
))
6871 and then Is_Interface
6872 (Find_Dispatching_Type
(Interface_Alias
(Prim
)))
6874 Set_DTC_Entity
(Prim
,
6877 Iface
=> Find_Dispatching_Type
(Interface_Alias
(Prim
))));
6879 Set_DTC_Entity
(Prim
,
6880 First_Tag_Component
(Tagged_Type
));
6882 end Set_DTC_Entity_Value
;
6888 function Tagged_Kind
(T
: Entity_Id
) return Node_Id
is
6889 Conc_Typ
: Entity_Id
;
6890 Loc
: constant Source_Ptr
:= Sloc
(T
);
6894 (Is_Tagged_Type
(T
) and then RTE_Available
(RE_Tagged_Kind
));
6898 if Is_Abstract_Type
(T
) then
6899 if Is_Limited_Record
(T
) then
6900 return New_Reference_To
(RTE
(RE_TK_Abstract_Limited_Tagged
), Loc
);
6902 return New_Reference_To
(RTE
(RE_TK_Abstract_Tagged
), Loc
);
6907 elsif Is_Concurrent_Record_Type
(T
) then
6908 Conc_Typ
:= Corresponding_Concurrent_Type
(T
);
6910 if Present
(Full_View
(Conc_Typ
)) then
6911 Conc_Typ
:= Full_View
(Conc_Typ
);
6914 if Ekind
(Conc_Typ
) = E_Protected_Type
then
6915 return New_Reference_To
(RTE
(RE_TK_Protected
), Loc
);
6917 pragma Assert
(Ekind
(Conc_Typ
) = E_Task_Type
);
6918 return New_Reference_To
(RTE
(RE_TK_Task
), Loc
);
6921 -- Regular tagged kinds
6924 if Is_Limited_Record
(T
) then
6925 return New_Reference_To
(RTE
(RE_TK_Limited_Tagged
), Loc
);
6927 return New_Reference_To
(RTE
(RE_TK_Tagged
), Loc
);
6936 procedure Write_DT
(Typ
: Entity_Id
) is
6941 -- Protect this procedure against wrong usage. Required because it will
6942 -- be used directly from GDB
6944 if not (Typ
<= Last_Node_Id
)
6945 or else not Is_Tagged_Type
(Typ
)
6947 Write_Str
("wrong usage: Write_DT must be used with tagged types");
6952 Write_Int
(Int
(Typ
));
6954 Write_Name
(Chars
(Typ
));
6956 if Is_Interface
(Typ
) then
6957 Write_Str
(" is interface");
6962 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
6963 while Present
(Elmt
) loop
6964 Prim
:= Node
(Elmt
);
6967 -- Indicate if this primitive will be allocated in the primary
6968 -- dispatch table or in a secondary dispatch table associated
6969 -- with an abstract interface type
6971 if Present
(DTC_Entity
(Prim
)) then
6972 if Etype
(DTC_Entity
(Prim
)) = RTE
(RE_Tag
) then
6979 -- Output the node of this primitive operation and its name
6981 Write_Int
(Int
(Prim
));
6984 if Is_Predefined_Dispatching_Operation
(Prim
) then
6985 Write_Str
("(predefined) ");
6988 Write_Name
(Chars
(Prim
));
6990 -- Indicate if this primitive has an aliased primitive
6992 if Present
(Alias
(Prim
)) then
6993 Write_Str
(" (alias = ");
6994 Write_Int
(Int
(Alias
(Prim
)));
6996 -- If the DTC_Entity attribute is already set we can also output
6997 -- the name of the interface covered by this primitive (if any)
6999 if Present
(DTC_Entity
(Alias
(Prim
)))
7000 and then Is_Interface
(Scope
(DTC_Entity
(Alias
(Prim
))))
7002 Write_Str
(" from interface ");
7003 Write_Name
(Chars
(Scope
(DTC_Entity
(Alias
(Prim
)))));
7006 if Present
(Interface_Alias
(Prim
)) then
7007 Write_Str
(", AI_Alias of ");
7009 (Chars
(Find_Dispatching_Type
(Interface_Alias
(Prim
))));
7011 Write_Int
(Int
(Interface_Alias
(Prim
)));
7017 -- Display the final position of this primitive in its associated
7018 -- (primary or secondary) dispatch table
7020 if Present
(DTC_Entity
(Prim
))
7021 and then DT_Position
(Prim
) /= No_Uint
7023 Write_Str
(" at #");
7024 Write_Int
(UI_To_Int
(DT_Position
(Prim
)));
7027 if Is_Abstract_Subprogram
(Prim
) then
7028 Write_Str
(" is abstract;");
7030 -- Check if this is a null primitive
7032 elsif Comes_From_Source
(Prim
)
7033 and then Ekind
(Prim
) = E_Procedure
7034 and then Null_Present
(Parent
(Prim
))
7036 Write_Str
(" is null;");