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 with Atree; use Atree;
27 with Einfo; use Einfo;
28 with Elists; use Elists;
29 with Exp_Util; use Exp_Util;
30 with Namet; use Namet;
31 with Nlists; use Nlists;
32 with Nmake; use Nmake;
33 with Rtsfind; use Rtsfind;
34 with Sinfo; use Sinfo;
35 with Sem_Aux; use Sem_Aux;
36 with Sem_Util; use Sem_Util;
37 with Stand; use Stand;
38 with Snames; use Snames;
39 with Tbuild; use Tbuild;
41 package body Exp_Atag is
43 -----------------------
44 -- Local Subprograms --
45 -----------------------
49 Tag_Node : Node_Id) return Node_Id;
50 -- Build code that displaces the Tag to reference the base of the wrapper
54 -- To_Dispatch_Table_Ptr
55 -- (To_Address (Tag_Node) - Tag_Node.Prims_Ptr'Position);
59 Tag_Node_Addr : Node_Id) return Node_Id;
60 -- Build code that retrieves the address of the record containing the Type
61 -- Specific Data generated by GNAT.
63 -- Generate: To_Type_Specific_Data_Ptr
64 -- (To_Addr_Ptr (Tag_Node_Addr - Typeinfo_Offset).all);
66 ------------------------------------------------
67 -- Build_Common_Dispatching_Select_Statements --
68 ------------------------------------------------
70 procedure Build_Common_Dispatching_Select_Statements
77 -- C := get_prim_op_kind (tag! (<type>VP), S);
79 -- where C is the out parameter capturing the call kind and S is the
80 -- dispatch table slot number.
83 Make_Assignment_Statement (Loc,
85 Make_Identifier (Loc, Name_uC),
87 Make_Function_Call (Loc,
88 Name => New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc),
89 Parameter_Associations => New_List (
90 Unchecked_Convert_To (RTE (RE_Tag),
91 New_Reference_To (DT_Ptr, Loc)),
92 Make_Identifier (Loc, Name_uS)))));
96 -- if C = POK_Procedure
97 -- or else C = POK_Protected_Procedure
98 -- or else C = POK_Task_Procedure;
103 -- where F is the out parameter capturing the status of a potential
107 Make_If_Statement (Loc,
114 Make_Identifier (Loc, Name_uC),
116 New_Reference_To (RTE (RE_POK_Procedure), Loc)),
122 Make_Identifier (Loc, Name_uC),
124 New_Reference_To (RTE (
125 RE_POK_Protected_Procedure), Loc)),
129 Make_Identifier (Loc, Name_uC),
131 New_Reference_To (RTE (
132 RE_POK_Task_Procedure), Loc)))),
136 Make_Assignment_Statement (Loc,
137 Name => Make_Identifier (Loc, Name_uF),
138 Expression => New_Reference_To (Standard_True, Loc)),
139 Make_Simple_Return_Statement (Loc))));
140 end Build_Common_Dispatching_Select_Statements;
142 -------------------------
143 -- Build_CW_Membership --
144 -------------------------
146 procedure Build_CW_Membership
148 Obj_Tag_Node : in out Node_Id;
149 Typ_Tag_Node : Node_Id;
150 Related_Nod : Node_Id;
151 New_Node : out Node_Id)
153 Tag_Addr : constant Entity_Id := Make_Defining_Identifier (Loc,
154 New_Internal_Name ('D'));
155 Obj_TSD : constant Entity_Id := Make_Defining_Identifier (Loc,
156 New_Internal_Name ('D'));
157 Typ_TSD : constant Entity_Id := Make_Defining_Identifier (Loc,
158 New_Internal_Name ('D'));
159 Index : constant Entity_Id := Make_Defining_Identifier (Loc,
160 New_Internal_Name ('D'));
165 -- Tag_Addr : constant Tag := Address!(Obj_Tag);
166 -- Obj_TSD : constant Type_Specific_Data_Ptr
167 -- := Build_TSD (Tag_Addr);
168 -- Typ_TSD : constant Type_Specific_Data_Ptr
169 -- := Build_TSD (Address!(Typ_Tag));
170 -- Index : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth
171 -- Index > 0 and then Obj_TSD.Tags_Table (Index) = Typ'Tag
173 Insert_Action (Related_Nod,
174 Make_Object_Declaration (Loc,
175 Defining_Identifier => Tag_Addr,
176 Constant_Present => True,
177 Object_Definition => New_Reference_To (RTE (RE_Address), Loc),
178 Expression => Unchecked_Convert_To
179 (RTE (RE_Address), Obj_Tag_Node)));
181 -- Unchecked_Convert_To relocates Obj_Tag_Node and therefore we must
184 Obj_Tag_Node := Expression (Expression (Parent (Tag_Addr)));
186 Insert_Action (Related_Nod,
187 Make_Object_Declaration (Loc,
188 Defining_Identifier => Obj_TSD,
189 Constant_Present => True,
190 Object_Definition => New_Reference_To
191 (RTE (RE_Type_Specific_Data_Ptr), Loc),
192 Expression => Build_TSD (Loc, New_Reference_To (Tag_Addr, Loc))));
194 Insert_Action (Related_Nod,
195 Make_Object_Declaration (Loc,
196 Defining_Identifier => Typ_TSD,
197 Constant_Present => True,
198 Object_Definition => New_Reference_To
199 (RTE (RE_Type_Specific_Data_Ptr), Loc),
200 Expression => Build_TSD (Loc,
201 Unchecked_Convert_To (RTE (RE_Address),
204 Insert_Action (Related_Nod,
205 Make_Object_Declaration (Loc,
206 Defining_Identifier => Index,
207 Constant_Present => True,
208 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
210 Make_Op_Subtract (Loc,
212 Make_Selected_Component (Loc,
213 Prefix => New_Reference_To (Obj_TSD, Loc),
216 (RTE_Record_Component (RE_Idepth), Loc)),
219 Make_Selected_Component (Loc,
220 Prefix => New_Reference_To (Typ_TSD, Loc),
223 (RTE_Record_Component (RE_Idepth), Loc)))));
229 Left_Opnd => New_Occurrence_Of (Index, Loc),
230 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
235 Make_Indexed_Component (Loc,
237 Make_Selected_Component (Loc,
238 Prefix => New_Reference_To (Obj_TSD, Loc),
241 (RTE_Record_Component (RE_Tags_Table), Loc)),
243 New_List (New_Occurrence_Of (Index, Loc))),
245 Right_Opnd => Typ_Tag_Node));
246 end Build_CW_Membership;
254 Tag_Node : Node_Id) return Node_Id
258 Make_Function_Call (Loc,
259 Name => New_Reference_To (RTE (RE_DT), Loc),
260 Parameter_Associations => New_List (
261 Unchecked_Convert_To (RTE (RE_Tag), Tag_Node)));
264 ----------------------------
265 -- Build_Get_Access_Level --
266 ----------------------------
268 function Build_Get_Access_Level
270 Tag_Node : Node_Id) return Node_Id
274 Make_Selected_Component (Loc,
277 Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
280 (RTE_Record_Component (RE_Access_Level), Loc));
281 end Build_Get_Access_Level;
283 ------------------------------------------
284 -- Build_Get_Predefined_Prim_Op_Address --
285 ------------------------------------------
287 procedure Build_Get_Predefined_Prim_Op_Address
290 Tag_Node : in out Node_Id;
291 New_Node : out Node_Id)
296 Ctrl_Tag := Unchecked_Convert_To (RTE (RE_Address), Tag_Node);
298 -- Unchecked_Convert_To relocates the controlling tag node and therefore
299 -- we must update it.
301 Tag_Node := Expression (Ctrl_Tag);
303 -- Build code that retrieves the address of the dispatch table
304 -- containing the predefined Ada primitives:
307 -- To_Predef_Prims_Table_Ptr
308 -- (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all);
311 Make_Indexed_Component (Loc,
313 Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
314 Make_Explicit_Dereference (Loc,
315 Unchecked_Convert_To (RTE (RE_Addr_Ptr),
316 Make_Function_Call (Loc,
318 Make_Expanded_Name (Loc,
319 Chars => Name_Op_Subtract,
322 (RTU_Entity (System_Storage_Elements), Loc),
324 Make_Identifier (Loc,
325 Chars => Name_Op_Subtract)),
326 Parameter_Associations => New_List (
328 New_Reference_To (RTE (RE_DT_Predef_Prims_Offset),
331 New_List (Make_Integer_Literal (Loc, Position)));
332 end Build_Get_Predefined_Prim_Op_Address;
334 -------------------------
335 -- Build_Inherit_Prims --
336 -------------------------
338 function Build_Inherit_Prims
341 Old_Tag_Node : Node_Id;
342 New_Tag_Node : Node_Id;
343 Num_Prims : Nat) return Node_Id
346 if RTE_Available (RE_DT) then
348 Make_Assignment_Statement (Loc,
352 Make_Selected_Component (Loc,
354 Build_DT (Loc, New_Tag_Node),
357 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
360 Low_Bound => Make_Integer_Literal (Loc, 1),
361 High_Bound => Make_Integer_Literal (Loc, Num_Prims))),
366 Make_Selected_Component (Loc,
368 Build_DT (Loc, Old_Tag_Node),
371 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
374 Low_Bound => Make_Integer_Literal (Loc, 1),
375 High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
378 Make_Assignment_Statement (Loc,
383 (Node (Last_Elmt (Access_Disp_Table (Typ))),
387 Low_Bound => Make_Integer_Literal (Loc, 1),
388 High_Bound => Make_Integer_Literal (Loc, Num_Prims))),
394 (Node (Last_Elmt (Access_Disp_Table (Typ))),
398 Low_Bound => Make_Integer_Literal (Loc, 1),
399 High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
401 end Build_Inherit_Prims;
403 -------------------------------
404 -- Build_Get_Prim_Op_Address --
405 -------------------------------
407 procedure Build_Get_Prim_Op_Address
411 Tag_Node : in out Node_Id;
412 New_Node : out Node_Id)
414 New_Prefix : Node_Id;
418 (Position <= DT_Entry_Count (First_Tag_Component (Typ)));
420 -- At the end of the Access_Disp_Table list we have the type
421 -- declaration required to convert the tag into a pointer to
422 -- the prims_ptr table (see Freeze_Record_Type).
426 (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node);
428 -- Unchecked_Convert_To relocates the controlling tag node and therefore
429 -- we must update it.
431 Tag_Node := Expression (New_Prefix);
434 Make_Indexed_Component (Loc,
435 Prefix => New_Prefix,
436 Expressions => New_List (Make_Integer_Literal (Loc, Position)));
437 end Build_Get_Prim_Op_Address;
439 -----------------------------
440 -- Build_Get_Transportable --
441 -----------------------------
443 function Build_Get_Transportable
445 Tag_Node : Node_Id) return Node_Id
449 Make_Selected_Component (Loc,
452 Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
455 (RTE_Record_Component (RE_Transportable), Loc));
456 end Build_Get_Transportable;
458 ------------------------------------
459 -- Build_Inherit_Predefined_Prims --
460 ------------------------------------
462 function Build_Inherit_Predefined_Prims
464 Old_Tag_Node : Node_Id;
465 New_Tag_Node : Node_Id) return Node_Id
469 Make_Assignment_Statement (Loc,
473 Make_Explicit_Dereference (Loc,
474 Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
475 Make_Explicit_Dereference (Loc,
476 Unchecked_Convert_To (RTE (RE_Addr_Ptr),
478 Discrete_Range => Make_Range (Loc,
479 Make_Integer_Literal (Loc, Uint_1),
480 New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
485 Make_Explicit_Dereference (Loc,
486 Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
487 Make_Explicit_Dereference (Loc,
488 Unchecked_Convert_To (RTE (RE_Addr_Ptr),
492 Make_Integer_Literal (Loc, 1),
493 New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
494 end Build_Inherit_Predefined_Prims;
496 -------------------------
497 -- Build_Offset_To_Top --
498 -------------------------
500 function Build_Offset_To_Top
502 This_Node : Node_Id) return Node_Id
508 Make_Explicit_Dereference (Loc,
509 Unchecked_Convert_To (RTE (RE_Tag_Ptr), This_Node));
512 Make_Explicit_Dereference (Loc,
513 Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr),
514 Make_Function_Call (Loc,
516 Make_Expanded_Name (Loc,
517 Chars => Name_Op_Subtract,
518 Prefix => New_Reference_To
519 (RTU_Entity (System_Storage_Elements), Loc),
520 Selector_Name => Make_Identifier (Loc,
521 Chars => Name_Op_Subtract)),
522 Parameter_Associations => New_List (
523 Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
524 New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset),
526 end Build_Offset_To_Top;
528 ------------------------------------------
529 -- Build_Set_Predefined_Prim_Op_Address --
530 ------------------------------------------
532 function Build_Set_Predefined_Prim_Op_Address
536 Address_Node : Node_Id) return Node_Id
540 Make_Assignment_Statement (Loc,
542 Make_Indexed_Component (Loc,
544 Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
545 Make_Explicit_Dereference (Loc,
546 Unchecked_Convert_To (RTE (RE_Addr_Ptr), Tag_Node))),
548 New_List (Make_Integer_Literal (Loc, Position))),
550 Expression => Address_Node);
551 end Build_Set_Predefined_Prim_Op_Address;
553 -------------------------------
554 -- Build_Set_Prim_Op_Address --
555 -------------------------------
557 function Build_Set_Prim_Op_Address
562 Address_Node : Node_Id) return Node_Id
564 Ctrl_Tag : Node_Id := Tag_Node;
568 Build_Get_Prim_Op_Address (Loc, Typ, Position, Ctrl_Tag, New_Node);
571 Make_Assignment_Statement (Loc,
573 Expression => Address_Node);
574 end Build_Set_Prim_Op_Address;
576 -----------------------------
577 -- Build_Set_Size_Function --
578 -----------------------------
580 function Build_Set_Size_Function
583 Size_Func : Entity_Id) return Node_Id is
585 pragma Assert (Chars (Size_Func) = Name_uSize
586 and then RTE_Record_Component_Available (RE_Size_Func));
588 Make_Assignment_Statement (Loc,
590 Make_Selected_Component (Loc,
593 Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
596 (RTE_Record_Component (RE_Size_Func), Loc)),
598 Unchecked_Convert_To (RTE (RE_Size_Ptr),
599 Make_Attribute_Reference (Loc,
600 Prefix => New_Reference_To (Size_Func, Loc),
601 Attribute_Name => Name_Unrestricted_Access)));
602 end Build_Set_Size_Function;
604 ------------------------------------
605 -- Build_Set_Static_Offset_To_Top --
606 ------------------------------------
608 function Build_Set_Static_Offset_To_Top
611 Offset_Value : Node_Id) return Node_Id is
614 Make_Assignment_Statement (Loc,
615 Make_Explicit_Dereference (Loc,
616 Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr),
617 Make_Function_Call (Loc,
619 Make_Expanded_Name (Loc,
620 Chars => Name_Op_Subtract,
621 Prefix => New_Reference_To
622 (RTU_Entity (System_Storage_Elements), Loc),
623 Selector_Name => Make_Identifier (Loc,
624 Chars => Name_Op_Subtract)),
625 Parameter_Associations => New_List (
626 Unchecked_Convert_To (RTE (RE_Address), Iface_Tag),
627 New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset),
630 end Build_Set_Static_Offset_To_Top;
638 Tag_Node_Addr : Node_Id) return Node_Id is
641 Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr),
642 Make_Explicit_Dereference (Loc,
643 Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr),
644 Make_Function_Call (Loc,
646 Make_Expanded_Name (Loc,
647 Chars => Name_Op_Subtract,
650 (RTU_Entity (System_Storage_Elements), Loc),
652 Make_Identifier (Loc,
653 Chars => Name_Op_Subtract)),
655 Parameter_Associations => New_List (
658 (RTE (RE_DT_Typeinfo_Ptr_Size), Loc))))));