1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2006-2023, 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 Einfo
.Entities
; use Einfo
.Entities
;
29 with Einfo
.Utils
; use Einfo
.Utils
;
30 with Elists
; use Elists
;
31 with Exp_Disp
; use Exp_Disp
;
32 with Namet
; use Namet
;
33 with Nlists
; use Nlists
;
34 with Nmake
; use Nmake
;
36 with Rtsfind
; use Rtsfind
;
37 with Sinfo
; use Sinfo
;
38 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
39 with Sem_Aux
; use Sem_Aux
;
40 with Sem_Disp
; use Sem_Disp
;
41 with Sem_Util
; use Sem_Util
;
42 with Stand
; use Stand
;
43 with Snames
; use Snames
;
44 with Tbuild
; use Tbuild
;
46 package body Exp_Atag
is
48 -----------------------
49 -- Local Subprograms --
50 -----------------------
54 Tag_Node
: Node_Id
) return Node_Id
;
55 -- Build code that displaces the Tag to reference the base of the wrapper
59 -- To_Dispatch_Table_Ptr
60 -- (To_Address (Tag_Node) - Tag_Node.Prims_Ptr'Position);
62 function Build_Range
(Loc
: Source_Ptr
; Lo
, Hi
: Nat
) return Node_Id
;
63 -- Build an N_Range node for [Lo; Hi] with Standard.Natural type
67 Tag_Node_Addr
: Node_Id
) return Node_Id
;
68 -- Build code that retrieves the address of the record containing the Type
69 -- Specific Data generated by GNAT.
71 -- Generate: To_Type_Specific_Data_Ptr
72 -- (To_Addr_Ptr (Tag_Node_Addr - Typeinfo_Offset).all);
74 function Build_Val
(Loc
: Source_Ptr
; V
: Uint
) return Node_Id
;
75 -- Build an N_Integer_Literal node for V with Standard.Natural type
77 ------------------------------------------------
78 -- Build_Common_Dispatching_Select_Statements --
79 ------------------------------------------------
81 procedure Build_Common_Dispatching_Select_Statements
85 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
90 -- C := get_prim_op_kind (tag! (<type>VP), S);
92 -- where C is the out parameter capturing the call kind and S is the
93 -- dispatch table slot number.
95 if Tagged_Type_Expansion
then
97 Unchecked_Convert_To
(RTE
(RE_Tag
),
99 (Node
(First_Elmt
(Access_Disp_Table
(Typ
))), Loc
));
103 Make_Attribute_Reference
(Loc
,
104 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
105 Attribute_Name
=> Name_Tag
);
109 Make_Assignment_Statement
(Loc
,
110 Name
=> Make_Identifier
(Loc
, Name_uC
),
112 Make_Function_Call
(Loc
,
114 New_Occurrence_Of
(RTE
(RE_Get_Prim_Op_Kind
), Loc
),
115 Parameter_Associations
=> New_List
(
117 Make_Identifier
(Loc
, Name_uS
)))));
121 -- if C = POK_Procedure
122 -- or else C = POK_Protected_Procedure
123 -- or else C = POK_Task_Procedure;
128 -- where F is the out parameter capturing the status of a potential
132 Make_If_Statement
(Loc
,
138 Left_Opnd
=> Make_Identifier
(Loc
, Name_uC
),
140 New_Occurrence_Of
(RTE
(RE_POK_Procedure
), Loc
)),
145 Left_Opnd
=> Make_Identifier
(Loc
, Name_uC
),
148 (RTE
(RE_POK_Protected_Procedure
), Loc
)),
151 Left_Opnd
=> Make_Identifier
(Loc
, Name_uC
),
154 (RTE
(RE_POK_Task_Procedure
), Loc
)))),
158 Make_Assignment_Statement
(Loc
,
159 Name
=> Make_Identifier
(Loc
, Name_uF
),
160 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)),
161 Make_Simple_Return_Statement
(Loc
))));
162 end Build_Common_Dispatching_Select_Statements
;
170 Tag_Node
: Node_Id
) return Node_Id
174 Make_Function_Call
(Loc
,
175 Name
=> New_Occurrence_Of
(RTE
(RE_DT
), Loc
),
176 Parameter_Associations
=> New_List
(
177 Unchecked_Convert_To
(RTE
(RE_Tag
), Tag_Node
)));
180 ----------------------------
181 -- Build_Get_Access_Level --
182 ----------------------------
184 function Build_Get_Access_Level
186 Tag_Node
: Node_Id
) return Node_Id
190 Make_Selected_Component
(Loc
,
192 Make_Explicit_Dereference
(Loc
,
194 Unchecked_Convert_To
(RTE
(RE_Address
), Tag_Node
))),
197 (RTE_Record_Component
(RE_Access_Level
), Loc
));
198 end Build_Get_Access_Level
;
200 -------------------------
201 -- Build_Get_Alignment --
202 -------------------------
204 function Build_Get_Alignment
206 Tag_Node
: Node_Id
) return Node_Id
210 Make_Selected_Component
(Loc
,
212 Make_Explicit_Dereference
(Loc
,
214 Unchecked_Convert_To
(RTE
(RE_Address
), Tag_Node
))),
216 New_Occurrence_Of
(RTE_Record_Component
(RE_Alignment
), Loc
));
217 end Build_Get_Alignment
;
219 ------------------------------------------
220 -- Build_Get_Predefined_Prim_Op_Address --
221 ------------------------------------------
223 procedure Build_Get_Predefined_Prim_Op_Address
226 Tag_Node
: in out Node_Id
;
227 New_Node
: out Node_Id
)
232 Ctrl_Tag
:= Unchecked_Convert_To
(RTE
(RE_Address
), Tag_Node
);
234 -- Unchecked_Convert_To relocates the controlling tag node and therefore
235 -- we must update it.
237 Tag_Node
:= Expression
(Ctrl_Tag
);
239 -- Build code that retrieves the address of the dispatch table
240 -- containing the predefined Ada primitives:
243 -- To_Predef_Prims_Table_Ptr
244 -- (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all);
247 Make_Indexed_Component
(Loc
,
249 Unchecked_Convert_To
(RTE
(RE_Predef_Prims_Table_Ptr
),
250 Make_Explicit_Dereference
(Loc
,
251 Unchecked_Convert_To
(RTE
(RE_Addr_Ptr
),
252 Make_Function_Call
(Loc
,
254 Make_Expanded_Name
(Loc
,
255 Chars
=> Name_Op_Subtract
,
258 (RTU_Entity
(System_Storage_Elements
), Loc
),
260 Make_Identifier
(Loc
, Name_Op_Subtract
)),
261 Parameter_Associations
=> New_List
(
264 (RTE
(RE_DT_Predef_Prims_Offset
), Loc
)))))),
266 New_List
(Build_Val
(Loc
, Position
)));
267 end Build_Get_Predefined_Prim_Op_Address
;
269 -----------------------------
270 -- Build_Inherit_CPP_Prims --
271 -----------------------------
273 function Build_Inherit_CPP_Prims
(Typ
: Entity_Id
) return List_Id
is
274 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
275 CPP_Nb_Prims
: constant Nat
:= CPP_Num_Prims
(Typ
);
276 CPP_Table
: array (1 .. CPP_Nb_Prims
) of Boolean := (others => False);
277 CPP_Typ
: constant Entity_Id
:= Enclosing_CPP_Parent
(Typ
);
278 Result
: constant List_Id
:= New_List
;
279 Parent_Typ
: constant Entity_Id
:= Etype
(Typ
);
282 Parent_Tag
: Entity_Id
;
288 pragma Assert
(not Is_CPP_Class
(Typ
));
290 -- No code needed if this type has no primitives inherited from C++
292 if CPP_Nb_Prims
= 0 then
296 -- Stage 1: Inherit and override C++ slots of the primary dispatch table
299 -- Typ'Tag (Prim_Pos) := Prim'Unrestricted_Access;
301 Parent_Tag
:= Node
(First_Elmt
(Access_Disp_Table
(Parent_Typ
)));
302 Typ_Tag
:= Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
304 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
305 while Present
(Elmt
) loop
307 E
:= Ultimate_Alias
(Prim
);
308 Prim_Pos
:= UI_To_Int
(DT_Position
(E
));
310 -- Skip predefined, abstract, and eliminated primitives. Skip also
311 -- primitives not located in the C++ part of the dispatch table.
313 if not Is_Predefined_Dispatching_Operation
(Prim
)
314 and then not Is_Predefined_Dispatching_Operation
(E
)
315 and then No
(Interface_Alias
(Prim
))
316 and then not Is_Abstract_Subprogram
(E
)
317 and then not Is_Eliminated
(E
)
318 and then Prim_Pos
<= CPP_Nb_Prims
319 and then Find_Dispatching_Type
(E
) = Typ
321 -- Remember that this slot is used
323 pragma Assert
(CPP_Table
(Prim_Pos
) = False);
324 CPP_Table
(Prim_Pos
) := True;
327 Make_Assignment_Statement
(Loc
,
329 Make_Indexed_Component
(Loc
,
331 Make_Explicit_Dereference
(Loc
,
333 (Node
(Last_Elmt
(Access_Disp_Table
(Typ
))),
334 New_Occurrence_Of
(Typ_Tag
, Loc
))),
336 New_List
(Build_Val
(Loc
, UI_From_Int
(Prim_Pos
)))),
339 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
340 Make_Attribute_Reference
(Loc
,
341 Prefix
=> New_Occurrence_Of
(E
, Loc
),
342 Attribute_Name
=> Name_Unrestricted_Access
))));
348 -- If all primitives have been overridden then there is no need to copy
349 -- from Typ's parent its dispatch table. Otherwise, if some primitive is
350 -- inherited from the parent we copy only the C++ part of the dispatch
351 -- table from the parent before the assignments that initialize the
352 -- overridden primitives.
356 -- type CPP_TypG is array (1 .. CPP_Nb_Prims) ofd Prim_Ptr;
357 -- type CPP_TypH is access CPP_TypG;
358 -- CPP_TypG!(Typ_Tag).all := CPP_TypG!(Parent_Tag).all;
360 -- Note: There is no need to duplicate the declarations of CPP_TypG and
361 -- CPP_TypH because, for expansion of dispatching calls, these
362 -- entities are stored in the last elements of Access_Disp_Table.
364 for J
in CPP_Table
'Range loop
365 if not CPP_Table
(J
) then
367 Make_Assignment_Statement
(Loc
,
369 Make_Explicit_Dereference
(Loc
,
371 (Node
(Last_Elmt
(Access_Disp_Table
(CPP_Typ
))),
372 New_Occurrence_Of
(Typ_Tag
, Loc
))),
374 Make_Explicit_Dereference
(Loc
,
376 (Node
(Last_Elmt
(Access_Disp_Table
(CPP_Typ
))),
377 New_Occurrence_Of
(Parent_Tag
, Loc
)))));
382 -- Stage 2: Inherit and override C++ slots of secondary dispatch tables
386 Iface_Nb_Prims
: Nat
;
387 Parent_Ifaces_List
: Elist_Id
;
388 Parent_Ifaces_Comp_List
: Elist_Id
;
389 Parent_Ifaces_Tag_List
: Elist_Id
;
390 Parent_Iface_Tag_Elmt
: Elmt_Id
;
391 Typ_Ifaces_List
: Elist_Id
;
392 Typ_Ifaces_Comp_List
: Elist_Id
;
393 Typ_Ifaces_Tag_List
: Elist_Id
;
394 Typ_Iface_Tag_Elmt
: Elmt_Id
;
397 Collect_Interfaces_Info
399 Ifaces_List
=> Parent_Ifaces_List
,
400 Components_List
=> Parent_Ifaces_Comp_List
,
401 Tags_List
=> Parent_Ifaces_Tag_List
);
403 Collect_Interfaces_Info
405 Ifaces_List
=> Typ_Ifaces_List
,
406 Components_List
=> Typ_Ifaces_Comp_List
,
407 Tags_List
=> Typ_Ifaces_Tag_List
);
409 Parent_Iface_Tag_Elmt
:= First_Elmt
(Parent_Ifaces_Tag_List
);
410 Typ_Iface_Tag_Elmt
:= First_Elmt
(Typ_Ifaces_Tag_List
);
411 while Present
(Parent_Iface_Tag_Elmt
) loop
412 Parent_Tag
:= Node
(Parent_Iface_Tag_Elmt
);
413 Typ_Tag
:= Node
(Typ_Iface_Tag_Elmt
);
416 (Related_Type
(Parent_Tag
) = Related_Type
(Typ_Tag
));
417 Iface
:= Related_Type
(Parent_Tag
);
420 UI_To_Int
(DT_Entry_Count
(First_Tag_Component
(Iface
)));
422 if Iface_Nb_Prims
> 0 then
424 -- Update slots of overridden primitives
427 Last_Nod
: constant Node_Id
:= Last
(Result
);
428 Nb_Prims
: constant Nat
:= UI_To_Int
430 (First_Tag_Component
(Iface
)));
436 Prims_Table
: array (1 .. Nb_Prims
) of Boolean;
439 Prims_Table
:= (others => False);
441 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
442 while Present
(Elmt
) loop
444 E
:= Ultimate_Alias
(Prim
);
446 if not Is_Predefined_Dispatching_Operation
(Prim
)
447 and then Present
(Interface_Alias
(Prim
))
448 and then Find_Dispatching_Type
(Interface_Alias
(Prim
))
450 and then not Is_Abstract_Subprogram
(E
)
451 and then not Is_Eliminated
(E
)
452 and then Find_Dispatching_Type
(E
) = Typ
454 Prim_Pos
:= UI_To_Int
(DT_Position
(Prim
));
456 -- Remember that this slot is already initialized
458 pragma Assert
(Prims_Table
(Prim_Pos
) = False);
459 Prims_Table
(Prim_Pos
) := True;
462 Make_Assignment_Statement
(Loc
,
464 Make_Indexed_Component
(Loc
,
466 Make_Explicit_Dereference
(Loc
,
470 (Access_Disp_Table
(Iface
))),
471 New_Occurrence_Of
(Typ_Tag
, Loc
))),
474 (Build_Val
(Loc
, UI_From_Int
(Prim_Pos
)))),
477 Unchecked_Convert_To
(RTE
(RE_Prim_Ptr
),
478 Make_Attribute_Reference
(Loc
,
479 Prefix
=> New_Occurrence_Of
(E
, Loc
),
481 Name_Unrestricted_Access
))));
487 -- Check if all primitives from the parent have been
488 -- overridden (to avoid copying the whole secondary
489 -- table from the parent).
491 -- IfaceG!(Typ_Sec_Tag).all := IfaceG!(Parent_Sec_Tag).all;
493 for J
in Prims_Table
'Range loop
494 if not Prims_Table
(J
) then
495 Insert_After
(Last_Nod
,
496 Make_Assignment_Statement
(Loc
,
498 Make_Explicit_Dereference
(Loc
,
500 (Node
(Last_Elmt
(Access_Disp_Table
(Iface
))),
501 New_Occurrence_Of
(Typ_Tag
, Loc
))),
503 Make_Explicit_Dereference
(Loc
,
505 (Node
(Last_Elmt
(Access_Disp_Table
(Iface
))),
506 New_Occurrence_Of
(Parent_Tag
, Loc
)))));
513 Next_Elmt
(Typ_Iface_Tag_Elmt
);
514 Next_Elmt
(Parent_Iface_Tag_Elmt
);
519 end Build_Inherit_CPP_Prims
;
521 -------------------------
522 -- Build_Inherit_Prims --
523 -------------------------
525 function Build_Inherit_Prims
528 Old_Tag_Node
: Node_Id
;
529 New_Tag_Node
: Node_Id
;
530 Num_Prims
: Nat
) return Node_Id
533 if RTE_Available
(RE_DT
) then
535 Make_Assignment_Statement
(Loc
,
539 Make_Selected_Component
(Loc
,
541 Make_Explicit_Dereference
(Loc
,
542 Build_DT
(Loc
, New_Tag_Node
)),
545 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
547 Build_Range
(Loc
, 1, Num_Prims
)),
552 Make_Selected_Component
(Loc
,
554 Make_Explicit_Dereference
(Loc
,
555 Build_DT
(Loc
, Old_Tag_Node
)),
558 (RTE_Record_Component
(RE_Prims_Ptr
), Loc
)),
560 Build_Range
(Loc
, 1, Num_Prims
)));
563 Make_Assignment_Statement
(Loc
,
568 (Node
(Last_Elmt
(Access_Disp_Table
(Typ
))),
571 Build_Range
(Loc
, 1, Num_Prims
)),
577 (Node
(Last_Elmt
(Access_Disp_Table
(Typ
))),
580 Build_Range
(Loc
, 1, Num_Prims
)));
582 end Build_Inherit_Prims
;
584 -------------------------------
585 -- Build_Get_Prim_Op_Address --
586 -------------------------------
588 procedure Build_Get_Prim_Op_Address
592 Tag_Node
: in out Node_Id
;
593 New_Node
: out Node_Id
)
595 New_Prefix
: Node_Id
;
599 (Position
<= DT_Entry_Count
(First_Tag_Component
(Typ
)));
601 -- At the end of the Access_Disp_Table list we have the type
602 -- declaration required to convert the tag into a pointer to
603 -- the prims_ptr table (see Freeze_Record_Type).
607 (Node
(Last_Elmt
(Access_Disp_Table
(Typ
))), Tag_Node
);
609 -- Unchecked_Convert_To relocates the controlling tag node and therefore
610 -- we must update it.
612 Tag_Node
:= Expression
(New_Prefix
);
615 Make_Indexed_Component
(Loc
,
616 Prefix
=> New_Prefix
,
617 Expressions
=> New_List
(Build_Val
(Loc
, Position
)));
618 end Build_Get_Prim_Op_Address
;
620 -----------------------------
621 -- Build_Get_Transportable --
622 -----------------------------
624 function Build_Get_Transportable
626 Tag_Node
: Node_Id
) return Node_Id
630 Make_Selected_Component
(Loc
,
632 Make_Explicit_Dereference
(Loc
,
634 Unchecked_Convert_To
(RTE
(RE_Address
), Tag_Node
))),
637 (RTE_Record_Component
(RE_Transportable
), Loc
));
638 end Build_Get_Transportable
;
640 ------------------------------------
641 -- Build_Inherit_Predefined_Prims --
642 ------------------------------------
644 function Build_Inherit_Predefined_Prims
646 Old_Tag_Node
: Node_Id
;
647 New_Tag_Node
: Node_Id
;
648 Num_Predef_Prims
: Nat
) return Node_Id
652 Make_Assignment_Statement
(Loc
,
656 Make_Explicit_Dereference
(Loc
,
657 Unchecked_Convert_To
(RTE
(RE_Predef_Prims_Table_Ptr
),
658 Make_Explicit_Dereference
(Loc
,
659 Unchecked_Convert_To
(RTE
(RE_Addr_Ptr
),
662 Build_Range
(Loc
, 1, Num_Predef_Prims
)),
667 Make_Explicit_Dereference
(Loc
,
668 Unchecked_Convert_To
(RTE
(RE_Predef_Prims_Table_Ptr
),
669 Make_Explicit_Dereference
(Loc
,
670 Unchecked_Convert_To
(RTE
(RE_Addr_Ptr
),
673 Build_Range
(Loc
, 1, Num_Predef_Prims
)));
674 end Build_Inherit_Predefined_Prims
;
676 -------------------------
677 -- Build_Offset_To_Top --
678 -------------------------
680 function Build_Offset_To_Top
682 This_Node
: Node_Id
) return Node_Id
688 Make_Explicit_Dereference
(Loc
,
689 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
), This_Node
));
692 Make_Explicit_Dereference
(Loc
,
693 Unchecked_Convert_To
(RTE
(RE_Offset_To_Top_Ptr
),
694 Make_Function_Call
(Loc
,
696 Make_Expanded_Name
(Loc
,
697 Chars
=> Name_Op_Subtract
,
700 (RTU_Entity
(System_Storage_Elements
), Loc
),
701 Selector_Name
=> Make_Identifier
(Loc
, Name_Op_Subtract
)),
702 Parameter_Associations
=> New_List
(
703 Unchecked_Convert_To
(RTE
(RE_Address
), Tag_Node
),
705 (RTE
(RE_DT_Offset_To_Top_Offset
), Loc
)))));
706 end Build_Offset_To_Top
;
712 function Build_Range
(Loc
: Source_Ptr
; Lo
, Hi
: Nat
) return Node_Id
is
718 Low_Bound
=> Build_Val
(Loc
, UI_From_Int
(Lo
)),
719 High_Bound
=> Build_Val
(Loc
, UI_From_Int
(Hi
)));
720 Set_Etype
(Result
, Standard_Natural
);
721 Set_Analyzed
(Result
);
725 ------------------------------------------
726 -- Build_Set_Predefined_Prim_Op_Address --
727 ------------------------------------------
729 function Build_Set_Predefined_Prim_Op_Address
733 Address_Node
: Node_Id
) return Node_Id
737 Make_Assignment_Statement
(Loc
,
739 Make_Indexed_Component
(Loc
,
741 Unchecked_Convert_To
(RTE
(RE_Predef_Prims_Table_Ptr
),
742 Make_Explicit_Dereference
(Loc
,
743 Unchecked_Convert_To
(RTE
(RE_Addr_Ptr
), Tag_Node
))),
745 New_List
(Build_Val
(Loc
, Position
))),
747 Expression
=> Address_Node
);
748 end Build_Set_Predefined_Prim_Op_Address
;
750 -------------------------------
751 -- Build_Set_Prim_Op_Address --
752 -------------------------------
754 function Build_Set_Prim_Op_Address
759 Address_Node
: Node_Id
) return Node_Id
761 Ctrl_Tag
: Node_Id
:= Tag_Node
;
765 Build_Get_Prim_Op_Address
(Loc
, Typ
, Position
, Ctrl_Tag
, New_Node
);
768 Make_Assignment_Statement
(Loc
,
770 Expression
=> Address_Node
);
771 end Build_Set_Prim_Op_Address
;
773 -----------------------------
774 -- Build_Set_Size_Function --
775 -----------------------------
777 function Build_Set_Size_Function
780 Size_Func
: Entity_Id
) return Node_Id
is
782 pragma Assert
(Chars
(Size_Func
) = Name_uSize
783 and then RTE_Record_Component_Available
(RE_Size_Func
));
785 Make_Assignment_Statement
(Loc
,
787 Make_Selected_Component
(Loc
,
789 Make_Explicit_Dereference
(Loc
,
791 Unchecked_Convert_To
(RTE
(RE_Address
), Tag_Node
))),
794 (RTE_Record_Component
(RE_Size_Func
), Loc
)),
796 Unchecked_Convert_To
(RTE
(RE_Size_Ptr
),
797 Make_Attribute_Reference
(Loc
,
798 Prefix
=> New_Occurrence_Of
(Size_Func
, Loc
),
799 Attribute_Name
=> Name_Unrestricted_Access
)));
800 end Build_Set_Size_Function
;
802 ------------------------------------
803 -- Build_Set_Static_Offset_To_Top --
804 ------------------------------------
806 function Build_Set_Static_Offset_To_Top
809 Offset_Value
: Node_Id
) return Node_Id
is
812 Make_Assignment_Statement
(Loc
,
813 Make_Explicit_Dereference
(Loc
,
814 Unchecked_Convert_To
(RTE
(RE_Offset_To_Top_Ptr
),
815 Make_Function_Call
(Loc
,
817 Make_Expanded_Name
(Loc
,
818 Chars
=> Name_Op_Subtract
,
821 (RTU_Entity
(System_Storage_Elements
), Loc
),
822 Selector_Name
=> Make_Identifier
(Loc
, Name_Op_Subtract
)),
823 Parameter_Associations
=> New_List
(
824 Unchecked_Convert_To
(RTE
(RE_Address
), Iface_Tag
),
826 (RTE
(RE_DT_Offset_To_Top_Offset
), Loc
))))),
828 end Build_Set_Static_Offset_To_Top
;
836 Tag_Node_Addr
: Node_Id
) return Node_Id
is
839 Unchecked_Convert_To
(RTE
(RE_Type_Specific_Data_Ptr
),
840 Make_Explicit_Dereference
(Loc
,
841 Prefix
=> Unchecked_Convert_To
(RTE
(RE_Addr_Ptr
),
842 Make_Function_Call
(Loc
,
844 Make_Expanded_Name
(Loc
,
845 Chars
=> Name_Op_Subtract
,
848 (RTU_Entity
(System_Storage_Elements
), Loc
),
849 Selector_Name
=> Make_Identifier
(Loc
, Name_Op_Subtract
)),
851 Parameter_Associations
=> New_List
(
854 (RTE
(RE_DT_Typeinfo_Ptr_Size
), Loc
))))));
861 function Build_Val
(Loc
: Source_Ptr
; V
: Uint
) return Node_Id
is
865 Result
:= Make_Integer_Literal
(Loc
, V
);
866 Set_Etype
(Result
, Standard_Natural
);
867 Set_Is_Static_Expression
(Result
);
868 Set_Analyzed
(Result
);