1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ D I S P -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2003 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Atree; use Atree; 28with Checks; use Checks; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Errout; use Errout; 32with Exp_Ch7; use Exp_Ch7; 33with Exp_Tss; use Exp_Tss; 34with Exp_Util; use Exp_Util; 35with Fname; use Fname; 36with Itypes; use Itypes; 37with Lib; use Lib; 38with Nlists; use Nlists; 39with Nmake; use Nmake; 40with Opt; use Opt; 41with Rtsfind; use Rtsfind; 42with Sem_Disp; use Sem_Disp; 43with Sem_Res; use Sem_Res; 44with Sem_Util; use Sem_Util; 45with Sinfo; use Sinfo; 46with Snames; use Snames; 47with Stand; use Stand; 48with Tbuild; use Tbuild; 49with Uintp; use Uintp; 50 51package body Exp_Disp is 52 53 Ada_Actions : constant array (DT_Access_Action) of RE_Id := 54 (CW_Membership => RE_CW_Membership, 55 DT_Entry_Size => RE_DT_Entry_Size, 56 DT_Prologue_Size => RE_DT_Prologue_Size, 57 Get_Expanded_Name => RE_Get_Expanded_Name, 58 Get_External_Tag => RE_Get_External_Tag, 59 Get_Prim_Op_Address => RE_Get_Prim_Op_Address, 60 Get_RC_Offset => RE_Get_RC_Offset, 61 Get_Remotely_Callable => RE_Get_Remotely_Callable, 62 Get_TSD => RE_Get_TSD, 63 Inherit_DT => RE_Inherit_DT, 64 Inherit_TSD => RE_Inherit_TSD, 65 Register_Tag => RE_Register_Tag, 66 Set_Expanded_Name => RE_Set_Expanded_Name, 67 Set_External_Tag => RE_Set_External_Tag, 68 Set_Prim_Op_Address => RE_Set_Prim_Op_Address, 69 Set_RC_Offset => RE_Set_RC_Offset, 70 Set_Remotely_Callable => RE_Set_Remotely_Callable, 71 Set_TSD => RE_Set_TSD, 72 TSD_Entry_Size => RE_TSD_Entry_Size, 73 TSD_Prologue_Size => RE_TSD_Prologue_Size); 74 75 CPP_Actions : constant array (DT_Access_Action) of RE_Id := 76 (CW_Membership => RE_CPP_CW_Membership, 77 DT_Entry_Size => RE_CPP_DT_Entry_Size, 78 DT_Prologue_Size => RE_CPP_DT_Prologue_Size, 79 Get_Expanded_Name => RE_CPP_Get_Expanded_Name, 80 Get_External_Tag => RE_CPP_Get_External_Tag, 81 Get_Prim_Op_Address => RE_CPP_Get_Prim_Op_Address, 82 Get_RC_Offset => RE_CPP_Get_RC_Offset, 83 Get_Remotely_Callable => RE_CPP_Get_Remotely_Callable, 84 Get_TSD => RE_CPP_Get_TSD, 85 Inherit_DT => RE_CPP_Inherit_DT, 86 Inherit_TSD => RE_CPP_Inherit_TSD, 87 Register_Tag => RE_CPP_Register_Tag, 88 Set_Expanded_Name => RE_CPP_Set_Expanded_Name, 89 Set_External_Tag => RE_CPP_Set_External_Tag, 90 Set_Prim_Op_Address => RE_CPP_Set_Prim_Op_Address, 91 Set_RC_Offset => RE_CPP_Set_RC_Offset, 92 Set_Remotely_Callable => RE_CPP_Set_Remotely_Callable, 93 Set_TSD => RE_CPP_Set_TSD, 94 TSD_Entry_Size => RE_CPP_TSD_Entry_Size, 95 TSD_Prologue_Size => RE_CPP_TSD_Prologue_Size); 96 97 Action_Is_Proc : constant array (DT_Access_Action) of Boolean := 98 (CW_Membership => False, 99 DT_Entry_Size => False, 100 DT_Prologue_Size => False, 101 Get_Expanded_Name => False, 102 Get_External_Tag => False, 103 Get_Prim_Op_Address => False, 104 Get_Remotely_Callable => False, 105 Get_RC_Offset => False, 106 Get_TSD => False, 107 Inherit_DT => True, 108 Inherit_TSD => True, 109 Register_Tag => True, 110 Set_Expanded_Name => True, 111 Set_External_Tag => True, 112 Set_Prim_Op_Address => True, 113 Set_RC_Offset => True, 114 Set_Remotely_Callable => True, 115 Set_TSD => True, 116 TSD_Entry_Size => False, 117 TSD_Prologue_Size => False); 118 119 Action_Nb_Arg : constant array (DT_Access_Action) of Int := 120 (CW_Membership => 2, 121 DT_Entry_Size => 0, 122 DT_Prologue_Size => 0, 123 Get_Expanded_Name => 1, 124 Get_External_Tag => 1, 125 Get_Prim_Op_Address => 2, 126 Get_RC_Offset => 1, 127 Get_Remotely_Callable => 1, 128 Get_TSD => 1, 129 Inherit_DT => 3, 130 Inherit_TSD => 2, 131 Register_Tag => 1, 132 Set_Expanded_Name => 2, 133 Set_External_Tag => 2, 134 Set_Prim_Op_Address => 3, 135 Set_RC_Offset => 2, 136 Set_Remotely_Callable => 2, 137 Set_TSD => 2, 138 TSD_Entry_Size => 0, 139 TSD_Prologue_Size => 0); 140 141 function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean; 142 -- Check if the type has a private view or if the public view appears 143 -- in the visible part of a package spec. 144 145 -------------------------- 146 -- Expand_Dispatch_Call -- 147 -------------------------- 148 149 procedure Expand_Dispatch_Call (Call_Node : Node_Id) is 150 Loc : constant Source_Ptr := Sloc (Call_Node); 151 Call_Typ : constant Entity_Id := Etype (Call_Node); 152 153 Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node); 154 Param_List : constant List_Id := Parameter_Associations (Call_Node); 155 Subp : Entity_Id := Entity (Name (Call_Node)); 156 157 CW_Typ : Entity_Id; 158 New_Call : Node_Id; 159 New_Call_Name : Node_Id; 160 New_Params : List_Id := No_List; 161 Param : Node_Id; 162 Res_Typ : Entity_Id; 163 Subp_Ptr_Typ : Entity_Id; 164 Subp_Typ : Entity_Id; 165 Typ : Entity_Id; 166 Eq_Prim_Op : Entity_Id := Empty; 167 168 function New_Value (From : Node_Id) return Node_Id; 169 -- From is the original Expression. New_Value is equivalent to a call 170 -- to Duplicate_Subexpr with an explicit dereference when From is an 171 -- access parameter 172 173 --------------- 174 -- New_Value -- 175 --------------- 176 177 function New_Value (From : Node_Id) return Node_Id is 178 Res : constant Node_Id := Duplicate_Subexpr (From); 179 180 begin 181 if Is_Access_Type (Etype (From)) then 182 return Make_Explicit_Dereference (Sloc (From), Res); 183 else 184 return Res; 185 end if; 186 end New_Value; 187 188 -- Start of processing for Expand_Dispatch_Call 189 190 begin 191 -- If this is an inherited operation that was overriden, the body 192 -- that is being called is its alias. 193 194 if Present (Alias (Subp)) 195 and then Is_Inherited_Operation (Subp) 196 and then No (DTC_Entity (Subp)) 197 then 198 Subp := Alias (Subp); 199 end if; 200 201 -- Expand_Dispatch is called directly from the semantics, so we need 202 -- a check to see whether expansion is active before proceeding 203 204 if not Expander_Active then 205 return; 206 end if; 207 208 -- Definition of the ClassWide Type and the Tagged type 209 210 if Is_Access_Type (Etype (Ctrl_Arg)) then 211 CW_Typ := Designated_Type (Etype (Ctrl_Arg)); 212 else 213 CW_Typ := Etype (Ctrl_Arg); 214 end if; 215 216 Typ := Root_Type (CW_Typ); 217 218 if not Is_Limited_Type (Typ) then 219 Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); 220 end if; 221 222 if Is_CPP_Class (Root_Type (Typ)) then 223 224 -- Create a new parameter list with the displaced 'this' 225 226 New_Params := New_List; 227 Param := First_Actual (Call_Node); 228 while Present (Param) loop 229 230 -- We assume that dispatching through the main dispatch table 231 -- (referenced by Tag_Component) doesn't require a displacement 232 -- so the expansion below is only done when dispatching on 233 -- another vtable pointer, in which case the first argument 234 -- is expanded into : 235 236 -- typ!(Displaced_This (Address!(Param))) 237 238 if Param = Ctrl_Arg 239 and then DTC_Entity (Subp) /= Tag_Component (Typ) 240 then 241 Append_To (New_Params, 242 243 Unchecked_Convert_To (Etype (Param), 244 Make_Function_Call (Loc, 245 Name => New_Reference_To (RTE (RE_Displaced_This), Loc), 246 Parameter_Associations => New_List ( 247 248 -- Current_This 249 250 Make_Unchecked_Type_Conversion (Loc, 251 Subtype_Mark => 252 New_Reference_To (RTE (RE_Address), Loc), 253 Expression => Relocate_Node (Param)), 254 255 -- Vptr 256 257 Make_Selected_Component (Loc, 258 Prefix => Duplicate_Subexpr (Ctrl_Arg), 259 Selector_Name => 260 New_Reference_To (DTC_Entity (Subp), Loc)), 261 262 -- Position 263 264 Make_Integer_Literal (Loc, DT_Position (Subp)))))); 265 266 else 267 Append_To (New_Params, Relocate_Node (Param)); 268 end if; 269 270 Next_Actual (Param); 271 end loop; 272 273 elsif Present (Param_List) then 274 275 -- Generate the Tag checks when appropriate 276 277 New_Params := New_List; 278 279 Param := First_Actual (Call_Node); 280 while Present (Param) loop 281 282 -- No tag check with itself 283 284 if Param = Ctrl_Arg then 285 Append_To (New_Params, 286 Duplicate_Subexpr_Move_Checks (Param)); 287 288 -- No tag check for parameter whose type is neither tagged nor 289 -- access to tagged (for access parameters) 290 291 elsif No (Find_Controlling_Arg (Param)) then 292 Append_To (New_Params, Relocate_Node (Param)); 293 294 -- No tag check for function dispatching on result it the 295 -- Tag given by the context is this one 296 297 elsif Find_Controlling_Arg (Param) = Ctrl_Arg then 298 Append_To (New_Params, Relocate_Node (Param)); 299 300 -- "=" is the only dispatching operation allowed to get 301 -- operands with incompatible tags (it just returns false). 302 -- We use Duplicate_Subexpr_Move_Checks instead of calling 303 -- Relocate_Node because the value will be duplicated to 304 -- check the tags. 305 306 elsif Subp = Eq_Prim_Op then 307 Append_To (New_Params, 308 Duplicate_Subexpr_Move_Checks (Param)); 309 310 -- No check in presence of suppress flags 311 312 elsif Tag_Checks_Suppressed (Etype (Param)) 313 or else (Is_Access_Type (Etype (Param)) 314 and then Tag_Checks_Suppressed 315 (Designated_Type (Etype (Param)))) 316 then 317 Append_To (New_Params, Relocate_Node (Param)); 318 319 -- Optimization: no tag checks if the parameters are identical 320 321 elsif Is_Entity_Name (Param) 322 and then Is_Entity_Name (Ctrl_Arg) 323 and then Entity (Param) = Entity (Ctrl_Arg) 324 then 325 Append_To (New_Params, Relocate_Node (Param)); 326 327 -- Now we need to generate the Tag check 328 329 else 330 -- Generate code for tag equality check 331 -- Perhaps should have Checks.Apply_Tag_Equality_Check??? 332 333 Insert_Action (Ctrl_Arg, 334 Make_Implicit_If_Statement (Call_Node, 335 Condition => 336 Make_Op_Ne (Loc, 337 Left_Opnd => 338 Make_Selected_Component (Loc, 339 Prefix => New_Value (Ctrl_Arg), 340 Selector_Name => 341 New_Reference_To (Tag_Component (Typ), Loc)), 342 343 Right_Opnd => 344 Make_Selected_Component (Loc, 345 Prefix => 346 Unchecked_Convert_To (Typ, New_Value (Param)), 347 Selector_Name => 348 New_Reference_To (Tag_Component (Typ), Loc))), 349 350 Then_Statements => 351 New_List (New_Constraint_Error (Loc)))); 352 353 Append_To (New_Params, Relocate_Node (Param)); 354 end if; 355 356 Next_Actual (Param); 357 end loop; 358 end if; 359 360 -- Generate the appropriate subprogram pointer type 361 362 if Etype (Subp) = Typ then 363 Res_Typ := CW_Typ; 364 else 365 Res_Typ := Etype (Subp); 366 end if; 367 368 Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node); 369 Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node); 370 Set_Etype (Subp_Typ, Res_Typ); 371 Init_Size_Align (Subp_Ptr_Typ); 372 Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp)); 373 374 -- Create a new list of parameters which is a copy of the old formal 375 -- list including the creation of a new set of matching entities. 376 377 declare 378 Old_Formal : Entity_Id := First_Formal (Subp); 379 New_Formal : Entity_Id; 380 Extra : Entity_Id; 381 382 begin 383 if Present (Old_Formal) then 384 New_Formal := New_Copy (Old_Formal); 385 Set_First_Entity (Subp_Typ, New_Formal); 386 Param := First_Actual (Call_Node); 387 388 loop 389 Set_Scope (New_Formal, Subp_Typ); 390 391 -- Change all the controlling argument types to be class-wide 392 -- to avoid a recursion in dispatching 393 394 if Is_Controlling_Actual (Param) then 395 Set_Etype (New_Formal, Etype (Param)); 396 end if; 397 398 if Is_Itype (Etype (New_Formal)) then 399 Extra := New_Copy (Etype (New_Formal)); 400 401 if Ekind (Extra) = E_Record_Subtype 402 or else Ekind (Extra) = E_Class_Wide_Subtype 403 then 404 Set_Cloned_Subtype (Extra, Etype (New_Formal)); 405 end if; 406 407 Set_Etype (New_Formal, Extra); 408 Set_Scope (Etype (New_Formal), Subp_Typ); 409 end if; 410 411 Extra := New_Formal; 412 Next_Formal (Old_Formal); 413 exit when No (Old_Formal); 414 415 Set_Next_Entity (New_Formal, New_Copy (Old_Formal)); 416 Next_Entity (New_Formal); 417 Next_Actual (Param); 418 end loop; 419 Set_Last_Entity (Subp_Typ, Extra); 420 421 -- Copy extra formals 422 423 New_Formal := First_Entity (Subp_Typ); 424 while Present (New_Formal) loop 425 if Present (Extra_Constrained (New_Formal)) then 426 Set_Extra_Formal (Extra, 427 New_Copy (Extra_Constrained (New_Formal))); 428 Extra := Extra_Formal (Extra); 429 Set_Extra_Constrained (New_Formal, Extra); 430 431 elsif Present (Extra_Accessibility (New_Formal)) then 432 Set_Extra_Formal (Extra, 433 New_Copy (Extra_Accessibility (New_Formal))); 434 Extra := Extra_Formal (Extra); 435 Set_Extra_Accessibility (New_Formal, Extra); 436 end if; 437 438 Next_Formal (New_Formal); 439 end loop; 440 end if; 441 end; 442 443 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); 444 Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ); 445 446 -- Generate: 447 -- Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos)); 448 449 New_Call_Name := 450 Unchecked_Convert_To (Subp_Ptr_Typ, 451 Make_DT_Access_Action (Typ, 452 Action => Get_Prim_Op_Address, 453 Args => New_List ( 454 455 -- Vptr 456 457 Make_Selected_Component (Loc, 458 Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg), 459 Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc)), 460 461 -- Position 462 463 Make_Integer_Literal (Loc, DT_Position (Subp))))); 464 465 if Nkind (Call_Node) = N_Function_Call then 466 New_Call := 467 Make_Function_Call (Loc, 468 Name => New_Call_Name, 469 Parameter_Associations => New_Params); 470 471 -- if this is a dispatching "=", we must first compare the tags so 472 -- we generate: x.tag = y.tag and then x = y 473 474 if Subp = Eq_Prim_Op then 475 476 Param := First_Actual (Call_Node); 477 New_Call := 478 Make_And_Then (Loc, 479 Left_Opnd => 480 Make_Op_Eq (Loc, 481 Left_Opnd => 482 Make_Selected_Component (Loc, 483 Prefix => New_Value (Param), 484 Selector_Name => 485 New_Reference_To (Tag_Component (Typ), Loc)), 486 487 Right_Opnd => 488 Make_Selected_Component (Loc, 489 Prefix => 490 Unchecked_Convert_To (Typ, 491 New_Value (Next_Actual (Param))), 492 Selector_Name => 493 New_Reference_To (Tag_Component (Typ), Loc))), 494 495 Right_Opnd => New_Call); 496 end if; 497 498 else 499 New_Call := 500 Make_Procedure_Call_Statement (Loc, 501 Name => New_Call_Name, 502 Parameter_Associations => New_Params); 503 end if; 504 505 Rewrite (Call_Node, New_Call); 506 Analyze_And_Resolve (Call_Node, Call_Typ); 507 end Expand_Dispatch_Call; 508 509 ------------- 510 -- Fill_DT -- 511 ------------- 512 513 function Fill_DT_Entry 514 (Loc : Source_Ptr; 515 Prim : Entity_Id) 516 return Node_Id 517 is 518 Typ : constant Entity_Id := Scope (DTC_Entity (Prim)); 519 DT_Ptr : constant Entity_Id := Access_Disp_Table (Typ); 520 521 begin 522 return 523 Make_DT_Access_Action (Typ, 524 Action => Set_Prim_Op_Address, 525 Args => New_List ( 526 New_Reference_To (DT_Ptr, Loc), -- DTptr 527 528 Make_Integer_Literal (Loc, DT_Position (Prim)), -- Position 529 530 Make_Attribute_Reference (Loc, -- Value 531 Prefix => New_Reference_To (Prim, Loc), 532 Attribute_Name => Name_Address))); 533 end Fill_DT_Entry; 534 535 --------------------------- 536 -- Get_Remotely_Callable -- 537 --------------------------- 538 539 function Get_Remotely_Callable (Obj : Node_Id) return Node_Id is 540 Loc : constant Source_Ptr := Sloc (Obj); 541 542 begin 543 return Make_DT_Access_Action 544 (Typ => Etype (Obj), 545 Action => Get_Remotely_Callable, 546 Args => New_List ( 547 Make_Selected_Component (Loc, 548 Prefix => Obj, 549 Selector_Name => Make_Identifier (Loc, Name_uTag)))); 550 end Get_Remotely_Callable; 551 552 ------------- 553 -- Make_DT -- 554 ------------- 555 556 function Make_DT (Typ : Entity_Id) return List_Id is 557 Loc : constant Source_Ptr := Sloc (Typ); 558 559 Result : constant List_Id := New_List; 560 Elab_Code : constant List_Id := New_List; 561 562 Tname : constant Name_Id := Chars (Typ); 563 Name_DT : constant Name_Id := New_External_Name (Tname, 'T'); 564 Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P'); 565 Name_TSD : constant Name_Id := New_External_Name (Tname, 'B'); 566 Name_Exname : constant Name_Id := New_External_Name (Tname, 'E'); 567 Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F'); 568 569 DT : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT); 570 DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr); 571 TSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD); 572 Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname); 573 No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg); 574 575 I_Depth : Int; 576 Generalized_Tag : Entity_Id; 577 Size_Expr_Node : Node_Id; 578 Old_Tag : Node_Id; 579 Old_TSD : Node_Id; 580 581 begin 582 if not RTE_Available (RE_Tag) then 583 Error_Msg_CRT ("tagged types", Typ); 584 return New_List; 585 end if; 586 587 if Is_CPP_Class (Root_Type (Typ)) then 588 Generalized_Tag := RTE (RE_Vtable_Ptr); 589 else 590 Generalized_Tag := RTE (RE_Tag); 591 end if; 592 593 -- Dispatch table and related entities are allocated statically 594 595 Set_Ekind (DT, E_Variable); 596 Set_Is_Statically_Allocated (DT); 597 598 Set_Ekind (DT_Ptr, E_Variable); 599 Set_Is_Statically_Allocated (DT_Ptr); 600 601 Set_Ekind (TSD, E_Variable); 602 Set_Is_Statically_Allocated (TSD); 603 604 Set_Ekind (Exname, E_Variable); 605 Set_Is_Statically_Allocated (Exname); 606 607 Set_Ekind (No_Reg, E_Variable); 608 Set_Is_Statically_Allocated (No_Reg); 609 610 -- Generate code to create the storage for the Dispatch_Table object: 611 612 -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size); 613 -- for DT'Alignment use Address'Alignment 614 615 Size_Expr_Node := 616 Make_Op_Add (Loc, 617 Left_Opnd => Make_DT_Access_Action (Typ, DT_Prologue_Size, No_List), 618 Right_Opnd => 619 Make_Op_Multiply (Loc, 620 Left_Opnd => 621 Make_DT_Access_Action (Typ, DT_Entry_Size, No_List), 622 Right_Opnd => 623 Make_Integer_Literal (Loc, 624 DT_Entry_Count (Tag_Component (Typ))))); 625 626 Append_To (Result, 627 Make_Object_Declaration (Loc, 628 Defining_Identifier => DT, 629 Aliased_Present => True, 630 Object_Definition => 631 Make_Subtype_Indication (Loc, 632 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc), 633 Constraint => Make_Index_Or_Discriminant_Constraint (Loc, 634 Constraints => New_List ( 635 Make_Range (Loc, 636 Low_Bound => Make_Integer_Literal (Loc, 1), 637 High_Bound => Size_Expr_Node)))))); 638 639 Append_To (Result, 640 Make_Attribute_Definition_Clause (Loc, 641 Name => New_Reference_To (DT, Loc), 642 Chars => Name_Alignment, 643 Expression => 644 Make_Attribute_Reference (Loc, 645 Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), 646 Attribute_Name => Name_Alignment))); 647 648 -- Generate code to create the pointer to the dispatch table 649 650 -- DT_Ptr : Tag := Tag!(DT'Address); Ada case 651 -- or 652 -- DT_Ptr : Vtable_Ptr := Vtable_Ptr!(DT'Address); CPP case 653 654 Append_To (Result, 655 Make_Object_Declaration (Loc, 656 Defining_Identifier => DT_Ptr, 657 Constant_Present => True, 658 Object_Definition => New_Reference_To (Generalized_Tag, Loc), 659 Expression => 660 Unchecked_Convert_To (Generalized_Tag, 661 Make_Attribute_Reference (Loc, 662 Prefix => New_Reference_To (DT, Loc), 663 Attribute_Name => Name_Address)))); 664 665 -- Generate code to define the boolean that controls registration, in 666 -- order to avoid multiple registrations for tagged types defined in 667 -- multiple-called scopes 668 669 Append_To (Result, 670 Make_Object_Declaration (Loc, 671 Defining_Identifier => No_Reg, 672 Object_Definition => New_Reference_To (Standard_Boolean, Loc), 673 Expression => New_Reference_To (Standard_True, Loc))); 674 675 -- Set Access_Disp_Table field to be the dispatch table pointer 676 677 Set_Access_Disp_Table (Typ, DT_Ptr); 678 679 -- Count ancestors to compute the inheritance depth. For private 680 -- extensions, always go to the full view in order to compute the real 681 -- inheritance depth. 682 683 declare 684 Parent_Type : Entity_Id := Typ; 685 P : Entity_Id; 686 687 begin 688 I_Depth := 0; 689 690 loop 691 P := Etype (Parent_Type); 692 693 if Is_Private_Type (P) then 694 P := Full_View (Base_Type (P)); 695 end if; 696 697 exit when P = Parent_Type; 698 699 I_Depth := I_Depth + 1; 700 Parent_Type := P; 701 end loop; 702 end; 703 704 -- Generate code to create the storage for the type specific data object 705 706 -- TSD: Storage_Array (1..TSD_Prologue_Size+(1+Idepth)*TSD_Entry_Size); 707 -- for TSD'Alignment use Address'Alignment 708 709 Size_Expr_Node := 710 Make_Op_Add (Loc, 711 Left_Opnd => 712 Make_DT_Access_Action (Typ, TSD_Prologue_Size, No_List), 713 Right_Opnd => 714 Make_Op_Multiply (Loc, 715 Left_Opnd => 716 Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List), 717 Right_Opnd => 718 Make_Op_Add (Loc, 719 Left_Opnd => Make_Integer_Literal (Loc, 1), 720 Right_Opnd => 721 Make_Integer_Literal (Loc, I_Depth)))); 722 723 Append_To (Result, 724 Make_Object_Declaration (Loc, 725 Defining_Identifier => TSD, 726 Aliased_Present => True, 727 Object_Definition => 728 Make_Subtype_Indication (Loc, 729 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc), 730 Constraint => Make_Index_Or_Discriminant_Constraint (Loc, 731 Constraints => New_List ( 732 Make_Range (Loc, 733 Low_Bound => Make_Integer_Literal (Loc, 1), 734 High_Bound => Size_Expr_Node)))))); 735 736 Append_To (Result, 737 Make_Attribute_Definition_Clause (Loc, 738 Name => New_Reference_To (TSD, Loc), 739 Chars => Name_Alignment, 740 Expression => 741 Make_Attribute_Reference (Loc, 742 Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), 743 Attribute_Name => Name_Alignment))); 744 745 -- Generate code to put the Address of the TSD in the dispatch table 746 -- Set_TSD (DT_Ptr, TSD); 747 748 Append_To (Elab_Code, 749 Make_DT_Access_Action (Typ, 750 Action => Set_TSD, 751 Args => New_List ( 752 New_Reference_To (DT_Ptr, Loc), -- DTptr 753 Make_Attribute_Reference (Loc, -- Value 754 Prefix => New_Reference_To (TSD, Loc), 755 Attribute_Name => Name_Address)))); 756 757 if Typ = Etype (Typ) 758 or else Is_CPP_Class (Etype (Typ)) 759 then 760 Old_Tag := 761 Unchecked_Convert_To (Generalized_Tag, 762 Make_Integer_Literal (Loc, 0)); 763 764 Old_TSD := 765 Unchecked_Convert_To (RTE (RE_Address), 766 Make_Integer_Literal (Loc, 0)); 767 768 else 769 Old_Tag := New_Reference_To (Access_Disp_Table (Etype (Typ)), Loc); 770 Old_TSD := 771 Make_DT_Access_Action (Typ, 772 Action => Get_TSD, 773 Args => New_List ( 774 New_Reference_To (Access_Disp_Table (Etype (Typ)), Loc))); 775 end if; 776 777 -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent); 778 779 Append_To (Elab_Code, 780 Make_DT_Access_Action (Typ, 781 Action => Inherit_DT, 782 Args => New_List ( 783 Node1 => Old_Tag, 784 Node2 => New_Reference_To (DT_Ptr, Loc), 785 Node3 => Make_Integer_Literal (Loc, 786 DT_Entry_Count (Tag_Component (Etype (Typ))))))); 787 788 -- Generate: Inherit_TSD (Get_TSD (parent), DT_Ptr); 789 790 Append_To (Elab_Code, 791 Make_DT_Access_Action (Typ, 792 Action => Inherit_TSD, 793 Args => New_List ( 794 Node1 => Old_TSD, 795 Node2 => New_Reference_To (DT_Ptr, Loc)))); 796 797 -- Generate: Exname : constant String := full_qualified_name (typ); 798 -- The type itself may be an anonymous parent type, so use the first 799 -- subtype to have a user-recognizable name. 800 801 Append_To (Result, 802 Make_Object_Declaration (Loc, 803 Defining_Identifier => Exname, 804 Constant_Present => True, 805 Object_Definition => New_Reference_To (Standard_String, Loc), 806 Expression => 807 Make_String_Literal (Loc, 808 Full_Qualified_Name (First_Subtype (Typ))))); 809 810 -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address); 811 812 Append_To (Elab_Code, 813 Make_DT_Access_Action (Typ, 814 Action => Set_Expanded_Name, 815 Args => New_List ( 816 Node1 => New_Reference_To (DT_Ptr, Loc), 817 Node2 => 818 Make_Attribute_Reference (Loc, 819 Prefix => New_Reference_To (Exname, Loc), 820 Attribute_Name => Name_Address)))); 821 822 -- for types with no controlled components 823 -- Generate: Set_RC_Offset (DT_Ptr, 0); 824 -- for simple types with controlled components 825 -- Generate: Set_RC_Offset (DT_Ptr, type._record_controller'position); 826 -- for complex types with controlled components where the position 827 -- of the record controller is not statically computable, if there are 828 -- controlled components at this level 829 -- Generate: Set_RC_Offset (DT_Ptr, -1); 830 -- to indicate that the _controller field is right after the _parent or 831 -- if there are no controlled components at this level, 832 -- Generate: Set_RC_Offset (DT_Ptr, -2); 833 -- to indicate that we need to get the position from the parent. 834 835 declare 836 Position : Node_Id; 837 838 begin 839 if not Has_Controlled_Component (Typ) then 840 Position := Make_Integer_Literal (Loc, 0); 841 842 elsif Etype (Typ) /= Typ and then Has_Discriminants (Etype (Typ)) then 843 if Has_New_Controlled_Component (Typ) then 844 Position := Make_Integer_Literal (Loc, -1); 845 else 846 Position := Make_Integer_Literal (Loc, -2); 847 end if; 848 else 849 Position := 850 Make_Attribute_Reference (Loc, 851 Prefix => 852 Make_Selected_Component (Loc, 853 Prefix => New_Reference_To (Typ, Loc), 854 Selector_Name => 855 New_Reference_To (Controller_Component (Typ), Loc)), 856 Attribute_Name => Name_Position); 857 858 -- This is not proper Ada code to use the attribute 'Position 859 -- on something else than an object but this is supported by 860 -- the back end (see comment on the Bit_Component attribute in 861 -- sem_attr). So we avoid semantic checking here. 862 863 Set_Analyzed (Position); 864 Set_Etype (Prefix (Position), RTE (RE_Record_Controller)); 865 Set_Etype (Prefix (Prefix (Position)), Typ); 866 Set_Etype (Selector_Name (Prefix (Position)), 867 RTE (RE_Record_Controller)); 868 Set_Etype (Position, RTE (RE_Storage_Offset)); 869 end if; 870 871 Append_To (Elab_Code, 872 Make_DT_Access_Action (Typ, 873 Action => Set_RC_Offset, 874 Args => New_List ( 875 Node1 => New_Reference_To (DT_Ptr, Loc), 876 Node2 => Position))); 877 end; 878 879 -- Generate: Set_Remotely_Callable (DT_Ptr, status); 880 -- where status is described in E.4 (18) 881 882 declare 883 Status : Entity_Id; 884 885 begin 886 if Is_Pure (Typ) 887 or else Is_Shared_Passive (Typ) 888 or else 889 ((Is_Remote_Types (Typ) or else Is_Remote_Call_Interface (Typ)) 890 and then Original_View_In_Visible_Part (Typ)) 891 or else not Comes_From_Source (Typ) 892 then 893 Status := Standard_True; 894 else 895 Status := Standard_False; 896 end if; 897 898 Append_To (Elab_Code, 899 Make_DT_Access_Action (Typ, 900 Action => Set_Remotely_Callable, 901 Args => New_List ( 902 New_Occurrence_Of (DT_Ptr, Loc), 903 New_Occurrence_Of (Status, Loc)))); 904 end; 905 906 -- Generate: Set_External_Tag (DT_Ptr, exname'Address); 907 -- Should be the external name not the qualified name??? 908 909 if not Has_External_Tag_Rep_Clause (Typ) then 910 Append_To (Elab_Code, 911 Make_DT_Access_Action (Typ, 912 Action => Set_External_Tag, 913 Args => New_List ( 914 Node1 => New_Reference_To (DT_Ptr, Loc), 915 Node2 => 916 Make_Attribute_Reference (Loc, 917 Prefix => New_Reference_To (Exname, Loc), 918 Attribute_Name => Name_Address)))); 919 920 -- Generate code to register the Tag in the External_Tag hash 921 -- table for the pure Ada type only. 922 923 -- Register_Tag (Dt_Ptr); 924 925 -- Skip this if routine not available, or in No_Run_Time mode 926 927 if RTE_Available (RE_Register_Tag) 928 and then Is_RTE (Generalized_Tag, RE_Tag) 929 and then not No_Run_Time_Mode 930 then 931 Append_To (Elab_Code, 932 Make_Procedure_Call_Statement (Loc, 933 Name => New_Reference_To (RTE (RE_Register_Tag), Loc), 934 Parameter_Associations => 935 New_List (New_Reference_To (DT_Ptr, Loc)))); 936 end if; 937 end if; 938 939 -- Generate: 940 -- if No_Reg then 941 -- <elab_code> 942 -- No_Reg := False; 943 -- end if; 944 945 Append_To (Elab_Code, 946 Make_Assignment_Statement (Loc, 947 Name => New_Reference_To (No_Reg, Loc), 948 Expression => New_Reference_To (Standard_False, Loc))); 949 950 Append_To (Result, 951 Make_Implicit_If_Statement (Typ, 952 Condition => New_Reference_To (No_Reg, Loc), 953 Then_Statements => Elab_Code)); 954 955 return Result; 956 end Make_DT; 957 958 --------------------------- 959 -- Make_DT_Access_Action -- 960 --------------------------- 961 962 function Make_DT_Access_Action 963 (Typ : Entity_Id; 964 Action : DT_Access_Action; 965 Args : List_Id) 966 return Node_Id 967 is 968 Action_Name : Entity_Id; 969 Loc : Source_Ptr; 970 971 begin 972 if Is_CPP_Class (Root_Type (Typ)) then 973 Action_Name := RTE (CPP_Actions (Action)); 974 else 975 Action_Name := RTE (Ada_Actions (Action)); 976 end if; 977 978 if No (Args) then 979 980 -- This is a constant 981 982 return New_Reference_To (Action_Name, Sloc (Typ)); 983 end if; 984 985 pragma Assert (List_Length (Args) = Action_Nb_Arg (Action)); 986 987 Loc := Sloc (First (Args)); 988 989 if Action_Is_Proc (Action) then 990 return 991 Make_Procedure_Call_Statement (Loc, 992 Name => New_Reference_To (Action_Name, Loc), 993 Parameter_Associations => Args); 994 995 else 996 return 997 Make_Function_Call (Loc, 998 Name => New_Reference_To (Action_Name, Loc), 999 Parameter_Associations => Args); 1000 end if; 1001 end Make_DT_Access_Action; 1002 1003 ----------------------------------- 1004 -- Original_View_In_Visible_Part -- 1005 ----------------------------------- 1006 1007 function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is 1008 Scop : constant Entity_Id := Scope (Typ); 1009 1010 begin 1011 -- The scope must be a package 1012 1013 if Ekind (Scop) /= E_Package 1014 and then Ekind (Scop) /= E_Generic_Package 1015 then 1016 return False; 1017 end if; 1018 1019 -- A type with a private declaration has a private view declared in 1020 -- the visible part. 1021 1022 if Has_Private_Declaration (Typ) then 1023 return True; 1024 end if; 1025 1026 return List_Containing (Parent (Typ)) = 1027 Visible_Declarations (Specification (Unit_Declaration_Node (Scop))); 1028 end Original_View_In_Visible_Part; 1029 1030 ------------------------- 1031 -- Set_All_DT_Position -- 1032 ------------------------- 1033 1034 procedure Set_All_DT_Position (Typ : Entity_Id) is 1035 Parent_Typ : constant Entity_Id := Etype (Typ); 1036 Root_Typ : constant Entity_Id := Root_Type (Typ); 1037 First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ)); 1038 The_Tag : constant Entity_Id := Tag_Component (Typ); 1039 Adjusted : Boolean := False; 1040 Finalized : Boolean := False; 1041 Parent_EC : Int; 1042 Nb_Prim : Int; 1043 Prim : Entity_Id; 1044 Prim_Elmt : Elmt_Id; 1045 1046 begin 1047 1048 -- Get Entry_Count of the parent 1049 1050 if Parent_Typ /= Typ 1051 and then DT_Entry_Count (Tag_Component (Parent_Typ)) /= No_Uint 1052 then 1053 Parent_EC := UI_To_Int (DT_Entry_Count (Tag_Component (Parent_Typ))); 1054 else 1055 Parent_EC := 0; 1056 end if; 1057 1058 -- C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable 1059 -- give a coherent set of information 1060 1061 if Is_CPP_Class (Root_Typ) then 1062 1063 -- Compute the number of primitive operations in the main Vtable 1064 -- Set their position: 1065 -- - where it was set if overriden or inherited 1066 -- - after the end of the parent vtable otherwise 1067 1068 Prim_Elmt := First_Prim; 1069 Nb_Prim := 0; 1070 while Present (Prim_Elmt) loop 1071 Prim := Node (Prim_Elmt); 1072 1073 if not Is_CPP_Class (Typ) then 1074 Set_DTC_Entity (Prim, The_Tag); 1075 1076 elsif Present (Alias (Prim)) then 1077 Set_DTC_Entity (Prim, DTC_Entity (Alias (Prim))); 1078 Set_DT_Position (Prim, DT_Position (Alias (Prim))); 1079 1080 elsif No (DTC_Entity (Prim)) and then Is_CPP_Class (Typ) then 1081 Error_Msg_NE ("is a primitive operation of&," & 1082 " pragma Cpp_Virtual required", Prim, Typ); 1083 end if; 1084 1085 if DTC_Entity (Prim) = The_Tag then 1086 1087 -- Get the slot from the parent subprogram if any 1088 1089 declare 1090 H : Entity_Id := Homonym (Prim); 1091 1092 begin 1093 while Present (H) loop 1094 if Present (DTC_Entity (H)) 1095 and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ 1096 then 1097 Set_DT_Position (Prim, DT_Position (H)); 1098 exit; 1099 end if; 1100 1101 H := Homonym (H); 1102 end loop; 1103 end; 1104 1105 -- Otherwise take the canonical slot after the end of the 1106 -- parent Vtable 1107 1108 if DT_Position (Prim) = No_Uint then 1109 Nb_Prim := Nb_Prim + 1; 1110 Set_DT_Position (Prim, UI_From_Int (Parent_EC + Nb_Prim)); 1111 1112 elsif UI_To_Int (DT_Position (Prim)) > Parent_EC then 1113 Nb_Prim := Nb_Prim + 1; 1114 end if; 1115 end if; 1116 1117 Next_Elmt (Prim_Elmt); 1118 end loop; 1119 1120 -- Check that the declared size of the Vtable is bigger or equal 1121 -- than the number of primitive operations (if bigger it means that 1122 -- some of the c++ virtual functions were not imported, that is 1123 -- allowed) 1124 1125 if DT_Entry_Count (The_Tag) = No_Uint 1126 or else not Is_CPP_Class (Typ) 1127 then 1128 Set_DT_Entry_Count (The_Tag, UI_From_Int (Parent_EC + Nb_Prim)); 1129 1130 elsif UI_To_Int (DT_Entry_Count (The_Tag)) < Parent_EC + Nb_Prim then 1131 Error_Msg_N ("not enough room in the Vtable for all virtual" 1132 & " functions", The_Tag); 1133 end if; 1134 1135 -- Check that Positions are not duplicate nor outside the range of 1136 -- the Vtable 1137 1138 declare 1139 Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag)); 1140 Pos : Int; 1141 Prim_Pos_Table : array (1 .. Size) of Entity_Id := 1142 (others => Empty); 1143 1144 begin 1145 Prim_Elmt := First_Prim; 1146 while Present (Prim_Elmt) loop 1147 Prim := Node (Prim_Elmt); 1148 1149 if DTC_Entity (Prim) = The_Tag then 1150 Pos := UI_To_Int (DT_Position (Prim)); 1151 1152 if Pos not in Prim_Pos_Table'Range then 1153 Error_Msg_N 1154 ("position not in range of virtual table", Prim); 1155 1156 elsif Present (Prim_Pos_Table (Pos)) then 1157 Error_Msg_NE ("cannot be at the same position in the" 1158 & " vtable than&", Prim, Prim_Pos_Table (Pos)); 1159 1160 else 1161 Prim_Pos_Table (Pos) := Prim; 1162 end if; 1163 end if; 1164 1165 Next_Elmt (Prim_Elmt); 1166 end loop; 1167 end; 1168 1169 -- For regular Ada tagged types, just set the DT_Position for 1170 -- each primitive operation. Perform some sanity checks to avoid 1171 -- to build completely inconsistant dispatch tables. 1172 1173 -- Note that the _Size primitive is always set at position 1 in order 1174 -- to comply with the needs of Ada.Tags.Parent_Size (see documentation 1175 -- in a-tags.ad?) 1176 1177 else 1178 Nb_Prim := 1; 1179 Prim_Elmt := First_Prim; 1180 while Present (Prim_Elmt) loop 1181 Nb_Prim := Nb_Prim + 1; 1182 Prim := Node (Prim_Elmt); 1183 Set_DTC_Entity (Prim, The_Tag); 1184 1185 if Chars (Prim) = Name_uSize then 1186 Set_DT_Position (Prim, Uint_1); 1187 Nb_Prim := Nb_Prim - 1; 1188 else 1189 Set_DT_Position (Prim, UI_From_Int (Nb_Prim)); 1190 end if; 1191 1192 if Chars (Prim) = Name_Finalize 1193 and then 1194 (Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) 1195 or else not Is_Predefined_File_Name 1196 (Unit_File_Name (Get_Source_Unit (Prim)))) 1197 then 1198 Finalized := True; 1199 end if; 1200 1201 if Chars (Prim) = Name_Adjust then 1202 Adjusted := True; 1203 end if; 1204 1205 -- An abstract operation cannot be declared in the private part 1206 -- for a visible abstract type, because it could never be over- 1207 -- ridden. For explicit declarations this is checked at the point 1208 -- of declaration, but for inherited operations it must be done 1209 -- when building the dispatch table. Input is excluded because 1210 1211 if Is_Abstract (Typ) 1212 and then Is_Abstract (Prim) 1213 and then Present (Alias (Prim)) 1214 and then Is_Derived_Type (Typ) 1215 and then In_Private_Part (Current_Scope) 1216 and then List_Containing (Parent (Prim)) 1217 = Private_Declarations 1218 (Specification (Unit_Declaration_Node (Current_Scope))) 1219 and then Original_View_In_Visible_Part (Typ) 1220 then 1221 -- We exclude Input and Output stream operations because 1222 -- Limited_Controlled inherits useless Input and Output 1223 -- stream operations from Root_Controlled, which can 1224 -- never be overridden. 1225 1226 if not Is_TSS (Prim, TSS_Stream_Input) 1227 and then 1228 not Is_TSS (Prim, TSS_Stream_Output) 1229 then 1230 Error_Msg_NE 1231 ("abstract inherited private operation&" & 1232 " must be overridden ('R'M 3.9.3(10))", 1233 Parent (Typ), Prim); 1234 end if; 1235 end if; 1236 Next_Elmt (Prim_Elmt); 1237 end loop; 1238 1239 if Is_Controlled (Typ) then 1240 if not Finalized then 1241 Error_Msg_N 1242 ("controlled type has no explicit Finalize method?", Typ); 1243 1244 elsif not Adjusted then 1245 Error_Msg_N 1246 ("controlled type has no explicit Adjust method?", Typ); 1247 end if; 1248 end if; 1249 1250 Set_DT_Entry_Count (The_Tag, UI_From_Int (Nb_Prim)); 1251 1252 -- The derived type must have at least as many components as its 1253 -- parent (for root types, the Etype points back to itself 1254 -- and the test should not fail) 1255 1256 pragma Assert ( 1257 DT_Entry_Count (The_Tag) >= 1258 DT_Entry_Count (Tag_Component (Parent_Typ))); 1259 end if; 1260 end Set_All_DT_Position; 1261 1262 ----------------------------- 1263 -- Set_Default_Constructor -- 1264 ----------------------------- 1265 1266 procedure Set_Default_Constructor (Typ : Entity_Id) is 1267 Loc : Source_Ptr; 1268 Init : Entity_Id; 1269 Param : Entity_Id; 1270 E : Entity_Id; 1271 1272 begin 1273 -- Look for the default constructor entity. For now only the 1274 -- default constructor has the flag Is_Constructor. 1275 1276 E := Next_Entity (Typ); 1277 while Present (E) 1278 and then (Ekind (E) /= E_Function or else not Is_Constructor (E)) 1279 loop 1280 Next_Entity (E); 1281 end loop; 1282 1283 -- Create the init procedure 1284 1285 if Present (E) then 1286 Loc := Sloc (E); 1287 Init := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ)); 1288 Param := Make_Defining_Identifier (Loc, Name_X); 1289 1290 Discard_Node ( 1291 Make_Subprogram_Declaration (Loc, 1292 Make_Procedure_Specification (Loc, 1293 Defining_Unit_Name => Init, 1294 Parameter_Specifications => New_List ( 1295 Make_Parameter_Specification (Loc, 1296 Defining_Identifier => Param, 1297 Parameter_Type => New_Reference_To (Typ, Loc)))))); 1298 1299 Set_Init_Proc (Typ, Init); 1300 Set_Is_Imported (Init); 1301 Set_Interface_Name (Init, Interface_Name (E)); 1302 Set_Convention (Init, Convention_C); 1303 Set_Is_Public (Init); 1304 Set_Has_Completion (Init); 1305 1306 -- If there are no constructors, mark the type as abstract since we 1307 -- won't be able to declare objects of that type. 1308 1309 else 1310 Set_Is_Abstract (Typ); 1311 end if; 1312 end Set_Default_Constructor; 1313 1314end Exp_Disp; 1315