1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ 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 Debug; use Debug; 29with Elists; use Elists; 30with Einfo; use Einfo; 31with Exp_Disp; use Exp_Disp; 32with Exp_Ch7; use Exp_Ch7; 33with Exp_Tss; use Exp_Tss; 34with Errout; use Errout; 35with Hostparm; use Hostparm; 36with Nlists; use Nlists; 37with Opt; use Opt; 38with Output; use Output; 39with Sem; use Sem; 40with Sem_Ch6; use Sem_Ch6; 41with Sem_Eval; use Sem_Eval; 42with Sem_Util; use Sem_Util; 43with Snames; use Snames; 44with Sinfo; use Sinfo; 45with Uintp; use Uintp; 46 47package body Sem_Disp is 48 49 ----------------------- 50 -- Local Subprograms -- 51 ----------------------- 52 53 procedure Override_Dispatching_Operation 54 (Tagged_Type : Entity_Id; 55 Prev_Op : Entity_Id; 56 New_Op : Entity_Id); 57 -- Replace an implicit dispatching operation with an explicit one. 58 -- Prev_Op is an inherited primitive operation which is overridden 59 -- by the explicit declaration of New_Op. 60 61 procedure Add_Dispatching_Operation 62 (Tagged_Type : Entity_Id; 63 New_Op : Entity_Id); 64 -- Add New_Op in the list of primitive operations of Tagged_Type 65 66 function Check_Controlling_Type 67 (T : Entity_Id; 68 Subp : Entity_Id) 69 return Entity_Id; 70 -- T is the type of a formal parameter of subp. Returns the tagged 71 -- if the parameter can be a controlling argument, empty otherwise 72 73 -------------------------------- 74 -- Add_Dispatching_Operation -- 75 -------------------------------- 76 77 procedure Add_Dispatching_Operation 78 (Tagged_Type : Entity_Id; 79 New_Op : Entity_Id) 80 is 81 List : constant Elist_Id := Primitive_Operations (Tagged_Type); 82 83 begin 84 Append_Elmt (New_Op, List); 85 end Add_Dispatching_Operation; 86 87 ------------------------------- 88 -- Check_Controlling_Formals -- 89 ------------------------------- 90 91 procedure Check_Controlling_Formals 92 (Typ : Entity_Id; 93 Subp : Entity_Id) 94 is 95 Formal : Entity_Id; 96 Ctrl_Type : Entity_Id; 97 Remote : constant Boolean := 98 Is_Remote_Types (Current_Scope) 99 and then Comes_From_Source (Subp) 100 and then Scope (Typ) = Current_Scope; 101 102 begin 103 Formal := First_Formal (Subp); 104 105 while Present (Formal) loop 106 Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp); 107 108 if Present (Ctrl_Type) then 109 if Ctrl_Type = Typ then 110 Set_Is_Controlling_Formal (Formal); 111 112 -- Check that the parameter's nominal subtype statically 113 -- matches the first subtype. 114 115 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then 116 if not Subtypes_Statically_Match 117 (Typ, Designated_Type (Etype (Formal))) 118 then 119 Error_Msg_N 120 ("parameter subtype does not match controlling type", 121 Formal); 122 end if; 123 124 elsif not Subtypes_Statically_Match (Typ, Etype (Formal)) then 125 Error_Msg_N 126 ("parameter subtype does not match controlling type", 127 Formal); 128 end if; 129 130 if Present (Default_Value (Formal)) then 131 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then 132 Error_Msg_N 133 ("default not allowed for controlling access parameter", 134 Default_Value (Formal)); 135 136 elsif not Is_Tag_Indeterminate (Default_Value (Formal)) then 137 Error_Msg_N 138 ("default expression must be a tag indeterminate" & 139 " function call", Default_Value (Formal)); 140 end if; 141 end if; 142 143 elsif Comes_From_Source (Subp) then 144 Error_Msg_N 145 ("operation can be dispatching in only one type", Subp); 146 end if; 147 148 -- Verify that the restriction in E.2.2 (14) is obeyed 149 150 elsif Remote 151 and then Ekind (Etype (Formal)) = E_Anonymous_Access_Type 152 then 153 Error_Msg_N 154 ("Access parameter of a remote subprogram must be controlling", 155 Formal); 156 end if; 157 158 Next_Formal (Formal); 159 end loop; 160 161 if Present (Etype (Subp)) then 162 Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp); 163 164 if Present (Ctrl_Type) then 165 if Ctrl_Type = Typ then 166 Set_Has_Controlling_Result (Subp); 167 168 -- Check that the result subtype statically matches 169 -- the first subtype. 170 171 if not Subtypes_Statically_Match (Typ, Etype (Subp)) then 172 Error_Msg_N 173 ("result subtype does not match controlling type", Subp); 174 end if; 175 176 elsif Comes_From_Source (Subp) then 177 Error_Msg_N 178 ("operation can be dispatching in only one type", Subp); 179 end if; 180 181 -- The following check is clearly required, although the RM says 182 -- nothing about return types. If the return type is a limited 183 -- class-wide type declared in the current scope, there is no way 184 -- to declare stream procedures for it, so the return cannot be 185 -- marshalled. 186 187 elsif Remote 188 and then Is_Limited_Type (Typ) 189 and then Etype (Subp) = Class_Wide_Type (Typ) 190 then 191 Error_Msg_N ("return type has no stream attributes", Subp); 192 end if; 193 end if; 194 end Check_Controlling_Formals; 195 196 ---------------------------- 197 -- Check_Controlling_Type -- 198 ---------------------------- 199 200 function Check_Controlling_Type 201 (T : Entity_Id; 202 Subp : Entity_Id) 203 return Entity_Id 204 is 205 Tagged_Type : Entity_Id := Empty; 206 207 begin 208 if Is_Tagged_Type (T) then 209 if Is_First_Subtype (T) then 210 Tagged_Type := T; 211 else 212 Tagged_Type := Base_Type (T); 213 end if; 214 215 elsif Ekind (T) = E_Anonymous_Access_Type 216 and then Is_Tagged_Type (Designated_Type (T)) 217 and then Ekind (Designated_Type (T)) /= E_Incomplete_Type 218 then 219 if Is_First_Subtype (Designated_Type (T)) then 220 Tagged_Type := Designated_Type (T); 221 else 222 Tagged_Type := Base_Type (Designated_Type (T)); 223 end if; 224 end if; 225 226 if No (Tagged_Type) 227 or else Is_Class_Wide_Type (Tagged_Type) 228 then 229 return Empty; 230 231 -- The dispatching type and the primitive operation must be defined 232 -- in the same scope except for internal operations. 233 234 elsif (Scope (Subp) = Scope (Tagged_Type) 235 or else Is_Internal (Subp)) 236 and then 237 (not Is_Generic_Type (Tagged_Type) 238 or else not Comes_From_Source (Subp)) 239 then 240 return Tagged_Type; 241 242 else 243 return Empty; 244 end if; 245 end Check_Controlling_Type; 246 247 ---------------------------- 248 -- Check_Dispatching_Call -- 249 ---------------------------- 250 251 procedure Check_Dispatching_Call (N : Node_Id) is 252 Actual : Node_Id; 253 Control : Node_Id := Empty; 254 Func : Entity_Id; 255 256 procedure Check_Dispatching_Context; 257 -- If the call is tag-indeterminate and the entity being called is 258 -- abstract, verify that the context is a call that will eventually 259 -- provide a tag for dispatching, or has provided one already. 260 261 ------------------------------- 262 -- Check_Dispatching_Context -- 263 ------------------------------- 264 265 procedure Check_Dispatching_Context is 266 Func : constant Entity_Id := Entity (Name (N)); 267 Par : Node_Id; 268 269 begin 270 if Is_Abstract (Func) 271 and then No (Controlling_Argument (N)) 272 then 273 if Present (Alias (Func)) 274 and then not Is_Abstract (Alias (Func)) 275 and then No (DTC_Entity (Func)) 276 then 277 -- Private overriding of inherited abstract operation, 278 -- call is legal. 279 280 Set_Entity (Name (N), Alias (Func)); 281 return; 282 283 else 284 Par := Parent (N); 285 286 while Present (Par) loop 287 288 if (Nkind (Par) = N_Function_Call or else 289 Nkind (Par) = N_Procedure_Call_Statement or else 290 Nkind (Par) = N_Assignment_Statement or else 291 Nkind (Par) = N_Op_Eq or else 292 Nkind (Par) = N_Op_Ne) 293 and then Is_Tagged_Type (Etype (Func)) 294 then 295 return; 296 297 elsif Nkind (Par) = N_Qualified_Expression 298 or else Nkind (Par) = N_Unchecked_Type_Conversion 299 then 300 Par := Parent (Par); 301 302 else 303 Error_Msg_N 304 ("call to abstract function must be dispatching", N); 305 return; 306 end if; 307 end loop; 308 end if; 309 end if; 310 end Check_Dispatching_Context; 311 312 -- Start of processing for Check_Dispatching_Call 313 314 begin 315 -- Find a controlling argument, if any 316 317 if Present (Parameter_Associations (N)) then 318 Actual := First_Actual (N); 319 320 while Present (Actual) loop 321 Control := Find_Controlling_Arg (Actual); 322 exit when Present (Control); 323 Next_Actual (Actual); 324 end loop; 325 326 if Present (Control) then 327 328 -- Verify that no controlling arguments are statically tagged 329 330 if Debug_Flag_E then 331 Write_Str ("Found Dispatching call"); 332 Write_Int (Int (N)); 333 Write_Eol; 334 end if; 335 336 Actual := First_Actual (N); 337 338 while Present (Actual) loop 339 if Actual /= Control then 340 341 if not Is_Controlling_Actual (Actual) then 342 null; -- can be anything 343 344 elsif Is_Dynamically_Tagged (Actual) then 345 null; -- valid parameter 346 347 elsif Is_Tag_Indeterminate (Actual) then 348 349 -- The tag is inherited from the enclosing call (the 350 -- node we are currently analyzing). Explicitly expand 351 -- the actual, since the previous call to Expand 352 -- (from Resolve_Call) had no way of knowing about 353 -- the required dispatching. 354 355 Propagate_Tag (Control, Actual); 356 357 else 358 Error_Msg_N 359 ("controlling argument is not dynamically tagged", 360 Actual); 361 return; 362 end if; 363 end if; 364 365 Next_Actual (Actual); 366 end loop; 367 368 -- Mark call as a dispatching call 369 370 Set_Controlling_Argument (N, Control); 371 372 else 373 -- The call is not dispatching, check that there isn't any 374 -- tag indeterminate abstract call left 375 376 Actual := First_Actual (N); 377 378 while Present (Actual) loop 379 if Is_Tag_Indeterminate (Actual) then 380 381 -- Function call case 382 383 if Nkind (Original_Node (Actual)) = N_Function_Call then 384 Func := Entity (Name (Original_Node (Actual))); 385 386 -- Only other possibility is a qualified expression whose 387 -- consituent expression is itself a call. 388 389 else 390 Func := 391 Entity (Name 392 (Original_Node 393 (Expression (Original_Node (Actual))))); 394 end if; 395 396 if Is_Abstract (Func) then 397 Error_Msg_N ( 398 "call to abstract function must be dispatching", N); 399 end if; 400 end if; 401 402 Next_Actual (Actual); 403 end loop; 404 405 Check_Dispatching_Context; 406 end if; 407 408 else 409 -- If dispatching on result, the enclosing call, if any, will 410 -- determine the controlling argument. Otherwise this is the 411 -- primitive operation of the root type. 412 413 Check_Dispatching_Context; 414 end if; 415 end Check_Dispatching_Call; 416 417 --------------------------------- 418 -- Check_Dispatching_Operation -- 419 --------------------------------- 420 421 procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is 422 Tagged_Type : Entity_Id; 423 Has_Dispatching_Parent : Boolean := False; 424 Body_Is_Last_Primitive : Boolean := False; 425 426 begin 427 if Ekind (Subp) /= E_Procedure and then Ekind (Subp) /= E_Function then 428 return; 429 end if; 430 431 Set_Is_Dispatching_Operation (Subp, False); 432 Tagged_Type := Find_Dispatching_Type (Subp); 433 434 -- If Subp is derived from a dispatching operation then it should 435 -- always be treated as dispatching. In this case various checks 436 -- below will be bypassed. Makes sure that late declarations for 437 -- inherited private subprograms are treated as dispatching, even 438 -- if the associated tagged type is already frozen. 439 440 Has_Dispatching_Parent := 441 Present (Alias (Subp)) 442 and then Is_Dispatching_Operation (Alias (Subp)); 443 444 if No (Tagged_Type) then 445 return; 446 447 -- The subprograms build internally after the freezing point (such as 448 -- the Init procedure) are not primitives 449 450 elsif Is_Frozen (Tagged_Type) 451 and then not Comes_From_Source (Subp) 452 and then not Has_Dispatching_Parent 453 then 454 return; 455 456 -- The operation may be a child unit, whose scope is the defining 457 -- package, but which is not a primitive operation of the type. 458 459 elsif Is_Child_Unit (Subp) then 460 return; 461 462 -- If the subprogram is not defined in a package spec, the only case 463 -- where it can be a dispatching op is when it overrides an operation 464 -- before the freezing point of the type. 465 466 elsif ((not Is_Package (Scope (Subp))) 467 or else In_Package_Body (Scope (Subp))) 468 and then not Has_Dispatching_Parent 469 then 470 if not Comes_From_Source (Subp) 471 or else (Present (Old_Subp) and then not Is_Frozen (Tagged_Type)) 472 then 473 null; 474 475 -- If the type is already frozen, the overriding is not allowed 476 -- except when Old_Subp is not a dispatching operation (which 477 -- can occur when Old_Subp was inherited by an untagged type). 478 -- However, a body with no previous spec freezes the type "after" 479 -- its declaration, and therefore is a legal overriding (unless 480 -- the type has already been frozen). Only the first such body 481 -- is legal. 482 483 elsif Present (Old_Subp) 484 and then Is_Dispatching_Operation (Old_Subp) 485 then 486 if Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Body 487 and then Comes_From_Source (Subp) 488 then 489 declare 490 Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp); 491 Decl_Item : Node_Id := Next (Parent (Tagged_Type)); 492 493 begin 494 -- ??? The checks here for whether the type has been 495 -- frozen prior to the new body are not complete. It's 496 -- not simple to check frozenness at this point since 497 -- the body has already caused the type to be prematurely 498 -- frozen in Analyze_Declarations, but we're forced to 499 -- recheck this here because of the odd rule interpretation 500 -- that allows the overriding if the type wasn't frozen 501 -- prior to the body. The freezing action should probably 502 -- be delayed until after the spec is seen, but that's 503 -- a tricky change to the delicate freezing code. 504 505 -- Look at each declaration following the type up 506 -- until the new subprogram body. If any of the 507 -- declarations is a body then the type has been 508 -- frozen already so the overriding primitive is 509 -- illegal. 510 511 while Present (Decl_Item) 512 and then (Decl_Item /= Subp_Body) 513 loop 514 if Comes_From_Source (Decl_Item) 515 and then (Nkind (Decl_Item) in N_Proper_Body 516 or else Nkind (Decl_Item) in N_Body_Stub) 517 then 518 Error_Msg_N ("overriding of& is too late!", Subp); 519 Error_Msg_N 520 ("\spec should appear immediately after the type!", 521 Subp); 522 exit; 523 end if; 524 525 Next (Decl_Item); 526 end loop; 527 528 -- If the subprogram doesn't follow in the list of 529 -- declarations including the type then the type 530 -- has definitely been frozen already and the body 531 -- is illegal. 532 533 if not Present (Decl_Item) then 534 Error_Msg_N ("overriding of& is too late!", Subp); 535 Error_Msg_N 536 ("\spec should appear immediately after the type!", 537 Subp); 538 539 elsif Is_Frozen (Subp) then 540 541 -- The subprogram body declares a primitive operation. 542 -- if the subprogram is already frozen, we must update 543 -- its dispatching information explicitly here. The 544 -- information is taken from the overridden subprogram. 545 546 Body_Is_Last_Primitive := True; 547 548 if Present (DTC_Entity (Old_Subp)) then 549 Set_DTC_Entity (Subp, DTC_Entity (Old_Subp)); 550 Set_DT_Position (Subp, DT_Position (Old_Subp)); 551 Insert_After ( 552 Subp_Body, Fill_DT_Entry (Sloc (Subp_Body), Subp)); 553 end if; 554 end if; 555 end; 556 557 else 558 Error_Msg_N ("overriding of& is too late!", Subp); 559 Error_Msg_N 560 ("\subprogram spec should appear immediately after the type!", 561 Subp); 562 end if; 563 564 -- If the type is not frozen yet and we are not in the overridding 565 -- case it looks suspiciously like an attempt to define a primitive 566 -- operation. 567 568 elsif not Is_Frozen (Tagged_Type) then 569 Error_Msg_N 570 ("?not dispatching (must be defined in a package spec)", Subp); 571 return; 572 573 -- When the type is frozen, it is legitimate to define a new 574 -- non-primitive operation. 575 576 else 577 return; 578 end if; 579 580 -- Now, we are sure that the scope is a package spec. If the subprogram 581 -- is declared after the freezing point ot the type that's an error 582 583 elsif Is_Frozen (Tagged_Type) and then not Has_Dispatching_Parent then 584 Error_Msg_N ("this primitive operation is declared too late", Subp); 585 Error_Msg_NE 586 ("?no primitive operations for& after this line", 587 Freeze_Node (Tagged_Type), 588 Tagged_Type); 589 return; 590 end if; 591 592 Check_Controlling_Formals (Tagged_Type, Subp); 593 594 -- Now it should be a correct primitive operation, put it in the list 595 596 if Present (Old_Subp) then 597 Check_Subtype_Conformant (Subp, Old_Subp); 598 Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp); 599 Set_Is_Overriding_Operation (Subp); 600 else 601 Add_Dispatching_Operation (Tagged_Type, Subp); 602 end if; 603 604 Set_Is_Dispatching_Operation (Subp, True); 605 606 if not Body_Is_Last_Primitive then 607 Set_DT_Position (Subp, No_Uint); 608 609 elsif Has_Controlled_Component (Tagged_Type) 610 and then 611 (Chars (Subp) = Name_Initialize 612 or else Chars (Subp) = Name_Adjust 613 or else Chars (Subp) = Name_Finalize) 614 then 615 declare 616 F_Node : constant Node_Id := Freeze_Node (Tagged_Type); 617 Decl : Node_Id; 618 Old_P : Entity_Id; 619 Old_Bod : Node_Id; 620 Old_Spec : Entity_Id; 621 622 C_Names : constant array (1 .. 3) of Name_Id := 623 (Name_Initialize, 624 Name_Adjust, 625 Name_Finalize); 626 627 D_Names : constant array (1 .. 3) of TSS_Name_Type := 628 (TSS_Deep_Initialize, 629 TSS_Deep_Adjust, 630 TSS_Deep_Finalize); 631 632 begin 633 -- Remove previous controlled function, which was constructed 634 -- and analyzed when the type was frozen. This requires 635 -- removing the body of the redefined primitive, as well as 636 -- its specification if needed (there is no spec created for 637 -- Deep_Initialize, see exp_ch3.adb). We must also dismantle 638 -- the exception information that may have been generated for 639 -- it when front end zero-cost tables are enabled. 640 641 for J in D_Names'Range loop 642 Old_P := TSS (Tagged_Type, D_Names (J)); 643 644 if Present (Old_P) 645 and then Chars (Subp) = C_Names (J) 646 then 647 Old_Bod := Unit_Declaration_Node (Old_P); 648 Remove (Old_Bod); 649 Set_Is_Eliminated (Old_P); 650 Set_Scope (Old_P, Scope (Current_Scope)); 651 652 if Nkind (Old_Bod) = N_Subprogram_Body 653 and then Present (Corresponding_Spec (Old_Bod)) 654 then 655 Old_Spec := Corresponding_Spec (Old_Bod); 656 Set_Has_Completion (Old_Spec, False); 657 658 if Exception_Mechanism = Front_End_ZCX_Exceptions then 659 Set_Has_Subprogram_Descriptor (Old_Spec, False); 660 Set_Handler_Records (Old_Spec, No_List); 661 Set_Is_Eliminated (Old_Spec); 662 end if; 663 end if; 664 665 end if; 666 end loop; 667 668 Build_Late_Proc (Tagged_Type, Chars (Subp)); 669 670 -- The new operation is added to the actions of the freeze 671 -- node for the type, but this node has already been analyzed, 672 -- so we must retrieve and analyze explicitly the one new body, 673 674 if Present (F_Node) 675 and then Present (Actions (F_Node)) 676 then 677 Decl := Last (Actions (F_Node)); 678 Analyze (Decl); 679 end if; 680 end; 681 end if; 682 end Check_Dispatching_Operation; 683 684 ------------------------------------------ 685 -- Check_Operation_From_Incomplete_Type -- 686 ------------------------------------------ 687 688 procedure Check_Operation_From_Incomplete_Type 689 (Subp : Entity_Id; 690 Typ : Entity_Id) 691 is 692 Full : constant Entity_Id := Full_View (Typ); 693 Parent_Typ : constant Entity_Id := Etype (Full); 694 Old_Prim : constant Elist_Id := Primitive_Operations (Parent_Typ); 695 New_Prim : constant Elist_Id := Primitive_Operations (Full); 696 Op1, Op2 : Elmt_Id; 697 Prev : Elmt_Id := No_Elmt; 698 699 function Derives_From (Proc : Entity_Id) return Boolean; 700 -- Check that Subp has the signature of an operation derived from Proc. 701 -- Subp has an access parameter that designates Typ. 702 703 ------------------ 704 -- Derives_From -- 705 ------------------ 706 707 function Derives_From (Proc : Entity_Id) return Boolean is 708 F1, F2 : Entity_Id; 709 710 begin 711 if Chars (Proc) /= Chars (Subp) then 712 return False; 713 end if; 714 715 F1 := First_Formal (Proc); 716 F2 := First_Formal (Subp); 717 718 while Present (F1) and then Present (F2) loop 719 720 if Ekind (Etype (F1)) = E_Anonymous_Access_Type then 721 722 if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then 723 return False; 724 725 elsif Designated_Type (Etype (F1)) = Parent_Typ 726 and then Designated_Type (Etype (F2)) /= Full 727 then 728 return False; 729 end if; 730 731 elsif Ekind (Etype (F2)) = E_Anonymous_Access_Type then 732 return False; 733 734 elsif Etype (F1) /= Etype (F2) then 735 return False; 736 end if; 737 738 Next_Formal (F1); 739 Next_Formal (F2); 740 end loop; 741 742 return No (F1) and then No (F2); 743 end Derives_From; 744 745 -- Start of processing for Check_Operation_From_Incomplete_Type 746 747 begin 748 -- The operation may override an inherited one, or may be a new one 749 -- altogether. The inherited operation will have been hidden by the 750 -- current one at the point of the type derivation, so it does not 751 -- appear in the list of primitive operations of the type. We have to 752 -- find the proper place of insertion in the list of primitive opera- 753 -- tions by iterating over the list for the parent type. 754 755 Op1 := First_Elmt (Old_Prim); 756 Op2 := First_Elmt (New_Prim); 757 758 while Present (Op1) and then Present (Op2) loop 759 760 if Derives_From (Node (Op1)) then 761 762 if No (Prev) then 763 Prepend_Elmt (Subp, New_Prim); 764 else 765 Insert_Elmt_After (Subp, Prev); 766 end if; 767 768 return; 769 end if; 770 771 Prev := Op2; 772 Next_Elmt (Op1); 773 Next_Elmt (Op2); 774 end loop; 775 776 -- Operation is a new primitive 777 778 Append_Elmt (Subp, New_Prim); 779 end Check_Operation_From_Incomplete_Type; 780 781 --------------------------------------- 782 -- Check_Operation_From_Private_View -- 783 --------------------------------------- 784 785 procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id) is 786 Tagged_Type : Entity_Id; 787 788 begin 789 if Is_Dispatching_Operation (Alias (Subp)) then 790 Set_Scope (Subp, Current_Scope); 791 Tagged_Type := Find_Dispatching_Type (Subp); 792 793 if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then 794 Append_Elmt (Old_Subp, Primitive_Operations (Tagged_Type)); 795 796 -- If Old_Subp isn't already marked as dispatching then 797 -- this is the case of an operation of an untagged private 798 -- type fulfilled by a tagged type that overrides an 799 -- inherited dispatching operation, so we set the necessary 800 -- dispatching attributes here. 801 802 if not Is_Dispatching_Operation (Old_Subp) then 803 804 -- If the untagged type has no discriminants, and the full 805 -- view is constrained, there will be a spurious mismatch 806 -- of subtypes on the controlling arguments, because the tagged 807 -- type is the internal base type introduced in the derivation. 808 -- Use the original type to verify conformance, rather than the 809 -- base type. 810 811 if not Comes_From_Source (Tagged_Type) 812 and then Has_Discriminants (Tagged_Type) 813 then 814 declare 815 Formal : Entity_Id; 816 begin 817 Formal := First_Formal (Old_Subp); 818 while Present (Formal) loop 819 if Tagged_Type = Base_Type (Etype (Formal)) then 820 Tagged_Type := Etype (Formal); 821 end if; 822 823 Next_Formal (Formal); 824 end loop; 825 end; 826 827 if Tagged_Type = Base_Type (Etype (Old_Subp)) then 828 Tagged_Type := Etype (Old_Subp); 829 end if; 830 end if; 831 832 Check_Controlling_Formals (Tagged_Type, Old_Subp); 833 Set_Is_Dispatching_Operation (Old_Subp, True); 834 Set_DT_Position (Old_Subp, No_Uint); 835 end if; 836 837 -- If the old subprogram is an explicit renaming of some other 838 -- entity, it is not overridden by the inherited subprogram. 839 -- Otherwise, update its alias and other attributes. 840 841 if Present (Alias (Old_Subp)) 842 and then Nkind (Unit_Declaration_Node (Old_Subp)) 843 /= N_Subprogram_Renaming_Declaration 844 then 845 Set_Alias (Old_Subp, Alias (Subp)); 846 847 -- The derived subprogram should inherit the abstractness 848 849 -- of the parent subprogram (except in the case of a function 850 -- returning the type). This sets the abstractness properly 851 -- for cases where a private extension may have inherited 852 -- an abstract operation, but the full type is derived from 853 -- a descendant type and inherits a nonabstract version. 854 855 if Etype (Subp) /= Tagged_Type then 856 Set_Is_Abstract (Old_Subp, Is_Abstract (Alias (Subp))); 857 end if; 858 end if; 859 end if; 860 end if; 861 end Check_Operation_From_Private_View; 862 863 -------------------------- 864 -- Find_Controlling_Arg -- 865 -------------------------- 866 867 function Find_Controlling_Arg (N : Node_Id) return Node_Id is 868 Orig_Node : constant Node_Id := Original_Node (N); 869 Typ : Entity_Id; 870 871 begin 872 if Nkind (Orig_Node) = N_Qualified_Expression then 873 return Find_Controlling_Arg (Expression (Orig_Node)); 874 end if; 875 876 -- Dispatching on result case 877 878 if Nkind (Orig_Node) = N_Function_Call 879 and then Present (Controlling_Argument (Orig_Node)) 880 and then Has_Controlling_Result (Entity (Name (Orig_Node))) 881 then 882 return Controlling_Argument (Orig_Node); 883 884 -- Normal case 885 886 elsif Is_Controlling_Actual (N) 887 or else 888 (Nkind (Parent (N)) = N_Qualified_Expression 889 and then Is_Controlling_Actual (Parent (N))) 890 then 891 Typ := Etype (N); 892 893 if Is_Access_Type (Typ) then 894 -- In the case of an Access attribute, use the type of 895 -- the prefix, since in the case of an actual for an 896 -- access parameter, the attribute's type may be of a 897 -- specific designated type, even though the prefix 898 -- type is class-wide. 899 900 if Nkind (N) = N_Attribute_Reference then 901 Typ := Etype (Prefix (N)); 902 903 -- An allocator is dispatching if the type of qualified 904 -- expression is class_wide, in which case this is the 905 -- controlling type. 906 907 elsif Nkind (Orig_Node) = N_Allocator 908 and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression 909 then 910 Typ := Etype (Expression (Orig_Node)); 911 912 else 913 Typ := Designated_Type (Typ); 914 end if; 915 end if; 916 917 if Is_Class_Wide_Type (Typ) 918 or else 919 (Nkind (Parent (N)) = N_Qualified_Expression 920 and then Is_Access_Type (Etype (N)) 921 and then Is_Class_Wide_Type (Designated_Type (Etype (N)))) 922 then 923 return N; 924 end if; 925 end if; 926 927 return Empty; 928 end Find_Controlling_Arg; 929 930 --------------------------- 931 -- Find_Dispatching_Type -- 932 --------------------------- 933 934 function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is 935 Formal : Entity_Id; 936 Ctrl_Type : Entity_Id; 937 938 begin 939 if Present (DTC_Entity (Subp)) then 940 return Scope (DTC_Entity (Subp)); 941 942 else 943 Formal := First_Formal (Subp); 944 while Present (Formal) loop 945 Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp); 946 947 if Present (Ctrl_Type) then 948 return Ctrl_Type; 949 end if; 950 951 Next_Formal (Formal); 952 end loop; 953 954 -- The subprogram may also be dispatching on result 955 956 if Present (Etype (Subp)) then 957 Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp); 958 959 if Present (Ctrl_Type) then 960 return Ctrl_Type; 961 end if; 962 end if; 963 end if; 964 965 return Empty; 966 end Find_Dispatching_Type; 967 968 --------------------------- 969 -- Is_Dynamically_Tagged -- 970 --------------------------- 971 972 function Is_Dynamically_Tagged (N : Node_Id) return Boolean is 973 begin 974 return Find_Controlling_Arg (N) /= Empty; 975 end Is_Dynamically_Tagged; 976 977 -------------------------- 978 -- Is_Tag_Indeterminate -- 979 -------------------------- 980 981 function Is_Tag_Indeterminate (N : Node_Id) return Boolean is 982 Nam : Entity_Id; 983 Actual : Node_Id; 984 Orig_Node : constant Node_Id := Original_Node (N); 985 986 begin 987 if Nkind (Orig_Node) = N_Function_Call 988 and then Is_Entity_Name (Name (Orig_Node)) 989 then 990 Nam := Entity (Name (Orig_Node)); 991 992 if not Has_Controlling_Result (Nam) then 993 return False; 994 995 -- An explicit dereference means that the call has already been 996 -- expanded and there is no tag to propagate. 997 998 elsif Nkind (N) = N_Explicit_Dereference then 999 return False; 1000 1001 -- If there are no actuals, the call is tag-indeterminate 1002 1003 elsif No (Parameter_Associations (Orig_Node)) then 1004 return True; 1005 1006 else 1007 Actual := First_Actual (Orig_Node); 1008 1009 while Present (Actual) loop 1010 if Is_Controlling_Actual (Actual) 1011 and then not Is_Tag_Indeterminate (Actual) 1012 then 1013 return False; -- one operand is dispatching 1014 end if; 1015 1016 Next_Actual (Actual); 1017 end loop; 1018 1019 return True; 1020 1021 end if; 1022 1023 elsif Nkind (Orig_Node) = N_Qualified_Expression then 1024 return Is_Tag_Indeterminate (Expression (Orig_Node)); 1025 1026 else 1027 return False; 1028 end if; 1029 end Is_Tag_Indeterminate; 1030 1031 ------------------------------------ 1032 -- Override_Dispatching_Operation -- 1033 ------------------------------------ 1034 1035 procedure Override_Dispatching_Operation 1036 (Tagged_Type : Entity_Id; 1037 Prev_Op : Entity_Id; 1038 New_Op : Entity_Id) 1039 is 1040 Op_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type)); 1041 1042 begin 1043 -- Patch the primitive operation list 1044 1045 while Present (Op_Elmt) 1046 and then Node (Op_Elmt) /= Prev_Op 1047 loop 1048 Next_Elmt (Op_Elmt); 1049 end loop; 1050 1051 -- If there is no previous operation to override, the type declaration 1052 -- was malformed, and an error must have been emitted already. 1053 1054 if No (Op_Elmt) then 1055 return; 1056 end if; 1057 1058 Replace_Elmt (Op_Elmt, New_Op); 1059 1060 if (not Is_Package (Current_Scope)) 1061 or else not In_Private_Part (Current_Scope) 1062 then 1063 -- Not a private primitive 1064 1065 null; 1066 1067 else pragma Assert (Is_Inherited_Operation (Prev_Op)); 1068 1069 -- Make the overriding operation into an alias of the implicit one. 1070 -- In this fashion a call from outside ends up calling the new 1071 -- body even if non-dispatching, and a call from inside calls the 1072 -- overriding operation because it hides the implicit one. 1073 -- To indicate that the body of Prev_Op is never called, set its 1074 -- dispatch table entity to Empty. 1075 1076 Set_Alias (Prev_Op, New_Op); 1077 Set_DTC_Entity (Prev_Op, Empty); 1078 return; 1079 end if; 1080 end Override_Dispatching_Operation; 1081 1082 ------------------- 1083 -- Propagate_Tag -- 1084 ------------------- 1085 1086 procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id) is 1087 Call_Node : Node_Id; 1088 Arg : Node_Id; 1089 1090 begin 1091 if Nkind (Actual) = N_Function_Call then 1092 Call_Node := Actual; 1093 1094 elsif Nkind (Actual) = N_Identifier 1095 and then Nkind (Original_Node (Actual)) = N_Function_Call 1096 then 1097 -- Call rewritten as object declaration when stack-checking 1098 -- is enabled. Propagate tag to expression in declaration, which 1099 -- is original call. 1100 1101 Call_Node := Expression (Parent (Entity (Actual))); 1102 1103 -- Only other possibility is parenthesized or qualified expression 1104 1105 else 1106 Call_Node := Expression (Actual); 1107 end if; 1108 1109 -- Do not set the Controlling_Argument if already set. This happens 1110 -- in the special case of _Input (see Exp_Attr, case Input). 1111 1112 if No (Controlling_Argument (Call_Node)) then 1113 Set_Controlling_Argument (Call_Node, Control); 1114 end if; 1115 1116 Arg := First_Actual (Call_Node); 1117 1118 while Present (Arg) loop 1119 if Is_Tag_Indeterminate (Arg) then 1120 Propagate_Tag (Control, Arg); 1121 end if; 1122 1123 Next_Actual (Arg); 1124 end loop; 1125 1126 -- Expansion of dispatching calls is suppressed when Java_VM, because 1127 -- the JVM back end directly handles the generation of dispatching 1128 -- calls and would have to undo any expansion to an indirect call. 1129 1130 if not Java_VM then 1131 Expand_Dispatch_Call (Call_Node); 1132 end if; 1133 end Propagate_Tag; 1134 1135end Sem_Disp; 1136