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