1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ A T A G -- 6-- -- 7-- S p e c -- 8-- -- 9-- Copyright (C) 2006-2019, Free Software Foundation, Inc. -- 10-- -- 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. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Einfo; use Einfo; 28with Elists; use Elists; 29with Exp_Disp; use Exp_Disp; 30with Exp_Util; use Exp_Util; 31with Namet; use Namet; 32with Nlists; use Nlists; 33with Nmake; use Nmake; 34with Opt; use Opt; 35with Rtsfind; use Rtsfind; 36with Sinfo; use Sinfo; 37with Sem_Aux; use Sem_Aux; 38with Sem_Disp; use Sem_Disp; 39with Sem_Util; use Sem_Util; 40with Stand; use Stand; 41with Snames; use Snames; 42with Tbuild; use Tbuild; 43 44package body Exp_Atag is 45 46 ----------------------- 47 -- Local Subprograms -- 48 ----------------------- 49 50 function Build_DT 51 (Loc : Source_Ptr; 52 Tag_Node : Node_Id) return Node_Id; 53 -- Build code that displaces the Tag to reference the base of the wrapper 54 -- record 55 -- 56 -- Generates: 57 -- To_Dispatch_Table_Ptr 58 -- (To_Address (Tag_Node) - Tag_Node.Prims_Ptr'Position); 59 60 function Build_TSD 61 (Loc : Source_Ptr; 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. 65 -- 66 -- Generate: To_Type_Specific_Data_Ptr 67 -- (To_Addr_Ptr (Tag_Node_Addr - Typeinfo_Offset).all); 68 69 ------------------------------------------------ 70 -- Build_Common_Dispatching_Select_Statements -- 71 ------------------------------------------------ 72 73 procedure Build_Common_Dispatching_Select_Statements 74 (Typ : Entity_Id; 75 Stmts : List_Id) 76 is 77 Loc : constant Source_Ptr := Sloc (Typ); 78 Tag_Node : Node_Id; 79 80 begin 81 -- Generate: 82 -- C := get_prim_op_kind (tag! (<type>VP), S); 83 84 -- where C is the out parameter capturing the call kind and S is the 85 -- dispatch table slot number. 86 87 if Tagged_Type_Expansion then 88 Tag_Node := 89 Unchecked_Convert_To (RTE (RE_Tag), 90 New_Occurrence_Of 91 (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)); 92 93 else 94 Tag_Node := 95 Make_Attribute_Reference (Loc, 96 Prefix => New_Occurrence_Of (Typ, Loc), 97 Attribute_Name => Name_Tag); 98 end if; 99 100 Append_To (Stmts, 101 Make_Assignment_Statement (Loc, 102 Name => Make_Identifier (Loc, Name_uC), 103 Expression => 104 Make_Function_Call (Loc, 105 Name => 106 New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc), 107 Parameter_Associations => New_List ( 108 Tag_Node, 109 Make_Identifier (Loc, Name_uS))))); 110 111 -- Generate: 112 113 -- if C = POK_Procedure 114 -- or else C = POK_Protected_Procedure 115 -- or else C = POK_Task_Procedure; 116 -- then 117 -- F := True; 118 -- return; 119 120 -- where F is the out parameter capturing the status of a potential 121 -- entry call. 122 123 Append_To (Stmts, 124 Make_If_Statement (Loc, 125 126 Condition => 127 Make_Or_Else (Loc, 128 Left_Opnd => 129 Make_Op_Eq (Loc, 130 Left_Opnd => Make_Identifier (Loc, Name_uC), 131 Right_Opnd => 132 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)), 133 Right_Opnd => 134 Make_Or_Else (Loc, 135 Left_Opnd => 136 Make_Op_Eq (Loc, 137 Left_Opnd => Make_Identifier (Loc, Name_uC), 138 Right_Opnd => 139 New_Occurrence_Of 140 (RTE (RE_POK_Protected_Procedure), Loc)), 141 Right_Opnd => 142 Make_Op_Eq (Loc, 143 Left_Opnd => Make_Identifier (Loc, Name_uC), 144 Right_Opnd => 145 New_Occurrence_Of 146 (RTE (RE_POK_Task_Procedure), Loc)))), 147 148 Then_Statements => 149 New_List ( 150 Make_Assignment_Statement (Loc, 151 Name => Make_Identifier (Loc, Name_uF), 152 Expression => New_Occurrence_Of (Standard_True, Loc)), 153 Make_Simple_Return_Statement (Loc)))); 154 end Build_Common_Dispatching_Select_Statements; 155 156 ------------------------- 157 -- Build_CW_Membership -- 158 ------------------------- 159 160 procedure Build_CW_Membership 161 (Loc : Source_Ptr; 162 Obj_Tag_Node : in out Node_Id; 163 Typ_Tag_Node : Node_Id; 164 Related_Nod : Node_Id; 165 New_Node : out Node_Id) 166 is 167 Tag_Addr : constant Entity_Id := Make_Temporary (Loc, 'D', Obj_Tag_Node); 168 Obj_TSD : constant Entity_Id := Make_Temporary (Loc, 'D'); 169 Typ_TSD : constant Entity_Id := Make_Temporary (Loc, 'D'); 170 Index : constant Entity_Id := Make_Temporary (Loc, 'D'); 171 172 begin 173 -- Generate: 174 175 -- Tag_Addr : constant Tag := Address!(Obj_Tag); 176 -- Obj_TSD : constant Type_Specific_Data_Ptr 177 -- := Build_TSD (Tag_Addr); 178 -- Typ_TSD : constant Type_Specific_Data_Ptr 179 -- := Build_TSD (Address!(Typ_Tag)); 180 -- Index : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth 181 -- Index >= 0 and then Obj_TSD.Tags_Table (Index) = Typ'Tag 182 183 Insert_Action (Related_Nod, 184 Make_Object_Declaration (Loc, 185 Defining_Identifier => Tag_Addr, 186 Constant_Present => True, 187 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc), 188 Expression => Unchecked_Convert_To 189 (RTE (RE_Address), Obj_Tag_Node))); 190 191 -- Unchecked_Convert_To relocates Obj_Tag_Node and therefore we must 192 -- update it. 193 194 Obj_Tag_Node := Expression (Expression (Parent (Tag_Addr))); 195 196 Insert_Action (Related_Nod, 197 Make_Object_Declaration (Loc, 198 Defining_Identifier => Obj_TSD, 199 Constant_Present => True, 200 Object_Definition => 201 New_Occurrence_Of (RTE (RE_Type_Specific_Data_Ptr), Loc), 202 Expression => 203 Build_TSD (Loc, New_Occurrence_Of (Tag_Addr, Loc))), 204 Suppress => All_Checks); 205 206 Insert_Action (Related_Nod, 207 Make_Object_Declaration (Loc, 208 Defining_Identifier => Typ_TSD, 209 Constant_Present => True, 210 Object_Definition => 211 New_Occurrence_Of (RTE (RE_Type_Specific_Data_Ptr), Loc), 212 Expression => 213 Build_TSD (Loc, 214 Unchecked_Convert_To (RTE (RE_Address), Typ_Tag_Node))), 215 Suppress => All_Checks); 216 217 Insert_Action (Related_Nod, 218 Make_Object_Declaration (Loc, 219 Defining_Identifier => Index, 220 Constant_Present => True, 221 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 222 Expression => 223 Make_Op_Subtract (Loc, 224 Left_Opnd => 225 Make_Selected_Component (Loc, 226 Prefix => New_Occurrence_Of (Obj_TSD, Loc), 227 Selector_Name => 228 New_Occurrence_Of 229 (RTE_Record_Component (RE_Idepth), Loc)), 230 231 Right_Opnd => 232 Make_Selected_Component (Loc, 233 Prefix => New_Occurrence_Of (Typ_TSD, Loc), 234 Selector_Name => 235 New_Occurrence_Of 236 (RTE_Record_Component (RE_Idepth), Loc)))), 237 Suppress => All_Checks); 238 239 New_Node := 240 Make_And_Then (Loc, 241 Left_Opnd => 242 Make_Op_Ge (Loc, 243 Left_Opnd => New_Occurrence_Of (Index, Loc), 244 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), 245 246 Right_Opnd => 247 Make_Op_Eq (Loc, 248 Left_Opnd => 249 Make_Indexed_Component (Loc, 250 Prefix => 251 Make_Selected_Component (Loc, 252 Prefix => New_Occurrence_Of (Obj_TSD, Loc), 253 Selector_Name => 254 New_Occurrence_Of 255 (RTE_Record_Component (RE_Tags_Table), Loc)), 256 Expressions => 257 New_List (New_Occurrence_Of (Index, Loc))), 258 259 Right_Opnd => Typ_Tag_Node)); 260 end Build_CW_Membership; 261 262 -------------- 263 -- Build_DT -- 264 -------------- 265 266 function Build_DT 267 (Loc : Source_Ptr; 268 Tag_Node : Node_Id) return Node_Id 269 is 270 begin 271 return 272 Make_Function_Call (Loc, 273 Name => New_Occurrence_Of (RTE (RE_DT), Loc), 274 Parameter_Associations => New_List ( 275 Unchecked_Convert_To (RTE (RE_Tag), Tag_Node))); 276 end Build_DT; 277 278 ---------------------------- 279 -- Build_Get_Access_Level -- 280 ---------------------------- 281 282 function Build_Get_Access_Level 283 (Loc : Source_Ptr; 284 Tag_Node : Node_Id) return Node_Id 285 is 286 begin 287 return 288 Make_Selected_Component (Loc, 289 Prefix => 290 Build_TSD (Loc, 291 Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), 292 Selector_Name => 293 New_Occurrence_Of 294 (RTE_Record_Component (RE_Access_Level), Loc)); 295 end Build_Get_Access_Level; 296 297 ------------------------- 298 -- Build_Get_Alignment -- 299 ------------------------- 300 301 function Build_Get_Alignment 302 (Loc : Source_Ptr; 303 Tag_Node : Node_Id) return Node_Id 304 is 305 begin 306 return 307 Make_Selected_Component (Loc, 308 Prefix => 309 Build_TSD (Loc, Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), 310 Selector_Name => 311 New_Occurrence_Of (RTE_Record_Component (RE_Alignment), Loc)); 312 end Build_Get_Alignment; 313 314 ------------------------------------------ 315 -- Build_Get_Predefined_Prim_Op_Address -- 316 ------------------------------------------ 317 318 procedure Build_Get_Predefined_Prim_Op_Address 319 (Loc : Source_Ptr; 320 Position : Uint; 321 Tag_Node : in out Node_Id; 322 New_Node : out Node_Id) 323 is 324 Ctrl_Tag : Node_Id; 325 326 begin 327 Ctrl_Tag := Unchecked_Convert_To (RTE (RE_Address), Tag_Node); 328 329 -- Unchecked_Convert_To relocates the controlling tag node and therefore 330 -- we must update it. 331 332 Tag_Node := Expression (Ctrl_Tag); 333 334 -- Build code that retrieves the address of the dispatch table 335 -- containing the predefined Ada primitives: 336 -- 337 -- Generate: 338 -- To_Predef_Prims_Table_Ptr 339 -- (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all); 340 341 New_Node := 342 Make_Indexed_Component (Loc, 343 Prefix => 344 Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), 345 Make_Explicit_Dereference (Loc, 346 Unchecked_Convert_To (RTE (RE_Addr_Ptr), 347 Make_Function_Call (Loc, 348 Name => 349 Make_Expanded_Name (Loc, 350 Chars => Name_Op_Subtract, 351 Prefix => 352 New_Occurrence_Of 353 (RTU_Entity (System_Storage_Elements), Loc), 354 Selector_Name => 355 Make_Identifier (Loc, Name_Op_Subtract)), 356 Parameter_Associations => New_List ( 357 Ctrl_Tag, 358 New_Occurrence_Of 359 (RTE (RE_DT_Predef_Prims_Offset), Loc)))))), 360 Expressions => 361 New_List (Make_Integer_Literal (Loc, Position))); 362 end Build_Get_Predefined_Prim_Op_Address; 363 364 ----------------------------- 365 -- Build_Inherit_CPP_Prims -- 366 ----------------------------- 367 368 function Build_Inherit_CPP_Prims (Typ : Entity_Id) return List_Id is 369 Loc : constant Source_Ptr := Sloc (Typ); 370 CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ); 371 CPP_Table : array (1 .. CPP_Nb_Prims) of Boolean := (others => False); 372 CPP_Typ : constant Entity_Id := Enclosing_CPP_Parent (Typ); 373 Result : constant List_Id := New_List; 374 Parent_Typ : constant Entity_Id := Etype (Typ); 375 E : Entity_Id; 376 Elmt : Elmt_Id; 377 Parent_Tag : Entity_Id; 378 Prim : Entity_Id; 379 Prim_Pos : Nat; 380 Typ_Tag : Entity_Id; 381 382 begin 383 pragma Assert (not Is_CPP_Class (Typ)); 384 385 -- No code needed if this type has no primitives inherited from C++ 386 387 if CPP_Nb_Prims = 0 then 388 return Result; 389 end if; 390 391 -- Stage 1: Inherit and override C++ slots of the primary dispatch table 392 393 -- Generate: 394 -- Typ'Tag (Prim_Pos) := Prim'Unrestricted_Access; 395 396 Parent_Tag := Node (First_Elmt (Access_Disp_Table (Parent_Typ))); 397 Typ_Tag := Node (First_Elmt (Access_Disp_Table (Typ))); 398 399 Elmt := First_Elmt (Primitive_Operations (Typ)); 400 while Present (Elmt) loop 401 Prim := Node (Elmt); 402 E := Ultimate_Alias (Prim); 403 Prim_Pos := UI_To_Int (DT_Position (E)); 404 405 -- Skip predefined, abstract, and eliminated primitives. Skip also 406 -- primitives not located in the C++ part of the dispatch table. 407 408 if not Is_Predefined_Dispatching_Operation (Prim) 409 and then not Is_Predefined_Dispatching_Operation (E) 410 and then not Present (Interface_Alias (Prim)) 411 and then not Is_Abstract_Subprogram (E) 412 and then not Is_Eliminated (E) 413 and then Prim_Pos <= CPP_Nb_Prims 414 and then Find_Dispatching_Type (E) = Typ 415 then 416 -- Remember that this slot is used 417 418 pragma Assert (CPP_Table (Prim_Pos) = False); 419 CPP_Table (Prim_Pos) := True; 420 421 Append_To (Result, 422 Make_Assignment_Statement (Loc, 423 Name => 424 Make_Indexed_Component (Loc, 425 Prefix => 426 Make_Explicit_Dereference (Loc, 427 Unchecked_Convert_To 428 (Node (Last_Elmt (Access_Disp_Table (Typ))), 429 New_Occurrence_Of (Typ_Tag, Loc))), 430 Expressions => 431 New_List (Make_Integer_Literal (Loc, Prim_Pos))), 432 433 Expression => 434 Unchecked_Convert_To (RTE (RE_Prim_Ptr), 435 Make_Attribute_Reference (Loc, 436 Prefix => New_Occurrence_Of (E, Loc), 437 Attribute_Name => Name_Unrestricted_Access)))); 438 end if; 439 440 Next_Elmt (Elmt); 441 end loop; 442 443 -- If all primitives have been overridden then there is no need to copy 444 -- from Typ's parent its dispatch table. Otherwise, if some primitive is 445 -- inherited from the parent we copy only the C++ part of the dispatch 446 -- table from the parent before the assignments that initialize the 447 -- overridden primitives. 448 449 -- Generate: 450 451 -- type CPP_TypG is array (1 .. CPP_Nb_Prims) ofd Prim_Ptr; 452 -- type CPP_TypH is access CPP_TypG; 453 -- CPP_TypG!(Typ_Tag).all := CPP_TypG!(Parent_Tag).all; 454 455 -- Note: There is no need to duplicate the declarations of CPP_TypG and 456 -- CPP_TypH because, for expansion of dispatching calls, these 457 -- entities are stored in the last elements of Access_Disp_Table. 458 459 for J in CPP_Table'Range loop 460 if not CPP_Table (J) then 461 Prepend_To (Result, 462 Make_Assignment_Statement (Loc, 463 Name => 464 Make_Explicit_Dereference (Loc, 465 Unchecked_Convert_To 466 (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))), 467 New_Occurrence_Of (Typ_Tag, Loc))), 468 Expression => 469 Make_Explicit_Dereference (Loc, 470 Unchecked_Convert_To 471 (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))), 472 New_Occurrence_Of (Parent_Tag, Loc))))); 473 exit; 474 end if; 475 end loop; 476 477 -- Stage 2: Inherit and override C++ slots of secondary dispatch tables 478 479 declare 480 Iface : Entity_Id; 481 Iface_Nb_Prims : Nat; 482 Parent_Ifaces_List : Elist_Id; 483 Parent_Ifaces_Comp_List : Elist_Id; 484 Parent_Ifaces_Tag_List : Elist_Id; 485 Parent_Iface_Tag_Elmt : Elmt_Id; 486 Typ_Ifaces_List : Elist_Id; 487 Typ_Ifaces_Comp_List : Elist_Id; 488 Typ_Ifaces_Tag_List : Elist_Id; 489 Typ_Iface_Tag_Elmt : Elmt_Id; 490 491 begin 492 Collect_Interfaces_Info 493 (T => Parent_Typ, 494 Ifaces_List => Parent_Ifaces_List, 495 Components_List => Parent_Ifaces_Comp_List, 496 Tags_List => Parent_Ifaces_Tag_List); 497 498 Collect_Interfaces_Info 499 (T => Typ, 500 Ifaces_List => Typ_Ifaces_List, 501 Components_List => Typ_Ifaces_Comp_List, 502 Tags_List => Typ_Ifaces_Tag_List); 503 504 Parent_Iface_Tag_Elmt := First_Elmt (Parent_Ifaces_Tag_List); 505 Typ_Iface_Tag_Elmt := First_Elmt (Typ_Ifaces_Tag_List); 506 while Present (Parent_Iface_Tag_Elmt) loop 507 Parent_Tag := Node (Parent_Iface_Tag_Elmt); 508 Typ_Tag := Node (Typ_Iface_Tag_Elmt); 509 510 pragma Assert 511 (Related_Type (Parent_Tag) = Related_Type (Typ_Tag)); 512 Iface := Related_Type (Parent_Tag); 513 514 Iface_Nb_Prims := 515 UI_To_Int (DT_Entry_Count (First_Tag_Component (Iface))); 516 517 if Iface_Nb_Prims > 0 then 518 519 -- Update slots of overridden primitives 520 521 declare 522 Last_Nod : constant Node_Id := Last (Result); 523 Nb_Prims : constant Nat := UI_To_Int 524 (DT_Entry_Count 525 (First_Tag_Component (Iface))); 526 Elmt : Elmt_Id; 527 Prim : Entity_Id; 528 E : Entity_Id; 529 Prim_Pos : Nat; 530 531 Prims_Table : array (1 .. Nb_Prims) of Boolean; 532 533 begin 534 Prims_Table := (others => False); 535 536 Elmt := First_Elmt (Primitive_Operations (Typ)); 537 while Present (Elmt) loop 538 Prim := Node (Elmt); 539 E := Ultimate_Alias (Prim); 540 541 if not Is_Predefined_Dispatching_Operation (Prim) 542 and then Present (Interface_Alias (Prim)) 543 and then Find_Dispatching_Type (Interface_Alias (Prim)) 544 = Iface 545 and then not Is_Abstract_Subprogram (E) 546 and then not Is_Eliminated (E) 547 and then Find_Dispatching_Type (E) = Typ 548 then 549 Prim_Pos := UI_To_Int (DT_Position (Prim)); 550 551 -- Remember that this slot is already initialized 552 553 pragma Assert (Prims_Table (Prim_Pos) = False); 554 Prims_Table (Prim_Pos) := True; 555 556 Append_To (Result, 557 Make_Assignment_Statement (Loc, 558 Name => 559 Make_Indexed_Component (Loc, 560 Prefix => 561 Make_Explicit_Dereference (Loc, 562 Unchecked_Convert_To 563 (Node 564 (Last_Elmt 565 (Access_Disp_Table (Iface))), 566 New_Occurrence_Of (Typ_Tag, Loc))), 567 Expressions => 568 New_List 569 (Make_Integer_Literal (Loc, Prim_Pos))), 570 571 Expression => 572 Unchecked_Convert_To (RTE (RE_Prim_Ptr), 573 Make_Attribute_Reference (Loc, 574 Prefix => New_Occurrence_Of (E, Loc), 575 Attribute_Name => 576 Name_Unrestricted_Access)))); 577 end if; 578 579 Next_Elmt (Elmt); 580 end loop; 581 582 -- Check if all primitives from the parent have been 583 -- overridden (to avoid copying the whole secondary 584 -- table from the parent). 585 586 -- IfaceG!(Typ_Sec_Tag).all := IfaceG!(Parent_Sec_Tag).all; 587 588 for J in Prims_Table'Range loop 589 if not Prims_Table (J) then 590 Insert_After (Last_Nod, 591 Make_Assignment_Statement (Loc, 592 Name => 593 Make_Explicit_Dereference (Loc, 594 Unchecked_Convert_To 595 (Node (Last_Elmt (Access_Disp_Table (Iface))), 596 New_Occurrence_Of (Typ_Tag, Loc))), 597 Expression => 598 Make_Explicit_Dereference (Loc, 599 Unchecked_Convert_To 600 (Node (Last_Elmt (Access_Disp_Table (Iface))), 601 New_Occurrence_Of (Parent_Tag, Loc))))); 602 exit; 603 end if; 604 end loop; 605 end; 606 end if; 607 608 Next_Elmt (Typ_Iface_Tag_Elmt); 609 Next_Elmt (Parent_Iface_Tag_Elmt); 610 end loop; 611 end; 612 613 return Result; 614 end Build_Inherit_CPP_Prims; 615 616 ------------------------- 617 -- Build_Inherit_Prims -- 618 ------------------------- 619 620 function Build_Inherit_Prims 621 (Loc : Source_Ptr; 622 Typ : Entity_Id; 623 Old_Tag_Node : Node_Id; 624 New_Tag_Node : Node_Id; 625 Num_Prims : Nat) return Node_Id 626 is 627 begin 628 if RTE_Available (RE_DT) then 629 return 630 Make_Assignment_Statement (Loc, 631 Name => 632 Make_Slice (Loc, 633 Prefix => 634 Make_Selected_Component (Loc, 635 Prefix => 636 Build_DT (Loc, New_Tag_Node), 637 Selector_Name => 638 New_Occurrence_Of 639 (RTE_Record_Component (RE_Prims_Ptr), Loc)), 640 Discrete_Range => 641 Make_Range (Loc, 642 Low_Bound => Make_Integer_Literal (Loc, 1), 643 High_Bound => Make_Integer_Literal (Loc, Num_Prims))), 644 645 Expression => 646 Make_Slice (Loc, 647 Prefix => 648 Make_Selected_Component (Loc, 649 Prefix => 650 Build_DT (Loc, Old_Tag_Node), 651 Selector_Name => 652 New_Occurrence_Of 653 (RTE_Record_Component (RE_Prims_Ptr), Loc)), 654 Discrete_Range => 655 Make_Range (Loc, 656 Low_Bound => Make_Integer_Literal (Loc, 1), 657 High_Bound => Make_Integer_Literal (Loc, Num_Prims)))); 658 else 659 return 660 Make_Assignment_Statement (Loc, 661 Name => 662 Make_Slice (Loc, 663 Prefix => 664 Unchecked_Convert_To 665 (Node (Last_Elmt (Access_Disp_Table (Typ))), 666 New_Tag_Node), 667 Discrete_Range => 668 Make_Range (Loc, 669 Low_Bound => Make_Integer_Literal (Loc, 1), 670 High_Bound => Make_Integer_Literal (Loc, Num_Prims))), 671 672 Expression => 673 Make_Slice (Loc, 674 Prefix => 675 Unchecked_Convert_To 676 (Node (Last_Elmt (Access_Disp_Table (Typ))), 677 Old_Tag_Node), 678 Discrete_Range => 679 Make_Range (Loc, 680 Low_Bound => Make_Integer_Literal (Loc, 1), 681 High_Bound => Make_Integer_Literal (Loc, Num_Prims)))); 682 end if; 683 end Build_Inherit_Prims; 684 685 ------------------------------- 686 -- Build_Get_Prim_Op_Address -- 687 ------------------------------- 688 689 procedure Build_Get_Prim_Op_Address 690 (Loc : Source_Ptr; 691 Typ : Entity_Id; 692 Position : Uint; 693 Tag_Node : in out Node_Id; 694 New_Node : out Node_Id) 695 is 696 New_Prefix : Node_Id; 697 698 begin 699 pragma Assert 700 (Position <= DT_Entry_Count (First_Tag_Component (Typ))); 701 702 -- At the end of the Access_Disp_Table list we have the type 703 -- declaration required to convert the tag into a pointer to 704 -- the prims_ptr table (see Freeze_Record_Type). 705 706 New_Prefix := 707 Unchecked_Convert_To 708 (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node); 709 710 -- Unchecked_Convert_To relocates the controlling tag node and therefore 711 -- we must update it. 712 713 Tag_Node := Expression (New_Prefix); 714 715 New_Node := 716 Make_Indexed_Component (Loc, 717 Prefix => New_Prefix, 718 Expressions => New_List (Make_Integer_Literal (Loc, Position))); 719 end Build_Get_Prim_Op_Address; 720 721 ----------------------------- 722 -- Build_Get_Transportable -- 723 ----------------------------- 724 725 function Build_Get_Transportable 726 (Loc : Source_Ptr; 727 Tag_Node : Node_Id) return Node_Id 728 is 729 begin 730 return 731 Make_Selected_Component (Loc, 732 Prefix => 733 Build_TSD (Loc, 734 Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), 735 Selector_Name => 736 New_Occurrence_Of 737 (RTE_Record_Component (RE_Transportable), Loc)); 738 end Build_Get_Transportable; 739 740 ------------------------------------ 741 -- Build_Inherit_Predefined_Prims -- 742 ------------------------------------ 743 744 function Build_Inherit_Predefined_Prims 745 (Loc : Source_Ptr; 746 Old_Tag_Node : Node_Id; 747 New_Tag_Node : Node_Id; 748 Num_Predef_Prims : Int) return Node_Id 749 is 750 begin 751 return 752 Make_Assignment_Statement (Loc, 753 Name => 754 Make_Slice (Loc, 755 Prefix => 756 Make_Explicit_Dereference (Loc, 757 Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), 758 Make_Explicit_Dereference (Loc, 759 Unchecked_Convert_To (RTE (RE_Addr_Ptr), 760 New_Tag_Node)))), 761 Discrete_Range => Make_Range (Loc, 762 Make_Integer_Literal (Loc, Uint_1), 763 Make_Integer_Literal (Loc, Num_Predef_Prims))), 764 765 Expression => 766 Make_Slice (Loc, 767 Prefix => 768 Make_Explicit_Dereference (Loc, 769 Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), 770 Make_Explicit_Dereference (Loc, 771 Unchecked_Convert_To (RTE (RE_Addr_Ptr), 772 Old_Tag_Node)))), 773 Discrete_Range => 774 Make_Range (Loc, 775 Make_Integer_Literal (Loc, 1), 776 Make_Integer_Literal (Loc, Num_Predef_Prims)))); 777 end Build_Inherit_Predefined_Prims; 778 779 ------------------------- 780 -- Build_Offset_To_Top -- 781 ------------------------- 782 783 function Build_Offset_To_Top 784 (Loc : Source_Ptr; 785 This_Node : Node_Id) return Node_Id 786 is 787 Tag_Node : Node_Id; 788 789 begin 790 Tag_Node := 791 Make_Explicit_Dereference (Loc, 792 Unchecked_Convert_To (RTE (RE_Tag_Ptr), This_Node)); 793 794 return 795 Make_Explicit_Dereference (Loc, 796 Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr), 797 Make_Function_Call (Loc, 798 Name => 799 Make_Expanded_Name (Loc, 800 Chars => Name_Op_Subtract, 801 Prefix => 802 New_Occurrence_Of 803 (RTU_Entity (System_Storage_Elements), Loc), 804 Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)), 805 Parameter_Associations => New_List ( 806 Unchecked_Convert_To (RTE (RE_Address), Tag_Node), 807 New_Occurrence_Of 808 (RTE (RE_DT_Offset_To_Top_Offset), Loc))))); 809 end Build_Offset_To_Top; 810 811 ------------------------------------------ 812 -- Build_Set_Predefined_Prim_Op_Address -- 813 ------------------------------------------ 814 815 function Build_Set_Predefined_Prim_Op_Address 816 (Loc : Source_Ptr; 817 Tag_Node : Node_Id; 818 Position : Uint; 819 Address_Node : Node_Id) return Node_Id 820 is 821 begin 822 return 823 Make_Assignment_Statement (Loc, 824 Name => 825 Make_Indexed_Component (Loc, 826 Prefix => 827 Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), 828 Make_Explicit_Dereference (Loc, 829 Unchecked_Convert_To (RTE (RE_Addr_Ptr), Tag_Node))), 830 Expressions => 831 New_List (Make_Integer_Literal (Loc, Position))), 832 833 Expression => Address_Node); 834 end Build_Set_Predefined_Prim_Op_Address; 835 836 ------------------------------- 837 -- Build_Set_Prim_Op_Address -- 838 ------------------------------- 839 840 function Build_Set_Prim_Op_Address 841 (Loc : Source_Ptr; 842 Typ : Entity_Id; 843 Tag_Node : Node_Id; 844 Position : Uint; 845 Address_Node : Node_Id) return Node_Id 846 is 847 Ctrl_Tag : Node_Id := Tag_Node; 848 New_Node : Node_Id; 849 850 begin 851 Build_Get_Prim_Op_Address (Loc, Typ, Position, Ctrl_Tag, New_Node); 852 853 return 854 Make_Assignment_Statement (Loc, 855 Name => New_Node, 856 Expression => Address_Node); 857 end Build_Set_Prim_Op_Address; 858 859 ----------------------------- 860 -- Build_Set_Size_Function -- 861 ----------------------------- 862 863 function Build_Set_Size_Function 864 (Loc : Source_Ptr; 865 Tag_Node : Node_Id; 866 Size_Func : Entity_Id) return Node_Id is 867 begin 868 pragma Assert (Chars (Size_Func) = Name_uSize 869 and then RTE_Record_Component_Available (RE_Size_Func)); 870 return 871 Make_Assignment_Statement (Loc, 872 Name => 873 Make_Selected_Component (Loc, 874 Prefix => 875 Build_TSD (Loc, 876 Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), 877 Selector_Name => 878 New_Occurrence_Of 879 (RTE_Record_Component (RE_Size_Func), Loc)), 880 Expression => 881 Unchecked_Convert_To (RTE (RE_Size_Ptr), 882 Make_Attribute_Reference (Loc, 883 Prefix => New_Occurrence_Of (Size_Func, Loc), 884 Attribute_Name => Name_Unrestricted_Access))); 885 end Build_Set_Size_Function; 886 887 ------------------------------------ 888 -- Build_Set_Static_Offset_To_Top -- 889 ------------------------------------ 890 891 function Build_Set_Static_Offset_To_Top 892 (Loc : Source_Ptr; 893 Iface_Tag : Node_Id; 894 Offset_Value : Node_Id) return Node_Id is 895 begin 896 return 897 Make_Assignment_Statement (Loc, 898 Make_Explicit_Dereference (Loc, 899 Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr), 900 Make_Function_Call (Loc, 901 Name => 902 Make_Expanded_Name (Loc, 903 Chars => Name_Op_Subtract, 904 Prefix => 905 New_Occurrence_Of 906 (RTU_Entity (System_Storage_Elements), Loc), 907 Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)), 908 Parameter_Associations => New_List ( 909 Unchecked_Convert_To (RTE (RE_Address), Iface_Tag), 910 New_Occurrence_Of 911 (RTE (RE_DT_Offset_To_Top_Offset), Loc))))), 912 Offset_Value); 913 end Build_Set_Static_Offset_To_Top; 914 915 --------------- 916 -- Build_TSD -- 917 --------------- 918 919 function Build_TSD 920 (Loc : Source_Ptr; 921 Tag_Node_Addr : Node_Id) return Node_Id is 922 begin 923 return 924 Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr), 925 Make_Explicit_Dereference (Loc, 926 Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr), 927 Make_Function_Call (Loc, 928 Name => 929 Make_Expanded_Name (Loc, 930 Chars => Name_Op_Subtract, 931 Prefix => 932 New_Occurrence_Of 933 (RTU_Entity (System_Storage_Elements), Loc), 934 Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)), 935 936 Parameter_Associations => New_List ( 937 Tag_Node_Addr, 938 New_Occurrence_Of 939 (RTE (RE_DT_Typeinfo_Ptr_Size), Loc)))))); 940 end Build_TSD; 941 942end Exp_Atag; 943