1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2006-2007, 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 Einfo
; use Einfo
;
27 with Elists
; use Elists
;
28 with Exp_Util
; use Exp_Util
;
29 with Nlists
; use Nlists
;
30 with Nmake
; use Nmake
;
31 with Rtsfind
; use Rtsfind
;
32 with Sem_Util
; use Sem_Util
;
33 with Stand
; use Stand
;
34 with Snames
; use Snames
;
35 with Tbuild
; use Tbuild
;
37 package body Exp_Atag
is
39 -----------------------
40 -- Local Subprograms --
41 -----------------------
45 Tag_Node
: Node_Id
) return Node_Id
;
46 -- Build code that displaces the Tag to reference the base of the wrapper
50 -- To_Dispatch_Table_Ptr
51 -- (To_Address (Tag_Node) - Tag_Node.Prims_Ptr'Position);
53 function Build_TSD
(Loc
: Source_Ptr
; Tag_Node
: Node_Id
) return Node_Id
;
54 -- Build code that retrieves the address of the record containing the Type
55 -- Specific Data generated by GNAT.
57 -- Generate: To_Type_Specific_Data_Ptr
58 -- (To_Addr_Ptr (To_Address (Tag) - Typeinfo_Offset).all);
60 function Build_Predef_Prims
62 Tag_Node
: Node_Id
) return Node_Id
;
63 -- Build code that retrieves the address of the dispatch table containing
64 -- the predefined Ada primitives:
66 -- Generate: To_Predef_Prims_Table_Ptr
67 -- (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all);
69 ------------------------------------------------
70 -- Build_Common_Dispatching_Select_Statements --
71 ------------------------------------------------
73 procedure Build_Common_Dispatching_Select_Statements
80 -- C := get_prim_op_kind (tag! (<type>VP), S);
82 -- where C is the out parameter capturing the call kind and S is the
83 -- dispatch table slot number.
86 Make_Assignment_Statement
(Loc
,
88 Make_Identifier
(Loc
, Name_uC
),
90 Make_Function_Call
(Loc
,
91 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Prim_Op_Kind
), Loc
),
92 Parameter_Associations
=> New_List
(
93 Unchecked_Convert_To
(RTE
(RE_Tag
),
94 New_Reference_To
(DT_Ptr
, Loc
)),
95 Make_Identifier
(Loc
, Name_uS
)))));
99 -- if C = POK_Procedure
100 -- or else C = POK_Protected_Procedure
101 -- or else C = POK_Task_Procedure;
106 -- where F is the out parameter capturing the status of a potential
110 Make_If_Statement
(Loc
,
117 Make_Identifier
(Loc
, Name_uC
),
119 New_Reference_To
(RTE
(RE_POK_Procedure
), Loc
)),
125 Make_Identifier
(Loc
, Name_uC
),
127 New_Reference_To
(RTE
(
128 RE_POK_Protected_Procedure
), Loc
)),
132 Make_Identifier
(Loc
, Name_uC
),
134 New_Reference_To
(RTE
(
135 RE_POK_Task_Procedure
), Loc
)))),
139 Make_Assignment_Statement
(Loc
,
140 Name
=> Make_Identifier
(Loc
, Name_uF
),
141 Expression
=> New_Reference_To
(Standard_True
, Loc
)),
142 Make_Simple_Return_Statement
(Loc
))));
143 end Build_Common_Dispatching_Select_Statements
;
145 -------------------------
146 -- Build_CW_Membership --
147 -------------------------
149 function Build_CW_Membership
151 Obj_Tag_Node
: Node_Id
;
152 Typ_Tag_Node
: Node_Id
) return Node_Id
154 function Build_Pos
return Node_Id
;
155 -- Generate TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
157 function Build_Pos
return Node_Id
is
160 Make_Op_Subtract
(Loc
,
162 Make_Selected_Component
(Loc
,
163 Prefix
=> Build_TSD
(Loc
, Duplicate_Subexpr
(Obj_Tag_Node
)),
165 New_Reference_To
(RTE_Record_Component
(RE_Idepth
), Loc
)),
168 Make_Selected_Component
(Loc
,
169 Prefix
=> Build_TSD
(Loc
, Duplicate_Subexpr
(Typ_Tag_Node
)),
171 New_Reference_To
(RTE_Record_Component
(RE_Idepth
), Loc
)));
174 -- Start of processing for Build_CW_Membership
181 Left_Opnd
=> Build_Pos
,
182 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
187 Make_Indexed_Component
(Loc
,
189 Make_Selected_Component
(Loc
,
190 Prefix
=> Build_TSD
(Loc
, Obj_Tag_Node
),
193 (RTE_Record_Component
(RE_Tags_Table
), Loc
)),
195 New_List
(Build_Pos
)),
197 Right_Opnd
=> Typ_Tag_Node
));
198 end Build_CW_Membership
;
206 Tag_Node
: Node_Id
) return Node_Id
is
209 Make_Function_Call
(Loc
,
210 Name
=> New_Reference_To
(RTE
(RE_DT
), Loc
),
211 Parameter_Associations
=> New_List
(
212 Unchecked_Convert_To
(RTE
(RE_Tag
), Tag_Node
)));
215 ----------------------------
216 -- Build_Get_Access_Level --
217 ----------------------------
219 function Build_Get_Access_Level
221 Tag_Node
: Node_Id
) return Node_Id
225 Make_Selected_Component
(Loc
,
226 Prefix
=> Build_TSD
(Loc
, Tag_Node
),
229 (RTE_Record_Component
(RE_Access_Level
), Loc
));
230 end Build_Get_Access_Level
;
232 ------------------------------------------
233 -- Build_Get_Predefined_Prim_Op_Address --
234 ------------------------------------------
236 function Build_Get_Predefined_Prim_Op_Address
239 Position
: Uint
) return Node_Id
243 Make_Indexed_Component
(Loc
,
245 Build_Predef_Prims
(Loc
, Tag_Node
),
247 New_List
(Make_Integer_Literal
(Loc
, Position
)));
248 end Build_Get_Predefined_Prim_Op_Address
;
250 -------------------------
251 -- Build_Inherit_Prims --
252 -------------------------
254 function Build_Inherit_Prims
257 Old_Tag_Node
: Node_Id
;
258 New_Tag_Node
: Node_Id
;
259 Num_Prims
: Nat
) return Node_Id
262 if RTE_Available
(RE_DT
) then
264 Make_Assignment_Statement
(Loc
,
268 Make_Selected_Component
(Loc
,
270 Build_DT
(Loc
, New_Tag_Node
),
273 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
276 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
277 High_Bound
=> Make_Integer_Literal
(Loc
, Num_Prims
))),
282 Make_Selected_Component
(Loc
,
284 Build_DT
(Loc
, Old_Tag_Node
),
287 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
290 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
291 High_Bound
=> Make_Integer_Literal
(Loc
, Num_Prims
))));
294 Make_Assignment_Statement
(Loc
,
299 (Node
(Last_Elmt
(Access_Disp_Table
(Typ
))),
303 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
304 High_Bound
=> Make_Integer_Literal
(Loc
, Num_Prims
))),
310 (Node
(Last_Elmt
(Access_Disp_Table
(Typ
))),
314 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
315 High_Bound
=> Make_Integer_Literal
(Loc
, Num_Prims
))));
317 end Build_Inherit_Prims
;
319 -------------------------------
320 -- Build_Get_Prim_Op_Address --
321 -------------------------------
323 function Build_Get_Prim_Op_Address
327 Position
: Uint
) return Node_Id
331 (Position
<= DT_Entry_Count
(First_Tag_Component
(Typ
)));
333 -- At the end of the Access_Disp_Table list we have the type
334 -- declaration required to convert the tag into a pointer to
335 -- the prims_ptr table (see Freeze_Record_Type).
338 Make_Indexed_Component
(Loc
,
341 (Node
(Last_Elmt
(Access_Disp_Table
(Typ
))), Tag_Node
),
342 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Position
)));
343 end Build_Get_Prim_Op_Address
;
345 -----------------------------
346 -- Build_Get_Transportable --
347 -----------------------------
349 function Build_Get_Transportable
351 Tag_Node
: Node_Id
) return Node_Id
355 Make_Selected_Component
(Loc
,
356 Prefix
=> Build_TSD
(Loc
, Tag_Node
),
359 (RTE_Record_Component
(RE_Transportable
), Loc
));
360 end Build_Get_Transportable
;
362 ------------------------------------
363 -- Build_Inherit_Predefined_Prims --
364 ------------------------------------
366 function Build_Inherit_Predefined_Prims
368 Old_Tag_Node
: Node_Id
;
369 New_Tag_Node
: Node_Id
) return Node_Id
372 if RTE_Available
(RE_DT
) then
374 Make_Assignment_Statement
(Loc
,
378 Make_Explicit_Dereference
(Loc
,
379 Unchecked_Convert_To
(RTE
(RE_Predef_Prims_Table_Ptr
),
380 Make_Selected_Component
(Loc
,
382 Build_DT
(Loc
, New_Tag_Node
),
385 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)))),
386 Discrete_Range
=> Make_Range
(Loc
,
387 Make_Integer_Literal
(Loc
, Uint_1
),
388 New_Reference_To
(RTE
(RE_Max_Predef_Prims
), Loc
))),
393 Make_Explicit_Dereference
(Loc
,
394 Unchecked_Convert_To
(RTE
(RE_Predef_Prims_Table_Ptr
),
395 Make_Selected_Component
(Loc
,
397 Build_DT
(Loc
, Old_Tag_Node
),
400 (RTE_Record_Component
(RE_Predef_Prims
), Loc
)))),
404 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
406 New_Reference_To
(RTE
(RE_Max_Predef_Prims
), Loc
))));
409 Make_Assignment_Statement
(Loc
,
413 Make_Explicit_Dereference
(Loc
,
414 Build_Predef_Prims
(Loc
, New_Tag_Node
)),
415 Discrete_Range
=> Make_Range
(Loc
,
416 Make_Integer_Literal
(Loc
, Uint_1
),
417 New_Reference_To
(RTE
(RE_Max_Predef_Prims
), Loc
))),
422 Make_Explicit_Dereference
(Loc
,
423 Build_Predef_Prims
(Loc
, Old_Tag_Node
)),
426 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
428 New_Reference_To
(RTE
(RE_Max_Predef_Prims
), Loc
))));
430 end Build_Inherit_Predefined_Prims
;
432 ------------------------
433 -- Build_Predef_Prims --
434 ------------------------
436 function Build_Predef_Prims
438 Tag_Node
: Node_Id
) return Node_Id
442 Unchecked_Convert_To
(RTE
(RE_Predef_Prims_Table_Ptr
),
443 Make_Explicit_Dereference
(Loc
,
444 Unchecked_Convert_To
(RTE
(RE_Addr_Ptr
),
445 Make_Function_Call
(Loc
,
447 Make_Expanded_Name
(Loc
,
448 Chars
=> Name_Op_Subtract
,
451 (RTU_Entity
(System_Storage_Elements
), Loc
),
453 Make_Identifier
(Loc
,
454 Chars
=> Name_Op_Subtract
)),
456 Parameter_Associations
=> New_List
(
457 Unchecked_Convert_To
(RTE
(RE_Address
), Tag_Node
),
458 New_Reference_To
(RTE
(RE_DT_Predef_Prims_Offset
),
460 end Build_Predef_Prims
;
462 ------------------------------------------
463 -- Build_Set_Predefined_Prim_Op_Address --
464 ------------------------------------------
466 function Build_Set_Predefined_Prim_Op_Address
470 Address_Node
: Node_Id
) return Node_Id
474 Make_Assignment_Statement
(Loc
,
475 Name
=> Build_Get_Predefined_Prim_Op_Address
(Loc
,
477 Expression
=> Address_Node
);
478 end Build_Set_Predefined_Prim_Op_Address
;
480 -------------------------------
481 -- Build_Set_Prim_Op_Address --
482 -------------------------------
484 function Build_Set_Prim_Op_Address
489 Address_Node
: Node_Id
) return Node_Id
493 Make_Assignment_Statement
(Loc
,
494 Name
=> Build_Get_Prim_Op_Address
495 (Loc
, Typ
, Tag_Node
, Position
),
496 Expression
=> Address_Node
);
497 end Build_Set_Prim_Op_Address
;
503 function Build_TSD
(Loc
: Source_Ptr
; Tag_Node
: Node_Id
) return Node_Id
is
506 Unchecked_Convert_To
(RTE
(RE_Type_Specific_Data_Ptr
),
507 Make_Explicit_Dereference
(Loc
,
508 Prefix
=> Unchecked_Convert_To
(RTE
(RE_Addr_Ptr
),
509 Make_Function_Call
(Loc
,
511 Make_Expanded_Name
(Loc
,
512 Chars
=> Name_Op_Subtract
,
515 (RTU_Entity
(System_Storage_Elements
), Loc
),
517 Make_Identifier
(Loc
,
518 Chars
=> Name_Op_Subtract
)),
520 Parameter_Associations
=> New_List
(
521 Unchecked_Convert_To
(RTE
(RE_Address
), Tag_Node
),
523 (RTE
(RE_DT_Typeinfo_Ptr_Size
), Loc
))))));