1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2006-2009, 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 procedure Build_Get_Predefined_Prim_Op_Address
67 Tag_Node : in out Node_Id;
68 New_Node : out Node_Id);
69 -- Given a pointer to a dispatch table (T) and a position in the DT, build
70 -- code that gets the address of the predefined virtual function stored in
71 -- it (used for dispatching calls). Tag_Node is relocated.
73 -- Generates: Predefined_DT (Tag).D (Position);
75 procedure Build_Get_Prim_Op_Address
79 Tag_Node : in out Node_Id;
80 New_Node : out Node_Id);
81 -- Build code that retrieves the address of the virtual function stored in
82 -- a given position of the dispatch table (used for dispatching calls).
83 -- Tag_Node is relocated.
85 -- Generates: To_Tag (Tag).D (Position);
87 function Build_Get_Transportable
89 Tag_Node : Node_Id) return Node_Id;
90 -- Build code that retrieves the value of the Transportable flag for
93 -- Generates: TSD (Tag).Transportable;
95 function Build_Inherit_Predefined_Prims
97 Old_Tag_Node : Node_Id;
98 New_Tag_Node : Node_Id) return Node_Id;
99 -- Build code that inherits the predefined primitives of the parent.
101 -- Generates: Predefined_DT (New_T).D (All_Predefined_Prims) :=
102 -- Predefined_DT (Old_T).D (All_Predefined_Prims);
104 -- Required to build non-library level dispatch tables. Also required
105 -- when compiling without static dispatch tables support.
107 function Build_Inherit_Prims
110 Old_Tag_Node : Node_Id;
111 New_Tag_Node : Node_Id;
112 Num_Prims : Nat) return Node_Id;
113 -- Build code that inherits Num_Prims user-defined primitives from the
114 -- dispatch table of the parent type of tagged type Typ. It is used to
115 -- copy the dispatch table of the parent in the following cases:
116 -- a) case of derivations of CPP_Class types
117 -- b) tagged types whose dispatch table is not statically allocated
120 -- New_Tag.Prims_Ptr (1 .. Num_Prims) :=
121 -- Old_Tag.Prims_Ptr (1 .. Num_Prims);
123 function Build_Offset_To_Top
125 This_Node : Node_Id) return Node_Id;
126 -- Build code that references the Offset_To_Top component of the primary
127 -- or secondary dispatch table associated with This_Node. This subprogram
128 -- provides a subset of the functionality provided by the function
129 -- Offset_To_Top of package Ada.Tags, and is only called by the frontend
130 -- when such routine is not available in a configurable runtime.
134 -- (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset)
136 function Build_Set_Predefined_Prim_Op_Address
140 Address_Node : Node_Id) return Node_Id;
141 -- Build code that saves the address of a virtual function in a given
142 -- Position of the portion of the dispatch table associated with the
143 -- predefined primitives of Tag. Called from Exp_Disp.Fill_DT_Entry
144 -- and Exp_Disp.Fill_Secondary_DT_Entry. It is used for:
145 -- 1) Filling the dispatch table of CPP_Class types.
146 -- 2) Late overriding (see Check_Dispatching_Operation).
148 -- Generates: Predefined_DT (Tag).D (Position) := Value
150 function Build_Set_Prim_Op_Address
155 Address_Node : Node_Id) return Node_Id;
156 -- Build code that saves the address of a virtual function in a given
157 -- Position of the dispatch table associated with the Tag. Called from
158 -- Exp_Disp.Fill_DT_Entry and Exp_Disp.Fill_Secondary_DT_Entry. Used for:
159 -- 1) Filling the dispatch table of CPP_Class types.
160 -- 2) Late overriding (see Check_Dispatching_Operation).
162 -- Generates: Tag.D (Position) := Value
164 function Build_Set_Size_Function
167 Size_Func : Entity_Id) return Node_Id;
168 -- Build code that saves in the TSD the address of the function
169 -- calculating _size of the object.
171 function Build_Set_Static_Offset_To_Top
174 Offset_Value : Node_Id) return Node_Id;
175 -- Build code that initialize the Offset_To_Top component of the
176 -- secondary dispatch table referenced by Iface_Tag.
180 -- (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset).all