1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2006-2021, 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 not Present (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);