1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2006-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 -- This package contains routines involved in the frontend expansion of
27 -- subprograms of package Ada.Tags
29 with Types
; use Types
;
30 with Uintp
; use Uintp
;
34 -- Note: In all the subprograms of this package formal 'Loc' is the source
35 -- location used in constructing the corresponding nodes.
37 procedure Build_Common_Dispatching_Select_Statements
41 -- Ada 2005 (AI-345): Generate statements that are common between timed,
42 -- asynchronous, and conditional select expansion.
44 function Build_CW_Membership
46 Obj_Tag_Node
: Node_Id
;
47 Typ_Tag_Node
: Node_Id
) return Node_Id
;
48 -- Build code that returns true if Obj_Tag is in Typ_Tag'Class. Each DT
49 -- has a table of ancestors and its inheritance level (Idepth). Obj is in
50 -- Typ'Class if Typ'Tag is found in the table of ancestors referenced by
51 -- Obj'Tag. Knowing the level of inheritance of both types, this can be
52 -- computed in constant time by the formula:
54 -- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
57 function Build_Get_Access_Level
59 Tag_Node
: Node_Id
) return Node_Id
;
60 -- Build code that retrieves the accessibility level of the tagged type.
62 -- Generates: TSD (Tag).Access_Level
64 function Build_Get_Predefined_Prim_Op_Address
67 Position
: Uint
) return Node_Id
;
68 -- Given a pointer to a dispatch table (T) and a position in the DT, build
69 -- code that gets the address of the predefined virtual function stored in
70 -- it (used for dispatching calls).
72 -- Generates: Predefined_DT (Tag).D (Position);
74 function Build_Get_Prim_Op_Address
78 Position
: Uint
) return Node_Id
;
79 -- Build code that retrieves the address of the virtual function stored in
80 -- a given position of the dispatch table (used for dispatching calls).
82 -- Generates: To_Tag (Tag).D (Position);
84 function Build_Get_Transportable
86 Tag_Node
: Node_Id
) return Node_Id
;
87 -- Build code that retrieves the value of the Transportable flag for
90 -- Generates: TSD (Tag).Transportable;
92 function Build_Inherit_Predefined_Prims
94 Old_Tag_Node
: Node_Id
;
95 New_Tag_Node
: Node_Id
) return Node_Id
;
96 -- Build code that inherits the predefined primitives of the parent.
98 -- Generates: Predefined_DT (New_T).D (All_Predefined_Prims) :=
99 -- Predefined_DT (Old_T).D (All_Predefined_Prims);
101 -- Required to build non-library level dispatch tables. Also required
102 -- when compiling without static dispatch tables support.
104 function Build_Inherit_Prims
107 Old_Tag_Node
: Node_Id
;
108 New_Tag_Node
: Node_Id
;
109 Num_Prims
: Nat
) return Node_Id
;
110 -- Build code that inherits Num_Prims user-defined primitives from the
111 -- dispatch table of the parent type of tagged type Typ. It is used to
112 -- copy the dispatch table of the parent in the following cases:
113 -- a) case of derivations of CPP_Class types
114 -- b) tagged types whose dispatch table is not statically allocated
117 -- New_Tag.Prims_Ptr (1 .. Num_Prims) :=
118 -- Old_Tag.Prims_Ptr (1 .. Num_Prims);
120 function Build_Offset_To_Top
122 This_Node
: Node_Id
) return Node_Id
;
123 -- Build code that references the Offset_To_Top component of the primary
124 -- or secondary dispatch table associated with This_Node. This subprogram
125 -- provides a subset of the functionality provided by the function
126 -- Offset_To_Top of package Ada.Tags, and is only called by the frontend
127 -- when such routine is not available in a configurable runtime.
131 -- (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset)
133 function Build_Set_Predefined_Prim_Op_Address
137 Address_Node
: Node_Id
) return Node_Id
;
138 -- Build code that saves the address of a virtual function in a given
139 -- Position of the portion of the dispatch table associated with the
140 -- predefined primitives of Tag. Called from Exp_Disp.Fill_DT_Entry
141 -- and Exp_Disp.Fill_Secondary_DT_Entry. It is used for:
142 -- 1) Filling the dispatch table of CPP_Class types.
143 -- 2) Late overriding (see Check_Dispatching_Operation).
145 -- Generates: Predefined_DT (Tag).D (Position) := Value
147 function Build_Set_Prim_Op_Address
152 Address_Node
: Node_Id
) return Node_Id
;
153 -- Build code that saves the address of a virtual function in a given
154 -- Position of the dispatch table associated with the Tag. Called from
155 -- Exp_Disp.Fill_DT_Entry and Exp_Disp.Fill_Secondary_DT_Entry. Used for:
156 -- 1) Filling the dispatch table of CPP_Class types.
157 -- 2) Late overriding (see Check_Dispatching_Operation).
159 -- Generates: Tag.D (Position) := Value
161 function Build_Set_Size_Function
164 Size_Func
: Entity_Id
) return Node_Id
;
165 -- Build code that saves in the TSD the address of the function
166 -- calculating _size of the object.
168 function Build_Set_Static_Offset_To_Top
171 Offset_Value
: Node_Id
) return Node_Id
;
172 -- Build code that initialize the Offset_To_Top component of the
173 -- secondary dispatch table referenced by Iface_Tag.
177 -- (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset).all