1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ T Y P E -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2015, 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 Alloc; 28with Debug; use Debug; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Nlists; use Nlists; 32with Errout; use Errout; 33with Lib; use Lib; 34with Namet; use Namet; 35with Opt; use Opt; 36with Output; use Output; 37with Sem; use Sem; 38with Sem_Aux; use Sem_Aux; 39with Sem_Ch6; use Sem_Ch6; 40with Sem_Ch8; use Sem_Ch8; 41with Sem_Ch12; use Sem_Ch12; 42with Sem_Disp; use Sem_Disp; 43with Sem_Dist; use Sem_Dist; 44with Sem_Util; use Sem_Util; 45with Stand; use Stand; 46with Sinfo; use Sinfo; 47with Snames; use Snames; 48with Table; 49with Treepr; use Treepr; 50with Uintp; use Uintp; 51 52package body Sem_Type is 53 54 --------------------- 55 -- Data Structures -- 56 --------------------- 57 58 -- The following data structures establish a mapping between nodes and 59 -- their interpretations. An overloaded node has an entry in Interp_Map, 60 -- which in turn contains a pointer into the All_Interp array. The 61 -- interpretations of a given node are contiguous in All_Interp. Each set 62 -- of interpretations is terminated with the marker No_Interp. In order to 63 -- speed up the retrieval of the interpretations of an overloaded node, the 64 -- Interp_Map table is accessed by means of a simple hashing scheme, and 65 -- the entries in Interp_Map are chained. The heads of clash lists are 66 -- stored in array Headers. 67 68 -- Headers Interp_Map All_Interp 69 70 -- _ +-----+ +--------+ 71 -- |_| |_____| --->|interp1 | 72 -- |_|---------->|node | | |interp2 | 73 -- |_| |index|---------| |nointerp| 74 -- |_| |next | | | 75 -- |-----| | | 76 -- +-----+ +--------+ 77 78 -- This scheme does not currently reclaim interpretations. In principle, 79 -- after a unit is compiled, all overloadings have been resolved, and the 80 -- candidate interpretations should be deleted. This should be easier 81 -- now than with the previous scheme??? 82 83 package All_Interp is new Table.Table ( 84 Table_Component_Type => Interp, 85 Table_Index_Type => Interp_Index, 86 Table_Low_Bound => 0, 87 Table_Initial => Alloc.All_Interp_Initial, 88 Table_Increment => Alloc.All_Interp_Increment, 89 Table_Name => "All_Interp"); 90 91 type Interp_Ref is record 92 Node : Node_Id; 93 Index : Interp_Index; 94 Next : Int; 95 end record; 96 97 Header_Size : constant Int := 2 ** 12; 98 No_Entry : constant Int := -1; 99 Headers : array (0 .. Header_Size) of Int := (others => No_Entry); 100 101 package Interp_Map is new Table.Table ( 102 Table_Component_Type => Interp_Ref, 103 Table_Index_Type => Int, 104 Table_Low_Bound => 0, 105 Table_Initial => Alloc.Interp_Map_Initial, 106 Table_Increment => Alloc.Interp_Map_Increment, 107 Table_Name => "Interp_Map"); 108 109 function Hash (N : Node_Id) return Int; 110 -- A trivial hashing function for nodes, used to insert an overloaded 111 -- node into the Interp_Map table. 112 113 ------------------------------------- 114 -- Handling of Overload Resolution -- 115 ------------------------------------- 116 117 -- Overload resolution uses two passes over the syntax tree of a complete 118 -- context. In the first, bottom-up pass, the types of actuals in calls 119 -- are used to resolve possibly overloaded subprogram and operator names. 120 -- In the second top-down pass, the type of the context (for example the 121 -- condition in a while statement) is used to resolve a possibly ambiguous 122 -- call, and the unique subprogram name in turn imposes a specific context 123 -- on each of its actuals. 124 125 -- Most expressions are in fact unambiguous, and the bottom-up pass is 126 -- sufficient to resolve most everything. To simplify the common case, 127 -- names and expressions carry a flag Is_Overloaded to indicate whether 128 -- they have more than one interpretation. If the flag is off, then each 129 -- name has already a unique meaning and type, and the bottom-up pass is 130 -- sufficient (and much simpler). 131 132 -------------------------- 133 -- Operator Overloading -- 134 -------------------------- 135 136 -- The visibility of operators is handled differently from that of other 137 -- entities. We do not introduce explicit versions of primitive operators 138 -- for each type definition. As a result, there is only one entity 139 -- corresponding to predefined addition on all numeric types, etc. The 140 -- back end resolves predefined operators according to their type. The 141 -- visibility of primitive operations then reduces to the visibility of the 142 -- resulting type: (a + b) is a legal interpretation of some primitive 143 -- operator + if the type of the result (which must also be the type of a 144 -- and b) is directly visible (either immediately visible or use-visible). 145 146 -- User-defined operators are treated like other functions, but the 147 -- visibility of these user-defined operations must be special-cased 148 -- to determine whether they hide or are hidden by predefined operators. 149 -- The form P."+" (x, y) requires additional handling. 150 151 -- Concatenation is treated more conventionally: for every one-dimensional 152 -- array type we introduce a explicit concatenation operator. This is 153 -- necessary to handle the case of (element & element => array) which 154 -- cannot be handled conveniently if there is no explicit instance of 155 -- resulting type of the operation. 156 157 ----------------------- 158 -- Local Subprograms -- 159 ----------------------- 160 161 procedure All_Overloads; 162 pragma Warnings (Off, All_Overloads); 163 -- Debugging procedure: list full contents of Overloads table 164 165 function Binary_Op_Interp_Has_Abstract_Op 166 (N : Node_Id; 167 E : Entity_Id) return Entity_Id; 168 -- Given the node and entity of a binary operator, determine whether the 169 -- actuals of E contain an abstract interpretation with regards to the 170 -- types of their corresponding formals. Return the abstract operation or 171 -- Empty. 172 173 function Function_Interp_Has_Abstract_Op 174 (N : Node_Id; 175 E : Entity_Id) return Entity_Id; 176 -- Given the node and entity of a function call, determine whether the 177 -- actuals of E contain an abstract interpretation with regards to the 178 -- types of their corresponding formals. Return the abstract operation or 179 -- Empty. 180 181 function Has_Abstract_Op 182 (N : Node_Id; 183 Typ : Entity_Id) return Entity_Id; 184 -- Subsidiary routine to Binary_Op_Interp_Has_Abstract_Op and Function_ 185 -- Interp_Has_Abstract_Op. Determine whether an overloaded node has an 186 -- abstract interpretation which yields type Typ. 187 188 procedure New_Interps (N : Node_Id); 189 -- Initialize collection of interpretations for the given node, which is 190 -- either an overloaded entity, or an operation whose arguments have 191 -- multiple interpretations. Interpretations can be added to only one 192 -- node at a time. 193 194 function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id; 195 -- If Typ_1 and Typ_2 are compatible, return the one that is not universal 196 -- or is not a "class" type (any_character, etc). 197 198 -------------------- 199 -- Add_One_Interp -- 200 -------------------- 201 202 procedure Add_One_Interp 203 (N : Node_Id; 204 E : Entity_Id; 205 T : Entity_Id; 206 Opnd_Type : Entity_Id := Empty) 207 is 208 Vis_Type : Entity_Id; 209 210 procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id); 211 -- Add one interpretation to an overloaded node. Add a new entry if 212 -- not hidden by previous one, and remove previous one if hidden by 213 -- new one. 214 215 function Is_Universal_Operation (Op : Entity_Id) return Boolean; 216 -- True if the entity is a predefined operator and the operands have 217 -- a universal Interpretation. 218 219 --------------- 220 -- Add_Entry -- 221 --------------- 222 223 procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is 224 Abstr_Op : Entity_Id := Empty; 225 I : Interp_Index; 226 It : Interp; 227 228 -- Start of processing for Add_Entry 229 230 begin 231 -- Find out whether the new entry references interpretations that 232 -- are abstract or disabled by abstract operators. 233 234 if Ada_Version >= Ada_2005 then 235 if Nkind (N) in N_Binary_Op then 236 Abstr_Op := Binary_Op_Interp_Has_Abstract_Op (N, Name); 237 elsif Nkind (N) = N_Function_Call then 238 Abstr_Op := Function_Interp_Has_Abstract_Op (N, Name); 239 end if; 240 end if; 241 242 Get_First_Interp (N, I, It); 243 while Present (It.Nam) loop 244 245 -- A user-defined subprogram hides another declared at an outer 246 -- level, or one that is use-visible. So return if previous 247 -- definition hides new one (which is either in an outer 248 -- scope, or use-visible). Note that for functions use-visible 249 -- is the same as potentially use-visible. If new one hides 250 -- previous one, replace entry in table of interpretations. 251 -- If this is a universal operation, retain the operator in case 252 -- preference rule applies. 253 254 if (((Ekind (Name) = E_Function or else Ekind (Name) = E_Procedure) 255 and then Ekind (Name) = Ekind (It.Nam)) 256 or else (Ekind (Name) = E_Operator 257 and then Ekind (It.Nam) = E_Function)) 258 and then Is_Immediately_Visible (It.Nam) 259 and then Type_Conformant (Name, It.Nam) 260 and then Base_Type (It.Typ) = Base_Type (T) 261 then 262 if Is_Universal_Operation (Name) then 263 exit; 264 265 -- If node is an operator symbol, we have no actuals with 266 -- which to check hiding, and this is done in full in the 267 -- caller (Analyze_Subprogram_Renaming) so we include the 268 -- predefined operator in any case. 269 270 elsif Nkind (N) = N_Operator_Symbol 271 or else 272 (Nkind (N) = N_Expanded_Name 273 and then Nkind (Selector_Name (N)) = N_Operator_Symbol) 274 then 275 exit; 276 277 elsif not In_Open_Scopes (Scope (Name)) 278 or else Scope_Depth (Scope (Name)) <= 279 Scope_Depth (Scope (It.Nam)) 280 then 281 -- If ambiguity within instance, and entity is not an 282 -- implicit operation, save for later disambiguation. 283 284 if Scope (Name) = Scope (It.Nam) 285 and then not Is_Inherited_Operation (Name) 286 and then In_Instance 287 then 288 exit; 289 else 290 return; 291 end if; 292 293 else 294 All_Interp.Table (I).Nam := Name; 295 return; 296 end if; 297 298 -- Avoid making duplicate entries in overloads 299 300 elsif Name = It.Nam 301 and then Base_Type (It.Typ) = Base_Type (T) 302 then 303 return; 304 305 -- Otherwise keep going 306 307 else 308 Get_Next_Interp (I, It); 309 end if; 310 311 end loop; 312 313 All_Interp.Table (All_Interp.Last) := (Name, Typ, Abstr_Op); 314 All_Interp.Append (No_Interp); 315 end Add_Entry; 316 317 ---------------------------- 318 -- Is_Universal_Operation -- 319 ---------------------------- 320 321 function Is_Universal_Operation (Op : Entity_Id) return Boolean is 322 Arg : Node_Id; 323 324 begin 325 if Ekind (Op) /= E_Operator then 326 return False; 327 328 elsif Nkind (N) in N_Binary_Op then 329 return Present (Universal_Interpretation (Left_Opnd (N))) 330 and then Present (Universal_Interpretation (Right_Opnd (N))); 331 332 elsif Nkind (N) in N_Unary_Op then 333 return Present (Universal_Interpretation (Right_Opnd (N))); 334 335 elsif Nkind (N) = N_Function_Call then 336 Arg := First_Actual (N); 337 while Present (Arg) loop 338 if No (Universal_Interpretation (Arg)) then 339 return False; 340 end if; 341 342 Next_Actual (Arg); 343 end loop; 344 345 return True; 346 347 else 348 return False; 349 end if; 350 end Is_Universal_Operation; 351 352 -- Start of processing for Add_One_Interp 353 354 begin 355 -- If the interpretation is a predefined operator, verify that the 356 -- result type is visible, or that the entity has already been 357 -- resolved (case of an instantiation node that refers to a predefined 358 -- operation, or an internally generated operator node, or an operator 359 -- given as an expanded name). If the operator is a comparison or 360 -- equality, it is the type of the operand that matters to determine 361 -- whether the operator is visible. In an instance, the check is not 362 -- performed, given that the operator was visible in the generic. 363 364 if Ekind (E) = E_Operator then 365 if Present (Opnd_Type) then 366 Vis_Type := Opnd_Type; 367 else 368 Vis_Type := Base_Type (T); 369 end if; 370 371 if In_Open_Scopes (Scope (Vis_Type)) 372 or else Is_Potentially_Use_Visible (Vis_Type) 373 or else In_Use (Vis_Type) 374 or else (In_Use (Scope (Vis_Type)) 375 and then not Is_Hidden (Vis_Type)) 376 or else Nkind (N) = N_Expanded_Name 377 or else (Nkind (N) in N_Op and then E = Entity (N)) 378 or else In_Instance 379 or else Ekind (Vis_Type) = E_Anonymous_Access_Type 380 then 381 null; 382 383 -- If the node is given in functional notation and the prefix 384 -- is an expanded name, then the operator is visible if the 385 -- prefix is the scope of the result type as well. If the 386 -- operator is (implicitly) defined in an extension of system, 387 -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb). 388 389 elsif Nkind (N) = N_Function_Call 390 and then Nkind (Name (N)) = N_Expanded_Name 391 and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T)) 392 or else Entity (Prefix (Name (N))) = Scope (Vis_Type) 393 or else Scope (Vis_Type) = System_Aux_Id) 394 then 395 null; 396 397 -- Save type for subsequent error message, in case no other 398 -- interpretation is found. 399 400 else 401 Candidate_Type := Vis_Type; 402 return; 403 end if; 404 405 -- In an instance, an abstract non-dispatching operation cannot be a 406 -- candidate interpretation, because it could not have been one in the 407 -- generic (it may be a spurious overloading in the instance). 408 409 elsif In_Instance 410 and then Is_Overloadable (E) 411 and then Is_Abstract_Subprogram (E) 412 and then not Is_Dispatching_Operation (E) 413 then 414 return; 415 416 -- An inherited interface operation that is implemented by some derived 417 -- type does not participate in overload resolution, only the 418 -- implementation operation does. 419 420 elsif Is_Hidden (E) 421 and then Is_Subprogram (E) 422 and then Present (Interface_Alias (E)) 423 then 424 -- Ada 2005 (AI-251): If this primitive operation corresponds with 425 -- an immediate ancestor interface there is no need to add it to the 426 -- list of interpretations. The corresponding aliased primitive is 427 -- also in this list of primitive operations and will be used instead 428 -- because otherwise we have a dummy ambiguity between the two 429 -- subprograms which are in fact the same. 430 431 if not Is_Ancestor 432 (Find_Dispatching_Type (Interface_Alias (E)), 433 Find_Dispatching_Type (E)) 434 then 435 Add_One_Interp (N, Interface_Alias (E), T); 436 end if; 437 438 return; 439 440 -- Calling stubs for an RACW operation never participate in resolution, 441 -- they are executed only through dispatching calls. 442 443 elsif Is_RACW_Stub_Type_Operation (E) then 444 return; 445 end if; 446 447 -- If this is the first interpretation of N, N has type Any_Type. 448 -- In that case place the new type on the node. If one interpretation 449 -- already exists, indicate that the node is overloaded, and store 450 -- both the previous and the new interpretation in All_Interp. If 451 -- this is a later interpretation, just add it to the set. 452 453 if Etype (N) = Any_Type then 454 if Is_Type (E) then 455 Set_Etype (N, T); 456 457 else 458 -- Record both the operator or subprogram name, and its type 459 460 if Nkind (N) in N_Op or else Is_Entity_Name (N) then 461 Set_Entity (N, E); 462 end if; 463 464 Set_Etype (N, T); 465 end if; 466 467 -- Either there is no current interpretation in the table for any 468 -- node or the interpretation that is present is for a different 469 -- node. In both cases add a new interpretation to the table. 470 471 elsif Interp_Map.Last < 0 472 or else 473 (Interp_Map.Table (Interp_Map.Last).Node /= N 474 and then not Is_Overloaded (N)) 475 then 476 New_Interps (N); 477 478 if (Nkind (N) in N_Op or else Is_Entity_Name (N)) 479 and then Present (Entity (N)) 480 then 481 Add_Entry (Entity (N), Etype (N)); 482 483 elsif Nkind (N) in N_Subprogram_Call 484 and then Is_Entity_Name (Name (N)) 485 then 486 Add_Entry (Entity (Name (N)), Etype (N)); 487 488 -- If this is an indirect call there will be no name associated 489 -- with the previous entry. To make diagnostics clearer, save 490 -- Subprogram_Type of first interpretation, so that the error will 491 -- point to the anonymous access to subprogram, not to the result 492 -- type of the call itself. 493 494 elsif (Nkind (N)) = N_Function_Call 495 and then Nkind (Name (N)) = N_Explicit_Dereference 496 and then Is_Overloaded (Name (N)) 497 then 498 declare 499 It : Interp; 500 501 Itn : Interp_Index; 502 pragma Warnings (Off, Itn); 503 504 begin 505 Get_First_Interp (Name (N), Itn, It); 506 Add_Entry (It.Nam, Etype (N)); 507 end; 508 509 else 510 -- Overloaded prefix in indexed or selected component, or call 511 -- whose name is an expression or another call. 512 513 Add_Entry (Etype (N), Etype (N)); 514 end if; 515 516 Add_Entry (E, T); 517 518 else 519 Add_Entry (E, T); 520 end if; 521 end Add_One_Interp; 522 523 ------------------- 524 -- All_Overloads -- 525 ------------------- 526 527 procedure All_Overloads is 528 begin 529 for J in All_Interp.First .. All_Interp.Last loop 530 531 if Present (All_Interp.Table (J).Nam) then 532 Write_Entity_Info (All_Interp.Table (J). Nam, " "); 533 else 534 Write_Str ("No Interp"); 535 Write_Eol; 536 end if; 537 538 Write_Str ("================="); 539 Write_Eol; 540 end loop; 541 end All_Overloads; 542 543 -------------------------------------- 544 -- Binary_Op_Interp_Has_Abstract_Op -- 545 -------------------------------------- 546 547 function Binary_Op_Interp_Has_Abstract_Op 548 (N : Node_Id; 549 E : Entity_Id) return Entity_Id 550 is 551 Abstr_Op : Entity_Id; 552 E_Left : constant Node_Id := First_Formal (E); 553 E_Right : constant Node_Id := Next_Formal (E_Left); 554 555 begin 556 Abstr_Op := Has_Abstract_Op (Left_Opnd (N), Etype (E_Left)); 557 if Present (Abstr_Op) then 558 return Abstr_Op; 559 end if; 560 561 return Has_Abstract_Op (Right_Opnd (N), Etype (E_Right)); 562 end Binary_Op_Interp_Has_Abstract_Op; 563 564 --------------------- 565 -- Collect_Interps -- 566 --------------------- 567 568 procedure Collect_Interps (N : Node_Id) is 569 Ent : constant Entity_Id := Entity (N); 570 H : Entity_Id; 571 First_Interp : Interp_Index; 572 573 function Within_Instance (E : Entity_Id) return Boolean; 574 -- Within an instance there can be spurious ambiguities between a local 575 -- entity and one declared outside of the instance. This can only happen 576 -- for subprograms, because otherwise the local entity hides the outer 577 -- one. For an overloadable entity, this predicate determines whether it 578 -- is a candidate within the instance, or must be ignored. 579 580 --------------------- 581 -- Within_Instance -- 582 --------------------- 583 584 function Within_Instance (E : Entity_Id) return Boolean is 585 Inst : Entity_Id; 586 Scop : Entity_Id; 587 588 begin 589 if not In_Instance then 590 return False; 591 end if; 592 593 Inst := Current_Scope; 594 while Present (Inst) and then not Is_Generic_Instance (Inst) loop 595 Inst := Scope (Inst); 596 end loop; 597 598 Scop := Scope (E); 599 while Present (Scop) and then Scop /= Standard_Standard loop 600 if Scop = Inst then 601 return True; 602 end if; 603 604 Scop := Scope (Scop); 605 end loop; 606 607 return False; 608 end Within_Instance; 609 610 -- Start of processing for Collect_Interps 611 612 begin 613 New_Interps (N); 614 615 -- Unconditionally add the entity that was initially matched 616 617 First_Interp := All_Interp.Last; 618 Add_One_Interp (N, Ent, Etype (N)); 619 620 -- For expanded name, pick up all additional entities from the 621 -- same scope, since these are obviously also visible. Note that 622 -- these are not necessarily contiguous on the homonym chain. 623 624 if Nkind (N) = N_Expanded_Name then 625 H := Homonym (Ent); 626 while Present (H) loop 627 if Scope (H) = Scope (Entity (N)) then 628 Add_One_Interp (N, H, Etype (H)); 629 end if; 630 631 H := Homonym (H); 632 end loop; 633 634 -- Case of direct name 635 636 else 637 -- First, search the homonym chain for directly visible entities 638 639 H := Current_Entity (Ent); 640 while Present (H) loop 641 exit when (not Is_Overloadable (H)) 642 and then Is_Immediately_Visible (H); 643 644 if Is_Immediately_Visible (H) and then H /= Ent then 645 646 -- Only add interpretation if not hidden by an inner 647 -- immediately visible one. 648 649 for J in First_Interp .. All_Interp.Last - 1 loop 650 651 -- Current homograph is not hidden. Add to overloads 652 653 if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then 654 exit; 655 656 -- Homograph is hidden, unless it is a predefined operator 657 658 elsif Type_Conformant (H, All_Interp.Table (J).Nam) then 659 660 -- A homograph in the same scope can occur within an 661 -- instantiation, the resulting ambiguity has to be 662 -- resolved later. The homographs may both be local 663 -- functions or actuals, or may be declared at different 664 -- levels within the instance. The renaming of an actual 665 -- within the instance must not be included. 666 667 if Within_Instance (H) 668 and then H /= Renamed_Entity (Ent) 669 and then not Is_Inherited_Operation (H) 670 then 671 All_Interp.Table (All_Interp.Last) := 672 (H, Etype (H), Empty); 673 All_Interp.Append (No_Interp); 674 goto Next_Homograph; 675 676 elsif Scope (H) /= Standard_Standard then 677 goto Next_Homograph; 678 end if; 679 end if; 680 end loop; 681 682 -- On exit, we know that current homograph is not hidden 683 684 Add_One_Interp (N, H, Etype (H)); 685 686 if Debug_Flag_E then 687 Write_Str ("Add overloaded interpretation "); 688 Write_Int (Int (H)); 689 Write_Eol; 690 end if; 691 end if; 692 693 <<Next_Homograph>> 694 H := Homonym (H); 695 end loop; 696 697 -- Scan list of homographs for use-visible entities only 698 699 H := Current_Entity (Ent); 700 701 while Present (H) loop 702 if Is_Potentially_Use_Visible (H) 703 and then H /= Ent 704 and then Is_Overloadable (H) 705 then 706 for J in First_Interp .. All_Interp.Last - 1 loop 707 708 if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then 709 exit; 710 711 elsif Type_Conformant (H, All_Interp.Table (J).Nam) then 712 goto Next_Use_Homograph; 713 end if; 714 end loop; 715 716 Add_One_Interp (N, H, Etype (H)); 717 end if; 718 719 <<Next_Use_Homograph>> 720 H := Homonym (H); 721 end loop; 722 end if; 723 724 if All_Interp.Last = First_Interp + 1 then 725 726 -- The final interpretation is in fact not overloaded. Note that the 727 -- unique legal interpretation may or may not be the original one, 728 -- so we need to update N's entity and etype now, because once N 729 -- is marked as not overloaded it is also expected to carry the 730 -- proper interpretation. 731 732 Set_Is_Overloaded (N, False); 733 Set_Entity (N, All_Interp.Table (First_Interp).Nam); 734 Set_Etype (N, All_Interp.Table (First_Interp).Typ); 735 end if; 736 end Collect_Interps; 737 738 ------------ 739 -- Covers -- 740 ------------ 741 742 function Covers (T1, T2 : Entity_Id) return Boolean is 743 BT1 : Entity_Id; 744 BT2 : Entity_Id; 745 746 function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean; 747 -- In an instance the proper view may not always be correct for 748 -- private types, but private and full view are compatible. This 749 -- removes spurious errors from nested instantiations that involve, 750 -- among other things, types derived from private types. 751 752 function Real_Actual (T : Entity_Id) return Entity_Id; 753 -- If an actual in an inner instance is the formal of an enclosing 754 -- generic, the actual in the enclosing instance is the one that can 755 -- create an accidental ambiguity, and the check on compatibily of 756 -- generic actual types must use this enclosing actual. 757 758 ---------------------- 759 -- Full_View_Covers -- 760 ---------------------- 761 762 function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean is 763 begin 764 return 765 Is_Private_Type (Typ1) 766 and then 767 ((Present (Full_View (Typ1)) 768 and then Covers (Full_View (Typ1), Typ2)) 769 or else (Present (Underlying_Full_View (Typ1)) 770 and then Covers (Underlying_Full_View (Typ1), Typ2)) 771 or else Base_Type (Typ1) = Typ2 772 or else Base_Type (Typ2) = Typ1); 773 end Full_View_Covers; 774 775 ----------------- 776 -- Real_Actual -- 777 ----------------- 778 779 function Real_Actual (T : Entity_Id) return Entity_Id is 780 Par : constant Node_Id := Parent (T); 781 RA : Entity_Id; 782 783 begin 784 -- Retrieve parent subtype from subtype declaration for actual 785 786 if Nkind (Par) = N_Subtype_Declaration 787 and then not Comes_From_Source (Par) 788 and then Is_Entity_Name (Subtype_Indication (Par)) 789 then 790 RA := Entity (Subtype_Indication (Par)); 791 792 if Is_Generic_Actual_Type (RA) then 793 return RA; 794 end if; 795 end if; 796 797 -- Otherwise actual is not the actual of an enclosing instance 798 799 return T; 800 end Real_Actual; 801 802 -- Start of processing for Covers 803 804 begin 805 -- If either operand missing, then this is an error, but ignore it (and 806 -- pretend we have a cover) if errors already detected, since this may 807 -- simply mean we have malformed trees or a semantic error upstream. 808 809 if No (T1) or else No (T2) then 810 if Total_Errors_Detected /= 0 then 811 return True; 812 else 813 raise Program_Error; 814 end if; 815 end if; 816 817 -- Trivial case: same types are always compatible 818 819 if T1 = T2 then 820 return True; 821 end if; 822 823 -- First check for Standard_Void_Type, which is special. Subsequent 824 -- processing in this routine assumes T1 and T2 are bona fide types; 825 -- Standard_Void_Type is a special entity that has some, but not all, 826 -- properties of types. 827 828 if (T1 = Standard_Void_Type) /= (T2 = Standard_Void_Type) then 829 return False; 830 end if; 831 832 BT1 := Base_Type (T1); 833 BT2 := Base_Type (T2); 834 835 -- Handle underlying view of records with unknown discriminants 836 -- using the original entity that motivated the construction of 837 -- this underlying record view (see Build_Derived_Private_Type). 838 839 if Is_Underlying_Record_View (BT1) then 840 BT1 := Underlying_Record_View (BT1); 841 end if; 842 843 if Is_Underlying_Record_View (BT2) then 844 BT2 := Underlying_Record_View (BT2); 845 end if; 846 847 -- Simplest case: types that have the same base type and are not generic 848 -- actuals are compatible. Generic actuals belong to their class but are 849 -- not compatible with other types of their class, and in particular 850 -- with other generic actuals. They are however compatible with their 851 -- own subtypes, and itypes with the same base are compatible as well. 852 -- Similarly, constrained subtypes obtained from expressions of an 853 -- unconstrained nominal type are compatible with the base type (may 854 -- lead to spurious ambiguities in obscure cases ???) 855 856 -- Generic actuals require special treatment to avoid spurious ambi- 857 -- guities in an instance, when two formal types are instantiated with 858 -- the same actual, so that different subprograms end up with the same 859 -- signature in the instance. If a generic actual is the actual of an 860 -- enclosing instance, it is that actual that we must compare: generic 861 -- actuals are only incompatible if they appear in the same instance. 862 863 if BT1 = BT2 864 or else BT1 = T2 865 or else BT2 = T1 866 then 867 if not Is_Generic_Actual_Type (T1) 868 or else 869 not Is_Generic_Actual_Type (T2) 870 then 871 return True; 872 873 -- Both T1 and T2 are generic actual types 874 875 else 876 declare 877 RT1 : constant Entity_Id := Real_Actual (T1); 878 RT2 : constant Entity_Id := Real_Actual (T2); 879 begin 880 return RT1 = RT2 881 or else Is_Itype (T1) 882 or else Is_Itype (T2) 883 or else Is_Constr_Subt_For_U_Nominal (T1) 884 or else Is_Constr_Subt_For_U_Nominal (T2) 885 or else Scope (RT1) /= Scope (RT2); 886 end; 887 end if; 888 889 -- Literals are compatible with types in a given "class" 890 891 elsif (T2 = Universal_Integer and then Is_Integer_Type (T1)) 892 or else (T2 = Universal_Real and then Is_Real_Type (T1)) 893 or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1)) 894 or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1)) 895 or else (T2 = Any_String and then Is_String_Type (T1)) 896 or else (T2 = Any_Character and then Is_Character_Type (T1)) 897 or else (T2 = Any_Access and then Is_Access_Type (T1)) 898 then 899 return True; 900 901 -- The context may be class wide, and a class-wide type is compatible 902 -- with any member of the class. 903 904 elsif Is_Class_Wide_Type (T1) 905 and then Is_Ancestor (Root_Type (T1), T2) 906 then 907 return True; 908 909 elsif Is_Class_Wide_Type (T1) 910 and then Is_Class_Wide_Type (T2) 911 and then Base_Type (Etype (T1)) = Base_Type (Etype (T2)) 912 then 913 return True; 914 915 -- Ada 2005 (AI-345): A class-wide abstract interface type covers a 916 -- task_type or protected_type that implements the interface. 917 918 elsif Ada_Version >= Ada_2005 919 and then Is_Class_Wide_Type (T1) 920 and then Is_Interface (Etype (T1)) 921 and then Is_Concurrent_Type (T2) 922 and then Interface_Present_In_Ancestor 923 (Typ => BT2, Iface => Etype (T1)) 924 then 925 return True; 926 927 -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an 928 -- object T2 implementing T1. 929 930 elsif Ada_Version >= Ada_2005 931 and then Is_Class_Wide_Type (T1) 932 and then Is_Interface (Etype (T1)) 933 and then Is_Tagged_Type (T2) 934 then 935 if Interface_Present_In_Ancestor (Typ => T2, 936 Iface => Etype (T1)) 937 then 938 return True; 939 end if; 940 941 declare 942 E : Entity_Id; 943 Elmt : Elmt_Id; 944 945 begin 946 if Is_Concurrent_Type (BT2) then 947 E := Corresponding_Record_Type (BT2); 948 else 949 E := BT2; 950 end if; 951 952 -- Ada 2005 (AI-251): A class-wide abstract interface type T1 953 -- covers an object T2 that implements a direct derivation of T1. 954 -- Note: test for presence of E is defense against previous error. 955 956 if No (E) then 957 958 -- If expansion is disabled the Corresponding_Record_Type may 959 -- not be available yet, so use the interface list in the 960 -- declaration directly. 961 962 if ASIS_Mode 963 and then Nkind (Parent (BT2)) = N_Protected_Type_Declaration 964 and then Present (Interface_List (Parent (BT2))) 965 then 966 declare 967 Intf : Node_Id := First (Interface_List (Parent (BT2))); 968 begin 969 while Present (Intf) loop 970 if Is_Ancestor (Etype (T1), Entity (Intf)) then 971 return True; 972 else 973 Next (Intf); 974 end if; 975 end loop; 976 end; 977 978 return False; 979 980 else 981 Check_Error_Detected; 982 end if; 983 984 -- Here we have a corresponding record type 985 986 elsif Present (Interfaces (E)) then 987 Elmt := First_Elmt (Interfaces (E)); 988 while Present (Elmt) loop 989 if Is_Ancestor (Etype (T1), Node (Elmt)) then 990 return True; 991 else 992 Next_Elmt (Elmt); 993 end if; 994 end loop; 995 end if; 996 997 -- We should also check the case in which T1 is an ancestor of 998 -- some implemented interface??? 999 1000 return False; 1001 end; 1002 1003 -- In a dispatching call, the formal is of some specific type, and the 1004 -- actual is of the corresponding class-wide type, including a subtype 1005 -- of the class-wide type. 1006 1007 elsif Is_Class_Wide_Type (T2) 1008 and then 1009 (Class_Wide_Type (T1) = Class_Wide_Type (T2) 1010 or else Base_Type (Root_Type (T2)) = BT1) 1011 then 1012 return True; 1013 1014 -- Some contexts require a class of types rather than a specific type. 1015 -- For example, conditions require any boolean type, fixed point 1016 -- attributes require some real type, etc. The built-in types Any_XXX 1017 -- represent these classes. 1018 1019 elsif (T1 = Any_Integer and then Is_Integer_Type (T2)) 1020 or else (T1 = Any_Boolean and then Is_Boolean_Type (T2)) 1021 or else (T1 = Any_Real and then Is_Real_Type (T2)) 1022 or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2)) 1023 or else (T1 = Any_Discrete and then Is_Discrete_Type (T2)) 1024 then 1025 return True; 1026 1027 -- An aggregate is compatible with an array or record type 1028 1029 elsif T2 = Any_Composite and then Is_Aggregate_Type (T1) then 1030 return True; 1031 1032 -- If the expected type is an anonymous access, the designated type must 1033 -- cover that of the expression. Use the base type for this check: even 1034 -- though access subtypes are rare in sources, they are generated for 1035 -- actuals in instantiations. 1036 1037 elsif Ekind (BT1) = E_Anonymous_Access_Type 1038 and then Is_Access_Type (T2) 1039 and then Covers (Designated_Type (T1), Designated_Type (T2)) 1040 then 1041 return True; 1042 1043 -- Ada 2012 (AI05-0149): Allow an anonymous access type in the context 1044 -- of a named general access type. An implicit conversion will be 1045 -- applied. For the resolution, one designated type must cover the 1046 -- other. 1047 1048 elsif Ada_Version >= Ada_2012 1049 and then Ekind (BT1) = E_General_Access_Type 1050 and then Ekind (BT2) = E_Anonymous_Access_Type 1051 and then (Covers (Designated_Type (T1), Designated_Type (T2)) 1052 or else 1053 Covers (Designated_Type (T2), Designated_Type (T1))) 1054 then 1055 return True; 1056 1057 -- An Access_To_Subprogram is compatible with itself, or with an 1058 -- anonymous type created for an attribute reference Access. 1059 1060 elsif Ekind_In (BT1, E_Access_Subprogram_Type, 1061 E_Access_Protected_Subprogram_Type) 1062 and then Is_Access_Type (T2) 1063 and then (not Comes_From_Source (T1) 1064 or else not Comes_From_Source (T2)) 1065 and then (Is_Overloadable (Designated_Type (T2)) 1066 or else Ekind (Designated_Type (T2)) = E_Subprogram_Type) 1067 and then Type_Conformant (Designated_Type (T1), Designated_Type (T2)) 1068 and then Mode_Conformant (Designated_Type (T1), Designated_Type (T2)) 1069 then 1070 return True; 1071 1072 -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible 1073 -- with itself, or with an anonymous type created for an attribute 1074 -- reference Access. 1075 1076 elsif Ekind_In (BT1, E_Anonymous_Access_Subprogram_Type, 1077 E_Anonymous_Access_Protected_Subprogram_Type) 1078 and then Is_Access_Type (T2) 1079 and then (not Comes_From_Source (T1) 1080 or else not Comes_From_Source (T2)) 1081 and then (Is_Overloadable (Designated_Type (T2)) 1082 or else Ekind (Designated_Type (T2)) = E_Subprogram_Type) 1083 and then Type_Conformant (Designated_Type (T1), Designated_Type (T2)) 1084 and then Mode_Conformant (Designated_Type (T1), Designated_Type (T2)) 1085 then 1086 return True; 1087 1088 -- The context can be a remote access type, and the expression the 1089 -- corresponding source type declared in a categorized package, or 1090 -- vice versa. 1091 1092 elsif Is_Record_Type (T1) 1093 and then (Is_Remote_Call_Interface (T1) or else Is_Remote_Types (T1)) 1094 and then Present (Corresponding_Remote_Type (T1)) 1095 then 1096 return Covers (Corresponding_Remote_Type (T1), T2); 1097 1098 -- and conversely. 1099 1100 elsif Is_Record_Type (T2) 1101 and then (Is_Remote_Call_Interface (T2) or else Is_Remote_Types (T2)) 1102 and then Present (Corresponding_Remote_Type (T2)) 1103 then 1104 return Covers (Corresponding_Remote_Type (T2), T1); 1105 1106 -- Synchronized types are represented at run time by their corresponding 1107 -- record type. During expansion one is replaced with the other, but 1108 -- they are compatible views of the same type. 1109 1110 elsif Is_Record_Type (T1) 1111 and then Is_Concurrent_Type (T2) 1112 and then Present (Corresponding_Record_Type (T2)) 1113 then 1114 return Covers (T1, Corresponding_Record_Type (T2)); 1115 1116 elsif Is_Concurrent_Type (T1) 1117 and then Present (Corresponding_Record_Type (T1)) 1118 and then Is_Record_Type (T2) 1119 then 1120 return Covers (Corresponding_Record_Type (T1), T2); 1121 1122 -- During analysis, an attribute reference 'Access has a special type 1123 -- kind: Access_Attribute_Type, to be replaced eventually with the type 1124 -- imposed by context. 1125 1126 elsif Ekind (T2) = E_Access_Attribute_Type 1127 and then Ekind_In (BT1, E_General_Access_Type, E_Access_Type) 1128 and then Covers (Designated_Type (T1), Designated_Type (T2)) 1129 then 1130 -- If the target type is a RACW type while the source is an access 1131 -- attribute type, we are building a RACW that may be exported. 1132 1133 if Is_Remote_Access_To_Class_Wide_Type (BT1) then 1134 Set_Has_RACW (Current_Sem_Unit); 1135 end if; 1136 1137 return True; 1138 1139 -- Ditto for allocators, which eventually resolve to the context type 1140 1141 elsif Ekind (T2) = E_Allocator_Type and then Is_Access_Type (T1) then 1142 return Covers (Designated_Type (T1), Designated_Type (T2)) 1143 or else 1144 (From_Limited_With (Designated_Type (T1)) 1145 and then Covers (Designated_Type (T2), Designated_Type (T1))); 1146 1147 -- A boolean operation on integer literals is compatible with modular 1148 -- context. 1149 1150 elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then 1151 return True; 1152 1153 -- The actual type may be the result of a previous error 1154 1155 elsif BT2 = Any_Type then 1156 return True; 1157 1158 -- A Raise_Expressions is legal in any expression context 1159 1160 elsif BT2 = Raise_Type then 1161 return True; 1162 1163 -- A packed array type covers its corresponding non-packed type. This is 1164 -- not legitimate Ada, but allows the omission of a number of otherwise 1165 -- useless unchecked conversions, and since this can only arise in 1166 -- (known correct) expanded code, no harm is done. 1167 1168 elsif Is_Array_Type (T2) 1169 and then Is_Packed (T2) 1170 and then T1 = Packed_Array_Impl_Type (T2) 1171 then 1172 return True; 1173 1174 -- Similarly an array type covers its corresponding packed array type 1175 1176 elsif Is_Array_Type (T1) 1177 and then Is_Packed (T1) 1178 and then T2 = Packed_Array_Impl_Type (T1) 1179 then 1180 return True; 1181 1182 -- In instances, or with types exported from instantiations, check 1183 -- whether a partial and a full view match. Verify that types are 1184 -- legal, to prevent cascaded errors. 1185 1186 elsif In_Instance 1187 and then (Full_View_Covers (T1, T2) or else Full_View_Covers (T2, T1)) 1188 then 1189 return True; 1190 1191 elsif Is_Type (T2) 1192 and then Is_Generic_Actual_Type (T2) 1193 and then Full_View_Covers (T1, T2) 1194 then 1195 return True; 1196 1197 elsif Is_Type (T1) 1198 and then Is_Generic_Actual_Type (T1) 1199 and then Full_View_Covers (T2, T1) 1200 then 1201 return True; 1202 1203 -- In the expansion of inlined bodies, types are compatible if they 1204 -- are structurally equivalent. 1205 1206 elsif In_Inlined_Body 1207 and then (Underlying_Type (T1) = Underlying_Type (T2) 1208 or else 1209 (Is_Access_Type (T1) 1210 and then Is_Access_Type (T2) 1211 and then Designated_Type (T1) = Designated_Type (T2)) 1212 or else 1213 (T1 = Any_Access 1214 and then Is_Access_Type (Underlying_Type (T2))) 1215 or else 1216 (T2 = Any_Composite 1217 and then Is_Composite_Type (Underlying_Type (T1)))) 1218 then 1219 return True; 1220 1221 -- Ada 2005 (AI-50217): Additional branches to make the shadow entity 1222 -- obtained through a limited_with compatible with its real entity. 1223 1224 elsif From_Limited_With (T1) then 1225 1226 -- If the expected type is the nonlimited view of a type, the 1227 -- expression may have the limited view. If that one in turn is 1228 -- incomplete, get full view if available. 1229 1230 return Has_Non_Limited_View (T1) 1231 and then Covers (Get_Full_View (Non_Limited_View (T1)), T2); 1232 1233 elsif From_Limited_With (T2) then 1234 1235 -- If units in the context have Limited_With clauses on each other, 1236 -- either type might have a limited view. Checks performed elsewhere 1237 -- verify that the context type is the nonlimited view. 1238 1239 return Has_Non_Limited_View (T2) 1240 and then Covers (T1, Get_Full_View (Non_Limited_View (T2))); 1241 1242 -- Ada 2005 (AI-412): Coverage for regular incomplete subtypes 1243 1244 elsif Ekind (T1) = E_Incomplete_Subtype then 1245 return Covers (Full_View (Etype (T1)), T2); 1246 1247 elsif Ekind (T2) = E_Incomplete_Subtype then 1248 return Covers (T1, Full_View (Etype (T2))); 1249 1250 -- Ada 2005 (AI-423): Coverage of formal anonymous access types 1251 -- and actual anonymous access types in the context of generic 1252 -- instantiations. We have the following situation: 1253 1254 -- generic 1255 -- type Formal is private; 1256 -- Formal_Obj : access Formal; -- T1 1257 -- package G is ... 1258 1259 -- package P is 1260 -- type Actual is ... 1261 -- Actual_Obj : access Actual; -- T2 1262 -- package Instance is new G (Formal => Actual, 1263 -- Formal_Obj => Actual_Obj); 1264 1265 elsif Ada_Version >= Ada_2005 1266 and then Ekind (T1) = E_Anonymous_Access_Type 1267 and then Ekind (T2) = E_Anonymous_Access_Type 1268 and then Is_Generic_Type (Directly_Designated_Type (T1)) 1269 and then Get_Instance_Of (Directly_Designated_Type (T1)) = 1270 Directly_Designated_Type (T2) 1271 then 1272 return True; 1273 1274 -- Otherwise, types are not compatible 1275 1276 else 1277 return False; 1278 end if; 1279 end Covers; 1280 1281 ------------------ 1282 -- Disambiguate -- 1283 ------------------ 1284 1285 function Disambiguate 1286 (N : Node_Id; 1287 I1, I2 : Interp_Index; 1288 Typ : Entity_Id) return Interp 1289 is 1290 I : Interp_Index; 1291 It : Interp; 1292 It1, It2 : Interp; 1293 Nam1, Nam2 : Entity_Id; 1294 Predef_Subp : Entity_Id; 1295 User_Subp : Entity_Id; 1296 1297 function Inherited_From_Actual (S : Entity_Id) return Boolean; 1298 -- Determine whether one of the candidates is an operation inherited by 1299 -- a type that is derived from an actual in an instantiation. 1300 1301 function In_Same_Declaration_List 1302 (Typ : Entity_Id; 1303 Op_Decl : Entity_Id) return Boolean; 1304 -- AI05-0020: a spurious ambiguity may arise when equality on anonymous 1305 -- access types is declared on the partial view of a designated type, so 1306 -- that the type declaration and equality are not in the same list of 1307 -- declarations. This AI gives a preference rule for the user-defined 1308 -- operation. Same rule applies for arithmetic operations on private 1309 -- types completed with fixed-point types: the predefined operation is 1310 -- hidden; this is already handled properly in GNAT. 1311 1312 function Is_Actual_Subprogram (S : Entity_Id) return Boolean; 1313 -- Determine whether a subprogram is an actual in an enclosing instance. 1314 -- An overloading between such a subprogram and one declared outside the 1315 -- instance is resolved in favor of the first, because it resolved in 1316 -- the generic. Within the instance the actual is represented by a 1317 -- constructed subprogram renaming. 1318 1319 function Matches (Actual, Formal : Node_Id) return Boolean; 1320 -- Look for exact type match in an instance, to remove spurious 1321 -- ambiguities when two formal types have the same actual. 1322 1323 function Operand_Type return Entity_Id; 1324 -- Determine type of operand for an equality operation, to apply 1325 -- Ada 2005 rules to equality on anonymous access types. 1326 1327 function Standard_Operator return Boolean; 1328 -- Check whether subprogram is predefined operator declared in Standard. 1329 -- It may given by an operator name, or by an expanded name whose prefix 1330 -- is Standard. 1331 1332 function Remove_Conversions return Interp; 1333 -- Last chance for pathological cases involving comparisons on literals, 1334 -- and user overloadings of the same operator. Such pathologies have 1335 -- been removed from the ACVC, but still appear in two DEC tests, with 1336 -- the following notable quote from Ben Brosgol: 1337 -- 1338 -- [Note: I disclaim all credit/responsibility/blame for coming up with 1339 -- this example; Robert Dewar brought it to our attention, since it is 1340 -- apparently found in the ACVC 1.5. I did not attempt to find the 1341 -- reason in the Reference Manual that makes the example legal, since I 1342 -- was too nauseated by it to want to pursue it further.] 1343 -- 1344 -- Accordingly, this is not a fully recursive solution, but it handles 1345 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes 1346 -- pathology in the other direction with calls whose multiple overloaded 1347 -- actuals make them truly unresolvable. 1348 1349 -- The new rules concerning abstract operations create additional need 1350 -- for special handling of expressions with universal operands, see 1351 -- comments to Has_Abstract_Interpretation below. 1352 1353 --------------------------- 1354 -- Inherited_From_Actual -- 1355 --------------------------- 1356 1357 function Inherited_From_Actual (S : Entity_Id) return Boolean is 1358 Par : constant Node_Id := Parent (S); 1359 begin 1360 if Nkind (Par) /= N_Full_Type_Declaration 1361 or else Nkind (Type_Definition (Par)) /= N_Derived_Type_Definition 1362 then 1363 return False; 1364 else 1365 return Is_Entity_Name (Subtype_Indication (Type_Definition (Par))) 1366 and then 1367 Is_Generic_Actual_Type ( 1368 Entity (Subtype_Indication (Type_Definition (Par)))); 1369 end if; 1370 end Inherited_From_Actual; 1371 1372 ------------------------------ 1373 -- In_Same_Declaration_List -- 1374 ------------------------------ 1375 1376 function In_Same_Declaration_List 1377 (Typ : Entity_Id; 1378 Op_Decl : Entity_Id) return Boolean 1379 is 1380 Scop : constant Entity_Id := Scope (Typ); 1381 1382 begin 1383 return In_Same_List (Parent (Typ), Op_Decl) 1384 or else 1385 (Ekind_In (Scop, E_Package, E_Generic_Package) 1386 and then List_Containing (Op_Decl) = 1387 Visible_Declarations (Parent (Scop)) 1388 and then List_Containing (Parent (Typ)) = 1389 Private_Declarations (Parent (Scop))); 1390 end In_Same_Declaration_List; 1391 1392 -------------------------- 1393 -- Is_Actual_Subprogram -- 1394 -------------------------- 1395 1396 function Is_Actual_Subprogram (S : Entity_Id) return Boolean is 1397 begin 1398 return In_Open_Scopes (Scope (S)) 1399 and then Nkind (Unit_Declaration_Node (S)) = 1400 N_Subprogram_Renaming_Declaration 1401 1402 -- Why the Comes_From_Source test here??? 1403 1404 and then not Comes_From_Source (Unit_Declaration_Node (S)) 1405 1406 and then 1407 (Is_Generic_Instance (Scope (S)) 1408 or else Is_Wrapper_Package (Scope (S))); 1409 end Is_Actual_Subprogram; 1410 1411 ------------- 1412 -- Matches -- 1413 ------------- 1414 1415 function Matches (Actual, Formal : Node_Id) return Boolean is 1416 T1 : constant Entity_Id := Etype (Actual); 1417 T2 : constant Entity_Id := Etype (Formal); 1418 begin 1419 return T1 = T2 1420 or else 1421 (Is_Numeric_Type (T2) 1422 and then (T1 = Universal_Real or else T1 = Universal_Integer)); 1423 end Matches; 1424 1425 ------------------ 1426 -- Operand_Type -- 1427 ------------------ 1428 1429 function Operand_Type return Entity_Id is 1430 Opnd : Node_Id; 1431 1432 begin 1433 if Nkind (N) = N_Function_Call then 1434 Opnd := First_Actual (N); 1435 else 1436 Opnd := Left_Opnd (N); 1437 end if; 1438 1439 return Etype (Opnd); 1440 end Operand_Type; 1441 1442 ------------------------ 1443 -- Remove_Conversions -- 1444 ------------------------ 1445 1446 function Remove_Conversions return Interp is 1447 I : Interp_Index; 1448 It : Interp; 1449 It1 : Interp; 1450 F1 : Entity_Id; 1451 Act1 : Node_Id; 1452 Act2 : Node_Id; 1453 1454 function Has_Abstract_Interpretation (N : Node_Id) return Boolean; 1455 -- If an operation has universal operands the universal operation 1456 -- is present among its interpretations. If there is an abstract 1457 -- interpretation for the operator, with a numeric result, this 1458 -- interpretation was already removed in sem_ch4, but the universal 1459 -- one is still visible. We must rescan the list of operators and 1460 -- remove the universal interpretation to resolve the ambiguity. 1461 1462 --------------------------------- 1463 -- Has_Abstract_Interpretation -- 1464 --------------------------------- 1465 1466 function Has_Abstract_Interpretation (N : Node_Id) return Boolean is 1467 E : Entity_Id; 1468 1469 begin 1470 if Nkind (N) not in N_Op 1471 or else Ada_Version < Ada_2005 1472 or else not Is_Overloaded (N) 1473 or else No (Universal_Interpretation (N)) 1474 then 1475 return False; 1476 1477 else 1478 E := Get_Name_Entity_Id (Chars (N)); 1479 while Present (E) loop 1480 if Is_Overloadable (E) 1481 and then Is_Abstract_Subprogram (E) 1482 and then Is_Numeric_Type (Etype (E)) 1483 then 1484 return True; 1485 else 1486 E := Homonym (E); 1487 end if; 1488 end loop; 1489 1490 -- Finally, if an operand of the binary operator is itself 1491 -- an operator, recurse to see whether its own abstract 1492 -- interpretation is responsible for the spurious ambiguity. 1493 1494 if Nkind (N) in N_Binary_Op then 1495 return Has_Abstract_Interpretation (Left_Opnd (N)) 1496 or else Has_Abstract_Interpretation (Right_Opnd (N)); 1497 1498 elsif Nkind (N) in N_Unary_Op then 1499 return Has_Abstract_Interpretation (Right_Opnd (N)); 1500 1501 else 1502 return False; 1503 end if; 1504 end if; 1505 end Has_Abstract_Interpretation; 1506 1507 -- Start of processing for Remove_Conversions 1508 1509 begin 1510 It1 := No_Interp; 1511 1512 Get_First_Interp (N, I, It); 1513 while Present (It.Typ) loop 1514 if not Is_Overloadable (It.Nam) then 1515 return No_Interp; 1516 end if; 1517 1518 F1 := First_Formal (It.Nam); 1519 1520 if No (F1) then 1521 return It1; 1522 1523 else 1524 if Nkind (N) in N_Subprogram_Call then 1525 Act1 := First_Actual (N); 1526 1527 if Present (Act1) then 1528 Act2 := Next_Actual (Act1); 1529 else 1530 Act2 := Empty; 1531 end if; 1532 1533 elsif Nkind (N) in N_Unary_Op then 1534 Act1 := Right_Opnd (N); 1535 Act2 := Empty; 1536 1537 elsif Nkind (N) in N_Binary_Op then 1538 Act1 := Left_Opnd (N); 1539 Act2 := Right_Opnd (N); 1540 1541 -- Use type of second formal, so as to include 1542 -- exponentiation, where the exponent may be 1543 -- ambiguous and the result non-universal. 1544 1545 Next_Formal (F1); 1546 1547 else 1548 return It1; 1549 end if; 1550 1551 if Nkind (Act1) in N_Op 1552 and then Is_Overloaded (Act1) 1553 and then Nkind_In (Left_Opnd (Act1), N_Integer_Literal, 1554 N_Real_Literal) 1555 and then Nkind_In (Right_Opnd (Act1), N_Integer_Literal, 1556 N_Real_Literal) 1557 and then Has_Compatible_Type (Act1, Standard_Boolean) 1558 and then Etype (F1) = Standard_Boolean 1559 then 1560 -- If the two candidates are the original ones, the 1561 -- ambiguity is real. Otherwise keep the original, further 1562 -- calls to Disambiguate will take care of others in the 1563 -- list of candidates. 1564 1565 if It1 /= No_Interp then 1566 if It = Disambiguate.It1 1567 or else It = Disambiguate.It2 1568 then 1569 if It1 = Disambiguate.It1 1570 or else It1 = Disambiguate.It2 1571 then 1572 return No_Interp; 1573 else 1574 It1 := It; 1575 end if; 1576 end if; 1577 1578 elsif Present (Act2) 1579 and then Nkind (Act2) in N_Op 1580 and then Is_Overloaded (Act2) 1581 and then Nkind_In (Right_Opnd (Act2), N_Integer_Literal, 1582 N_Real_Literal) 1583 and then Has_Compatible_Type (Act2, Standard_Boolean) 1584 then 1585 -- The preference rule on the first actual is not 1586 -- sufficient to disambiguate. 1587 1588 goto Next_Interp; 1589 1590 else 1591 It1 := It; 1592 end if; 1593 1594 elsif Is_Numeric_Type (Etype (F1)) 1595 and then Has_Abstract_Interpretation (Act1) 1596 then 1597 -- Current interpretation is not the right one because it 1598 -- expects a numeric operand. Examine all the other ones. 1599 1600 declare 1601 I : Interp_Index; 1602 It : Interp; 1603 1604 begin 1605 Get_First_Interp (N, I, It); 1606 while Present (It.Typ) loop 1607 if 1608 not Is_Numeric_Type (Etype (First_Formal (It.Nam))) 1609 then 1610 if No (Act2) 1611 or else not Has_Abstract_Interpretation (Act2) 1612 or else not 1613 Is_Numeric_Type 1614 (Etype (Next_Formal (First_Formal (It.Nam)))) 1615 then 1616 return It; 1617 end if; 1618 end if; 1619 1620 Get_Next_Interp (I, It); 1621 end loop; 1622 1623 return No_Interp; 1624 end; 1625 end if; 1626 end if; 1627 1628 <<Next_Interp>> 1629 Get_Next_Interp (I, It); 1630 end loop; 1631 1632 -- After some error, a formal may have Any_Type and yield a spurious 1633 -- match. To avoid cascaded errors if possible, check for such a 1634 -- formal in either candidate. 1635 1636 if Serious_Errors_Detected > 0 then 1637 declare 1638 Formal : Entity_Id; 1639 1640 begin 1641 Formal := First_Formal (Nam1); 1642 while Present (Formal) loop 1643 if Etype (Formal) = Any_Type then 1644 return Disambiguate.It2; 1645 end if; 1646 1647 Next_Formal (Formal); 1648 end loop; 1649 1650 Formal := First_Formal (Nam2); 1651 while Present (Formal) loop 1652 if Etype (Formal) = Any_Type then 1653 return Disambiguate.It1; 1654 end if; 1655 1656 Next_Formal (Formal); 1657 end loop; 1658 end; 1659 end if; 1660 1661 return It1; 1662 end Remove_Conversions; 1663 1664 ----------------------- 1665 -- Standard_Operator -- 1666 ----------------------- 1667 1668 function Standard_Operator return Boolean is 1669 Nam : Node_Id; 1670 1671 begin 1672 if Nkind (N) in N_Op then 1673 return True; 1674 1675 elsif Nkind (N) = N_Function_Call then 1676 Nam := Name (N); 1677 1678 if Nkind (Nam) /= N_Expanded_Name then 1679 return True; 1680 else 1681 return Entity (Prefix (Nam)) = Standard_Standard; 1682 end if; 1683 else 1684 return False; 1685 end if; 1686 end Standard_Operator; 1687 1688 -- Start of processing for Disambiguate 1689 1690 begin 1691 -- Recover the two legal interpretations 1692 1693 Get_First_Interp (N, I, It); 1694 while I /= I1 loop 1695 Get_Next_Interp (I, It); 1696 end loop; 1697 1698 It1 := It; 1699 Nam1 := It.Nam; 1700 while I /= I2 loop 1701 Get_Next_Interp (I, It); 1702 end loop; 1703 1704 It2 := It; 1705 Nam2 := It.Nam; 1706 1707 -- Check whether one of the entities is an Ada 2005/2012 and we are 1708 -- operating in an earlier mode, in which case we discard the Ada 1709 -- 2005/2012 entity, so that we get proper Ada 95 overload resolution. 1710 1711 if Ada_Version < Ada_2005 then 1712 if Is_Ada_2005_Only (Nam1) or else Is_Ada_2012_Only (Nam1) then 1713 return It2; 1714 elsif Is_Ada_2005_Only (Nam2) or else Is_Ada_2012_Only (Nam1) then 1715 return It1; 1716 end if; 1717 end if; 1718 1719 -- Check whether one of the entities is an Ada 2012 entity and we are 1720 -- operating in Ada 2005 mode, in which case we discard the Ada 2012 1721 -- entity, so that we get proper Ada 2005 overload resolution. 1722 1723 if Ada_Version = Ada_2005 then 1724 if Is_Ada_2012_Only (Nam1) then 1725 return It2; 1726 elsif Is_Ada_2012_Only (Nam2) then 1727 return It1; 1728 end if; 1729 end if; 1730 1731 -- If the context is universal, the predefined operator is preferred. 1732 -- This includes bounds in numeric type declarations, and expressions 1733 -- in type conversions. If no interpretation yields a universal type, 1734 -- then we must check whether the user-defined entity hides the prede- 1735 -- fined one. 1736 1737 if Chars (Nam1) in Any_Operator_Name and then Standard_Operator then 1738 if Typ = Universal_Integer 1739 or else Typ = Universal_Real 1740 or else Typ = Any_Integer 1741 or else Typ = Any_Discrete 1742 or else Typ = Any_Real 1743 or else Typ = Any_Type 1744 then 1745 -- Find an interpretation that yields the universal type, or else 1746 -- a predefined operator that yields a predefined numeric type. 1747 1748 declare 1749 Candidate : Interp := No_Interp; 1750 1751 begin 1752 Get_First_Interp (N, I, It); 1753 while Present (It.Typ) loop 1754 if (Covers (Typ, It.Typ) or else Typ = Any_Type) 1755 and then 1756 (It.Typ = Universal_Integer 1757 or else It.Typ = Universal_Real) 1758 then 1759 return It; 1760 1761 elsif Covers (Typ, It.Typ) 1762 and then Scope (It.Typ) = Standard_Standard 1763 and then Scope (It.Nam) = Standard_Standard 1764 and then Is_Numeric_Type (It.Typ) 1765 then 1766 Candidate := It; 1767 end if; 1768 1769 Get_Next_Interp (I, It); 1770 end loop; 1771 1772 if Candidate /= No_Interp then 1773 return Candidate; 1774 end if; 1775 end; 1776 1777 elsif Chars (Nam1) /= Name_Op_Not 1778 and then (Typ = Standard_Boolean or else Typ = Any_Boolean) 1779 then 1780 -- Equality or comparison operation. Choose predefined operator if 1781 -- arguments are universal. The node may be an operator, name, or 1782 -- a function call, so unpack arguments accordingly. 1783 1784 declare 1785 Arg1, Arg2 : Node_Id; 1786 1787 begin 1788 if Nkind (N) in N_Op then 1789 Arg1 := Left_Opnd (N); 1790 Arg2 := Right_Opnd (N); 1791 1792 elsif Is_Entity_Name (N) then 1793 Arg1 := First_Entity (Entity (N)); 1794 Arg2 := Next_Entity (Arg1); 1795 1796 else 1797 Arg1 := First_Actual (N); 1798 Arg2 := Next_Actual (Arg1); 1799 end if; 1800 1801 if Present (Arg2) 1802 and then Present (Universal_Interpretation (Arg1)) 1803 and then Universal_Interpretation (Arg2) = 1804 Universal_Interpretation (Arg1) 1805 then 1806 Get_First_Interp (N, I, It); 1807 while Scope (It.Nam) /= Standard_Standard loop 1808 Get_Next_Interp (I, It); 1809 end loop; 1810 1811 return It; 1812 end if; 1813 end; 1814 end if; 1815 end if; 1816 1817 -- If no universal interpretation, check whether user-defined operator 1818 -- hides predefined one, as well as other special cases. If the node 1819 -- is a range, then one or both bounds are ambiguous. Each will have 1820 -- to be disambiguated w.r.t. the context type. The type of the range 1821 -- itself is imposed by the context, so we can return either legal 1822 -- interpretation. 1823 1824 if Ekind (Nam1) = E_Operator then 1825 Predef_Subp := Nam1; 1826 User_Subp := Nam2; 1827 1828 elsif Ekind (Nam2) = E_Operator then 1829 Predef_Subp := Nam2; 1830 User_Subp := Nam1; 1831 1832 elsif Nkind (N) = N_Range then 1833 return It1; 1834 1835 -- Implement AI05-105: A renaming declaration with an access 1836 -- definition must resolve to an anonymous access type. This 1837 -- is a resolution rule and can be used to disambiguate. 1838 1839 elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration 1840 and then Present (Access_Definition (Parent (N))) 1841 then 1842 if Ekind_In (It1.Typ, E_Anonymous_Access_Type, 1843 E_Anonymous_Access_Subprogram_Type) 1844 then 1845 if Ekind (It2.Typ) = Ekind (It1.Typ) then 1846 1847 -- True ambiguity 1848 1849 return No_Interp; 1850 1851 else 1852 return It1; 1853 end if; 1854 1855 elsif Ekind_In (It2.Typ, E_Anonymous_Access_Type, 1856 E_Anonymous_Access_Subprogram_Type) 1857 then 1858 return It2; 1859 1860 -- No legal interpretation 1861 1862 else 1863 return No_Interp; 1864 end if; 1865 1866 -- If two user defined-subprograms are visible, it is a true ambiguity, 1867 -- unless one of them is an entry and the context is a conditional or 1868 -- timed entry call, or unless we are within an instance and this is 1869 -- results from two formals types with the same actual. 1870 1871 else 1872 if Nkind (N) = N_Procedure_Call_Statement 1873 and then Nkind (Parent (N)) = N_Entry_Call_Alternative 1874 and then N = Entry_Call_Statement (Parent (N)) 1875 then 1876 if Ekind (Nam2) = E_Entry then 1877 return It2; 1878 elsif Ekind (Nam1) = E_Entry then 1879 return It1; 1880 else 1881 return No_Interp; 1882 end if; 1883 1884 -- If the ambiguity occurs within an instance, it is due to several 1885 -- formal types with the same actual. Look for an exact match between 1886 -- the types of the formals of the overloadable entities, and the 1887 -- actuals in the call, to recover the unambiguous match in the 1888 -- original generic. 1889 1890 -- The ambiguity can also be due to an overloading between a formal 1891 -- subprogram and a subprogram declared outside the generic. If the 1892 -- node is overloaded, it did not resolve to the global entity in 1893 -- the generic, and we choose the formal subprogram. 1894 1895 -- Finally, the ambiguity can be between an explicit subprogram and 1896 -- one inherited (with different defaults) from an actual. In this 1897 -- case the resolution was to the explicit declaration in the 1898 -- generic, and remains so in the instance. 1899 1900 -- The same sort of disambiguation needed for calls is also required 1901 -- for the name given in a subprogram renaming, and that case is 1902 -- handled here as well. We test Comes_From_Source to exclude this 1903 -- treatment for implicit renamings created for formal subprograms. 1904 1905 elsif In_Instance and then not In_Generic_Actual (N) then 1906 if Nkind (N) in N_Subprogram_Call 1907 or else 1908 (Nkind (N) in N_Has_Entity 1909 and then 1910 Nkind (Parent (N)) = N_Subprogram_Renaming_Declaration 1911 and then Comes_From_Source (Parent (N))) 1912 then 1913 declare 1914 Actual : Node_Id; 1915 Formal : Entity_Id; 1916 Renam : Entity_Id := Empty; 1917 Is_Act1 : constant Boolean := Is_Actual_Subprogram (Nam1); 1918 Is_Act2 : constant Boolean := Is_Actual_Subprogram (Nam2); 1919 1920 begin 1921 if Is_Act1 and then not Is_Act2 then 1922 return It1; 1923 1924 elsif Is_Act2 and then not Is_Act1 then 1925 return It2; 1926 1927 elsif Inherited_From_Actual (Nam1) 1928 and then Comes_From_Source (Nam2) 1929 then 1930 return It2; 1931 1932 elsif Inherited_From_Actual (Nam2) 1933 and then Comes_From_Source (Nam1) 1934 then 1935 return It1; 1936 end if; 1937 1938 -- In the case of a renamed subprogram, pick up the entity 1939 -- of the renaming declaration so we can traverse its 1940 -- formal parameters. 1941 1942 if Nkind (N) in N_Has_Entity then 1943 Renam := Defining_Unit_Name (Specification (Parent (N))); 1944 end if; 1945 1946 if Present (Renam) then 1947 Actual := First_Formal (Renam); 1948 else 1949 Actual := First_Actual (N); 1950 end if; 1951 1952 Formal := First_Formal (Nam1); 1953 while Present (Actual) loop 1954 if Etype (Actual) /= Etype (Formal) then 1955 return It2; 1956 end if; 1957 1958 if Present (Renam) then 1959 Next_Formal (Actual); 1960 else 1961 Next_Actual (Actual); 1962 end if; 1963 1964 Next_Formal (Formal); 1965 end loop; 1966 1967 return It1; 1968 end; 1969 1970 elsif Nkind (N) in N_Binary_Op then 1971 if Matches (Left_Opnd (N), First_Formal (Nam1)) 1972 and then 1973 Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1))) 1974 then 1975 return It1; 1976 else 1977 return It2; 1978 end if; 1979 1980 elsif Nkind (N) in N_Unary_Op then 1981 if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then 1982 return It1; 1983 else 1984 return It2; 1985 end if; 1986 1987 else 1988 return Remove_Conversions; 1989 end if; 1990 else 1991 return Remove_Conversions; 1992 end if; 1993 end if; 1994 1995 -- An implicit concatenation operator on a string type cannot be 1996 -- disambiguated from the predefined concatenation. This can only 1997 -- happen with concatenation of string literals. 1998 1999 if Chars (User_Subp) = Name_Op_Concat 2000 and then Ekind (User_Subp) = E_Operator 2001 and then Is_String_Type (Etype (First_Formal (User_Subp))) 2002 then 2003 return No_Interp; 2004 2005 -- If the user-defined operator is in an open scope, or in the scope 2006 -- of the resulting type, or given by an expanded name that names its 2007 -- scope, it hides the predefined operator for the type. Exponentiation 2008 -- has to be special-cased because the implicit operator does not have 2009 -- a symmetric signature, and may not be hidden by the explicit one. 2010 2011 elsif (Nkind (N) = N_Function_Call 2012 and then Nkind (Name (N)) = N_Expanded_Name 2013 and then (Chars (Predef_Subp) /= Name_Op_Expon 2014 or else Hides_Op (User_Subp, Predef_Subp)) 2015 and then Scope (User_Subp) = Entity (Prefix (Name (N)))) 2016 or else Hides_Op (User_Subp, Predef_Subp) 2017 then 2018 if It1.Nam = User_Subp then 2019 return It1; 2020 else 2021 return It2; 2022 end if; 2023 2024 -- Otherwise, the predefined operator has precedence, or if the user- 2025 -- defined operation is directly visible we have a true ambiguity. 2026 2027 -- If this is a fixed-point multiplication and division in Ada 83 mode, 2028 -- exclude the universal_fixed operator, which often causes ambiguities 2029 -- in legacy code. 2030 2031 -- Ditto in Ada 2012, where an ambiguity may arise for an operation 2032 -- on a partial view that is completed with a fixed point type. See 2033 -- AI05-0020 and AI05-0209. The ambiguity is resolved in favor of the 2034 -- user-defined type and subprogram, so that a client of the package 2035 -- has the same resolution as the body of the package. 2036 2037 else 2038 if (In_Open_Scopes (Scope (User_Subp)) 2039 or else Is_Potentially_Use_Visible (User_Subp)) 2040 and then not In_Instance 2041 then 2042 if Is_Fixed_Point_Type (Typ) 2043 and then Nam_In (Chars (Nam1), Name_Op_Multiply, Name_Op_Divide) 2044 and then 2045 (Ada_Version = Ada_83 2046 or else (Ada_Version >= Ada_2012 2047 and then In_Same_Declaration_List 2048 (First_Subtype (Typ), 2049 Unit_Declaration_Node (User_Subp)))) 2050 then 2051 if It2.Nam = Predef_Subp then 2052 return It1; 2053 else 2054 return It2; 2055 end if; 2056 2057 -- Ada 2005, AI-420: preference rule for "=" on Universal_Access 2058 -- states that the operator defined in Standard is not available 2059 -- if there is a user-defined equality with the proper signature, 2060 -- declared in the same declarative list as the type. The node 2061 -- may be an operator or a function call. 2062 2063 elsif Nam_In (Chars (Nam1), Name_Op_Eq, Name_Op_Ne) 2064 and then Ada_Version >= Ada_2005 2065 and then Etype (User_Subp) = Standard_Boolean 2066 and then Ekind (Operand_Type) = E_Anonymous_Access_Type 2067 and then 2068 In_Same_Declaration_List 2069 (Designated_Type (Operand_Type), 2070 Unit_Declaration_Node (User_Subp)) 2071 then 2072 if It2.Nam = Predef_Subp then 2073 return It1; 2074 else 2075 return It2; 2076 end if; 2077 2078 -- An immediately visible operator hides a use-visible user- 2079 -- defined operation. This disambiguation cannot take place 2080 -- earlier because the visibility of the predefined operator 2081 -- can only be established when operand types are known. 2082 2083 elsif Ekind (User_Subp) = E_Function 2084 and then Ekind (Predef_Subp) = E_Operator 2085 and then Nkind (N) in N_Op 2086 and then not Is_Overloaded (Right_Opnd (N)) 2087 and then 2088 Is_Immediately_Visible (Base_Type (Etype (Right_Opnd (N)))) 2089 and then Is_Potentially_Use_Visible (User_Subp) 2090 then 2091 if It2.Nam = Predef_Subp then 2092 return It1; 2093 else 2094 return It2; 2095 end if; 2096 2097 else 2098 return No_Interp; 2099 end if; 2100 2101 elsif It1.Nam = Predef_Subp then 2102 return It1; 2103 2104 else 2105 return It2; 2106 end if; 2107 end if; 2108 end Disambiguate; 2109 2110 --------------------- 2111 -- End_Interp_List -- 2112 --------------------- 2113 2114 procedure End_Interp_List is 2115 begin 2116 All_Interp.Table (All_Interp.Last) := No_Interp; 2117 All_Interp.Increment_Last; 2118 end End_Interp_List; 2119 2120 ------------------------- 2121 -- Entity_Matches_Spec -- 2122 ------------------------- 2123 2124 function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is 2125 begin 2126 -- Simple case: same entity kinds, type conformance is required. A 2127 -- parameterless function can also rename a literal. 2128 2129 if Ekind (Old_S) = Ekind (New_S) 2130 or else (Ekind (New_S) = E_Function 2131 and then Ekind (Old_S) = E_Enumeration_Literal) 2132 then 2133 return Type_Conformant (New_S, Old_S); 2134 2135 elsif Ekind (New_S) = E_Function and then Ekind (Old_S) = E_Operator then 2136 return Operator_Matches_Spec (Old_S, New_S); 2137 2138 elsif Ekind (New_S) = E_Procedure and then Is_Entry (Old_S) then 2139 return Type_Conformant (New_S, Old_S); 2140 2141 else 2142 return False; 2143 end if; 2144 end Entity_Matches_Spec; 2145 2146 ---------------------- 2147 -- Find_Unique_Type -- 2148 ---------------------- 2149 2150 function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is 2151 T : constant Entity_Id := Etype (L); 2152 I : Interp_Index; 2153 It : Interp; 2154 TR : Entity_Id := Any_Type; 2155 2156 begin 2157 if Is_Overloaded (R) then 2158 Get_First_Interp (R, I, It); 2159 while Present (It.Typ) loop 2160 if Covers (T, It.Typ) or else Covers (It.Typ, T) then 2161 2162 -- If several interpretations are possible and L is universal, 2163 -- apply preference rule. 2164 2165 if TR /= Any_Type then 2166 if (T = Universal_Integer or else T = Universal_Real) 2167 and then It.Typ = T 2168 then 2169 TR := It.Typ; 2170 end if; 2171 2172 else 2173 TR := It.Typ; 2174 end if; 2175 end if; 2176 2177 Get_Next_Interp (I, It); 2178 end loop; 2179 2180 Set_Etype (R, TR); 2181 2182 -- In the non-overloaded case, the Etype of R is already set correctly 2183 2184 else 2185 null; 2186 end if; 2187 2188 -- If one of the operands is Universal_Fixed, the type of the other 2189 -- operand provides the context. 2190 2191 if Etype (R) = Universal_Fixed then 2192 return T; 2193 2194 elsif T = Universal_Fixed then 2195 return Etype (R); 2196 2197 -- Ada 2005 (AI-230): Support the following operators: 2198 2199 -- function "=" (L, R : universal_access) return Boolean; 2200 -- function "/=" (L, R : universal_access) return Boolean; 2201 2202 -- Pool specific access types (E_Access_Type) are not covered by these 2203 -- operators because of the legality rule of 4.5.2(9.2): "The operands 2204 -- of the equality operators for universal_access shall be convertible 2205 -- to one another (see 4.6)". For example, considering the type decla- 2206 -- ration "type P is access Integer" and an anonymous access to Integer, 2207 -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there 2208 -- is no rule in 4.6 that allows "access Integer" to be converted to P. 2209 2210 elsif Ada_Version >= Ada_2005 2211 and then Ekind_In (Etype (L), E_Anonymous_Access_Type, 2212 E_Anonymous_Access_Subprogram_Type) 2213 and then Is_Access_Type (Etype (R)) 2214 and then Ekind (Etype (R)) /= E_Access_Type 2215 then 2216 return Etype (L); 2217 2218 elsif Ada_Version >= Ada_2005 2219 and then Ekind_In (Etype (R), E_Anonymous_Access_Type, 2220 E_Anonymous_Access_Subprogram_Type) 2221 and then Is_Access_Type (Etype (L)) 2222 and then Ekind (Etype (L)) /= E_Access_Type 2223 then 2224 return Etype (R); 2225 2226 -- If one operand is a raise_expression, use type of other operand 2227 2228 elsif Nkind (L) = N_Raise_Expression then 2229 return Etype (R); 2230 2231 else 2232 return Specific_Type (T, Etype (R)); 2233 end if; 2234 end Find_Unique_Type; 2235 2236 ------------------------------------- 2237 -- Function_Interp_Has_Abstract_Op -- 2238 ------------------------------------- 2239 2240 function Function_Interp_Has_Abstract_Op 2241 (N : Node_Id; 2242 E : Entity_Id) return Entity_Id 2243 is 2244 Abstr_Op : Entity_Id; 2245 Act : Node_Id; 2246 Act_Parm : Node_Id; 2247 Form_Parm : Node_Id; 2248 2249 begin 2250 -- Why is check on E needed below ??? 2251 -- In any case this para needs comments ??? 2252 2253 if Is_Overloaded (N) and then Is_Overloadable (E) then 2254 Act_Parm := First_Actual (N); 2255 Form_Parm := First_Formal (E); 2256 while Present (Act_Parm) and then Present (Form_Parm) loop 2257 Act := Act_Parm; 2258 2259 if Nkind (Act) = N_Parameter_Association then 2260 Act := Explicit_Actual_Parameter (Act); 2261 end if; 2262 2263 Abstr_Op := Has_Abstract_Op (Act, Etype (Form_Parm)); 2264 2265 if Present (Abstr_Op) then 2266 return Abstr_Op; 2267 end if; 2268 2269 Next_Actual (Act_Parm); 2270 Next_Formal (Form_Parm); 2271 end loop; 2272 end if; 2273 2274 return Empty; 2275 end Function_Interp_Has_Abstract_Op; 2276 2277 ---------------------- 2278 -- Get_First_Interp -- 2279 ---------------------- 2280 2281 procedure Get_First_Interp 2282 (N : Node_Id; 2283 I : out Interp_Index; 2284 It : out Interp) 2285 is 2286 Int_Ind : Interp_Index; 2287 Map_Ptr : Int; 2288 O_N : Node_Id; 2289 2290 begin 2291 -- If a selected component is overloaded because the selector has 2292 -- multiple interpretations, the node is a call to a protected 2293 -- operation or an indirect call. Retrieve the interpretation from 2294 -- the selector name. The selected component may be overloaded as well 2295 -- if the prefix is overloaded. That case is unchanged. 2296 2297 if Nkind (N) = N_Selected_Component 2298 and then Is_Overloaded (Selector_Name (N)) 2299 then 2300 O_N := Selector_Name (N); 2301 else 2302 O_N := N; 2303 end if; 2304 2305 Map_Ptr := Headers (Hash (O_N)); 2306 while Map_Ptr /= No_Entry loop 2307 if Interp_Map.Table (Map_Ptr).Node = O_N then 2308 Int_Ind := Interp_Map.Table (Map_Ptr).Index; 2309 It := All_Interp.Table (Int_Ind); 2310 I := Int_Ind; 2311 return; 2312 else 2313 Map_Ptr := Interp_Map.Table (Map_Ptr).Next; 2314 end if; 2315 end loop; 2316 2317 -- Procedure should never be called if the node has no interpretations 2318 2319 raise Program_Error; 2320 end Get_First_Interp; 2321 2322 --------------------- 2323 -- Get_Next_Interp -- 2324 --------------------- 2325 2326 procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is 2327 begin 2328 I := I + 1; 2329 It := All_Interp.Table (I); 2330 end Get_Next_Interp; 2331 2332 ------------------------- 2333 -- Has_Compatible_Type -- 2334 ------------------------- 2335 2336 function Has_Compatible_Type 2337 (N : Node_Id; 2338 Typ : Entity_Id) return Boolean 2339 is 2340 I : Interp_Index; 2341 It : Interp; 2342 2343 begin 2344 if N = Error then 2345 return False; 2346 end if; 2347 2348 if Nkind (N) = N_Subtype_Indication 2349 or else not Is_Overloaded (N) 2350 then 2351 return 2352 Covers (Typ, Etype (N)) 2353 2354 -- Ada 2005 (AI-345): The context may be a synchronized interface. 2355 -- If the type is already frozen use the corresponding_record 2356 -- to check whether it is a proper descendant. 2357 2358 or else 2359 (Is_Record_Type (Typ) 2360 and then Is_Concurrent_Type (Etype (N)) 2361 and then Present (Corresponding_Record_Type (Etype (N))) 2362 and then Covers (Typ, Corresponding_Record_Type (Etype (N)))) 2363 2364 or else 2365 (Is_Concurrent_Type (Typ) 2366 and then Is_Record_Type (Etype (N)) 2367 and then Present (Corresponding_Record_Type (Typ)) 2368 and then Covers (Corresponding_Record_Type (Typ), Etype (N))) 2369 2370 or else 2371 (not Is_Tagged_Type (Typ) 2372 and then Ekind (Typ) /= E_Anonymous_Access_Type 2373 and then Covers (Etype (N), Typ)); 2374 2375 -- Overloaded case 2376 2377 else 2378 Get_First_Interp (N, I, It); 2379 while Present (It.Typ) loop 2380 if (Covers (Typ, It.Typ) 2381 and then 2382 (Scope (It.Nam) /= Standard_Standard 2383 or else not Is_Invisible_Operator (N, Base_Type (Typ)))) 2384 2385 -- Ada 2005 (AI-345) 2386 2387 or else 2388 (Is_Concurrent_Type (It.Typ) 2389 and then Present (Corresponding_Record_Type 2390 (Etype (It.Typ))) 2391 and then Covers (Typ, Corresponding_Record_Type 2392 (Etype (It.Typ)))) 2393 2394 or else (not Is_Tagged_Type (Typ) 2395 and then Ekind (Typ) /= E_Anonymous_Access_Type 2396 and then Covers (It.Typ, Typ)) 2397 then 2398 return True; 2399 end if; 2400 2401 Get_Next_Interp (I, It); 2402 end loop; 2403 2404 return False; 2405 end if; 2406 end Has_Compatible_Type; 2407 2408 --------------------- 2409 -- Has_Abstract_Op -- 2410 --------------------- 2411 2412 function Has_Abstract_Op 2413 (N : Node_Id; 2414 Typ : Entity_Id) return Entity_Id 2415 is 2416 I : Interp_Index; 2417 It : Interp; 2418 2419 begin 2420 if Is_Overloaded (N) then 2421 Get_First_Interp (N, I, It); 2422 while Present (It.Nam) loop 2423 if Present (It.Abstract_Op) 2424 and then Etype (It.Abstract_Op) = Typ 2425 then 2426 return It.Abstract_Op; 2427 end if; 2428 2429 Get_Next_Interp (I, It); 2430 end loop; 2431 end if; 2432 2433 return Empty; 2434 end Has_Abstract_Op; 2435 2436 ---------- 2437 -- Hash -- 2438 ---------- 2439 2440 function Hash (N : Node_Id) return Int is 2441 begin 2442 -- Nodes have a size that is power of two, so to select significant 2443 -- bits only we remove the low-order bits. 2444 2445 return ((Int (N) / 2 ** 5) mod Header_Size); 2446 end Hash; 2447 2448 -------------- 2449 -- Hides_Op -- 2450 -------------- 2451 2452 function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean is 2453 Btyp : constant Entity_Id := Base_Type (Etype (First_Formal (F))); 2454 begin 2455 return Operator_Matches_Spec (Op, F) 2456 and then (In_Open_Scopes (Scope (F)) 2457 or else Scope (F) = Scope (Btyp) 2458 or else (not In_Open_Scopes (Scope (Btyp)) 2459 and then not In_Use (Btyp) 2460 and then not In_Use (Scope (Btyp)))); 2461 end Hides_Op; 2462 2463 ------------------------ 2464 -- Init_Interp_Tables -- 2465 ------------------------ 2466 2467 procedure Init_Interp_Tables is 2468 begin 2469 All_Interp.Init; 2470 Interp_Map.Init; 2471 Headers := (others => No_Entry); 2472 end Init_Interp_Tables; 2473 2474 ----------------------------------- 2475 -- Interface_Present_In_Ancestor -- 2476 ----------------------------------- 2477 2478 function Interface_Present_In_Ancestor 2479 (Typ : Entity_Id; 2480 Iface : Entity_Id) return Boolean 2481 is 2482 Target_Typ : Entity_Id; 2483 Iface_Typ : Entity_Id; 2484 2485 function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean; 2486 -- Returns True if Typ or some ancestor of Typ implements Iface 2487 2488 ------------------------------- 2489 -- Iface_Present_In_Ancestor -- 2490 ------------------------------- 2491 2492 function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean is 2493 E : Entity_Id; 2494 AI : Entity_Id; 2495 Elmt : Elmt_Id; 2496 2497 begin 2498 if Typ = Iface_Typ then 2499 return True; 2500 end if; 2501 2502 -- Handle private types 2503 2504 if Present (Full_View (Typ)) 2505 and then not Is_Concurrent_Type (Full_View (Typ)) 2506 then 2507 E := Full_View (Typ); 2508 else 2509 E := Typ; 2510 end if; 2511 2512 loop 2513 if Present (Interfaces (E)) 2514 and then Present (Interfaces (E)) 2515 and then not Is_Empty_Elmt_List (Interfaces (E)) 2516 then 2517 Elmt := First_Elmt (Interfaces (E)); 2518 while Present (Elmt) loop 2519 AI := Node (Elmt); 2520 2521 if AI = Iface_Typ or else Is_Ancestor (Iface_Typ, AI) then 2522 return True; 2523 end if; 2524 2525 Next_Elmt (Elmt); 2526 end loop; 2527 end if; 2528 2529 exit when Etype (E) = E 2530 2531 -- Handle private types 2532 2533 or else (Present (Full_View (Etype (E))) 2534 and then Full_View (Etype (E)) = E); 2535 2536 -- Check if the current type is a direct derivation of the 2537 -- interface 2538 2539 if Etype (E) = Iface_Typ then 2540 return True; 2541 end if; 2542 2543 -- Climb to the immediate ancestor handling private types 2544 2545 if Present (Full_View (Etype (E))) then 2546 E := Full_View (Etype (E)); 2547 else 2548 E := Etype (E); 2549 end if; 2550 end loop; 2551 2552 return False; 2553 end Iface_Present_In_Ancestor; 2554 2555 -- Start of processing for Interface_Present_In_Ancestor 2556 2557 begin 2558 -- Iface might be a class-wide subtype, so we have to apply Base_Type 2559 2560 if Is_Class_Wide_Type (Iface) then 2561 Iface_Typ := Etype (Base_Type (Iface)); 2562 else 2563 Iface_Typ := Iface; 2564 end if; 2565 2566 -- Handle subtypes 2567 2568 Iface_Typ := Base_Type (Iface_Typ); 2569 2570 if Is_Access_Type (Typ) then 2571 Target_Typ := Etype (Directly_Designated_Type (Typ)); 2572 else 2573 Target_Typ := Typ; 2574 end if; 2575 2576 if Is_Concurrent_Record_Type (Target_Typ) then 2577 Target_Typ := Corresponding_Concurrent_Type (Target_Typ); 2578 end if; 2579 2580 Target_Typ := Base_Type (Target_Typ); 2581 2582 -- In case of concurrent types we can't use the Corresponding Record_Typ 2583 -- to look for the interface because it is built by the expander (and 2584 -- hence it is not always available). For this reason we traverse the 2585 -- list of interfaces (available in the parent of the concurrent type) 2586 2587 if Is_Concurrent_Type (Target_Typ) then 2588 if Present (Interface_List (Parent (Target_Typ))) then 2589 declare 2590 AI : Node_Id; 2591 2592 begin 2593 AI := First (Interface_List (Parent (Target_Typ))); 2594 2595 -- The progenitor itself may be a subtype of an interface type. 2596 2597 while Present (AI) loop 2598 if Etype (AI) = Iface_Typ 2599 or else Base_Type (Etype (AI)) = Iface_Typ 2600 then 2601 return True; 2602 2603 elsif Present (Interfaces (Etype (AI))) 2604 and then Iface_Present_In_Ancestor (Etype (AI)) 2605 then 2606 return True; 2607 end if; 2608 2609 Next (AI); 2610 end loop; 2611 end; 2612 end if; 2613 2614 return False; 2615 end if; 2616 2617 if Is_Class_Wide_Type (Target_Typ) then 2618 Target_Typ := Etype (Target_Typ); 2619 end if; 2620 2621 if Ekind (Target_Typ) = E_Incomplete_Type then 2622 2623 -- We must have either a full view or a nonlimited view of the type 2624 -- to locate the list of ancestors. 2625 2626 if Present (Full_View (Target_Typ)) then 2627 Target_Typ := Full_View (Target_Typ); 2628 else 2629 pragma Assert (Present (Non_Limited_View (Target_Typ))); 2630 Target_Typ := Non_Limited_View (Target_Typ); 2631 end if; 2632 2633 -- Protect the front end against previously detected errors 2634 2635 if Ekind (Target_Typ) = E_Incomplete_Type then 2636 return False; 2637 end if; 2638 end if; 2639 2640 return Iface_Present_In_Ancestor (Target_Typ); 2641 end Interface_Present_In_Ancestor; 2642 2643 --------------------- 2644 -- Intersect_Types -- 2645 --------------------- 2646 2647 function Intersect_Types (L, R : Node_Id) return Entity_Id is 2648 Index : Interp_Index; 2649 It : Interp; 2650 Typ : Entity_Id; 2651 2652 function Check_Right_Argument (T : Entity_Id) return Entity_Id; 2653 -- Find interpretation of right arg that has type compatible with T 2654 2655 -------------------------- 2656 -- Check_Right_Argument -- 2657 -------------------------- 2658 2659 function Check_Right_Argument (T : Entity_Id) return Entity_Id is 2660 Index : Interp_Index; 2661 It : Interp; 2662 T2 : Entity_Id; 2663 2664 begin 2665 if not Is_Overloaded (R) then 2666 return Specific_Type (T, Etype (R)); 2667 2668 else 2669 Get_First_Interp (R, Index, It); 2670 loop 2671 T2 := Specific_Type (T, It.Typ); 2672 2673 if T2 /= Any_Type then 2674 return T2; 2675 end if; 2676 2677 Get_Next_Interp (Index, It); 2678 exit when No (It.Typ); 2679 end loop; 2680 2681 return Any_Type; 2682 end if; 2683 end Check_Right_Argument; 2684 2685 -- Start of processing for Intersect_Types 2686 2687 begin 2688 if Etype (L) = Any_Type or else Etype (R) = Any_Type then 2689 return Any_Type; 2690 end if; 2691 2692 if not Is_Overloaded (L) then 2693 Typ := Check_Right_Argument (Etype (L)); 2694 2695 else 2696 Typ := Any_Type; 2697 Get_First_Interp (L, Index, It); 2698 while Present (It.Typ) loop 2699 Typ := Check_Right_Argument (It.Typ); 2700 exit when Typ /= Any_Type; 2701 Get_Next_Interp (Index, It); 2702 end loop; 2703 2704 end if; 2705 2706 -- If Typ is Any_Type, it means no compatible pair of types was found 2707 2708 if Typ = Any_Type then 2709 if Nkind (Parent (L)) in N_Op then 2710 Error_Msg_N ("incompatible types for operator", Parent (L)); 2711 2712 elsif Nkind (Parent (L)) = N_Range then 2713 Error_Msg_N ("incompatible types given in constraint", Parent (L)); 2714 2715 -- Ada 2005 (AI-251): Complete the error notification 2716 2717 elsif Is_Class_Wide_Type (Etype (R)) 2718 and then Is_Interface (Etype (Class_Wide_Type (Etype (R)))) 2719 then 2720 Error_Msg_NE ("(Ada 2005) does not implement interface }", 2721 L, Etype (Class_Wide_Type (Etype (R)))); 2722 2723 -- Specialize message if one operand is a limited view, a priori 2724 -- unrelated to all other types. 2725 2726 elsif From_Limited_With (Etype (R)) then 2727 Error_Msg_NE ("limited view of& not compatible with context", 2728 R, Etype (R)); 2729 2730 elsif From_Limited_With (Etype (L)) then 2731 Error_Msg_NE ("limited view of& not compatible with context", 2732 L, Etype (L)); 2733 else 2734 Error_Msg_N ("incompatible types", Parent (L)); 2735 end if; 2736 end if; 2737 2738 return Typ; 2739 end Intersect_Types; 2740 2741 ----------------------- 2742 -- In_Generic_Actual -- 2743 ----------------------- 2744 2745 function In_Generic_Actual (Exp : Node_Id) return Boolean is 2746 Par : constant Node_Id := Parent (Exp); 2747 2748 begin 2749 if No (Par) then 2750 return False; 2751 2752 elsif Nkind (Par) in N_Declaration then 2753 if Nkind (Par) = N_Object_Declaration then 2754 return Present (Corresponding_Generic_Association (Par)); 2755 else 2756 return False; 2757 end if; 2758 2759 elsif Nkind (Par) = N_Object_Renaming_Declaration then 2760 return Present (Corresponding_Generic_Association (Par)); 2761 2762 elsif Nkind (Par) in N_Statement_Other_Than_Procedure_Call then 2763 return False; 2764 2765 else 2766 return In_Generic_Actual (Parent (Par)); 2767 end if; 2768 end In_Generic_Actual; 2769 2770 ----------------- 2771 -- Is_Ancestor -- 2772 ----------------- 2773 2774 function Is_Ancestor 2775 (T1 : Entity_Id; 2776 T2 : Entity_Id; 2777 Use_Full_View : Boolean := False) return Boolean 2778 is 2779 BT1 : Entity_Id; 2780 BT2 : Entity_Id; 2781 Par : Entity_Id; 2782 2783 begin 2784 BT1 := Base_Type (T1); 2785 BT2 := Base_Type (T2); 2786 2787 -- Handle underlying view of records with unknown discriminants using 2788 -- the original entity that motivated the construction of this 2789 -- underlying record view (see Build_Derived_Private_Type). 2790 2791 if Is_Underlying_Record_View (BT1) then 2792 BT1 := Underlying_Record_View (BT1); 2793 end if; 2794 2795 if Is_Underlying_Record_View (BT2) then 2796 BT2 := Underlying_Record_View (BT2); 2797 end if; 2798 2799 if BT1 = BT2 then 2800 return True; 2801 2802 -- The predicate must look past privacy 2803 2804 elsif Is_Private_Type (T1) 2805 and then Present (Full_View (T1)) 2806 and then BT2 = Base_Type (Full_View (T1)) 2807 then 2808 return True; 2809 2810 elsif Is_Private_Type (T2) 2811 and then Present (Full_View (T2)) 2812 and then BT1 = Base_Type (Full_View (T2)) 2813 then 2814 return True; 2815 2816 else 2817 -- Obtain the parent of the base type of T2 (use the full view if 2818 -- allowed). 2819 2820 if Use_Full_View 2821 and then Is_Private_Type (BT2) 2822 and then Present (Full_View (BT2)) 2823 then 2824 -- No climbing needed if its full view is the root type 2825 2826 if Full_View (BT2) = Root_Type (Full_View (BT2)) then 2827 return False; 2828 end if; 2829 2830 Par := Etype (Full_View (BT2)); 2831 2832 else 2833 Par := Etype (BT2); 2834 end if; 2835 2836 loop 2837 -- If there was a error on the type declaration, do not recurse 2838 2839 if Error_Posted (Par) then 2840 return False; 2841 2842 elsif BT1 = Base_Type (Par) 2843 or else (Is_Private_Type (T1) 2844 and then Present (Full_View (T1)) 2845 and then Base_Type (Par) = Base_Type (Full_View (T1))) 2846 then 2847 return True; 2848 2849 elsif Is_Private_Type (Par) 2850 and then Present (Full_View (Par)) 2851 and then Full_View (Par) = BT1 2852 then 2853 return True; 2854 2855 -- Root type found 2856 2857 elsif Par = Root_Type (Par) then 2858 return False; 2859 2860 -- Continue climbing 2861 2862 else 2863 -- Use the full-view of private types (if allowed) 2864 2865 if Use_Full_View 2866 and then Is_Private_Type (Par) 2867 and then Present (Full_View (Par)) 2868 then 2869 Par := Etype (Full_View (Par)); 2870 else 2871 Par := Etype (Par); 2872 end if; 2873 end if; 2874 end loop; 2875 end if; 2876 end Is_Ancestor; 2877 2878 --------------------------- 2879 -- Is_Invisible_Operator -- 2880 --------------------------- 2881 2882 function Is_Invisible_Operator 2883 (N : Node_Id; 2884 T : Entity_Id) return Boolean 2885 is 2886 Orig_Node : constant Node_Id := Original_Node (N); 2887 2888 begin 2889 if Nkind (N) not in N_Op then 2890 return False; 2891 2892 elsif not Comes_From_Source (N) then 2893 return False; 2894 2895 elsif No (Universal_Interpretation (Right_Opnd (N))) then 2896 return False; 2897 2898 elsif Nkind (N) in N_Binary_Op 2899 and then No (Universal_Interpretation (Left_Opnd (N))) 2900 then 2901 return False; 2902 2903 else 2904 return Is_Numeric_Type (T) 2905 and then not In_Open_Scopes (Scope (T)) 2906 and then not Is_Potentially_Use_Visible (T) 2907 and then not In_Use (T) 2908 and then not In_Use (Scope (T)) 2909 and then 2910 (Nkind (Orig_Node) /= N_Function_Call 2911 or else Nkind (Name (Orig_Node)) /= N_Expanded_Name 2912 or else Entity (Prefix (Name (Orig_Node))) /= Scope (T)) 2913 and then not In_Instance; 2914 end if; 2915 end Is_Invisible_Operator; 2916 2917 -------------------- 2918 -- Is_Progenitor -- 2919 -------------------- 2920 2921 function Is_Progenitor 2922 (Iface : Entity_Id; 2923 Typ : Entity_Id) return Boolean 2924 is 2925 begin 2926 return Implements_Interface (Typ, Iface, Exclude_Parents => True); 2927 end Is_Progenitor; 2928 2929 ------------------- 2930 -- Is_Subtype_Of -- 2931 ------------------- 2932 2933 function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is 2934 S : Entity_Id; 2935 2936 begin 2937 S := Ancestor_Subtype (T1); 2938 while Present (S) loop 2939 if S = T2 then 2940 return True; 2941 else 2942 S := Ancestor_Subtype (S); 2943 end if; 2944 end loop; 2945 2946 return False; 2947 end Is_Subtype_Of; 2948 2949 ------------------ 2950 -- List_Interps -- 2951 ------------------ 2952 2953 procedure List_Interps (Nam : Node_Id; Err : Node_Id) is 2954 Index : Interp_Index; 2955 It : Interp; 2956 2957 begin 2958 Get_First_Interp (Nam, Index, It); 2959 while Present (It.Nam) loop 2960 if Scope (It.Nam) = Standard_Standard 2961 and then Scope (It.Typ) /= Standard_Standard 2962 then 2963 Error_Msg_Sloc := Sloc (Parent (It.Typ)); 2964 Error_Msg_NE ("\\& (inherited) declared#!", Err, It.Nam); 2965 2966 else 2967 Error_Msg_Sloc := Sloc (It.Nam); 2968 Error_Msg_NE ("\\& declared#!", Err, It.Nam); 2969 end if; 2970 2971 Get_Next_Interp (Index, It); 2972 end loop; 2973 end List_Interps; 2974 2975 ----------------- 2976 -- New_Interps -- 2977 ----------------- 2978 2979 procedure New_Interps (N : Node_Id) is 2980 Map_Ptr : Int; 2981 2982 begin 2983 All_Interp.Append (No_Interp); 2984 2985 Map_Ptr := Headers (Hash (N)); 2986 2987 if Map_Ptr = No_Entry then 2988 2989 -- Place new node at end of table 2990 2991 Interp_Map.Increment_Last; 2992 Headers (Hash (N)) := Interp_Map.Last; 2993 2994 else 2995 -- Place node at end of chain, or locate its previous entry 2996 2997 loop 2998 if Interp_Map.Table (Map_Ptr).Node = N then 2999 3000 -- Node is already in the table, and is being rewritten. 3001 -- Start a new interp section, retain hash link. 3002 3003 Interp_Map.Table (Map_Ptr).Node := N; 3004 Interp_Map.Table (Map_Ptr).Index := All_Interp.Last; 3005 Set_Is_Overloaded (N, True); 3006 return; 3007 3008 else 3009 exit when Interp_Map.Table (Map_Ptr).Next = No_Entry; 3010 Map_Ptr := Interp_Map.Table (Map_Ptr).Next; 3011 end if; 3012 end loop; 3013 3014 -- Chain the new node 3015 3016 Interp_Map.Increment_Last; 3017 Interp_Map.Table (Map_Ptr).Next := Interp_Map.Last; 3018 end if; 3019 3020 Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last, No_Entry); 3021 Set_Is_Overloaded (N, True); 3022 end New_Interps; 3023 3024 --------------------------- 3025 -- Operator_Matches_Spec -- 3026 --------------------------- 3027 3028 function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is 3029 Op_Name : constant Name_Id := Chars (Op); 3030 T : constant Entity_Id := Etype (New_S); 3031 New_F : Entity_Id; 3032 Old_F : Entity_Id; 3033 Num : Int; 3034 T1 : Entity_Id; 3035 T2 : Entity_Id; 3036 3037 begin 3038 -- To verify that a predefined operator matches a given signature, 3039 -- do a case analysis of the operator classes. Function can have one 3040 -- or two formals and must have the proper result type. 3041 3042 New_F := First_Formal (New_S); 3043 Old_F := First_Formal (Op); 3044 Num := 0; 3045 while Present (New_F) and then Present (Old_F) loop 3046 Num := Num + 1; 3047 Next_Formal (New_F); 3048 Next_Formal (Old_F); 3049 end loop; 3050 3051 -- Definite mismatch if different number of parameters 3052 3053 if Present (Old_F) or else Present (New_F) then 3054 return False; 3055 3056 -- Unary operators 3057 3058 elsif Num = 1 then 3059 T1 := Etype (First_Formal (New_S)); 3060 3061 if Nam_In (Op_Name, Name_Op_Subtract, Name_Op_Add, Name_Op_Abs) then 3062 return Base_Type (T1) = Base_Type (T) 3063 and then Is_Numeric_Type (T); 3064 3065 elsif Op_Name = Name_Op_Not then 3066 return Base_Type (T1) = Base_Type (T) 3067 and then Valid_Boolean_Arg (Base_Type (T)); 3068 3069 else 3070 return False; 3071 end if; 3072 3073 -- Binary operators 3074 3075 else 3076 T1 := Etype (First_Formal (New_S)); 3077 T2 := Etype (Next_Formal (First_Formal (New_S))); 3078 3079 if Nam_In (Op_Name, Name_Op_And, Name_Op_Or, Name_Op_Xor) then 3080 return Base_Type (T1) = Base_Type (T2) 3081 and then Base_Type (T1) = Base_Type (T) 3082 and then Valid_Boolean_Arg (Base_Type (T)); 3083 3084 elsif Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne) then 3085 return Base_Type (T1) = Base_Type (T2) 3086 and then not Is_Limited_Type (T1) 3087 and then Is_Boolean_Type (T); 3088 3089 elsif Nam_In (Op_Name, Name_Op_Lt, Name_Op_Le, 3090 Name_Op_Gt, Name_Op_Ge) 3091 then 3092 return Base_Type (T1) = Base_Type (T2) 3093 and then Valid_Comparison_Arg (T1) 3094 and then Is_Boolean_Type (T); 3095 3096 elsif Nam_In (Op_Name, Name_Op_Add, Name_Op_Subtract) then 3097 return Base_Type (T1) = Base_Type (T2) 3098 and then Base_Type (T1) = Base_Type (T) 3099 and then Is_Numeric_Type (T); 3100 3101 -- For division and multiplication, a user-defined function does not 3102 -- match the predefined universal_fixed operation, except in Ada 83. 3103 3104 elsif Op_Name = Name_Op_Divide then 3105 return (Base_Type (T1) = Base_Type (T2) 3106 and then Base_Type (T1) = Base_Type (T) 3107 and then Is_Numeric_Type (T) 3108 and then (not Is_Fixed_Point_Type (T) 3109 or else Ada_Version = Ada_83)) 3110 3111 -- Mixed_Mode operations on fixed-point types 3112 3113 or else (Base_Type (T1) = Base_Type (T) 3114 and then Base_Type (T2) = Base_Type (Standard_Integer) 3115 and then Is_Fixed_Point_Type (T)) 3116 3117 -- A user defined operator can also match (and hide) a mixed 3118 -- operation on universal literals. 3119 3120 or else (Is_Integer_Type (T2) 3121 and then Is_Floating_Point_Type (T1) 3122 and then Base_Type (T1) = Base_Type (T)); 3123 3124 elsif Op_Name = Name_Op_Multiply then 3125 return (Base_Type (T1) = Base_Type (T2) 3126 and then Base_Type (T1) = Base_Type (T) 3127 and then Is_Numeric_Type (T) 3128 and then (not Is_Fixed_Point_Type (T) 3129 or else Ada_Version = Ada_83)) 3130 3131 -- Mixed_Mode operations on fixed-point types 3132 3133 or else (Base_Type (T1) = Base_Type (T) 3134 and then Base_Type (T2) = Base_Type (Standard_Integer) 3135 and then Is_Fixed_Point_Type (T)) 3136 3137 or else (Base_Type (T2) = Base_Type (T) 3138 and then Base_Type (T1) = Base_Type (Standard_Integer) 3139 and then Is_Fixed_Point_Type (T)) 3140 3141 or else (Is_Integer_Type (T2) 3142 and then Is_Floating_Point_Type (T1) 3143 and then Base_Type (T1) = Base_Type (T)) 3144 3145 or else (Is_Integer_Type (T1) 3146 and then Is_Floating_Point_Type (T2) 3147 and then Base_Type (T2) = Base_Type (T)); 3148 3149 elsif Nam_In (Op_Name, Name_Op_Mod, Name_Op_Rem) then 3150 return Base_Type (T1) = Base_Type (T2) 3151 and then Base_Type (T1) = Base_Type (T) 3152 and then Is_Integer_Type (T); 3153 3154 elsif Op_Name = Name_Op_Expon then 3155 return Base_Type (T1) = Base_Type (T) 3156 and then Is_Numeric_Type (T) 3157 and then Base_Type (T2) = Base_Type (Standard_Integer); 3158 3159 elsif Op_Name = Name_Op_Concat then 3160 return Is_Array_Type (T) 3161 and then (Base_Type (T) = Base_Type (Etype (Op))) 3162 and then (Base_Type (T1) = Base_Type (T) 3163 or else 3164 Base_Type (T1) = Base_Type (Component_Type (T))) 3165 and then (Base_Type (T2) = Base_Type (T) 3166 or else 3167 Base_Type (T2) = Base_Type (Component_Type (T))); 3168 3169 else 3170 return False; 3171 end if; 3172 end if; 3173 end Operator_Matches_Spec; 3174 3175 ------------------- 3176 -- Remove_Interp -- 3177 ------------------- 3178 3179 procedure Remove_Interp (I : in out Interp_Index) is 3180 II : Interp_Index; 3181 3182 begin 3183 -- Find end of interp list and copy downward to erase the discarded one 3184 3185 II := I + 1; 3186 while Present (All_Interp.Table (II).Typ) loop 3187 II := II + 1; 3188 end loop; 3189 3190 for J in I + 1 .. II loop 3191 All_Interp.Table (J - 1) := All_Interp.Table (J); 3192 end loop; 3193 3194 -- Back up interp index to insure that iterator will pick up next 3195 -- available interpretation. 3196 3197 I := I - 1; 3198 end Remove_Interp; 3199 3200 ------------------ 3201 -- Save_Interps -- 3202 ------------------ 3203 3204 procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is 3205 Map_Ptr : Int; 3206 O_N : Node_Id := Old_N; 3207 3208 begin 3209 if Is_Overloaded (Old_N) then 3210 Set_Is_Overloaded (New_N); 3211 3212 if Nkind (Old_N) = N_Selected_Component 3213 and then Is_Overloaded (Selector_Name (Old_N)) 3214 then 3215 O_N := Selector_Name (Old_N); 3216 end if; 3217 3218 Map_Ptr := Headers (Hash (O_N)); 3219 3220 while Interp_Map.Table (Map_Ptr).Node /= O_N loop 3221 Map_Ptr := Interp_Map.Table (Map_Ptr).Next; 3222 pragma Assert (Map_Ptr /= No_Entry); 3223 end loop; 3224 3225 New_Interps (New_N); 3226 Interp_Map.Table (Interp_Map.Last).Index := 3227 Interp_Map.Table (Map_Ptr).Index; 3228 end if; 3229 end Save_Interps; 3230 3231 ------------------- 3232 -- Specific_Type -- 3233 ------------------- 3234 3235 function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id is 3236 T1 : constant Entity_Id := Available_View (Typ_1); 3237 T2 : constant Entity_Id := Available_View (Typ_2); 3238 B1 : constant Entity_Id := Base_Type (T1); 3239 B2 : constant Entity_Id := Base_Type (T2); 3240 3241 function Is_Remote_Access (T : Entity_Id) return Boolean; 3242 -- Check whether T is the equivalent type of a remote access type. 3243 -- If distribution is enabled, T is a legal context for Null. 3244 3245 ---------------------- 3246 -- Is_Remote_Access -- 3247 ---------------------- 3248 3249 function Is_Remote_Access (T : Entity_Id) return Boolean is 3250 begin 3251 return Is_Record_Type (T) 3252 and then (Is_Remote_Call_Interface (T) 3253 or else Is_Remote_Types (T)) 3254 and then Present (Corresponding_Remote_Type (T)) 3255 and then Is_Access_Type (Corresponding_Remote_Type (T)); 3256 end Is_Remote_Access; 3257 3258 -- Start of processing for Specific_Type 3259 3260 begin 3261 if T1 = Any_Type or else T2 = Any_Type then 3262 return Any_Type; 3263 end if; 3264 3265 if B1 = B2 then 3266 return B1; 3267 3268 elsif (T1 = Universal_Integer and then Is_Integer_Type (T2)) 3269 or else (T1 = Universal_Real and then Is_Real_Type (T2)) 3270 or else (T1 = Universal_Fixed and then Is_Fixed_Point_Type (T2)) 3271 or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2)) 3272 then 3273 return B2; 3274 3275 elsif (T2 = Universal_Integer and then Is_Integer_Type (T1)) 3276 or else (T2 = Universal_Real and then Is_Real_Type (T1)) 3277 or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1)) 3278 or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1)) 3279 then 3280 return B1; 3281 3282 elsif T2 = Any_String and then Is_String_Type (T1) then 3283 return B1; 3284 3285 elsif T1 = Any_String and then Is_String_Type (T2) then 3286 return B2; 3287 3288 elsif T2 = Any_Character and then Is_Character_Type (T1) then 3289 return B1; 3290 3291 elsif T1 = Any_Character and then Is_Character_Type (T2) then 3292 return B2; 3293 3294 elsif T1 = Any_Access 3295 and then (Is_Access_Type (T2) or else Is_Remote_Access (T2)) 3296 then 3297 return T2; 3298 3299 elsif T2 = Any_Access 3300 and then (Is_Access_Type (T1) or else Is_Remote_Access (T1)) 3301 then 3302 return T1; 3303 3304 -- In an instance, the specific type may have a private view. Use full 3305 -- view to check legality. 3306 3307 elsif T2 = Any_Access 3308 and then Is_Private_Type (T1) 3309 and then Present (Full_View (T1)) 3310 and then Is_Access_Type (Full_View (T1)) 3311 and then In_Instance 3312 then 3313 return T1; 3314 3315 elsif T2 = Any_Composite and then Is_Aggregate_Type (T1) then 3316 return T1; 3317 3318 elsif T1 = Any_Composite and then Is_Aggregate_Type (T2) then 3319 return T2; 3320 3321 elsif T1 = Any_Modular and then Is_Modular_Integer_Type (T2) then 3322 return T2; 3323 3324 elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then 3325 return T1; 3326 3327 -- ---------------------------------------------------------- 3328 -- Special cases for equality operators (all other predefined 3329 -- operators can never apply to tagged types) 3330 -- ---------------------------------------------------------- 3331 3332 -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an 3333 -- interface 3334 3335 elsif Is_Class_Wide_Type (T1) 3336 and then Is_Class_Wide_Type (T2) 3337 and then Is_Interface (Etype (T2)) 3338 then 3339 return T1; 3340 3341 -- Ada 2005 (AI-251): T1 is a concrete type that implements the 3342 -- class-wide interface T2 3343 3344 elsif Is_Class_Wide_Type (T2) 3345 and then Is_Interface (Etype (T2)) 3346 and then Interface_Present_In_Ancestor (Typ => T1, 3347 Iface => Etype (T2)) 3348 then 3349 return T1; 3350 3351 elsif Is_Class_Wide_Type (T1) 3352 and then Is_Ancestor (Root_Type (T1), T2) 3353 then 3354 return T1; 3355 3356 elsif Is_Class_Wide_Type (T2) 3357 and then Is_Ancestor (Root_Type (T2), T1) 3358 then 3359 return T2; 3360 3361 elsif Ekind_In (B1, E_Access_Subprogram_Type, 3362 E_Access_Protected_Subprogram_Type) 3363 and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type 3364 and then Is_Access_Type (T2) 3365 then 3366 return T2; 3367 3368 elsif Ekind_In (B2, E_Access_Subprogram_Type, 3369 E_Access_Protected_Subprogram_Type) 3370 and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type 3371 and then Is_Access_Type (T1) 3372 then 3373 return T1; 3374 3375 elsif Ekind_In (T1, E_Allocator_Type, 3376 E_Access_Attribute_Type, 3377 E_Anonymous_Access_Type) 3378 and then Is_Access_Type (T2) 3379 then 3380 return T2; 3381 3382 elsif Ekind_In (T2, E_Allocator_Type, 3383 E_Access_Attribute_Type, 3384 E_Anonymous_Access_Type) 3385 and then Is_Access_Type (T1) 3386 then 3387 return T1; 3388 3389 -- If none of the above cases applies, types are not compatible 3390 3391 else 3392 return Any_Type; 3393 end if; 3394 end Specific_Type; 3395 3396 --------------------- 3397 -- Set_Abstract_Op -- 3398 --------------------- 3399 3400 procedure Set_Abstract_Op (I : Interp_Index; V : Entity_Id) is 3401 begin 3402 All_Interp.Table (I).Abstract_Op := V; 3403 end Set_Abstract_Op; 3404 3405 ----------------------- 3406 -- Valid_Boolean_Arg -- 3407 ----------------------- 3408 3409 -- In addition to booleans and arrays of booleans, we must include 3410 -- aggregates as valid boolean arguments, because in the first pass of 3411 -- resolution their components are not examined. If it turns out not to be 3412 -- an aggregate of booleans, this will be diagnosed in Resolve. 3413 -- Any_Composite must be checked for prior to the array type checks because 3414 -- Any_Composite does not have any associated indexes. 3415 3416 function Valid_Boolean_Arg (T : Entity_Id) return Boolean is 3417 begin 3418 if Is_Boolean_Type (T) 3419 or else Is_Modular_Integer_Type (T) 3420 or else T = Universal_Integer 3421 or else T = Any_Composite 3422 then 3423 return True; 3424 3425 elsif Is_Array_Type (T) 3426 and then T /= Any_String 3427 and then Number_Dimensions (T) = 1 3428 and then Is_Boolean_Type (Component_Type (T)) 3429 and then 3430 ((not Is_Private_Composite (T) and then not Is_Limited_Composite (T)) 3431 or else In_Instance 3432 or else Available_Full_View_Of_Component (T)) 3433 then 3434 return True; 3435 3436 else 3437 return False; 3438 end if; 3439 end Valid_Boolean_Arg; 3440 3441 -------------------------- 3442 -- Valid_Comparison_Arg -- 3443 -------------------------- 3444 3445 function Valid_Comparison_Arg (T : Entity_Id) return Boolean is 3446 begin 3447 3448 if T = Any_Composite then 3449 return False; 3450 3451 elsif Is_Discrete_Type (T) 3452 or else Is_Real_Type (T) 3453 then 3454 return True; 3455 3456 elsif Is_Array_Type (T) 3457 and then Number_Dimensions (T) = 1 3458 and then Is_Discrete_Type (Component_Type (T)) 3459 and then (not Is_Private_Composite (T) or else In_Instance) 3460 and then (not Is_Limited_Composite (T) or else In_Instance) 3461 then 3462 return True; 3463 3464 elsif Is_Array_Type (T) 3465 and then Number_Dimensions (T) = 1 3466 and then Is_Discrete_Type (Component_Type (T)) 3467 and then Available_Full_View_Of_Component (T) 3468 then 3469 return True; 3470 3471 elsif Is_String_Type (T) then 3472 return True; 3473 else 3474 return False; 3475 end if; 3476 end Valid_Comparison_Arg; 3477 3478 ------------------ 3479 -- Write_Interp -- 3480 ------------------ 3481 3482 procedure Write_Interp (It : Interp) is 3483 begin 3484 Write_Str ("Nam: "); 3485 Print_Tree_Node (It.Nam); 3486 Write_Str ("Typ: "); 3487 Print_Tree_Node (It.Typ); 3488 Write_Str ("Abstract_Op: "); 3489 Print_Tree_Node (It.Abstract_Op); 3490 end Write_Interp; 3491 3492 ---------------------- 3493 -- Write_Interp_Ref -- 3494 ---------------------- 3495 3496 procedure Write_Interp_Ref (Map_Ptr : Int) is 3497 begin 3498 Write_Str (" Node: "); 3499 Write_Int (Int (Interp_Map.Table (Map_Ptr).Node)); 3500 Write_Str (" Index: "); 3501 Write_Int (Int (Interp_Map.Table (Map_Ptr).Index)); 3502 Write_Str (" Next: "); 3503 Write_Int (Interp_Map.Table (Map_Ptr).Next); 3504 Write_Eol; 3505 end Write_Interp_Ref; 3506 3507 --------------------- 3508 -- Write_Overloads -- 3509 --------------------- 3510 3511 procedure Write_Overloads (N : Node_Id) is 3512 I : Interp_Index; 3513 It : Interp; 3514 Nam : Entity_Id; 3515 3516 begin 3517 Write_Str ("Overloads: "); 3518 Print_Node_Briefly (N); 3519 3520 if not Is_Overloaded (N) then 3521 Write_Line ("Non-overloaded entity "); 3522 Write_Entity_Info (Entity (N), " "); 3523 3524 elsif Nkind (N) not in N_Has_Entity then 3525 Get_First_Interp (N, I, It); 3526 while Present (It.Nam) loop 3527 Write_Int (Int (It.Typ)); 3528 Write_Str (" "); 3529 Write_Name (Chars (It.Typ)); 3530 Write_Eol; 3531 Get_Next_Interp (I, It); 3532 end loop; 3533 3534 else 3535 Get_First_Interp (N, I, It); 3536 Write_Line ("Overloaded entity "); 3537 Write_Line (" Name Type Abstract Op"); 3538 Write_Line ("==============================================="); 3539 Nam := It.Nam; 3540 3541 while Present (Nam) loop 3542 Write_Int (Int (Nam)); 3543 Write_Str (" "); 3544 Write_Name (Chars (Nam)); 3545 Write_Str (" "); 3546 Write_Int (Int (It.Typ)); 3547 Write_Str (" "); 3548 Write_Name (Chars (It.Typ)); 3549 3550 if Present (It.Abstract_Op) then 3551 Write_Str (" "); 3552 Write_Int (Int (It.Abstract_Op)); 3553 Write_Str (" "); 3554 Write_Name (Chars (It.Abstract_Op)); 3555 end if; 3556 3557 Write_Eol; 3558 Get_Next_Interp (I, It); 3559 Nam := It.Nam; 3560 end loop; 3561 end if; 3562 end Write_Overloads; 3563 3564end Sem_Type; 3565