1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2006-2011, 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_Disp; use Exp_Disp;
30 with Exp_Util; use Exp_Util;
31 with Namet; use Namet;
32 with Nlists; use Nlists;
33 with Nmake; use Nmake;
35 with Rtsfind; use Rtsfind;
36 with Sinfo; use Sinfo;
37 with Sem_Aux; use Sem_Aux;
38 with Sem_Disp; use Sem_Disp;
39 with Sem_Util; use Sem_Util;
40 with Stand; use Stand;
41 with Snames; use Snames;
42 with Tbuild; use Tbuild;
44 package body Exp_Atag is
46 -----------------------
47 -- Local Subprograms --
48 -----------------------
52 Tag_Node : Node_Id) return Node_Id;
53 -- Build code that displaces the Tag to reference the base of the wrapper
57 -- To_Dispatch_Table_Ptr
58 -- (To_Address (Tag_Node) - Tag_Node.Prims_Ptr'Position);
62 Tag_Node_Addr : Node_Id) return Node_Id;
63 -- Build code that retrieves the address of the record containing the Type
64 -- Specific Data generated by GNAT.
66 -- Generate: To_Type_Specific_Data_Ptr
67 -- (To_Addr_Ptr (Tag_Node_Addr - Typeinfo_Offset).all);
69 ------------------------------------------------
70 -- Build_Common_Dispatching_Select_Statements --
71 ------------------------------------------------
73 procedure Build_Common_Dispatching_Select_Statements
77 Loc : constant Source_Ptr := Sloc (Typ);
82 -- C := get_prim_op_kind (tag! (<type>VP), S);
84 -- where C is the out parameter capturing the call kind and S is the
85 -- dispatch table slot number.
87 if Tagged_Type_Expansion then
89 Unchecked_Convert_To (RTE (RE_Tag),
91 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
95 Make_Attribute_Reference (Loc,
96 Prefix => New_Reference_To (Typ, Loc),
97 Attribute_Name => Name_Tag);
101 Make_Assignment_Statement (Loc,
102 Name => Make_Identifier (Loc, Name_uC),
104 Make_Function_Call (Loc,
105 Name => New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc),
106 Parameter_Associations => New_List (
108 Make_Identifier (Loc, Name_uS)))));
112 -- if C = POK_Procedure
113 -- or else C = POK_Protected_Procedure
114 -- or else C = POK_Task_Procedure;
119 -- where F is the out parameter capturing the status of a potential
123 Make_If_Statement (Loc,
129 Left_Opnd => Make_Identifier (Loc, Name_uC),
131 New_Reference_To (RTE (RE_POK_Procedure), Loc)),
136 Left_Opnd => Make_Identifier (Loc, Name_uC),
139 (RTE (RE_POK_Protected_Procedure), Loc)),
142 Left_Opnd => Make_Identifier (Loc, Name_uC),
145 (RTE (RE_POK_Task_Procedure), Loc)))),
149 Make_Assignment_Statement (Loc,
150 Name => Make_Identifier (Loc, Name_uF),
151 Expression => New_Reference_To (Standard_True, Loc)),
152 Make_Simple_Return_Statement (Loc))));
153 end Build_Common_Dispatching_Select_Statements;
155 -------------------------
156 -- Build_CW_Membership --
157 -------------------------
159 procedure Build_CW_Membership
161 Obj_Tag_Node : in out Node_Id;
162 Typ_Tag_Node : Node_Id;
163 Related_Nod : Node_Id;
164 New_Node : out Node_Id)
166 Tag_Addr : constant Entity_Id := Make_Temporary (Loc, 'D', Obj_Tag_Node);
167 Obj_TSD : constant Entity_Id := Make_Temporary (Loc, 'D');
168 Typ_TSD : constant Entity_Id := Make_Temporary (Loc, 'D');
169 Index : constant Entity_Id := Make_Temporary (Loc, 'D');
174 -- Tag_Addr : constant Tag := Address!(Obj_Tag);
175 -- Obj_TSD : constant Type_Specific_Data_Ptr
176 -- := Build_TSD (Tag_Addr);
177 -- Typ_TSD : constant Type_Specific_Data_Ptr
178 -- := Build_TSD (Address!(Typ_Tag));
179 -- Index : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth
180 -- Index > 0 and then Obj_TSD.Tags_Table (Index) = Typ'Tag
182 Insert_Action (Related_Nod,
183 Make_Object_Declaration (Loc,
184 Defining_Identifier => Tag_Addr,
185 Constant_Present => True,
186 Object_Definition => New_Reference_To (RTE (RE_Address), Loc),
187 Expression => Unchecked_Convert_To
188 (RTE (RE_Address), Obj_Tag_Node)));
190 -- Unchecked_Convert_To relocates Obj_Tag_Node and therefore we must
193 Obj_Tag_Node := Expression (Expression (Parent (Tag_Addr)));
195 Insert_Action (Related_Nod,
196 Make_Object_Declaration (Loc,
197 Defining_Identifier => Obj_TSD,
198 Constant_Present => True,
199 Object_Definition => New_Reference_To
200 (RTE (RE_Type_Specific_Data_Ptr), Loc),
201 Expression => Build_TSD (Loc, New_Reference_To (Tag_Addr, Loc))));
203 Insert_Action (Related_Nod,
204 Make_Object_Declaration (Loc,
205 Defining_Identifier => Typ_TSD,
206 Constant_Present => True,
207 Object_Definition => New_Reference_To
208 (RTE (RE_Type_Specific_Data_Ptr), Loc),
209 Expression => Build_TSD (Loc,
210 Unchecked_Convert_To (RTE (RE_Address),
213 Insert_Action (Related_Nod,
214 Make_Object_Declaration (Loc,
215 Defining_Identifier => Index,
216 Constant_Present => True,
217 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
219 Make_Op_Subtract (Loc,
221 Make_Selected_Component (Loc,
222 Prefix => New_Reference_To (Obj_TSD, Loc),
225 (RTE_Record_Component (RE_Idepth), Loc)),
228 Make_Selected_Component (Loc,
229 Prefix => New_Reference_To (Typ_TSD, Loc),
232 (RTE_Record_Component (RE_Idepth), Loc)))));
238 Left_Opnd => New_Occurrence_Of (Index, Loc),
239 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
244 Make_Indexed_Component (Loc,
246 Make_Selected_Component (Loc,
247 Prefix => New_Reference_To (Obj_TSD, Loc),
250 (RTE_Record_Component (RE_Tags_Table), Loc)),
252 New_List (New_Occurrence_Of (Index, Loc))),
254 Right_Opnd => Typ_Tag_Node));
255 end Build_CW_Membership;
263 Tag_Node : Node_Id) return Node_Id
267 Make_Function_Call (Loc,
268 Name => New_Reference_To (RTE (RE_DT), Loc),
269 Parameter_Associations => New_List (
270 Unchecked_Convert_To (RTE (RE_Tag), Tag_Node)));
273 ----------------------------
274 -- Build_Get_Access_Level --
275 ----------------------------
277 function Build_Get_Access_Level
279 Tag_Node : Node_Id) return Node_Id
283 Make_Selected_Component (Loc,
286 Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
289 (RTE_Record_Component (RE_Access_Level), Loc));
290 end Build_Get_Access_Level;
292 -------------------------
293 -- Build_Get_Alignment --
294 -------------------------
296 function Build_Get_Alignment
298 Tag_Node : Node_Id) return Node_Id
302 Make_Selected_Component (Loc,
304 Build_TSD (Loc, Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
306 New_Reference_To (RTE_Record_Component (RE_Alignment), Loc));
307 end Build_Get_Alignment;
309 ------------------------------------------
310 -- Build_Get_Predefined_Prim_Op_Address --
311 ------------------------------------------
313 procedure Build_Get_Predefined_Prim_Op_Address
316 Tag_Node : in out Node_Id;
317 New_Node : out Node_Id)
322 Ctrl_Tag := Unchecked_Convert_To (RTE (RE_Address), Tag_Node);
324 -- Unchecked_Convert_To relocates the controlling tag node and therefore
325 -- we must update it.
327 Tag_Node := Expression (Ctrl_Tag);
329 -- Build code that retrieves the address of the dispatch table
330 -- containing the predefined Ada primitives:
333 -- To_Predef_Prims_Table_Ptr
334 -- (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all);
337 Make_Indexed_Component (Loc,
339 Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
340 Make_Explicit_Dereference (Loc,
341 Unchecked_Convert_To (RTE (RE_Addr_Ptr),
342 Make_Function_Call (Loc,
344 Make_Expanded_Name (Loc,
345 Chars => Name_Op_Subtract,
348 (RTU_Entity (System_Storage_Elements), Loc),
350 Make_Identifier (Loc, Name_Op_Subtract)),
351 Parameter_Associations => New_List (
354 (RTE (RE_DT_Predef_Prims_Offset), Loc)))))),
356 New_List (Make_Integer_Literal (Loc, Position)));
357 end Build_Get_Predefined_Prim_Op_Address;
359 -----------------------------
360 -- Build_Inherit_CPP_Prims --
361 -----------------------------
363 function Build_Inherit_CPP_Prims (Typ : Entity_Id) return List_Id is
364 Loc : constant Source_Ptr := Sloc (Typ);
365 CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
366 CPP_Table : array (1 .. CPP_Nb_Prims) of Boolean := (others => False);
367 CPP_Typ : constant Entity_Id := Enclosing_CPP_Parent (Typ);
368 Result : constant List_Id := New_List;
369 Parent_Typ : constant Entity_Id := Etype (Typ);
372 Parent_Tag : Entity_Id;
378 pragma Assert (not Is_CPP_Class (Typ));
380 -- No code needed if this type has no primitives inherited from C++
382 if CPP_Nb_Prims = 0 then
386 -- Stage 1: Inherit and override C++ slots of the primary dispatch table
389 -- Typ'Tag (Prim_Pos) := Prim'Unrestricted_Access;
391 Parent_Tag := Node (First_Elmt (Access_Disp_Table (Parent_Typ)));
392 Typ_Tag := Node (First_Elmt (Access_Disp_Table (Typ)));
394 Elmt := First_Elmt (Primitive_Operations (Typ));
395 while Present (Elmt) loop
397 E := Ultimate_Alias (Prim);
398 Prim_Pos := UI_To_Int (DT_Position (E));
400 -- Skip predefined, abstract, and eliminated primitives. Skip also
401 -- primitives not located in the C++ part of the dispatch table.
403 if not Is_Predefined_Dispatching_Operation (Prim)
404 and then not Is_Predefined_Dispatching_Operation (E)
405 and then not Present (Interface_Alias (Prim))
406 and then not Is_Abstract_Subprogram (E)
407 and then not Is_Eliminated (E)
408 and then Prim_Pos <= CPP_Nb_Prims
409 and then Find_Dispatching_Type (E) = Typ
411 -- Remember that this slot is used
413 pragma Assert (CPP_Table (Prim_Pos) = False);
414 CPP_Table (Prim_Pos) := True;
417 Make_Assignment_Statement (Loc,
419 Make_Indexed_Component (Loc,
421 Make_Explicit_Dereference (Loc,
423 (Node (Last_Elmt (Access_Disp_Table (Typ))),
424 New_Reference_To (Typ_Tag, Loc))),
426 New_List (Make_Integer_Literal (Loc, Prim_Pos))),
429 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
430 Make_Attribute_Reference (Loc,
431 Prefix => New_Reference_To (E, Loc),
432 Attribute_Name => Name_Unrestricted_Access))));
438 -- If all primitives have been overridden then there is no need to copy
439 -- from Typ's parent its dispatch table. Otherwise, if some primitive is
440 -- inherited from the parent we copy only the C++ part of the dispatch
441 -- table from the parent before the assignments that initialize the
442 -- overridden primitives.
446 -- type CPP_TypG is array (1 .. CPP_Nb_Prims) ofd Prim_Ptr;
447 -- type CPP_TypH is access CPP_TypG;
448 -- CPP_TypG!(Typ_Tag).all := CPP_TypG!(Parent_Tag).all;
450 -- Note: There is no need to duplicate the declarations of CPP_TypG and
451 -- CPP_TypH because, for expansion of dispatching calls, these
452 -- entities are stored in the last elements of Access_Disp_Table.
454 for J in CPP_Table'Range loop
455 if not CPP_Table (J) then
457 Make_Assignment_Statement (Loc,
459 Make_Explicit_Dereference (Loc,
461 (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))),
462 New_Reference_To (Typ_Tag, Loc))),
464 Make_Explicit_Dereference (Loc,
466 (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))),
467 New_Reference_To (Parent_Tag, Loc)))));
472 -- Stage 2: Inherit and override C++ slots of secondary dispatch tables
476 Iface_Nb_Prims : Nat;
477 Parent_Ifaces_List : Elist_Id;
478 Parent_Ifaces_Comp_List : Elist_Id;
479 Parent_Ifaces_Tag_List : Elist_Id;
480 Parent_Iface_Tag_Elmt : Elmt_Id;
481 Typ_Ifaces_List : Elist_Id;
482 Typ_Ifaces_Comp_List : Elist_Id;
483 Typ_Ifaces_Tag_List : Elist_Id;
484 Typ_Iface_Tag_Elmt : Elmt_Id;
487 Collect_Interfaces_Info
489 Ifaces_List => Parent_Ifaces_List,
490 Components_List => Parent_Ifaces_Comp_List,
491 Tags_List => Parent_Ifaces_Tag_List);
493 Collect_Interfaces_Info
495 Ifaces_List => Typ_Ifaces_List,
496 Components_List => Typ_Ifaces_Comp_List,
497 Tags_List => Typ_Ifaces_Tag_List);
499 Parent_Iface_Tag_Elmt := First_Elmt (Parent_Ifaces_Tag_List);
500 Typ_Iface_Tag_Elmt := First_Elmt (Typ_Ifaces_Tag_List);
501 while Present (Parent_Iface_Tag_Elmt) loop
502 Parent_Tag := Node (Parent_Iface_Tag_Elmt);
503 Typ_Tag := Node (Typ_Iface_Tag_Elmt);
506 (Related_Type (Parent_Tag) = Related_Type (Typ_Tag));
507 Iface := Related_Type (Parent_Tag);
510 UI_To_Int (DT_Entry_Count (First_Tag_Component (Iface)));
512 if Iface_Nb_Prims > 0 then
514 -- Update slots of overridden primitives
517 Last_Nod : constant Node_Id := Last (Result);
518 Nb_Prims : constant Nat := UI_To_Int
520 (First_Tag_Component (Iface)));
526 Prims_Table : array (1 .. Nb_Prims) of Boolean;
529 Prims_Table := (others => False);
531 Elmt := First_Elmt (Primitive_Operations (Typ));
532 while Present (Elmt) loop
534 E := Ultimate_Alias (Prim);
536 if not Is_Predefined_Dispatching_Operation (Prim)
537 and then Present (Interface_Alias (Prim))
538 and then Find_Dispatching_Type (Interface_Alias (Prim))
540 and then not Is_Abstract_Subprogram (E)
541 and then not Is_Eliminated (E)
542 and then Find_Dispatching_Type (E) = Typ
544 Prim_Pos := UI_To_Int (DT_Position (Prim));
546 -- Remember that this slot is already initialized
548 pragma Assert (Prims_Table (Prim_Pos) = False);
549 Prims_Table (Prim_Pos) := True;
552 Make_Assignment_Statement (Loc,
554 Make_Indexed_Component (Loc,
556 Make_Explicit_Dereference (Loc,
560 (Access_Disp_Table (Iface))),
561 New_Reference_To (Typ_Tag, Loc))),
564 (Make_Integer_Literal (Loc, Prim_Pos))),
567 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
568 Make_Attribute_Reference (Loc,
569 Prefix => New_Reference_To (E, Loc),
571 Name_Unrestricted_Access))));
577 -- Check if all primitives from the parent have been
578 -- overridden (to avoid copying the whole secondary
579 -- table from the parent).
581 -- IfaceG!(Typ_Sec_Tag).all := IfaceG!(Parent_Sec_Tag).all;
583 for J in Prims_Table'Range loop
584 if not Prims_Table (J) then
585 Insert_After (Last_Nod,
586 Make_Assignment_Statement (Loc,
588 Make_Explicit_Dereference (Loc,
590 (Node (Last_Elmt (Access_Disp_Table (Iface))),
591 New_Reference_To (Typ_Tag, Loc))),
593 Make_Explicit_Dereference (Loc,
595 (Node (Last_Elmt (Access_Disp_Table (Iface))),
596 New_Reference_To (Parent_Tag, Loc)))));
603 Next_Elmt (Typ_Iface_Tag_Elmt);
604 Next_Elmt (Parent_Iface_Tag_Elmt);
609 end Build_Inherit_CPP_Prims;
611 -------------------------
612 -- Build_Inherit_Prims --
613 -------------------------
615 function Build_Inherit_Prims
618 Old_Tag_Node : Node_Id;
619 New_Tag_Node : Node_Id;
620 Num_Prims : Nat) return Node_Id
623 if RTE_Available (RE_DT) then
625 Make_Assignment_Statement (Loc,
629 Make_Selected_Component (Loc,
631 Build_DT (Loc, New_Tag_Node),
634 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
637 Low_Bound => Make_Integer_Literal (Loc, 1),
638 High_Bound => Make_Integer_Literal (Loc, Num_Prims))),
643 Make_Selected_Component (Loc,
645 Build_DT (Loc, Old_Tag_Node),
648 (RTE_Record_Component (RE_Prims_Ptr), Loc)),
651 Low_Bound => Make_Integer_Literal (Loc, 1),
652 High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
655 Make_Assignment_Statement (Loc,
660 (Node (Last_Elmt (Access_Disp_Table (Typ))),
664 Low_Bound => Make_Integer_Literal (Loc, 1),
665 High_Bound => Make_Integer_Literal (Loc, Num_Prims))),
671 (Node (Last_Elmt (Access_Disp_Table (Typ))),
675 Low_Bound => Make_Integer_Literal (Loc, 1),
676 High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
678 end Build_Inherit_Prims;
680 -------------------------------
681 -- Build_Get_Prim_Op_Address --
682 -------------------------------
684 procedure Build_Get_Prim_Op_Address
688 Tag_Node : in out Node_Id;
689 New_Node : out Node_Id)
691 New_Prefix : Node_Id;
695 (Position <= DT_Entry_Count (First_Tag_Component (Typ)));
697 -- At the end of the Access_Disp_Table list we have the type
698 -- declaration required to convert the tag into a pointer to
699 -- the prims_ptr table (see Freeze_Record_Type).
703 (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node);
705 -- Unchecked_Convert_To relocates the controlling tag node and therefore
706 -- we must update it.
708 Tag_Node := Expression (New_Prefix);
711 Make_Indexed_Component (Loc,
712 Prefix => New_Prefix,
713 Expressions => New_List (Make_Integer_Literal (Loc, Position)));
714 end Build_Get_Prim_Op_Address;
716 -----------------------------
717 -- Build_Get_Transportable --
718 -----------------------------
720 function Build_Get_Transportable
722 Tag_Node : Node_Id) return Node_Id
726 Make_Selected_Component (Loc,
729 Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
732 (RTE_Record_Component (RE_Transportable), Loc));
733 end Build_Get_Transportable;
735 ------------------------------------
736 -- Build_Inherit_Predefined_Prims --
737 ------------------------------------
739 function Build_Inherit_Predefined_Prims
741 Old_Tag_Node : Node_Id;
742 New_Tag_Node : Node_Id) return Node_Id
746 Make_Assignment_Statement (Loc,
750 Make_Explicit_Dereference (Loc,
751 Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
752 Make_Explicit_Dereference (Loc,
753 Unchecked_Convert_To (RTE (RE_Addr_Ptr),
755 Discrete_Range => Make_Range (Loc,
756 Make_Integer_Literal (Loc, Uint_1),
757 New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
762 Make_Explicit_Dereference (Loc,
763 Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
764 Make_Explicit_Dereference (Loc,
765 Unchecked_Convert_To (RTE (RE_Addr_Ptr),
769 Make_Integer_Literal (Loc, 1),
770 New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
771 end Build_Inherit_Predefined_Prims;
773 -------------------------
774 -- Build_Offset_To_Top --
775 -------------------------
777 function Build_Offset_To_Top
779 This_Node : Node_Id) return Node_Id
785 Make_Explicit_Dereference (Loc,
786 Unchecked_Convert_To (RTE (RE_Tag_Ptr), This_Node));
789 Make_Explicit_Dereference (Loc,
790 Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr),
791 Make_Function_Call (Loc,
793 Make_Expanded_Name (Loc,
794 Chars => Name_Op_Subtract,
797 (RTU_Entity (System_Storage_Elements), Loc),
798 Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)),
799 Parameter_Associations => New_List (
800 Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
802 (RTE (RE_DT_Offset_To_Top_Offset), Loc)))));
803 end Build_Offset_To_Top;
805 ------------------------------------------
806 -- Build_Set_Predefined_Prim_Op_Address --
807 ------------------------------------------
809 function Build_Set_Predefined_Prim_Op_Address
813 Address_Node : Node_Id) return Node_Id
817 Make_Assignment_Statement (Loc,
819 Make_Indexed_Component (Loc,
821 Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
822 Make_Explicit_Dereference (Loc,
823 Unchecked_Convert_To (RTE (RE_Addr_Ptr), Tag_Node))),
825 New_List (Make_Integer_Literal (Loc, Position))),
827 Expression => Address_Node);
828 end Build_Set_Predefined_Prim_Op_Address;
830 -------------------------------
831 -- Build_Set_Prim_Op_Address --
832 -------------------------------
834 function Build_Set_Prim_Op_Address
839 Address_Node : Node_Id) return Node_Id
841 Ctrl_Tag : Node_Id := Tag_Node;
845 Build_Get_Prim_Op_Address (Loc, Typ, Position, Ctrl_Tag, New_Node);
848 Make_Assignment_Statement (Loc,
850 Expression => Address_Node);
851 end Build_Set_Prim_Op_Address;
853 -----------------------------
854 -- Build_Set_Size_Function --
855 -----------------------------
857 function Build_Set_Size_Function
860 Size_Func : Entity_Id) return Node_Id is
862 pragma Assert (Chars (Size_Func) = Name_uSize
863 and then RTE_Record_Component_Available (RE_Size_Func));
865 Make_Assignment_Statement (Loc,
867 Make_Selected_Component (Loc,
870 Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
873 (RTE_Record_Component (RE_Size_Func), Loc)),
875 Unchecked_Convert_To (RTE (RE_Size_Ptr),
876 Make_Attribute_Reference (Loc,
877 Prefix => New_Reference_To (Size_Func, Loc),
878 Attribute_Name => Name_Unrestricted_Access)));
879 end Build_Set_Size_Function;
881 ------------------------------------
882 -- Build_Set_Static_Offset_To_Top --
883 ------------------------------------
885 function Build_Set_Static_Offset_To_Top
888 Offset_Value : Node_Id) return Node_Id is
891 Make_Assignment_Statement (Loc,
892 Make_Explicit_Dereference (Loc,
893 Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr),
894 Make_Function_Call (Loc,
896 Make_Expanded_Name (Loc,
897 Chars => Name_Op_Subtract,
900 (RTU_Entity (System_Storage_Elements), Loc),
901 Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)),
902 Parameter_Associations => New_List (
903 Unchecked_Convert_To (RTE (RE_Address), Iface_Tag),
905 (RTE (RE_DT_Offset_To_Top_Offset), Loc))))),
907 end Build_Set_Static_Offset_To_Top;
915 Tag_Node_Addr : Node_Id) return Node_Id is
918 Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr),
919 Make_Explicit_Dereference (Loc,
920 Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr),
921 Make_Function_Call (Loc,
923 Make_Expanded_Name (Loc,
924 Chars => Name_Op_Subtract,
927 (RTU_Entity (System_Storage_Elements), Loc),
928 Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)),
930 Parameter_Associations => New_List (
933 (RTE (RE_DT_Typeinfo_Ptr_Size), Loc))))));