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))))));