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