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-2014, 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 => New_Occurrence_Of 201 (RTE (RE_Type_Specific_Data_Ptr), Loc), 202 Expression => Build_TSD (Loc, New_Occurrence_Of (Tag_Addr, Loc)))); 203 204 Insert_Action (Related_Nod, 205 Make_Object_Declaration (Loc, 206 Defining_Identifier => Typ_TSD, 207 Constant_Present => True, 208 Object_Definition => New_Occurrence_Of 209 (RTE (RE_Type_Specific_Data_Ptr), Loc), 210 Expression => Build_TSD (Loc, 211 Unchecked_Convert_To (RTE (RE_Address), 212 Typ_Tag_Node)))); 213 214 Insert_Action (Related_Nod, 215 Make_Object_Declaration (Loc, 216 Defining_Identifier => Index, 217 Constant_Present => True, 218 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 219 Expression => 220 Make_Op_Subtract (Loc, 221 Left_Opnd => 222 Make_Selected_Component (Loc, 223 Prefix => New_Occurrence_Of (Obj_TSD, Loc), 224 Selector_Name => 225 New_Occurrence_Of 226 (RTE_Record_Component (RE_Idepth), Loc)), 227 228 Right_Opnd => 229 Make_Selected_Component (Loc, 230 Prefix => New_Occurrence_Of (Typ_TSD, Loc), 231 Selector_Name => 232 New_Occurrence_Of 233 (RTE_Record_Component (RE_Idepth), Loc))))); 234 235 New_Node := 236 Make_And_Then (Loc, 237 Left_Opnd => 238 Make_Op_Ge (Loc, 239 Left_Opnd => New_Occurrence_Of (Index, Loc), 240 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), 241 242 Right_Opnd => 243 Make_Op_Eq (Loc, 244 Left_Opnd => 245 Make_Indexed_Component (Loc, 246 Prefix => 247 Make_Selected_Component (Loc, 248 Prefix => New_Occurrence_Of (Obj_TSD, Loc), 249 Selector_Name => 250 New_Occurrence_Of 251 (RTE_Record_Component (RE_Tags_Table), Loc)), 252 Expressions => 253 New_List (New_Occurrence_Of (Index, Loc))), 254 255 Right_Opnd => Typ_Tag_Node)); 256 end Build_CW_Membership; 257 258 -------------- 259 -- Build_DT -- 260 -------------- 261 262 function Build_DT 263 (Loc : Source_Ptr; 264 Tag_Node : Node_Id) return Node_Id 265 is 266 begin 267 return 268 Make_Function_Call (Loc, 269 Name => New_Occurrence_Of (RTE (RE_DT), Loc), 270 Parameter_Associations => New_List ( 271 Unchecked_Convert_To (RTE (RE_Tag), Tag_Node))); 272 end Build_DT; 273 274 ---------------------------- 275 -- Build_Get_Access_Level -- 276 ---------------------------- 277 278 function Build_Get_Access_Level 279 (Loc : Source_Ptr; 280 Tag_Node : Node_Id) return Node_Id 281 is 282 begin 283 return 284 Make_Selected_Component (Loc, 285 Prefix => 286 Build_TSD (Loc, 287 Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), 288 Selector_Name => 289 New_Occurrence_Of 290 (RTE_Record_Component (RE_Access_Level), Loc)); 291 end Build_Get_Access_Level; 292 293 ------------------------- 294 -- Build_Get_Alignment -- 295 ------------------------- 296 297 function Build_Get_Alignment 298 (Loc : Source_Ptr; 299 Tag_Node : Node_Id) return Node_Id 300 is 301 begin 302 return 303 Make_Selected_Component (Loc, 304 Prefix => 305 Build_TSD (Loc, Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), 306 Selector_Name => 307 New_Occurrence_Of (RTE_Record_Component (RE_Alignment), Loc)); 308 end Build_Get_Alignment; 309 310 ------------------------------------------ 311 -- Build_Get_Predefined_Prim_Op_Address -- 312 ------------------------------------------ 313 314 procedure Build_Get_Predefined_Prim_Op_Address 315 (Loc : Source_Ptr; 316 Position : Uint; 317 Tag_Node : in out Node_Id; 318 New_Node : out Node_Id) 319 is 320 Ctrl_Tag : Node_Id; 321 322 begin 323 Ctrl_Tag := Unchecked_Convert_To (RTE (RE_Address), Tag_Node); 324 325 -- Unchecked_Convert_To relocates the controlling tag node and therefore 326 -- we must update it. 327 328 Tag_Node := Expression (Ctrl_Tag); 329 330 -- Build code that retrieves the address of the dispatch table 331 -- containing the predefined Ada primitives: 332 -- 333 -- Generate: 334 -- To_Predef_Prims_Table_Ptr 335 -- (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all); 336 337 New_Node := 338 Make_Indexed_Component (Loc, 339 Prefix => 340 Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), 341 Make_Explicit_Dereference (Loc, 342 Unchecked_Convert_To (RTE (RE_Addr_Ptr), 343 Make_Function_Call (Loc, 344 Name => 345 Make_Expanded_Name (Loc, 346 Chars => Name_Op_Subtract, 347 Prefix => 348 New_Occurrence_Of 349 (RTU_Entity (System_Storage_Elements), Loc), 350 Selector_Name => 351 Make_Identifier (Loc, Name_Op_Subtract)), 352 Parameter_Associations => New_List ( 353 Ctrl_Tag, 354 New_Occurrence_Of 355 (RTE (RE_DT_Predef_Prims_Offset), Loc)))))), 356 Expressions => 357 New_List (Make_Integer_Literal (Loc, Position))); 358 end Build_Get_Predefined_Prim_Op_Address; 359 360 ----------------------------- 361 -- Build_Inherit_CPP_Prims -- 362 ----------------------------- 363 364 function Build_Inherit_CPP_Prims (Typ : Entity_Id) return List_Id is 365 Loc : constant Source_Ptr := Sloc (Typ); 366 CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ); 367 CPP_Table : array (1 .. CPP_Nb_Prims) of Boolean := (others => False); 368 CPP_Typ : constant Entity_Id := Enclosing_CPP_Parent (Typ); 369 Result : constant List_Id := New_List; 370 Parent_Typ : constant Entity_Id := Etype (Typ); 371 E : Entity_Id; 372 Elmt : Elmt_Id; 373 Parent_Tag : Entity_Id; 374 Prim : Entity_Id; 375 Prim_Pos : Nat; 376 Typ_Tag : Entity_Id; 377 378 begin 379 pragma Assert (not Is_CPP_Class (Typ)); 380 381 -- No code needed if this type has no primitives inherited from C++ 382 383 if CPP_Nb_Prims = 0 then 384 return Result; 385 end if; 386 387 -- Stage 1: Inherit and override C++ slots of the primary dispatch table 388 389 -- Generate: 390 -- Typ'Tag (Prim_Pos) := Prim'Unrestricted_Access; 391 392 Parent_Tag := Node (First_Elmt (Access_Disp_Table (Parent_Typ))); 393 Typ_Tag := Node (First_Elmt (Access_Disp_Table (Typ))); 394 395 Elmt := First_Elmt (Primitive_Operations (Typ)); 396 while Present (Elmt) loop 397 Prim := Node (Elmt); 398 E := Ultimate_Alias (Prim); 399 Prim_Pos := UI_To_Int (DT_Position (E)); 400 401 -- Skip predefined, abstract, and eliminated primitives. Skip also 402 -- primitives not located in the C++ part of the dispatch table. 403 404 if not Is_Predefined_Dispatching_Operation (Prim) 405 and then not Is_Predefined_Dispatching_Operation (E) 406 and then not Present (Interface_Alias (Prim)) 407 and then not Is_Abstract_Subprogram (E) 408 and then not Is_Eliminated (E) 409 and then Prim_Pos <= CPP_Nb_Prims 410 and then Find_Dispatching_Type (E) = Typ 411 then 412 -- Remember that this slot is used 413 414 pragma Assert (CPP_Table (Prim_Pos) = False); 415 CPP_Table (Prim_Pos) := True; 416 417 Append_To (Result, 418 Make_Assignment_Statement (Loc, 419 Name => 420 Make_Indexed_Component (Loc, 421 Prefix => 422 Make_Explicit_Dereference (Loc, 423 Unchecked_Convert_To 424 (Node (Last_Elmt (Access_Disp_Table (Typ))), 425 New_Occurrence_Of (Typ_Tag, Loc))), 426 Expressions => 427 New_List (Make_Integer_Literal (Loc, Prim_Pos))), 428 429 Expression => 430 Unchecked_Convert_To (RTE (RE_Prim_Ptr), 431 Make_Attribute_Reference (Loc, 432 Prefix => New_Occurrence_Of (E, Loc), 433 Attribute_Name => Name_Unrestricted_Access)))); 434 end if; 435 436 Next_Elmt (Elmt); 437 end loop; 438 439 -- If all primitives have been overridden then there is no need to copy 440 -- from Typ's parent its dispatch table. Otherwise, if some primitive is 441 -- inherited from the parent we copy only the C++ part of the dispatch 442 -- table from the parent before the assignments that initialize the 443 -- overridden primitives. 444 445 -- Generate: 446 447 -- type CPP_TypG is array (1 .. CPP_Nb_Prims) ofd Prim_Ptr; 448 -- type CPP_TypH is access CPP_TypG; 449 -- CPP_TypG!(Typ_Tag).all := CPP_TypG!(Parent_Tag).all; 450 451 -- Note: There is no need to duplicate the declarations of CPP_TypG and 452 -- CPP_TypH because, for expansion of dispatching calls, these 453 -- entities are stored in the last elements of Access_Disp_Table. 454 455 for J in CPP_Table'Range loop 456 if not CPP_Table (J) then 457 Prepend_To (Result, 458 Make_Assignment_Statement (Loc, 459 Name => 460 Make_Explicit_Dereference (Loc, 461 Unchecked_Convert_To 462 (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))), 463 New_Occurrence_Of (Typ_Tag, Loc))), 464 Expression => 465 Make_Explicit_Dereference (Loc, 466 Unchecked_Convert_To 467 (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))), 468 New_Occurrence_Of (Parent_Tag, Loc))))); 469 exit; 470 end if; 471 end loop; 472 473 -- Stage 2: Inherit and override C++ slots of secondary dispatch tables 474 475 declare 476 Iface : Entity_Id; 477 Iface_Nb_Prims : Nat; 478 Parent_Ifaces_List : Elist_Id; 479 Parent_Ifaces_Comp_List : Elist_Id; 480 Parent_Ifaces_Tag_List : Elist_Id; 481 Parent_Iface_Tag_Elmt : Elmt_Id; 482 Typ_Ifaces_List : Elist_Id; 483 Typ_Ifaces_Comp_List : Elist_Id; 484 Typ_Ifaces_Tag_List : Elist_Id; 485 Typ_Iface_Tag_Elmt : Elmt_Id; 486 487 begin 488 Collect_Interfaces_Info 489 (T => Parent_Typ, 490 Ifaces_List => Parent_Ifaces_List, 491 Components_List => Parent_Ifaces_Comp_List, 492 Tags_List => Parent_Ifaces_Tag_List); 493 494 Collect_Interfaces_Info 495 (T => Typ, 496 Ifaces_List => Typ_Ifaces_List, 497 Components_List => Typ_Ifaces_Comp_List, 498 Tags_List => Typ_Ifaces_Tag_List); 499 500 Parent_Iface_Tag_Elmt := First_Elmt (Parent_Ifaces_Tag_List); 501 Typ_Iface_Tag_Elmt := First_Elmt (Typ_Ifaces_Tag_List); 502 while Present (Parent_Iface_Tag_Elmt) loop 503 Parent_Tag := Node (Parent_Iface_Tag_Elmt); 504 Typ_Tag := Node (Typ_Iface_Tag_Elmt); 505 506 pragma Assert 507 (Related_Type (Parent_Tag) = Related_Type (Typ_Tag)); 508 Iface := Related_Type (Parent_Tag); 509 510 Iface_Nb_Prims := 511 UI_To_Int (DT_Entry_Count (First_Tag_Component (Iface))); 512 513 if Iface_Nb_Prims > 0 then 514 515 -- Update slots of overridden primitives 516 517 declare 518 Last_Nod : constant Node_Id := Last (Result); 519 Nb_Prims : constant Nat := UI_To_Int 520 (DT_Entry_Count 521 (First_Tag_Component (Iface))); 522 Elmt : Elmt_Id; 523 Prim : Entity_Id; 524 E : Entity_Id; 525 Prim_Pos : Nat; 526 527 Prims_Table : array (1 .. Nb_Prims) of Boolean; 528 529 begin 530 Prims_Table := (others => False); 531 532 Elmt := First_Elmt (Primitive_Operations (Typ)); 533 while Present (Elmt) loop 534 Prim := Node (Elmt); 535 E := Ultimate_Alias (Prim); 536 537 if not Is_Predefined_Dispatching_Operation (Prim) 538 and then Present (Interface_Alias (Prim)) 539 and then Find_Dispatching_Type (Interface_Alias (Prim)) 540 = Iface 541 and then not Is_Abstract_Subprogram (E) 542 and then not Is_Eliminated (E) 543 and then Find_Dispatching_Type (E) = Typ 544 then 545 Prim_Pos := UI_To_Int (DT_Position (Prim)); 546 547 -- Remember that this slot is already initialized 548 549 pragma Assert (Prims_Table (Prim_Pos) = False); 550 Prims_Table (Prim_Pos) := True; 551 552 Append_To (Result, 553 Make_Assignment_Statement (Loc, 554 Name => 555 Make_Indexed_Component (Loc, 556 Prefix => 557 Make_Explicit_Dereference (Loc, 558 Unchecked_Convert_To 559 (Node 560 (Last_Elmt 561 (Access_Disp_Table (Iface))), 562 New_Occurrence_Of (Typ_Tag, Loc))), 563 Expressions => 564 New_List 565 (Make_Integer_Literal (Loc, Prim_Pos))), 566 567 Expression => 568 Unchecked_Convert_To (RTE (RE_Prim_Ptr), 569 Make_Attribute_Reference (Loc, 570 Prefix => New_Occurrence_Of (E, Loc), 571 Attribute_Name => 572 Name_Unrestricted_Access)))); 573 end if; 574 575 Next_Elmt (Elmt); 576 end loop; 577 578 -- Check if all primitives from the parent have been 579 -- overridden (to avoid copying the whole secondary 580 -- table from the parent). 581 582 -- IfaceG!(Typ_Sec_Tag).all := IfaceG!(Parent_Sec_Tag).all; 583 584 for J in Prims_Table'Range loop 585 if not Prims_Table (J) then 586 Insert_After (Last_Nod, 587 Make_Assignment_Statement (Loc, 588 Name => 589 Make_Explicit_Dereference (Loc, 590 Unchecked_Convert_To 591 (Node (Last_Elmt (Access_Disp_Table (Iface))), 592 New_Occurrence_Of (Typ_Tag, Loc))), 593 Expression => 594 Make_Explicit_Dereference (Loc, 595 Unchecked_Convert_To 596 (Node (Last_Elmt (Access_Disp_Table (Iface))), 597 New_Occurrence_Of (Parent_Tag, Loc))))); 598 exit; 599 end if; 600 end loop; 601 end; 602 end if; 603 604 Next_Elmt (Typ_Iface_Tag_Elmt); 605 Next_Elmt (Parent_Iface_Tag_Elmt); 606 end loop; 607 end; 608 609 return Result; 610 end Build_Inherit_CPP_Prims; 611 612 ------------------------- 613 -- Build_Inherit_Prims -- 614 ------------------------- 615 616 function Build_Inherit_Prims 617 (Loc : Source_Ptr; 618 Typ : Entity_Id; 619 Old_Tag_Node : Node_Id; 620 New_Tag_Node : Node_Id; 621 Num_Prims : Nat) return Node_Id 622 is 623 begin 624 if RTE_Available (RE_DT) then 625 return 626 Make_Assignment_Statement (Loc, 627 Name => 628 Make_Slice (Loc, 629 Prefix => 630 Make_Selected_Component (Loc, 631 Prefix => 632 Build_DT (Loc, New_Tag_Node), 633 Selector_Name => 634 New_Occurrence_Of 635 (RTE_Record_Component (RE_Prims_Ptr), Loc)), 636 Discrete_Range => 637 Make_Range (Loc, 638 Low_Bound => Make_Integer_Literal (Loc, 1), 639 High_Bound => Make_Integer_Literal (Loc, Num_Prims))), 640 641 Expression => 642 Make_Slice (Loc, 643 Prefix => 644 Make_Selected_Component (Loc, 645 Prefix => 646 Build_DT (Loc, Old_Tag_Node), 647 Selector_Name => 648 New_Occurrence_Of 649 (RTE_Record_Component (RE_Prims_Ptr), Loc)), 650 Discrete_Range => 651 Make_Range (Loc, 652 Low_Bound => Make_Integer_Literal (Loc, 1), 653 High_Bound => Make_Integer_Literal (Loc, Num_Prims)))); 654 else 655 return 656 Make_Assignment_Statement (Loc, 657 Name => 658 Make_Slice (Loc, 659 Prefix => 660 Unchecked_Convert_To 661 (Node (Last_Elmt (Access_Disp_Table (Typ))), 662 New_Tag_Node), 663 Discrete_Range => 664 Make_Range (Loc, 665 Low_Bound => Make_Integer_Literal (Loc, 1), 666 High_Bound => Make_Integer_Literal (Loc, Num_Prims))), 667 668 Expression => 669 Make_Slice (Loc, 670 Prefix => 671 Unchecked_Convert_To 672 (Node (Last_Elmt (Access_Disp_Table (Typ))), 673 Old_Tag_Node), 674 Discrete_Range => 675 Make_Range (Loc, 676 Low_Bound => Make_Integer_Literal (Loc, 1), 677 High_Bound => Make_Integer_Literal (Loc, Num_Prims)))); 678 end if; 679 end Build_Inherit_Prims; 680 681 ------------------------------- 682 -- Build_Get_Prim_Op_Address -- 683 ------------------------------- 684 685 procedure Build_Get_Prim_Op_Address 686 (Loc : Source_Ptr; 687 Typ : Entity_Id; 688 Position : Uint; 689 Tag_Node : in out Node_Id; 690 New_Node : out Node_Id) 691 is 692 New_Prefix : Node_Id; 693 694 begin 695 pragma Assert 696 (Position <= DT_Entry_Count (First_Tag_Component (Typ))); 697 698 -- At the end of the Access_Disp_Table list we have the type 699 -- declaration required to convert the tag into a pointer to 700 -- the prims_ptr table (see Freeze_Record_Type). 701 702 New_Prefix := 703 Unchecked_Convert_To 704 (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node); 705 706 -- Unchecked_Convert_To relocates the controlling tag node and therefore 707 -- we must update it. 708 709 Tag_Node := Expression (New_Prefix); 710 711 New_Node := 712 Make_Indexed_Component (Loc, 713 Prefix => New_Prefix, 714 Expressions => New_List (Make_Integer_Literal (Loc, Position))); 715 end Build_Get_Prim_Op_Address; 716 717 ----------------------------- 718 -- Build_Get_Transportable -- 719 ----------------------------- 720 721 function Build_Get_Transportable 722 (Loc : Source_Ptr; 723 Tag_Node : Node_Id) return Node_Id 724 is 725 begin 726 return 727 Make_Selected_Component (Loc, 728 Prefix => 729 Build_TSD (Loc, 730 Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), 731 Selector_Name => 732 New_Occurrence_Of 733 (RTE_Record_Component (RE_Transportable), Loc)); 734 end Build_Get_Transportable; 735 736 ------------------------------------ 737 -- Build_Inherit_Predefined_Prims -- 738 ------------------------------------ 739 740 function Build_Inherit_Predefined_Prims 741 (Loc : Source_Ptr; 742 Old_Tag_Node : Node_Id; 743 New_Tag_Node : Node_Id) return Node_Id 744 is 745 begin 746 return 747 Make_Assignment_Statement (Loc, 748 Name => 749 Make_Slice (Loc, 750 Prefix => 751 Make_Explicit_Dereference (Loc, 752 Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), 753 Make_Explicit_Dereference (Loc, 754 Unchecked_Convert_To (RTE (RE_Addr_Ptr), 755 New_Tag_Node)))), 756 Discrete_Range => Make_Range (Loc, 757 Make_Integer_Literal (Loc, Uint_1), 758 New_Occurrence_Of (RTE (RE_Max_Predef_Prims), Loc))), 759 760 Expression => 761 Make_Slice (Loc, 762 Prefix => 763 Make_Explicit_Dereference (Loc, 764 Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), 765 Make_Explicit_Dereference (Loc, 766 Unchecked_Convert_To (RTE (RE_Addr_Ptr), 767 Old_Tag_Node)))), 768 Discrete_Range => 769 Make_Range (Loc, 770 Make_Integer_Literal (Loc, 1), 771 New_Occurrence_Of (RTE (RE_Max_Predef_Prims), Loc)))); 772 end Build_Inherit_Predefined_Prims; 773 774 ------------------------- 775 -- Build_Offset_To_Top -- 776 ------------------------- 777 778 function Build_Offset_To_Top 779 (Loc : Source_Ptr; 780 This_Node : Node_Id) return Node_Id 781 is 782 Tag_Node : Node_Id; 783 784 begin 785 Tag_Node := 786 Make_Explicit_Dereference (Loc, 787 Unchecked_Convert_To (RTE (RE_Tag_Ptr), This_Node)); 788 789 return 790 Make_Explicit_Dereference (Loc, 791 Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr), 792 Make_Function_Call (Loc, 793 Name => 794 Make_Expanded_Name (Loc, 795 Chars => Name_Op_Subtract, 796 Prefix => 797 New_Occurrence_Of 798 (RTU_Entity (System_Storage_Elements), Loc), 799 Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)), 800 Parameter_Associations => New_List ( 801 Unchecked_Convert_To (RTE (RE_Address), Tag_Node), 802 New_Occurrence_Of 803 (RTE (RE_DT_Offset_To_Top_Offset), Loc))))); 804 end Build_Offset_To_Top; 805 806 ------------------------------------------ 807 -- Build_Set_Predefined_Prim_Op_Address -- 808 ------------------------------------------ 809 810 function Build_Set_Predefined_Prim_Op_Address 811 (Loc : Source_Ptr; 812 Tag_Node : Node_Id; 813 Position : Uint; 814 Address_Node : Node_Id) return Node_Id 815 is 816 begin 817 return 818 Make_Assignment_Statement (Loc, 819 Name => 820 Make_Indexed_Component (Loc, 821 Prefix => 822 Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), 823 Make_Explicit_Dereference (Loc, 824 Unchecked_Convert_To (RTE (RE_Addr_Ptr), Tag_Node))), 825 Expressions => 826 New_List (Make_Integer_Literal (Loc, Position))), 827 828 Expression => Address_Node); 829 end Build_Set_Predefined_Prim_Op_Address; 830 831 ------------------------------- 832 -- Build_Set_Prim_Op_Address -- 833 ------------------------------- 834 835 function Build_Set_Prim_Op_Address 836 (Loc : Source_Ptr; 837 Typ : Entity_Id; 838 Tag_Node : Node_Id; 839 Position : Uint; 840 Address_Node : Node_Id) return Node_Id 841 is 842 Ctrl_Tag : Node_Id := Tag_Node; 843 New_Node : Node_Id; 844 845 begin 846 Build_Get_Prim_Op_Address (Loc, Typ, Position, Ctrl_Tag, New_Node); 847 848 return 849 Make_Assignment_Statement (Loc, 850 Name => New_Node, 851 Expression => Address_Node); 852 end Build_Set_Prim_Op_Address; 853 854 ----------------------------- 855 -- Build_Set_Size_Function -- 856 ----------------------------- 857 858 function Build_Set_Size_Function 859 (Loc : Source_Ptr; 860 Tag_Node : Node_Id; 861 Size_Func : Entity_Id) return Node_Id is 862 begin 863 pragma Assert (Chars (Size_Func) = Name_uSize 864 and then RTE_Record_Component_Available (RE_Size_Func)); 865 return 866 Make_Assignment_Statement (Loc, 867 Name => 868 Make_Selected_Component (Loc, 869 Prefix => 870 Build_TSD (Loc, 871 Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), 872 Selector_Name => 873 New_Occurrence_Of 874 (RTE_Record_Component (RE_Size_Func), Loc)), 875 Expression => 876 Unchecked_Convert_To (RTE (RE_Size_Ptr), 877 Make_Attribute_Reference (Loc, 878 Prefix => New_Occurrence_Of (Size_Func, Loc), 879 Attribute_Name => Name_Unrestricted_Access))); 880 end Build_Set_Size_Function; 881 882 ------------------------------------ 883 -- Build_Set_Static_Offset_To_Top -- 884 ------------------------------------ 885 886 function Build_Set_Static_Offset_To_Top 887 (Loc : Source_Ptr; 888 Iface_Tag : Node_Id; 889 Offset_Value : Node_Id) return Node_Id is 890 begin 891 return 892 Make_Assignment_Statement (Loc, 893 Make_Explicit_Dereference (Loc, 894 Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr), 895 Make_Function_Call (Loc, 896 Name => 897 Make_Expanded_Name (Loc, 898 Chars => Name_Op_Subtract, 899 Prefix => 900 New_Occurrence_Of 901 (RTU_Entity (System_Storage_Elements), Loc), 902 Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)), 903 Parameter_Associations => New_List ( 904 Unchecked_Convert_To (RTE (RE_Address), Iface_Tag), 905 New_Occurrence_Of 906 (RTE (RE_DT_Offset_To_Top_Offset), Loc))))), 907 Offset_Value); 908 end Build_Set_Static_Offset_To_Top; 909 910 --------------- 911 -- Build_TSD -- 912 --------------- 913 914 function Build_TSD 915 (Loc : Source_Ptr; 916 Tag_Node_Addr : Node_Id) return Node_Id is 917 begin 918 return 919 Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr), 920 Make_Explicit_Dereference (Loc, 921 Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr), 922 Make_Function_Call (Loc, 923 Name => 924 Make_Expanded_Name (Loc, 925 Chars => Name_Op_Subtract, 926 Prefix => 927 New_Occurrence_Of 928 (RTU_Entity (System_Storage_Elements), Loc), 929 Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)), 930 931 Parameter_Associations => New_List ( 932 Tag_Node_Addr, 933 New_Occurrence_Of 934 (RTE (RE_DT_Typeinfo_Ptr_Size), Loc)))))); 935 end Build_TSD; 936 937end Exp_Atag; 938