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-2013, 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 Base_Type (Typ1) = Typ2 770 or else Base_Type (Typ2) = Typ1); 771 end Full_View_Covers; 772 773 ----------------- 774 -- Real_Actual -- 775 ----------------- 776 777 function Real_Actual (T : Entity_Id) return Entity_Id is 778 Par : constant Node_Id := Parent (T); 779 RA : Entity_Id; 780 781 begin 782 -- Retrieve parent subtype from subtype declaration for actual 783 784 if Nkind (Par) = N_Subtype_Declaration 785 and then not Comes_From_Source (Par) 786 and then Is_Entity_Name (Subtype_Indication (Par)) 787 then 788 RA := Entity (Subtype_Indication (Par)); 789 790 if Is_Generic_Actual_Type (RA) then 791 return RA; 792 end if; 793 end if; 794 795 -- Otherwise actual is not the actual of an enclosing instance 796 797 return T; 798 end Real_Actual; 799 800 -- Start of processing for Covers 801 802 begin 803 -- If either operand missing, then this is an error, but ignore it (and 804 -- pretend we have a cover) if errors already detected, since this may 805 -- simply mean we have malformed trees or a semantic error upstream. 806 807 if No (T1) or else No (T2) then 808 if Total_Errors_Detected /= 0 then 809 return True; 810 else 811 raise Program_Error; 812 end if; 813 end if; 814 815 -- Trivial case: same types are always compatible 816 817 if T1 = T2 then 818 return True; 819 end if; 820 821 -- First check for Standard_Void_Type, which is special. Subsequent 822 -- processing in this routine assumes T1 and T2 are bona fide types; 823 -- Standard_Void_Type is a special entity that has some, but not all, 824 -- properties of types. 825 826 if (T1 = Standard_Void_Type) /= (T2 = Standard_Void_Type) then 827 return False; 828 end if; 829 830 BT1 := Base_Type (T1); 831 BT2 := Base_Type (T2); 832 833 -- Handle underlying view of records with unknown discriminants 834 -- using the original entity that motivated the construction of 835 -- this underlying record view (see Build_Derived_Private_Type). 836 837 if Is_Underlying_Record_View (BT1) then 838 BT1 := Underlying_Record_View (BT1); 839 end if; 840 841 if Is_Underlying_Record_View (BT2) then 842 BT2 := Underlying_Record_View (BT2); 843 end if; 844 845 -- Simplest case: types that have the same base type and are not generic 846 -- actuals are compatible. Generic actuals belong to their class but are 847 -- not compatible with other types of their class, and in particular 848 -- with other generic actuals. They are however compatible with their 849 -- own subtypes, and itypes with the same base are compatible as well. 850 -- Similarly, constrained subtypes obtained from expressions of an 851 -- unconstrained nominal type are compatible with the base type (may 852 -- lead to spurious ambiguities in obscure cases ???) 853 854 -- Generic actuals require special treatment to avoid spurious ambi- 855 -- guities in an instance, when two formal types are instantiated with 856 -- the same actual, so that different subprograms end up with the same 857 -- signature in the instance. If a generic actual is the actual of an 858 -- enclosing instance, it is that actual that we must compare: generic 859 -- actuals are only incompatible if they appear in the same instance. 860 861 if BT1 = BT2 862 or else BT1 = T2 863 or else BT2 = T1 864 then 865 if not Is_Generic_Actual_Type (T1) 866 or else 867 not Is_Generic_Actual_Type (T2) 868 then 869 return True; 870 871 -- Both T1 and T2 are generic actual types 872 873 else 874 declare 875 RT1 : constant Entity_Id := Real_Actual (T1); 876 RT2 : constant Entity_Id := Real_Actual (T2); 877 begin 878 return RT1 = RT2 879 or else Is_Itype (T1) 880 or else Is_Itype (T2) 881 or else Is_Constr_Subt_For_U_Nominal (T1) 882 or else Is_Constr_Subt_For_U_Nominal (T2) 883 or else Scope (RT1) /= Scope (RT2); 884 end; 885 end if; 886 887 -- Literals are compatible with types in a given "class" 888 889 elsif (T2 = Universal_Integer and then Is_Integer_Type (T1)) 890 or else (T2 = Universal_Real and then Is_Real_Type (T1)) 891 or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1)) 892 or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1)) 893 or else (T2 = Any_String and then Is_String_Type (T1)) 894 or else (T2 = Any_Character and then Is_Character_Type (T1)) 895 or else (T2 = Any_Access and then Is_Access_Type (T1)) 896 then 897 return True; 898 899 -- The context may be class wide, and a class-wide type is compatible 900 -- with any member of the class. 901 902 elsif Is_Class_Wide_Type (T1) 903 and then Is_Ancestor (Root_Type (T1), T2) 904 then 905 return True; 906 907 elsif Is_Class_Wide_Type (T1) 908 and then Is_Class_Wide_Type (T2) 909 and then Base_Type (Etype (T1)) = Base_Type (Etype (T2)) 910 then 911 return True; 912 913 -- Ada 2005 (AI-345): A class-wide abstract interface type covers a 914 -- task_type or protected_type that implements the interface. 915 916 elsif Ada_Version >= Ada_2005 917 and then Is_Class_Wide_Type (T1) 918 and then Is_Interface (Etype (T1)) 919 and then Is_Concurrent_Type (T2) 920 and then Interface_Present_In_Ancestor 921 (Typ => BT2, Iface => Etype (T1)) 922 then 923 return True; 924 925 -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an 926 -- object T2 implementing T1. 927 928 elsif Ada_Version >= Ada_2005 929 and then Is_Class_Wide_Type (T1) 930 and then Is_Interface (Etype (T1)) 931 and then Is_Tagged_Type (T2) 932 then 933 if Interface_Present_In_Ancestor (Typ => T2, 934 Iface => Etype (T1)) 935 then 936 return True; 937 end if; 938 939 declare 940 E : Entity_Id; 941 Elmt : Elmt_Id; 942 943 begin 944 if Is_Concurrent_Type (BT2) then 945 E := Corresponding_Record_Type (BT2); 946 else 947 E := BT2; 948 end if; 949 950 -- Ada 2005 (AI-251): A class-wide abstract interface type T1 951 -- covers an object T2 that implements a direct derivation of T1. 952 -- Note: test for presence of E is defense against previous error. 953 954 if No (E) then 955 Check_Error_Detected; 956 957 elsif Present (Interfaces (E)) then 958 Elmt := First_Elmt (Interfaces (E)); 959 while Present (Elmt) loop 960 if Is_Ancestor (Etype (T1), Node (Elmt)) then 961 return True; 962 end if; 963 964 Next_Elmt (Elmt); 965 end loop; 966 end if; 967 968 -- We should also check the case in which T1 is an ancestor of 969 -- some implemented interface??? 970 971 return False; 972 end; 973 974 -- In a dispatching call, the formal is of some specific type, and the 975 -- actual is of the corresponding class-wide type, including a subtype 976 -- of the class-wide type. 977 978 elsif Is_Class_Wide_Type (T2) 979 and then 980 (Class_Wide_Type (T1) = Class_Wide_Type (T2) 981 or else Base_Type (Root_Type (T2)) = BT1) 982 then 983 return True; 984 985 -- Some contexts require a class of types rather than a specific type. 986 -- For example, conditions require any boolean type, fixed point 987 -- attributes require some real type, etc. The built-in types Any_XXX 988 -- represent these classes. 989 990 elsif (T1 = Any_Integer and then Is_Integer_Type (T2)) 991 or else (T1 = Any_Boolean and then Is_Boolean_Type (T2)) 992 or else (T1 = Any_Real and then Is_Real_Type (T2)) 993 or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2)) 994 or else (T1 = Any_Discrete and then Is_Discrete_Type (T2)) 995 then 996 return True; 997 998 -- An aggregate is compatible with an array or record type 999 1000 elsif T2 = Any_Composite and then Is_Aggregate_Type (T1) then 1001 return True; 1002 1003 -- If the expected type is an anonymous access, the designated type must 1004 -- cover that of the expression. Use the base type for this check: even 1005 -- though access subtypes are rare in sources, they are generated for 1006 -- actuals in instantiations. 1007 1008 elsif Ekind (BT1) = E_Anonymous_Access_Type 1009 and then Is_Access_Type (T2) 1010 and then Covers (Designated_Type (T1), Designated_Type (T2)) 1011 then 1012 return True; 1013 1014 -- Ada 2012 (AI05-0149): Allow an anonymous access type in the context 1015 -- of a named general access type. An implicit conversion will be 1016 -- applied. For the resolution, one designated type must cover the 1017 -- other. 1018 1019 elsif Ada_Version >= Ada_2012 1020 and then Ekind (BT1) = E_General_Access_Type 1021 and then Ekind (BT2) = E_Anonymous_Access_Type 1022 and then (Covers (Designated_Type (T1), Designated_Type (T2)) 1023 or else Covers (Designated_Type (T2), Designated_Type (T1))) 1024 then 1025 return True; 1026 1027 -- An Access_To_Subprogram is compatible with itself, or with an 1028 -- anonymous type created for an attribute reference Access. 1029 1030 elsif (Ekind (BT1) = E_Access_Subprogram_Type 1031 or else 1032 Ekind (BT1) = E_Access_Protected_Subprogram_Type) 1033 and then Is_Access_Type (T2) 1034 and then (not Comes_From_Source (T1) 1035 or else not Comes_From_Source (T2)) 1036 and then (Is_Overloadable (Designated_Type (T2)) 1037 or else Ekind (Designated_Type (T2)) = E_Subprogram_Type) 1038 and then Type_Conformant (Designated_Type (T1), Designated_Type (T2)) 1039 and then Mode_Conformant (Designated_Type (T1), Designated_Type (T2)) 1040 then 1041 return True; 1042 1043 -- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible 1044 -- with itself, or with an anonymous type created for an attribute 1045 -- reference Access. 1046 1047 elsif (Ekind (BT1) = E_Anonymous_Access_Subprogram_Type 1048 or else 1049 Ekind (BT1) 1050 = E_Anonymous_Access_Protected_Subprogram_Type) 1051 and then Is_Access_Type (T2) 1052 and then (not Comes_From_Source (T1) 1053 or else not Comes_From_Source (T2)) 1054 and then (Is_Overloadable (Designated_Type (T2)) 1055 or else Ekind (Designated_Type (T2)) = E_Subprogram_Type) 1056 and then Type_Conformant (Designated_Type (T1), Designated_Type (T2)) 1057 and then Mode_Conformant (Designated_Type (T1), Designated_Type (T2)) 1058 then 1059 return True; 1060 1061 -- The context can be a remote access type, and the expression the 1062 -- corresponding source type declared in a categorized package, or 1063 -- vice versa. 1064 1065 elsif Is_Record_Type (T1) 1066 and then (Is_Remote_Call_Interface (T1) or else Is_Remote_Types (T1)) 1067 and then Present (Corresponding_Remote_Type (T1)) 1068 then 1069 return Covers (Corresponding_Remote_Type (T1), T2); 1070 1071 -- and conversely. 1072 1073 elsif Is_Record_Type (T2) 1074 and then (Is_Remote_Call_Interface (T2) or else Is_Remote_Types (T2)) 1075 and then Present (Corresponding_Remote_Type (T2)) 1076 then 1077 return Covers (Corresponding_Remote_Type (T2), T1); 1078 1079 -- Synchronized types are represented at run time by their corresponding 1080 -- record type. During expansion one is replaced with the other, but 1081 -- they are compatible views of the same type. 1082 1083 elsif Is_Record_Type (T1) 1084 and then Is_Concurrent_Type (T2) 1085 and then Present (Corresponding_Record_Type (T2)) 1086 then 1087 return Covers (T1, Corresponding_Record_Type (T2)); 1088 1089 elsif Is_Concurrent_Type (T1) 1090 and then Present (Corresponding_Record_Type (T1)) 1091 and then Is_Record_Type (T2) 1092 then 1093 return Covers (Corresponding_Record_Type (T1), T2); 1094 1095 -- During analysis, an attribute reference 'Access has a special type 1096 -- kind: Access_Attribute_Type, to be replaced eventually with the type 1097 -- imposed by context. 1098 1099 elsif Ekind (T2) = E_Access_Attribute_Type 1100 and then Ekind_In (BT1, E_General_Access_Type, E_Access_Type) 1101 and then Covers (Designated_Type (T1), Designated_Type (T2)) 1102 then 1103 -- If the target type is a RACW type while the source is an access 1104 -- attribute type, we are building a RACW that may be exported. 1105 1106 if Is_Remote_Access_To_Class_Wide_Type (BT1) then 1107 Set_Has_RACW (Current_Sem_Unit); 1108 end if; 1109 1110 return True; 1111 1112 -- Ditto for allocators, which eventually resolve to the context type 1113 1114 elsif Ekind (T2) = E_Allocator_Type and then Is_Access_Type (T1) then 1115 return Covers (Designated_Type (T1), Designated_Type (T2)) 1116 or else 1117 (From_Limited_With (Designated_Type (T1)) 1118 and then Covers (Designated_Type (T2), Designated_Type (T1))); 1119 1120 -- A boolean operation on integer literals is compatible with modular 1121 -- context. 1122 1123 elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then 1124 return True; 1125 1126 -- The actual type may be the result of a previous error 1127 1128 elsif BT2 = Any_Type then 1129 return True; 1130 1131 -- A Raise_Expressions is legal in any expression context 1132 1133 elsif BT2 = Raise_Type then 1134 return True; 1135 1136 -- A packed array type covers its corresponding non-packed type. This is 1137 -- not legitimate Ada, but allows the omission of a number of otherwise 1138 -- useless unchecked conversions, and since this can only arise in 1139 -- (known correct) expanded code, no harm is done. 1140 1141 elsif Is_Array_Type (T2) 1142 and then Is_Packed (T2) 1143 and then T1 = Packed_Array_Type (T2) 1144 then 1145 return True; 1146 1147 -- Similarly an array type covers its corresponding packed array type 1148 1149 elsif Is_Array_Type (T1) 1150 and then Is_Packed (T1) 1151 and then T2 = Packed_Array_Type (T1) 1152 then 1153 return True; 1154 1155 -- In instances, or with types exported from instantiations, check 1156 -- whether a partial and a full view match. Verify that types are 1157 -- legal, to prevent cascaded errors. 1158 1159 elsif In_Instance 1160 and then (Full_View_Covers (T1, T2) or else Full_View_Covers (T2, T1)) 1161 then 1162 return True; 1163 1164 elsif Is_Type (T2) 1165 and then Is_Generic_Actual_Type (T2) 1166 and then Full_View_Covers (T1, T2) 1167 then 1168 return True; 1169 1170 elsif Is_Type (T1) 1171 and then Is_Generic_Actual_Type (T1) 1172 and then Full_View_Covers (T2, T1) 1173 then 1174 return True; 1175 1176 -- In the expansion of inlined bodies, types are compatible if they 1177 -- are structurally equivalent. 1178 1179 elsif In_Inlined_Body 1180 and then (Underlying_Type (T1) = Underlying_Type (T2) 1181 or else 1182 (Is_Access_Type (T1) 1183 and then Is_Access_Type (T2) 1184 and then Designated_Type (T1) = Designated_Type (T2)) 1185 or else 1186 (T1 = Any_Access 1187 and then Is_Access_Type (Underlying_Type (T2))) 1188 or else 1189 (T2 = Any_Composite 1190 and then Is_Composite_Type (Underlying_Type (T1)))) 1191 then 1192 return True; 1193 1194 -- Ada 2005 (AI-50217): Additional branches to make the shadow entity 1195 -- obtained through a limited_with compatible with its real entity. 1196 1197 elsif From_Limited_With (T1) then 1198 1199 -- If the expected type is the non-limited view of a type, the 1200 -- expression may have the limited view. If that one in turn is 1201 -- incomplete, get full view if available. 1202 1203 if Is_Incomplete_Type (T1) then 1204 return Covers (Get_Full_View (Non_Limited_View (T1)), T2); 1205 1206 elsif Ekind (T1) = E_Class_Wide_Type then 1207 return 1208 Covers (Class_Wide_Type (Non_Limited_View (Etype (T1))), T2); 1209 else 1210 return False; 1211 end if; 1212 1213 elsif From_Limited_With (T2) then 1214 1215 -- If units in the context have Limited_With clauses on each other, 1216 -- either type might have a limited view. Checks performed elsewhere 1217 -- verify that the context type is the nonlimited view. 1218 1219 if Is_Incomplete_Type (T2) then 1220 return Covers (T1, Get_Full_View (Non_Limited_View (T2))); 1221 1222 elsif Ekind (T2) = E_Class_Wide_Type then 1223 return 1224 Present (Non_Limited_View (Etype (T2))) 1225 and then 1226 Covers (T1, Class_Wide_Type (Non_Limited_View (Etype (T2)))); 1227 else 1228 return False; 1229 end if; 1230 1231 -- Ada 2005 (AI-412): Coverage for regular incomplete subtypes 1232 1233 elsif Ekind (T1) = E_Incomplete_Subtype then 1234 return Covers (Full_View (Etype (T1)), T2); 1235 1236 elsif Ekind (T2) = E_Incomplete_Subtype then 1237 return Covers (T1, Full_View (Etype (T2))); 1238 1239 -- Ada 2005 (AI-423): Coverage of formal anonymous access types 1240 -- and actual anonymous access types in the context of generic 1241 -- instantiations. We have the following situation: 1242 1243 -- generic 1244 -- type Formal is private; 1245 -- Formal_Obj : access Formal; -- T1 1246 -- package G is ... 1247 1248 -- package P is 1249 -- type Actual is ... 1250 -- Actual_Obj : access Actual; -- T2 1251 -- package Instance is new G (Formal => Actual, 1252 -- Formal_Obj => Actual_Obj); 1253 1254 elsif Ada_Version >= Ada_2005 1255 and then Ekind (T1) = E_Anonymous_Access_Type 1256 and then Ekind (T2) = E_Anonymous_Access_Type 1257 and then Is_Generic_Type (Directly_Designated_Type (T1)) 1258 and then Get_Instance_Of (Directly_Designated_Type (T1)) = 1259 Directly_Designated_Type (T2) 1260 then 1261 return True; 1262 1263 -- Otherwise, types are not compatible 1264 1265 else 1266 return False; 1267 end if; 1268 end Covers; 1269 1270 ------------------ 1271 -- Disambiguate -- 1272 ------------------ 1273 1274 function Disambiguate 1275 (N : Node_Id; 1276 I1, I2 : Interp_Index; 1277 Typ : Entity_Id) return Interp 1278 is 1279 I : Interp_Index; 1280 It : Interp; 1281 It1, It2 : Interp; 1282 Nam1, Nam2 : Entity_Id; 1283 Predef_Subp : Entity_Id; 1284 User_Subp : Entity_Id; 1285 1286 function Inherited_From_Actual (S : Entity_Id) return Boolean; 1287 -- Determine whether one of the candidates is an operation inherited by 1288 -- a type that is derived from an actual in an instantiation. 1289 1290 function In_Same_Declaration_List 1291 (Typ : Entity_Id; 1292 Op_Decl : Entity_Id) return Boolean; 1293 -- AI05-0020: a spurious ambiguity may arise when equality on anonymous 1294 -- access types is declared on the partial view of a designated type, so 1295 -- that the type declaration and equality are not in the same list of 1296 -- declarations. This AI gives a preference rule for the user-defined 1297 -- operation. Same rule applies for arithmetic operations on private 1298 -- types completed with fixed-point types: the predefined operation is 1299 -- hidden; this is already handled properly in GNAT. 1300 1301 function Is_Actual_Subprogram (S : Entity_Id) return Boolean; 1302 -- Determine whether a subprogram is an actual in an enclosing instance. 1303 -- An overloading between such a subprogram and one declared outside the 1304 -- instance is resolved in favor of the first, because it resolved in 1305 -- the generic. Within the instance the actual is represented by a 1306 -- constructed subprogram renaming. 1307 1308 function Matches (Actual, Formal : Node_Id) return Boolean; 1309 -- Look for exact type match in an instance, to remove spurious 1310 -- ambiguities when two formal types have the same actual. 1311 1312 function Operand_Type return Entity_Id; 1313 -- Determine type of operand for an equality operation, to apply 1314 -- Ada 2005 rules to equality on anonymous access types. 1315 1316 function Standard_Operator return Boolean; 1317 -- Check whether subprogram is predefined operator declared in Standard. 1318 -- It may given by an operator name, or by an expanded name whose prefix 1319 -- is Standard. 1320 1321 function Remove_Conversions return Interp; 1322 -- Last chance for pathological cases involving comparisons on literals, 1323 -- and user overloadings of the same operator. Such pathologies have 1324 -- been removed from the ACVC, but still appear in two DEC tests, with 1325 -- the following notable quote from Ben Brosgol: 1326 -- 1327 -- [Note: I disclaim all credit/responsibility/blame for coming up with 1328 -- this example; Robert Dewar brought it to our attention, since it is 1329 -- apparently found in the ACVC 1.5. I did not attempt to find the 1330 -- reason in the Reference Manual that makes the example legal, since I 1331 -- was too nauseated by it to want to pursue it further.] 1332 -- 1333 -- Accordingly, this is not a fully recursive solution, but it handles 1334 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes 1335 -- pathology in the other direction with calls whose multiple overloaded 1336 -- actuals make them truly unresolvable. 1337 1338 -- The new rules concerning abstract operations create additional need 1339 -- for special handling of expressions with universal operands, see 1340 -- comments to Has_Abstract_Interpretation below. 1341 1342 --------------------------- 1343 -- Inherited_From_Actual -- 1344 --------------------------- 1345 1346 function Inherited_From_Actual (S : Entity_Id) return Boolean is 1347 Par : constant Node_Id := Parent (S); 1348 begin 1349 if Nkind (Par) /= N_Full_Type_Declaration 1350 or else Nkind (Type_Definition (Par)) /= N_Derived_Type_Definition 1351 then 1352 return False; 1353 else 1354 return Is_Entity_Name (Subtype_Indication (Type_Definition (Par))) 1355 and then 1356 Is_Generic_Actual_Type ( 1357 Entity (Subtype_Indication (Type_Definition (Par)))); 1358 end if; 1359 end Inherited_From_Actual; 1360 1361 ------------------------------ 1362 -- In_Same_Declaration_List -- 1363 ------------------------------ 1364 1365 function In_Same_Declaration_List 1366 (Typ : Entity_Id; 1367 Op_Decl : Entity_Id) return Boolean 1368 is 1369 Scop : constant Entity_Id := Scope (Typ); 1370 1371 begin 1372 return In_Same_List (Parent (Typ), Op_Decl) 1373 or else 1374 (Ekind_In (Scop, E_Package, E_Generic_Package) 1375 and then List_Containing (Op_Decl) = 1376 Visible_Declarations (Parent (Scop)) 1377 and then List_Containing (Parent (Typ)) = 1378 Private_Declarations (Parent (Scop))); 1379 end In_Same_Declaration_List; 1380 1381 -------------------------- 1382 -- Is_Actual_Subprogram -- 1383 -------------------------- 1384 1385 function Is_Actual_Subprogram (S : Entity_Id) return Boolean is 1386 begin 1387 return In_Open_Scopes (Scope (S)) 1388 and then 1389 Nkind (Unit_Declaration_Node (S)) = 1390 N_Subprogram_Renaming_Declaration 1391 1392 -- Why the Comes_From_Source test here??? 1393 1394 and then not Comes_From_Source (Unit_Declaration_Node (S)) 1395 1396 and then 1397 (Is_Generic_Instance (Scope (S)) 1398 or else Is_Wrapper_Package (Scope (S))); 1399 end Is_Actual_Subprogram; 1400 1401 ------------- 1402 -- Matches -- 1403 ------------- 1404 1405 function Matches (Actual, Formal : Node_Id) return Boolean is 1406 T1 : constant Entity_Id := Etype (Actual); 1407 T2 : constant Entity_Id := Etype (Formal); 1408 begin 1409 return T1 = T2 1410 or else 1411 (Is_Numeric_Type (T2) 1412 and then (T1 = Universal_Real or else T1 = Universal_Integer)); 1413 end Matches; 1414 1415 ------------------ 1416 -- Operand_Type -- 1417 ------------------ 1418 1419 function Operand_Type return Entity_Id is 1420 Opnd : Node_Id; 1421 1422 begin 1423 if Nkind (N) = N_Function_Call then 1424 Opnd := First_Actual (N); 1425 else 1426 Opnd := Left_Opnd (N); 1427 end if; 1428 1429 return Etype (Opnd); 1430 end Operand_Type; 1431 1432 ------------------------ 1433 -- Remove_Conversions -- 1434 ------------------------ 1435 1436 function Remove_Conversions return Interp is 1437 I : Interp_Index; 1438 It : Interp; 1439 It1 : Interp; 1440 F1 : Entity_Id; 1441 Act1 : Node_Id; 1442 Act2 : Node_Id; 1443 1444 function Has_Abstract_Interpretation (N : Node_Id) return Boolean; 1445 -- If an operation has universal operands the universal operation 1446 -- is present among its interpretations. If there is an abstract 1447 -- interpretation for the operator, with a numeric result, this 1448 -- interpretation was already removed in sem_ch4, but the universal 1449 -- one is still visible. We must rescan the list of operators and 1450 -- remove the universal interpretation to resolve the ambiguity. 1451 1452 --------------------------------- 1453 -- Has_Abstract_Interpretation -- 1454 --------------------------------- 1455 1456 function Has_Abstract_Interpretation (N : Node_Id) return Boolean is 1457 E : Entity_Id; 1458 1459 begin 1460 if Nkind (N) not in N_Op 1461 or else Ada_Version < Ada_2005 1462 or else not Is_Overloaded (N) 1463 or else No (Universal_Interpretation (N)) 1464 then 1465 return False; 1466 1467 else 1468 E := Get_Name_Entity_Id (Chars (N)); 1469 while Present (E) loop 1470 if Is_Overloadable (E) 1471 and then Is_Abstract_Subprogram (E) 1472 and then Is_Numeric_Type (Etype (E)) 1473 then 1474 return True; 1475 else 1476 E := Homonym (E); 1477 end if; 1478 end loop; 1479 1480 -- Finally, if an operand of the binary operator is itself 1481 -- an operator, recurse to see whether its own abstract 1482 -- interpretation is responsible for the spurious ambiguity. 1483 1484 if Nkind (N) in N_Binary_Op then 1485 return Has_Abstract_Interpretation (Left_Opnd (N)) 1486 or else Has_Abstract_Interpretation (Right_Opnd (N)); 1487 1488 elsif Nkind (N) in N_Unary_Op then 1489 return Has_Abstract_Interpretation (Right_Opnd (N)); 1490 1491 else 1492 return False; 1493 end if; 1494 end if; 1495 end Has_Abstract_Interpretation; 1496 1497 -- Start of processing for Remove_Conversions 1498 1499 begin 1500 It1 := No_Interp; 1501 1502 Get_First_Interp (N, I, It); 1503 while Present (It.Typ) loop 1504 if not Is_Overloadable (It.Nam) then 1505 return No_Interp; 1506 end if; 1507 1508 F1 := First_Formal (It.Nam); 1509 1510 if No (F1) then 1511 return It1; 1512 1513 else 1514 if Nkind (N) in N_Subprogram_Call then 1515 Act1 := First_Actual (N); 1516 1517 if Present (Act1) then 1518 Act2 := Next_Actual (Act1); 1519 else 1520 Act2 := Empty; 1521 end if; 1522 1523 elsif Nkind (N) in N_Unary_Op then 1524 Act1 := Right_Opnd (N); 1525 Act2 := Empty; 1526 1527 elsif Nkind (N) in N_Binary_Op then 1528 Act1 := Left_Opnd (N); 1529 Act2 := Right_Opnd (N); 1530 1531 -- Use type of second formal, so as to include 1532 -- exponentiation, where the exponent may be 1533 -- ambiguous and the result non-universal. 1534 1535 Next_Formal (F1); 1536 1537 else 1538 return It1; 1539 end if; 1540 1541 if Nkind (Act1) in N_Op 1542 and then Is_Overloaded (Act1) 1543 and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal 1544 or else Nkind (Right_Opnd (Act1)) = N_Real_Literal) 1545 and then Has_Compatible_Type (Act1, Standard_Boolean) 1546 and then Etype (F1) = Standard_Boolean 1547 then 1548 -- If the two candidates are the original ones, the 1549 -- ambiguity is real. Otherwise keep the original, further 1550 -- calls to Disambiguate will take care of others in the 1551 -- list of candidates. 1552 1553 if It1 /= No_Interp then 1554 if It = Disambiguate.It1 1555 or else It = Disambiguate.It2 1556 then 1557 if It1 = Disambiguate.It1 1558 or else It1 = Disambiguate.It2 1559 then 1560 return No_Interp; 1561 else 1562 It1 := It; 1563 end if; 1564 end if; 1565 1566 elsif Present (Act2) 1567 and then Nkind (Act2) in N_Op 1568 and then Is_Overloaded (Act2) 1569 and then Nkind_In (Right_Opnd (Act2), N_Integer_Literal, 1570 N_Real_Literal) 1571 and then Has_Compatible_Type (Act2, Standard_Boolean) 1572 then 1573 -- The preference rule on the first actual is not 1574 -- sufficient to disambiguate. 1575 1576 goto Next_Interp; 1577 1578 else 1579 It1 := It; 1580 end if; 1581 1582 elsif Is_Numeric_Type (Etype (F1)) 1583 and then Has_Abstract_Interpretation (Act1) 1584 then 1585 -- Current interpretation is not the right one because it 1586 -- expects a numeric operand. Examine all the other ones. 1587 1588 declare 1589 I : Interp_Index; 1590 It : Interp; 1591 1592 begin 1593 Get_First_Interp (N, I, It); 1594 while Present (It.Typ) loop 1595 if 1596 not Is_Numeric_Type (Etype (First_Formal (It.Nam))) 1597 then 1598 if No (Act2) 1599 or else not Has_Abstract_Interpretation (Act2) 1600 or else not 1601 Is_Numeric_Type 1602 (Etype (Next_Formal (First_Formal (It.Nam)))) 1603 then 1604 return It; 1605 end if; 1606 end if; 1607 1608 Get_Next_Interp (I, It); 1609 end loop; 1610 1611 return No_Interp; 1612 end; 1613 end if; 1614 end if; 1615 1616 <<Next_Interp>> 1617 Get_Next_Interp (I, It); 1618 end loop; 1619 1620 -- After some error, a formal may have Any_Type and yield a spurious 1621 -- match. To avoid cascaded errors if possible, check for such a 1622 -- formal in either candidate. 1623 1624 if Serious_Errors_Detected > 0 then 1625 declare 1626 Formal : Entity_Id; 1627 1628 begin 1629 Formal := First_Formal (Nam1); 1630 while Present (Formal) loop 1631 if Etype (Formal) = Any_Type then 1632 return Disambiguate.It2; 1633 end if; 1634 1635 Next_Formal (Formal); 1636 end loop; 1637 1638 Formal := First_Formal (Nam2); 1639 while Present (Formal) loop 1640 if Etype (Formal) = Any_Type then 1641 return Disambiguate.It1; 1642 end if; 1643 1644 Next_Formal (Formal); 1645 end loop; 1646 end; 1647 end if; 1648 1649 return It1; 1650 end Remove_Conversions; 1651 1652 ----------------------- 1653 -- Standard_Operator -- 1654 ----------------------- 1655 1656 function Standard_Operator return Boolean is 1657 Nam : Node_Id; 1658 1659 begin 1660 if Nkind (N) in N_Op then 1661 return True; 1662 1663 elsif Nkind (N) = N_Function_Call then 1664 Nam := Name (N); 1665 1666 if Nkind (Nam) /= N_Expanded_Name then 1667 return True; 1668 else 1669 return Entity (Prefix (Nam)) = Standard_Standard; 1670 end if; 1671 else 1672 return False; 1673 end if; 1674 end Standard_Operator; 1675 1676 -- Start of processing for Disambiguate 1677 1678 begin 1679 -- Recover the two legal interpretations 1680 1681 Get_First_Interp (N, I, It); 1682 while I /= I1 loop 1683 Get_Next_Interp (I, It); 1684 end loop; 1685 1686 It1 := It; 1687 Nam1 := It.Nam; 1688 while I /= I2 loop 1689 Get_Next_Interp (I, It); 1690 end loop; 1691 1692 It2 := It; 1693 Nam2 := It.Nam; 1694 1695 -- Check whether one of the entities is an Ada 2005/2012 and we are 1696 -- operating in an earlier mode, in which case we discard the Ada 1697 -- 2005/2012 entity, so that we get proper Ada 95 overload resolution. 1698 1699 if Ada_Version < Ada_2005 then 1700 if Is_Ada_2005_Only (Nam1) or else Is_Ada_2012_Only (Nam1) then 1701 return It2; 1702 elsif Is_Ada_2005_Only (Nam2) or else Is_Ada_2012_Only (Nam1) then 1703 return It1; 1704 end if; 1705 end if; 1706 1707 -- Check whether one of the entities is an Ada 2012 entity and we are 1708 -- operating in Ada 2005 mode, in which case we discard the Ada 2012 1709 -- entity, so that we get proper Ada 2005 overload resolution. 1710 1711 if Ada_Version = Ada_2005 then 1712 if Is_Ada_2012_Only (Nam1) then 1713 return It2; 1714 elsif Is_Ada_2012_Only (Nam2) then 1715 return It1; 1716 end if; 1717 end if; 1718 1719 -- Check for overloaded CIL convention stuff because the CIL libraries 1720 -- do sick things like Console.Write_Line where it matches two different 1721 -- overloads, so just pick the first ??? 1722 1723 if Convention (Nam1) = Convention_CIL 1724 and then Convention (Nam2) = Convention_CIL 1725 and then Ekind (Nam1) = Ekind (Nam2) 1726 and then (Ekind (Nam1) = E_Procedure 1727 or else Ekind (Nam1) = E_Function) 1728 then 1729 return It2; 1730 end if; 1731 1732 -- If the context is universal, the predefined operator is preferred. 1733 -- This includes bounds in numeric type declarations, and expressions 1734 -- in type conversions. If no interpretation yields a universal type, 1735 -- then we must check whether the user-defined entity hides the prede- 1736 -- fined one. 1737 1738 if Chars (Nam1) in Any_Operator_Name 1739 and then Standard_Operator 1740 then 1741 if Typ = Universal_Integer 1742 or else Typ = Universal_Real 1743 or else Typ = Any_Integer 1744 or else Typ = Any_Discrete 1745 or else Typ = Any_Real 1746 or else Typ = Any_Type 1747 then 1748 -- Find an interpretation that yields the universal type, or else 1749 -- a predefined operator that yields a predefined numeric type. 1750 1751 declare 1752 Candidate : Interp := No_Interp; 1753 1754 begin 1755 Get_First_Interp (N, I, It); 1756 while Present (It.Typ) loop 1757 if (Covers (Typ, It.Typ) or else Typ = Any_Type) 1758 and then 1759 (It.Typ = Universal_Integer 1760 or else It.Typ = Universal_Real) 1761 then 1762 return It; 1763 1764 elsif Covers (Typ, It.Typ) 1765 and then Scope (It.Typ) = Standard_Standard 1766 and then Scope (It.Nam) = Standard_Standard 1767 and then Is_Numeric_Type (It.Typ) 1768 then 1769 Candidate := It; 1770 end if; 1771 1772 Get_Next_Interp (I, It); 1773 end loop; 1774 1775 if Candidate /= No_Interp then 1776 return Candidate; 1777 end if; 1778 end; 1779 1780 elsif Chars (Nam1) /= Name_Op_Not 1781 and then (Typ = Standard_Boolean or else Typ = Any_Boolean) 1782 then 1783 -- Equality or comparison operation. Choose predefined operator if 1784 -- arguments are universal. The node may be an operator, name, or 1785 -- a function call, so unpack arguments accordingly. 1786 1787 declare 1788 Arg1, Arg2 : Node_Id; 1789 1790 begin 1791 if Nkind (N) in N_Op then 1792 Arg1 := Left_Opnd (N); 1793 Arg2 := Right_Opnd (N); 1794 1795 elsif Is_Entity_Name (N) then 1796 Arg1 := First_Entity (Entity (N)); 1797 Arg2 := Next_Entity (Arg1); 1798 1799 else 1800 Arg1 := First_Actual (N); 1801 Arg2 := Next_Actual (Arg1); 1802 end if; 1803 1804 if Present (Arg2) 1805 and then Present (Universal_Interpretation (Arg1)) 1806 and then Universal_Interpretation (Arg2) = 1807 Universal_Interpretation (Arg1) 1808 then 1809 Get_First_Interp (N, I, It); 1810 while Scope (It.Nam) /= Standard_Standard loop 1811 Get_Next_Interp (I, It); 1812 end loop; 1813 1814 return It; 1815 end if; 1816 end; 1817 end if; 1818 end if; 1819 1820 -- If no universal interpretation, check whether user-defined operator 1821 -- hides predefined one, as well as other special cases. If the node 1822 -- is a range, then one or both bounds are ambiguous. Each will have 1823 -- to be disambiguated w.r.t. the context type. The type of the range 1824 -- itself is imposed by the context, so we can return either legal 1825 -- interpretation. 1826 1827 if Ekind (Nam1) = E_Operator then 1828 Predef_Subp := Nam1; 1829 User_Subp := Nam2; 1830 1831 elsif Ekind (Nam2) = E_Operator then 1832 Predef_Subp := Nam2; 1833 User_Subp := Nam1; 1834 1835 elsif Nkind (N) = N_Range then 1836 return It1; 1837 1838 -- Implement AI05-105: A renaming declaration with an access 1839 -- definition must resolve to an anonymous access type. This 1840 -- is a resolution rule and can be used to disambiguate. 1841 1842 elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration 1843 and then Present (Access_Definition (Parent (N))) 1844 then 1845 if Ekind_In (It1.Typ, E_Anonymous_Access_Type, 1846 E_Anonymous_Access_Subprogram_Type) 1847 then 1848 if Ekind (It2.Typ) = Ekind (It1.Typ) then 1849 1850 -- True ambiguity 1851 1852 return No_Interp; 1853 1854 else 1855 return It1; 1856 end if; 1857 1858 elsif Ekind_In (It2.Typ, E_Anonymous_Access_Type, 1859 E_Anonymous_Access_Subprogram_Type) 1860 then 1861 return It2; 1862 1863 -- No legal interpretation 1864 1865 else 1866 return No_Interp; 1867 end if; 1868 1869 -- If two user defined-subprograms are visible, it is a true ambiguity, 1870 -- unless one of them is an entry and the context is a conditional or 1871 -- timed entry call, or unless we are within an instance and this is 1872 -- results from two formals types with the same actual. 1873 1874 else 1875 if Nkind (N) = N_Procedure_Call_Statement 1876 and then Nkind (Parent (N)) = N_Entry_Call_Alternative 1877 and then N = Entry_Call_Statement (Parent (N)) 1878 then 1879 if Ekind (Nam2) = E_Entry then 1880 return It2; 1881 elsif Ekind (Nam1) = E_Entry then 1882 return It1; 1883 else 1884 return No_Interp; 1885 end if; 1886 1887 -- If the ambiguity occurs within an instance, it is due to several 1888 -- formal types with the same actual. Look for an exact match between 1889 -- the types of the formals of the overloadable entities, and the 1890 -- actuals in the call, to recover the unambiguous match in the 1891 -- original generic. 1892 1893 -- The ambiguity can also be due to an overloading between a formal 1894 -- subprogram and a subprogram declared outside the generic. If the 1895 -- node is overloaded, it did not resolve to the global entity in 1896 -- the generic, and we choose the formal subprogram. 1897 1898 -- Finally, the ambiguity can be between an explicit subprogram and 1899 -- one inherited (with different defaults) from an actual. In this 1900 -- case the resolution was to the explicit declaration in the 1901 -- generic, and remains so in the instance. 1902 1903 -- The same sort of disambiguation needed for calls is also required 1904 -- for the name given in a subprogram renaming, and that case is 1905 -- handled here as well. We test Comes_From_Source to exclude this 1906 -- treatment for implicit renamings created for formal subprograms. 1907 1908 elsif In_Instance and then not In_Generic_Actual (N) then 1909 if Nkind (N) in N_Subprogram_Call 1910 or else 1911 (Nkind (N) in N_Has_Entity 1912 and then 1913 Nkind (Parent (N)) = N_Subprogram_Renaming_Declaration 1914 and then Comes_From_Source (Parent (N))) 1915 then 1916 declare 1917 Actual : Node_Id; 1918 Formal : Entity_Id; 1919 Renam : Entity_Id := Empty; 1920 Is_Act1 : constant Boolean := Is_Actual_Subprogram (Nam1); 1921 Is_Act2 : constant Boolean := Is_Actual_Subprogram (Nam2); 1922 1923 begin 1924 if Is_Act1 and then not Is_Act2 then 1925 return It1; 1926 1927 elsif Is_Act2 and then not Is_Act1 then 1928 return It2; 1929 1930 elsif Inherited_From_Actual (Nam1) 1931 and then Comes_From_Source (Nam2) 1932 then 1933 return It2; 1934 1935 elsif Inherited_From_Actual (Nam2) 1936 and then Comes_From_Source (Nam1) 1937 then 1938 return It1; 1939 end if; 1940 1941 -- In the case of a renamed subprogram, pick up the entity 1942 -- of the renaming declaration so we can traverse its 1943 -- formal parameters. 1944 1945 if Nkind (N) in N_Has_Entity then 1946 Renam := Defining_Unit_Name (Specification (Parent (N))); 1947 end if; 1948 1949 if Present (Renam) then 1950 Actual := First_Formal (Renam); 1951 else 1952 Actual := First_Actual (N); 1953 end if; 1954 1955 Formal := First_Formal (Nam1); 1956 while Present (Actual) loop 1957 if Etype (Actual) /= Etype (Formal) then 1958 return It2; 1959 end if; 1960 1961 if Present (Renam) then 1962 Next_Formal (Actual); 1963 else 1964 Next_Actual (Actual); 1965 end if; 1966 1967 Next_Formal (Formal); 1968 end loop; 1969 1970 return It1; 1971 end; 1972 1973 elsif Nkind (N) in N_Binary_Op then 1974 if Matches (Left_Opnd (N), First_Formal (Nam1)) 1975 and then 1976 Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1))) 1977 then 1978 return It1; 1979 else 1980 return It2; 1981 end if; 1982 1983 elsif Nkind (N) in N_Unary_Op then 1984 if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then 1985 return It1; 1986 else 1987 return It2; 1988 end if; 1989 1990 else 1991 return Remove_Conversions; 1992 end if; 1993 else 1994 return Remove_Conversions; 1995 end if; 1996 end if; 1997 1998 -- An implicit concatenation operator on a string type cannot be 1999 -- disambiguated from the predefined concatenation. This can only 2000 -- happen with concatenation of string literals. 2001 2002 if Chars (User_Subp) = Name_Op_Concat 2003 and then Ekind (User_Subp) = E_Operator 2004 and then Is_String_Type (Etype (First_Formal (User_Subp))) 2005 then 2006 return No_Interp; 2007 2008 -- If the user-defined operator is in an open scope, or in the scope 2009 -- of the resulting type, or given by an expanded name that names its 2010 -- scope, it hides the predefined operator for the type. Exponentiation 2011 -- has to be special-cased because the implicit operator does not have 2012 -- a symmetric signature, and may not be hidden by the explicit one. 2013 2014 elsif (Nkind (N) = N_Function_Call 2015 and then Nkind (Name (N)) = N_Expanded_Name 2016 and then (Chars (Predef_Subp) /= Name_Op_Expon 2017 or else Hides_Op (User_Subp, Predef_Subp)) 2018 and then Scope (User_Subp) = Entity (Prefix (Name (N)))) 2019 or else Hides_Op (User_Subp, Predef_Subp) 2020 then 2021 if It1.Nam = User_Subp then 2022 return It1; 2023 else 2024 return It2; 2025 end if; 2026 2027 -- Otherwise, the predefined operator has precedence, or if the user- 2028 -- defined operation is directly visible we have a true ambiguity. 2029 2030 -- If this is a fixed-point multiplication and division in Ada 83 mode, 2031 -- exclude the universal_fixed operator, which often causes ambiguities 2032 -- in legacy code. 2033 2034 -- Ditto in Ada 2012, where an ambiguity may arise for an operation 2035 -- on a partial view that is completed with a fixed point type. See 2036 -- AI05-0020 and AI05-0209. The ambiguity is resolved in favor of the 2037 -- user-defined type and subprogram, so that a client of the package 2038 -- has the same resolution as the body of the package. 2039 2040 else 2041 if (In_Open_Scopes (Scope (User_Subp)) 2042 or else Is_Potentially_Use_Visible (User_Subp)) 2043 and then not In_Instance 2044 then 2045 if Is_Fixed_Point_Type (Typ) 2046 and then Nam_In (Chars (Nam1), Name_Op_Multiply, Name_Op_Divide) 2047 and then 2048 (Ada_Version = Ada_83 2049 or else (Ada_Version >= Ada_2012 2050 and then In_Same_Declaration_List 2051 (First_Subtype (Typ), 2052 Unit_Declaration_Node (User_Subp)))) 2053 then 2054 if It2.Nam = Predef_Subp then 2055 return It1; 2056 else 2057 return It2; 2058 end if; 2059 2060 -- Ada 2005, AI-420: preference rule for "=" on Universal_Access 2061 -- states that the operator defined in Standard is not available 2062 -- if there is a user-defined equality with the proper signature, 2063 -- declared in the same declarative list as the type. The node 2064 -- may be an operator or a function call. 2065 2066 elsif Nam_In (Chars (Nam1), Name_Op_Eq, Name_Op_Ne) 2067 and then Ada_Version >= Ada_2005 2068 and then Etype (User_Subp) = Standard_Boolean 2069 and then Ekind (Operand_Type) = E_Anonymous_Access_Type 2070 and then 2071 In_Same_Declaration_List 2072 (Designated_Type (Operand_Type), 2073 Unit_Declaration_Node (User_Subp)) 2074 then 2075 if It2.Nam = Predef_Subp then 2076 return It1; 2077 else 2078 return It2; 2079 end if; 2080 2081 -- An immediately visible operator hides a use-visible user- 2082 -- defined operation. This disambiguation cannot take place 2083 -- earlier because the visibility of the predefined operator 2084 -- can only be established when operand types are known. 2085 2086 elsif Ekind (User_Subp) = E_Function 2087 and then Ekind (Predef_Subp) = E_Operator 2088 and then Nkind (N) in N_Op 2089 and then not Is_Overloaded (Right_Opnd (N)) 2090 and then 2091 Is_Immediately_Visible (Base_Type (Etype (Right_Opnd (N)))) 2092 and then Is_Potentially_Use_Visible (User_Subp) 2093 then 2094 if It2.Nam = Predef_Subp then 2095 return It1; 2096 else 2097 return It2; 2098 end if; 2099 2100 else 2101 return No_Interp; 2102 end if; 2103 2104 elsif It1.Nam = Predef_Subp then 2105 return It1; 2106 2107 else 2108 return It2; 2109 end if; 2110 end if; 2111 end Disambiguate; 2112 2113 --------------------- 2114 -- End_Interp_List -- 2115 --------------------- 2116 2117 procedure End_Interp_List is 2118 begin 2119 All_Interp.Table (All_Interp.Last) := No_Interp; 2120 All_Interp.Increment_Last; 2121 end End_Interp_List; 2122 2123 ------------------------- 2124 -- Entity_Matches_Spec -- 2125 ------------------------- 2126 2127 function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is 2128 begin 2129 -- Simple case: same entity kinds, type conformance is required. A 2130 -- parameterless function can also rename a literal. 2131 2132 if Ekind (Old_S) = Ekind (New_S) 2133 or else (Ekind (New_S) = E_Function 2134 and then Ekind (Old_S) = E_Enumeration_Literal) 2135 then 2136 return Type_Conformant (New_S, Old_S); 2137 2138 elsif Ekind (New_S) = E_Function and then Ekind (Old_S) = E_Operator then 2139 return Operator_Matches_Spec (Old_S, New_S); 2140 2141 elsif Ekind (New_S) = E_Procedure and then Is_Entry (Old_S) then 2142 return Type_Conformant (New_S, Old_S); 2143 2144 else 2145 return False; 2146 end if; 2147 end Entity_Matches_Spec; 2148 2149 ---------------------- 2150 -- Find_Unique_Type -- 2151 ---------------------- 2152 2153 function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is 2154 T : constant Entity_Id := Etype (L); 2155 I : Interp_Index; 2156 It : Interp; 2157 TR : Entity_Id := Any_Type; 2158 2159 begin 2160 if Is_Overloaded (R) then 2161 Get_First_Interp (R, I, It); 2162 while Present (It.Typ) loop 2163 if Covers (T, It.Typ) or else Covers (It.Typ, T) then 2164 2165 -- If several interpretations are possible and L is universal, 2166 -- apply preference rule. 2167 2168 if TR /= Any_Type then 2169 if (T = Universal_Integer or else T = Universal_Real) 2170 and then It.Typ = T 2171 then 2172 TR := It.Typ; 2173 end if; 2174 2175 else 2176 TR := It.Typ; 2177 end if; 2178 end if; 2179 2180 Get_Next_Interp (I, It); 2181 end loop; 2182 2183 Set_Etype (R, TR); 2184 2185 -- In the non-overloaded case, the Etype of R is already set correctly 2186 2187 else 2188 null; 2189 end if; 2190 2191 -- If one of the operands is Universal_Fixed, the type of the other 2192 -- operand provides the context. 2193 2194 if Etype (R) = Universal_Fixed then 2195 return T; 2196 2197 elsif T = Universal_Fixed then 2198 return Etype (R); 2199 2200 -- Ada 2005 (AI-230): Support the following operators: 2201 2202 -- function "=" (L, R : universal_access) return Boolean; 2203 -- function "/=" (L, R : universal_access) return Boolean; 2204 2205 -- Pool specific access types (E_Access_Type) are not covered by these 2206 -- operators because of the legality rule of 4.5.2(9.2): "The operands 2207 -- of the equality operators for universal_access shall be convertible 2208 -- to one another (see 4.6)". For example, considering the type decla- 2209 -- ration "type P is access Integer" and an anonymous access to Integer, 2210 -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there 2211 -- is no rule in 4.6 that allows "access Integer" to be converted to P. 2212 2213 elsif Ada_Version >= Ada_2005 2214 and then Ekind_In (Etype (L), E_Anonymous_Access_Type, 2215 E_Anonymous_Access_Subprogram_Type) 2216 and then Is_Access_Type (Etype (R)) 2217 and then Ekind (Etype (R)) /= E_Access_Type 2218 then 2219 return Etype (L); 2220 2221 elsif Ada_Version >= Ada_2005 2222 and then Ekind_In (Etype (R), E_Anonymous_Access_Type, 2223 E_Anonymous_Access_Subprogram_Type) 2224 and then Is_Access_Type (Etype (L)) 2225 and then Ekind (Etype (L)) /= E_Access_Type 2226 then 2227 return Etype (R); 2228 2229 -- If one operand is a raise_expression, use type of other operand 2230 2231 elsif Nkind (L) = N_Raise_Expression then 2232 return Etype (R); 2233 2234 else 2235 return Specific_Type (T, Etype (R)); 2236 end if; 2237 end Find_Unique_Type; 2238 2239 ------------------------------------- 2240 -- Function_Interp_Has_Abstract_Op -- 2241 ------------------------------------- 2242 2243 function Function_Interp_Has_Abstract_Op 2244 (N : Node_Id; 2245 E : Entity_Id) return Entity_Id 2246 is 2247 Abstr_Op : Entity_Id; 2248 Act : Node_Id; 2249 Act_Parm : Node_Id; 2250 Form_Parm : Node_Id; 2251 2252 begin 2253 -- Why is check on E needed below ??? 2254 -- In any case this para needs comments ??? 2255 2256 if Is_Overloaded (N) and then Is_Overloadable (E) then 2257 Act_Parm := First_Actual (N); 2258 Form_Parm := First_Formal (E); 2259 while Present (Act_Parm) and then Present (Form_Parm) loop 2260 Act := Act_Parm; 2261 2262 if Nkind (Act) = N_Parameter_Association then 2263 Act := Explicit_Actual_Parameter (Act); 2264 end if; 2265 2266 Abstr_Op := Has_Abstract_Op (Act, Etype (Form_Parm)); 2267 2268 if Present (Abstr_Op) then 2269 return Abstr_Op; 2270 end if; 2271 2272 Next_Actual (Act_Parm); 2273 Next_Formal (Form_Parm); 2274 end loop; 2275 end if; 2276 2277 return Empty; 2278 end Function_Interp_Has_Abstract_Op; 2279 2280 ---------------------- 2281 -- Get_First_Interp -- 2282 ---------------------- 2283 2284 procedure Get_First_Interp 2285 (N : Node_Id; 2286 I : out Interp_Index; 2287 It : out Interp) 2288 is 2289 Int_Ind : Interp_Index; 2290 Map_Ptr : Int; 2291 O_N : Node_Id; 2292 2293 begin 2294 -- If a selected component is overloaded because the selector has 2295 -- multiple interpretations, the node is a call to a protected 2296 -- operation or an indirect call. Retrieve the interpretation from 2297 -- the selector name. The selected component may be overloaded as well 2298 -- if the prefix is overloaded. That case is unchanged. 2299 2300 if Nkind (N) = N_Selected_Component 2301 and then Is_Overloaded (Selector_Name (N)) 2302 then 2303 O_N := Selector_Name (N); 2304 else 2305 O_N := N; 2306 end if; 2307 2308 Map_Ptr := Headers (Hash (O_N)); 2309 while Map_Ptr /= No_Entry loop 2310 if Interp_Map.Table (Map_Ptr).Node = O_N then 2311 Int_Ind := Interp_Map.Table (Map_Ptr).Index; 2312 It := All_Interp.Table (Int_Ind); 2313 I := Int_Ind; 2314 return; 2315 else 2316 Map_Ptr := Interp_Map.Table (Map_Ptr).Next; 2317 end if; 2318 end loop; 2319 2320 -- Procedure should never be called if the node has no interpretations 2321 2322 raise Program_Error; 2323 end Get_First_Interp; 2324 2325 --------------------- 2326 -- Get_Next_Interp -- 2327 --------------------- 2328 2329 procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is 2330 begin 2331 I := I + 1; 2332 It := All_Interp.Table (I); 2333 end Get_Next_Interp; 2334 2335 ------------------------- 2336 -- Has_Compatible_Type -- 2337 ------------------------- 2338 2339 function Has_Compatible_Type 2340 (N : Node_Id; 2341 Typ : Entity_Id) return Boolean 2342 is 2343 I : Interp_Index; 2344 It : Interp; 2345 2346 begin 2347 if N = Error then 2348 return False; 2349 end if; 2350 2351 if Nkind (N) = N_Subtype_Indication 2352 or else not Is_Overloaded (N) 2353 then 2354 return 2355 Covers (Typ, Etype (N)) 2356 2357 -- Ada 2005 (AI-345): The context may be a synchronized interface. 2358 -- If the type is already frozen use the corresponding_record 2359 -- to check whether it is a proper descendant. 2360 2361 or else 2362 (Is_Record_Type (Typ) 2363 and then Is_Concurrent_Type (Etype (N)) 2364 and then Present (Corresponding_Record_Type (Etype (N))) 2365 and then Covers (Typ, Corresponding_Record_Type (Etype (N)))) 2366 2367 or else 2368 (Is_Concurrent_Type (Typ) 2369 and then Is_Record_Type (Etype (N)) 2370 and then Present (Corresponding_Record_Type (Typ)) 2371 and then Covers (Corresponding_Record_Type (Typ), Etype (N))) 2372 2373 or else 2374 (not Is_Tagged_Type (Typ) 2375 and then Ekind (Typ) /= E_Anonymous_Access_Type 2376 and then Covers (Etype (N), Typ)); 2377 2378 -- Overloaded case 2379 2380 else 2381 Get_First_Interp (N, I, It); 2382 while Present (It.Typ) loop 2383 if (Covers (Typ, It.Typ) 2384 and then 2385 (Scope (It.Nam) /= Standard_Standard 2386 or else not Is_Invisible_Operator (N, Base_Type (Typ)))) 2387 2388 -- Ada 2005 (AI-345) 2389 2390 or else 2391 (Is_Concurrent_Type (It.Typ) 2392 and then Present (Corresponding_Record_Type 2393 (Etype (It.Typ))) 2394 and then Covers (Typ, Corresponding_Record_Type 2395 (Etype (It.Typ)))) 2396 2397 or else (not Is_Tagged_Type (Typ) 2398 and then Ekind (Typ) /= E_Anonymous_Access_Type 2399 and then Covers (It.Typ, Typ)) 2400 then 2401 return True; 2402 end if; 2403 2404 Get_Next_Interp (I, It); 2405 end loop; 2406 2407 return False; 2408 end if; 2409 end Has_Compatible_Type; 2410 2411 --------------------- 2412 -- Has_Abstract_Op -- 2413 --------------------- 2414 2415 function Has_Abstract_Op 2416 (N : Node_Id; 2417 Typ : Entity_Id) return Entity_Id 2418 is 2419 I : Interp_Index; 2420 It : Interp; 2421 2422 begin 2423 if Is_Overloaded (N) then 2424 Get_First_Interp (N, I, It); 2425 while Present (It.Nam) loop 2426 if Present (It.Abstract_Op) 2427 and then Etype (It.Abstract_Op) = Typ 2428 then 2429 return It.Abstract_Op; 2430 end if; 2431 2432 Get_Next_Interp (I, It); 2433 end loop; 2434 end if; 2435 2436 return Empty; 2437 end Has_Abstract_Op; 2438 2439 ---------- 2440 -- Hash -- 2441 ---------- 2442 2443 function Hash (N : Node_Id) return Int is 2444 begin 2445 -- Nodes have a size that is power of two, so to select significant 2446 -- bits only we remove the low-order bits. 2447 2448 return ((Int (N) / 2 ** 5) mod Header_Size); 2449 end Hash; 2450 2451 -------------- 2452 -- Hides_Op -- 2453 -------------- 2454 2455 function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean is 2456 Btyp : constant Entity_Id := Base_Type (Etype (First_Formal (F))); 2457 begin 2458 return Operator_Matches_Spec (Op, F) 2459 and then (In_Open_Scopes (Scope (F)) 2460 or else Scope (F) = Scope (Btyp) 2461 or else (not In_Open_Scopes (Scope (Btyp)) 2462 and then not In_Use (Btyp) 2463 and then not In_Use (Scope (Btyp)))); 2464 end Hides_Op; 2465 2466 ------------------------ 2467 -- Init_Interp_Tables -- 2468 ------------------------ 2469 2470 procedure Init_Interp_Tables is 2471 begin 2472 All_Interp.Init; 2473 Interp_Map.Init; 2474 Headers := (others => No_Entry); 2475 end Init_Interp_Tables; 2476 2477 ----------------------------------- 2478 -- Interface_Present_In_Ancestor -- 2479 ----------------------------------- 2480 2481 function Interface_Present_In_Ancestor 2482 (Typ : Entity_Id; 2483 Iface : Entity_Id) return Boolean 2484 is 2485 Target_Typ : Entity_Id; 2486 Iface_Typ : Entity_Id; 2487 2488 function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean; 2489 -- Returns True if Typ or some ancestor of Typ implements Iface 2490 2491 ------------------------------- 2492 -- Iface_Present_In_Ancestor -- 2493 ------------------------------- 2494 2495 function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean is 2496 E : Entity_Id; 2497 AI : Entity_Id; 2498 Elmt : Elmt_Id; 2499 2500 begin 2501 if Typ = Iface_Typ then 2502 return True; 2503 end if; 2504 2505 -- Handle private types 2506 2507 if Present (Full_View (Typ)) 2508 and then not Is_Concurrent_Type (Full_View (Typ)) 2509 then 2510 E := Full_View (Typ); 2511 else 2512 E := Typ; 2513 end if; 2514 2515 loop 2516 if Present (Interfaces (E)) 2517 and then Present (Interfaces (E)) 2518 and then not Is_Empty_Elmt_List (Interfaces (E)) 2519 then 2520 Elmt := First_Elmt (Interfaces (E)); 2521 while Present (Elmt) loop 2522 AI := Node (Elmt); 2523 2524 if AI = Iface_Typ or else Is_Ancestor (Iface_Typ, AI) then 2525 return True; 2526 end if; 2527 2528 Next_Elmt (Elmt); 2529 end loop; 2530 end if; 2531 2532 exit when Etype (E) = E 2533 2534 -- Handle private types 2535 2536 or else (Present (Full_View (Etype (E))) 2537 and then Full_View (Etype (E)) = E); 2538 2539 -- Check if the current type is a direct derivation of the 2540 -- interface 2541 2542 if Etype (E) = Iface_Typ then 2543 return True; 2544 end if; 2545 2546 -- Climb to the immediate ancestor handling private types 2547 2548 if Present (Full_View (Etype (E))) then 2549 E := Full_View (Etype (E)); 2550 else 2551 E := Etype (E); 2552 end if; 2553 end loop; 2554 2555 return False; 2556 end Iface_Present_In_Ancestor; 2557 2558 -- Start of processing for Interface_Present_In_Ancestor 2559 2560 begin 2561 -- Iface might be a class-wide subtype, so we have to apply Base_Type 2562 2563 if Is_Class_Wide_Type (Iface) then 2564 Iface_Typ := Etype (Base_Type (Iface)); 2565 else 2566 Iface_Typ := Iface; 2567 end if; 2568 2569 -- Handle subtypes 2570 2571 Iface_Typ := Base_Type (Iface_Typ); 2572 2573 if Is_Access_Type (Typ) then 2574 Target_Typ := Etype (Directly_Designated_Type (Typ)); 2575 else 2576 Target_Typ := Typ; 2577 end if; 2578 2579 if Is_Concurrent_Record_Type (Target_Typ) then 2580 Target_Typ := Corresponding_Concurrent_Type (Target_Typ); 2581 end if; 2582 2583 Target_Typ := Base_Type (Target_Typ); 2584 2585 -- In case of concurrent types we can't use the Corresponding Record_Typ 2586 -- to look for the interface because it is built by the expander (and 2587 -- hence it is not always available). For this reason we traverse the 2588 -- list of interfaces (available in the parent of the concurrent type) 2589 2590 if Is_Concurrent_Type (Target_Typ) then 2591 if Present (Interface_List (Parent (Target_Typ))) then 2592 declare 2593 AI : Node_Id; 2594 2595 begin 2596 AI := First (Interface_List (Parent (Target_Typ))); 2597 2598 -- The progenitor itself may be a subtype of an interface type. 2599 2600 while Present (AI) loop 2601 if Etype (AI) = Iface_Typ 2602 or else Base_Type (Etype (AI)) = Iface_Typ 2603 then 2604 return True; 2605 2606 elsif Present (Interfaces (Etype (AI))) 2607 and then Iface_Present_In_Ancestor (Etype (AI)) 2608 then 2609 return True; 2610 end if; 2611 2612 Next (AI); 2613 end loop; 2614 end; 2615 end if; 2616 2617 return False; 2618 end if; 2619 2620 if Is_Class_Wide_Type (Target_Typ) then 2621 Target_Typ := Etype (Target_Typ); 2622 end if; 2623 2624 if Ekind (Target_Typ) = E_Incomplete_Type then 2625 pragma Assert (Present (Non_Limited_View (Target_Typ))); 2626 Target_Typ := Non_Limited_View (Target_Typ); 2627 2628 -- Protect the frontend against previously detected errors 2629 2630 if Ekind (Target_Typ) = E_Incomplete_Type then 2631 return False; 2632 end if; 2633 end if; 2634 2635 return Iface_Present_In_Ancestor (Target_Typ); 2636 end Interface_Present_In_Ancestor; 2637 2638 --------------------- 2639 -- Intersect_Types -- 2640 --------------------- 2641 2642 function Intersect_Types (L, R : Node_Id) return Entity_Id is 2643 Index : Interp_Index; 2644 It : Interp; 2645 Typ : Entity_Id; 2646 2647 function Check_Right_Argument (T : Entity_Id) return Entity_Id; 2648 -- Find interpretation of right arg that has type compatible with T 2649 2650 -------------------------- 2651 -- Check_Right_Argument -- 2652 -------------------------- 2653 2654 function Check_Right_Argument (T : Entity_Id) return Entity_Id is 2655 Index : Interp_Index; 2656 It : Interp; 2657 T2 : Entity_Id; 2658 2659 begin 2660 if not Is_Overloaded (R) then 2661 return Specific_Type (T, Etype (R)); 2662 2663 else 2664 Get_First_Interp (R, Index, It); 2665 loop 2666 T2 := Specific_Type (T, It.Typ); 2667 2668 if T2 /= Any_Type then 2669 return T2; 2670 end if; 2671 2672 Get_Next_Interp (Index, It); 2673 exit when No (It.Typ); 2674 end loop; 2675 2676 return Any_Type; 2677 end if; 2678 end Check_Right_Argument; 2679 2680 -- Start of processing for Intersect_Types 2681 2682 begin 2683 if Etype (L) = Any_Type or else Etype (R) = Any_Type then 2684 return Any_Type; 2685 end if; 2686 2687 if not Is_Overloaded (L) then 2688 Typ := Check_Right_Argument (Etype (L)); 2689 2690 else 2691 Typ := Any_Type; 2692 Get_First_Interp (L, Index, It); 2693 while Present (It.Typ) loop 2694 Typ := Check_Right_Argument (It.Typ); 2695 exit when Typ /= Any_Type; 2696 Get_Next_Interp (Index, It); 2697 end loop; 2698 2699 end if; 2700 2701 -- If Typ is Any_Type, it means no compatible pair of types was found 2702 2703 if Typ = Any_Type then 2704 if Nkind (Parent (L)) in N_Op then 2705 Error_Msg_N ("incompatible types for operator", Parent (L)); 2706 2707 elsif Nkind (Parent (L)) = N_Range then 2708 Error_Msg_N ("incompatible types given in constraint", Parent (L)); 2709 2710 -- Ada 2005 (AI-251): Complete the error notification 2711 2712 elsif Is_Class_Wide_Type (Etype (R)) 2713 and then Is_Interface (Etype (Class_Wide_Type (Etype (R)))) 2714 then 2715 Error_Msg_NE ("(Ada 2005) does not implement interface }", 2716 L, Etype (Class_Wide_Type (Etype (R)))); 2717 else 2718 Error_Msg_N ("incompatible types", Parent (L)); 2719 end if; 2720 end if; 2721 2722 return Typ; 2723 end Intersect_Types; 2724 2725 ----------------------- 2726 -- In_Generic_Actual -- 2727 ----------------------- 2728 2729 function In_Generic_Actual (Exp : Node_Id) return Boolean is 2730 Par : constant Node_Id := Parent (Exp); 2731 2732 begin 2733 if No (Par) then 2734 return False; 2735 2736 elsif Nkind (Par) in N_Declaration then 2737 if Nkind (Par) = N_Object_Declaration then 2738 return Present (Corresponding_Generic_Association (Par)); 2739 else 2740 return False; 2741 end if; 2742 2743 elsif Nkind (Par) = N_Object_Renaming_Declaration then 2744 return Present (Corresponding_Generic_Association (Par)); 2745 2746 elsif Nkind (Par) in N_Statement_Other_Than_Procedure_Call then 2747 return False; 2748 2749 else 2750 return In_Generic_Actual (Parent (Par)); 2751 end if; 2752 end In_Generic_Actual; 2753 2754 ----------------- 2755 -- Is_Ancestor -- 2756 ----------------- 2757 2758 function Is_Ancestor 2759 (T1 : Entity_Id; 2760 T2 : Entity_Id; 2761 Use_Full_View : Boolean := False) return Boolean 2762 is 2763 BT1 : Entity_Id; 2764 BT2 : Entity_Id; 2765 Par : Entity_Id; 2766 2767 begin 2768 BT1 := Base_Type (T1); 2769 BT2 := Base_Type (T2); 2770 2771 -- Handle underlying view of records with unknown discriminants using 2772 -- the original entity that motivated the construction of this 2773 -- underlying record view (see Build_Derived_Private_Type). 2774 2775 if Is_Underlying_Record_View (BT1) then 2776 BT1 := Underlying_Record_View (BT1); 2777 end if; 2778 2779 if Is_Underlying_Record_View (BT2) then 2780 BT2 := Underlying_Record_View (BT2); 2781 end if; 2782 2783 if BT1 = BT2 then 2784 return True; 2785 2786 -- The predicate must look past privacy 2787 2788 elsif Is_Private_Type (T1) 2789 and then Present (Full_View (T1)) 2790 and then BT2 = Base_Type (Full_View (T1)) 2791 then 2792 return True; 2793 2794 elsif Is_Private_Type (T2) 2795 and then Present (Full_View (T2)) 2796 and then BT1 = Base_Type (Full_View (T2)) 2797 then 2798 return True; 2799 2800 else 2801 -- Obtain the parent of the base type of T2 (use the full view if 2802 -- allowed). 2803 2804 if Use_Full_View 2805 and then Is_Private_Type (BT2) 2806 and then Present (Full_View (BT2)) 2807 then 2808 -- No climbing needed if its full view is the root type 2809 2810 if Full_View (BT2) = Root_Type (Full_View (BT2)) then 2811 return False; 2812 end if; 2813 2814 Par := Etype (Full_View (BT2)); 2815 2816 else 2817 Par := Etype (BT2); 2818 end if; 2819 2820 loop 2821 -- If there was a error on the type declaration, do not recurse 2822 2823 if Error_Posted (Par) then 2824 return False; 2825 2826 elsif BT1 = Base_Type (Par) 2827 or else (Is_Private_Type (T1) 2828 and then Present (Full_View (T1)) 2829 and then Base_Type (Par) = Base_Type (Full_View (T1))) 2830 then 2831 return True; 2832 2833 elsif Is_Private_Type (Par) 2834 and then Present (Full_View (Par)) 2835 and then Full_View (Par) = BT1 2836 then 2837 return True; 2838 2839 -- Root type found 2840 2841 elsif Par = Root_Type (Par) then 2842 return False; 2843 2844 -- Continue climbing 2845 2846 else 2847 -- Use the full-view of private types (if allowed) 2848 2849 if Use_Full_View 2850 and then Is_Private_Type (Par) 2851 and then Present (Full_View (Par)) 2852 then 2853 Par := Etype (Full_View (Par)); 2854 else 2855 Par := Etype (Par); 2856 end if; 2857 end if; 2858 end loop; 2859 end if; 2860 end Is_Ancestor; 2861 2862 --------------------------- 2863 -- Is_Invisible_Operator -- 2864 --------------------------- 2865 2866 function Is_Invisible_Operator 2867 (N : Node_Id; 2868 T : Entity_Id) return Boolean 2869 is 2870 Orig_Node : constant Node_Id := Original_Node (N); 2871 2872 begin 2873 if Nkind (N) not in N_Op then 2874 return False; 2875 2876 elsif not Comes_From_Source (N) then 2877 return False; 2878 2879 elsif No (Universal_Interpretation (Right_Opnd (N))) then 2880 return False; 2881 2882 elsif Nkind (N) in N_Binary_Op 2883 and then No (Universal_Interpretation (Left_Opnd (N))) 2884 then 2885 return False; 2886 2887 else 2888 return Is_Numeric_Type (T) 2889 and then not In_Open_Scopes (Scope (T)) 2890 and then not Is_Potentially_Use_Visible (T) 2891 and then not In_Use (T) 2892 and then not In_Use (Scope (T)) 2893 and then 2894 (Nkind (Orig_Node) /= N_Function_Call 2895 or else Nkind (Name (Orig_Node)) /= N_Expanded_Name 2896 or else Entity (Prefix (Name (Orig_Node))) /= Scope (T)) 2897 and then not In_Instance; 2898 end if; 2899 end Is_Invisible_Operator; 2900 2901 -------------------- 2902 -- Is_Progenitor -- 2903 -------------------- 2904 2905 function Is_Progenitor 2906 (Iface : Entity_Id; 2907 Typ : Entity_Id) return Boolean 2908 is 2909 begin 2910 return Implements_Interface (Typ, Iface, Exclude_Parents => True); 2911 end Is_Progenitor; 2912 2913 ------------------- 2914 -- Is_Subtype_Of -- 2915 ------------------- 2916 2917 function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is 2918 S : Entity_Id; 2919 2920 begin 2921 S := Ancestor_Subtype (T1); 2922 while Present (S) loop 2923 if S = T2 then 2924 return True; 2925 else 2926 S := Ancestor_Subtype (S); 2927 end if; 2928 end loop; 2929 2930 return False; 2931 end Is_Subtype_Of; 2932 2933 ------------------ 2934 -- List_Interps -- 2935 ------------------ 2936 2937 procedure List_Interps (Nam : Node_Id; Err : Node_Id) is 2938 Index : Interp_Index; 2939 It : Interp; 2940 2941 begin 2942 Get_First_Interp (Nam, Index, It); 2943 while Present (It.Nam) loop 2944 if Scope (It.Nam) = Standard_Standard 2945 and then Scope (It.Typ) /= Standard_Standard 2946 then 2947 Error_Msg_Sloc := Sloc (Parent (It.Typ)); 2948 Error_Msg_NE ("\\& (inherited) declared#!", Err, It.Nam); 2949 2950 else 2951 Error_Msg_Sloc := Sloc (It.Nam); 2952 Error_Msg_NE ("\\& declared#!", Err, It.Nam); 2953 end if; 2954 2955 Get_Next_Interp (Index, It); 2956 end loop; 2957 end List_Interps; 2958 2959 ----------------- 2960 -- New_Interps -- 2961 ----------------- 2962 2963 procedure New_Interps (N : Node_Id) is 2964 Map_Ptr : Int; 2965 2966 begin 2967 All_Interp.Append (No_Interp); 2968 2969 Map_Ptr := Headers (Hash (N)); 2970 2971 if Map_Ptr = No_Entry then 2972 2973 -- Place new node at end of table 2974 2975 Interp_Map.Increment_Last; 2976 Headers (Hash (N)) := Interp_Map.Last; 2977 2978 else 2979 -- Place node at end of chain, or locate its previous entry 2980 2981 loop 2982 if Interp_Map.Table (Map_Ptr).Node = N then 2983 2984 -- Node is already in the table, and is being rewritten. 2985 -- Start a new interp section, retain hash link. 2986 2987 Interp_Map.Table (Map_Ptr).Node := N; 2988 Interp_Map.Table (Map_Ptr).Index := All_Interp.Last; 2989 Set_Is_Overloaded (N, True); 2990 return; 2991 2992 else 2993 exit when Interp_Map.Table (Map_Ptr).Next = No_Entry; 2994 Map_Ptr := Interp_Map.Table (Map_Ptr).Next; 2995 end if; 2996 end loop; 2997 2998 -- Chain the new node 2999 3000 Interp_Map.Increment_Last; 3001 Interp_Map.Table (Map_Ptr).Next := Interp_Map.Last; 3002 end if; 3003 3004 Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last, No_Entry); 3005 Set_Is_Overloaded (N, True); 3006 end New_Interps; 3007 3008 --------------------------- 3009 -- Operator_Matches_Spec -- 3010 --------------------------- 3011 3012 function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is 3013 Op_Name : constant Name_Id := Chars (Op); 3014 T : constant Entity_Id := Etype (New_S); 3015 New_F : Entity_Id; 3016 Old_F : Entity_Id; 3017 Num : Int; 3018 T1 : Entity_Id; 3019 T2 : Entity_Id; 3020 3021 begin 3022 -- To verify that a predefined operator matches a given signature, 3023 -- do a case analysis of the operator classes. Function can have one 3024 -- or two formals and must have the proper result type. 3025 3026 New_F := First_Formal (New_S); 3027 Old_F := First_Formal (Op); 3028 Num := 0; 3029 while Present (New_F) and then Present (Old_F) loop 3030 Num := Num + 1; 3031 Next_Formal (New_F); 3032 Next_Formal (Old_F); 3033 end loop; 3034 3035 -- Definite mismatch if different number of parameters 3036 3037 if Present (Old_F) or else Present (New_F) then 3038 return False; 3039 3040 -- Unary operators 3041 3042 elsif Num = 1 then 3043 T1 := Etype (First_Formal (New_S)); 3044 3045 if Nam_In (Op_Name, Name_Op_Subtract, Name_Op_Add, Name_Op_Abs) then 3046 return Base_Type (T1) = Base_Type (T) 3047 and then Is_Numeric_Type (T); 3048 3049 elsif Op_Name = Name_Op_Not then 3050 return Base_Type (T1) = Base_Type (T) 3051 and then Valid_Boolean_Arg (Base_Type (T)); 3052 3053 else 3054 return False; 3055 end if; 3056 3057 -- Binary operators 3058 3059 else 3060 T1 := Etype (First_Formal (New_S)); 3061 T2 := Etype (Next_Formal (First_Formal (New_S))); 3062 3063 if Nam_In (Op_Name, Name_Op_And, Name_Op_Or, Name_Op_Xor) then 3064 return Base_Type (T1) = Base_Type (T2) 3065 and then Base_Type (T1) = Base_Type (T) 3066 and then Valid_Boolean_Arg (Base_Type (T)); 3067 3068 elsif Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne) then 3069 return Base_Type (T1) = Base_Type (T2) 3070 and then not Is_Limited_Type (T1) 3071 and then Is_Boolean_Type (T); 3072 3073 elsif Nam_In (Op_Name, Name_Op_Lt, Name_Op_Le, 3074 Name_Op_Gt, Name_Op_Ge) 3075 then 3076 return Base_Type (T1) = Base_Type (T2) 3077 and then Valid_Comparison_Arg (T1) 3078 and then Is_Boolean_Type (T); 3079 3080 elsif Nam_In (Op_Name, Name_Op_Add, Name_Op_Subtract) then 3081 return Base_Type (T1) = Base_Type (T2) 3082 and then Base_Type (T1) = Base_Type (T) 3083 and then Is_Numeric_Type (T); 3084 3085 -- For division and multiplication, a user-defined function does not 3086 -- match the predefined universal_fixed operation, except in Ada 83. 3087 3088 elsif Op_Name = Name_Op_Divide then 3089 return (Base_Type (T1) = Base_Type (T2) 3090 and then Base_Type (T1) = Base_Type (T) 3091 and then Is_Numeric_Type (T) 3092 and then (not Is_Fixed_Point_Type (T) 3093 or else Ada_Version = Ada_83)) 3094 3095 -- Mixed_Mode operations on fixed-point types 3096 3097 or else (Base_Type (T1) = Base_Type (T) 3098 and then Base_Type (T2) = Base_Type (Standard_Integer) 3099 and then Is_Fixed_Point_Type (T)) 3100 3101 -- A user defined operator can also match (and hide) a mixed 3102 -- operation on universal literals. 3103 3104 or else (Is_Integer_Type (T2) 3105 and then Is_Floating_Point_Type (T1) 3106 and then Base_Type (T1) = Base_Type (T)); 3107 3108 elsif Op_Name = Name_Op_Multiply then 3109 return (Base_Type (T1) = Base_Type (T2) 3110 and then Base_Type (T1) = Base_Type (T) 3111 and then Is_Numeric_Type (T) 3112 and then (not Is_Fixed_Point_Type (T) 3113 or else Ada_Version = Ada_83)) 3114 3115 -- Mixed_Mode operations on fixed-point types 3116 3117 or else (Base_Type (T1) = Base_Type (T) 3118 and then Base_Type (T2) = Base_Type (Standard_Integer) 3119 and then Is_Fixed_Point_Type (T)) 3120 3121 or else (Base_Type (T2) = Base_Type (T) 3122 and then Base_Type (T1) = Base_Type (Standard_Integer) 3123 and then Is_Fixed_Point_Type (T)) 3124 3125 or else (Is_Integer_Type (T2) 3126 and then Is_Floating_Point_Type (T1) 3127 and then Base_Type (T1) = Base_Type (T)) 3128 3129 or else (Is_Integer_Type (T1) 3130 and then Is_Floating_Point_Type (T2) 3131 and then Base_Type (T2) = Base_Type (T)); 3132 3133 elsif Nam_In (Op_Name, Name_Op_Mod, Name_Op_Rem) then 3134 return Base_Type (T1) = Base_Type (T2) 3135 and then Base_Type (T1) = Base_Type (T) 3136 and then Is_Integer_Type (T); 3137 3138 elsif Op_Name = Name_Op_Expon then 3139 return Base_Type (T1) = Base_Type (T) 3140 and then Is_Numeric_Type (T) 3141 and then Base_Type (T2) = Base_Type (Standard_Integer); 3142 3143 elsif Op_Name = Name_Op_Concat then 3144 return Is_Array_Type (T) 3145 and then (Base_Type (T) = Base_Type (Etype (Op))) 3146 and then (Base_Type (T1) = Base_Type (T) 3147 or else 3148 Base_Type (T1) = Base_Type (Component_Type (T))) 3149 and then (Base_Type (T2) = Base_Type (T) 3150 or else 3151 Base_Type (T2) = Base_Type (Component_Type (T))); 3152 3153 else 3154 return False; 3155 end if; 3156 end if; 3157 end Operator_Matches_Spec; 3158 3159 ------------------- 3160 -- Remove_Interp -- 3161 ------------------- 3162 3163 procedure Remove_Interp (I : in out Interp_Index) is 3164 II : Interp_Index; 3165 3166 begin 3167 -- Find end of interp list and copy downward to erase the discarded one 3168 3169 II := I + 1; 3170 while Present (All_Interp.Table (II).Typ) loop 3171 II := II + 1; 3172 end loop; 3173 3174 for J in I + 1 .. II loop 3175 All_Interp.Table (J - 1) := All_Interp.Table (J); 3176 end loop; 3177 3178 -- Back up interp index to insure that iterator will pick up next 3179 -- available interpretation. 3180 3181 I := I - 1; 3182 end Remove_Interp; 3183 3184 ------------------ 3185 -- Save_Interps -- 3186 ------------------ 3187 3188 procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is 3189 Map_Ptr : Int; 3190 O_N : Node_Id := Old_N; 3191 3192 begin 3193 if Is_Overloaded (Old_N) then 3194 Set_Is_Overloaded (New_N); 3195 3196 if Nkind (Old_N) = N_Selected_Component 3197 and then Is_Overloaded (Selector_Name (Old_N)) 3198 then 3199 O_N := Selector_Name (Old_N); 3200 end if; 3201 3202 Map_Ptr := Headers (Hash (O_N)); 3203 3204 while Interp_Map.Table (Map_Ptr).Node /= O_N loop 3205 Map_Ptr := Interp_Map.Table (Map_Ptr).Next; 3206 pragma Assert (Map_Ptr /= No_Entry); 3207 end loop; 3208 3209 New_Interps (New_N); 3210 Interp_Map.Table (Interp_Map.Last).Index := 3211 Interp_Map.Table (Map_Ptr).Index; 3212 end if; 3213 end Save_Interps; 3214 3215 ------------------- 3216 -- Specific_Type -- 3217 ------------------- 3218 3219 function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id is 3220 T1 : constant Entity_Id := Available_View (Typ_1); 3221 T2 : constant Entity_Id := Available_View (Typ_2); 3222 B1 : constant Entity_Id := Base_Type (T1); 3223 B2 : constant Entity_Id := Base_Type (T2); 3224 3225 function Is_Remote_Access (T : Entity_Id) return Boolean; 3226 -- Check whether T is the equivalent type of a remote access type. 3227 -- If distribution is enabled, T is a legal context for Null. 3228 3229 ---------------------- 3230 -- Is_Remote_Access -- 3231 ---------------------- 3232 3233 function Is_Remote_Access (T : Entity_Id) return Boolean is 3234 begin 3235 return Is_Record_Type (T) 3236 and then (Is_Remote_Call_Interface (T) 3237 or else Is_Remote_Types (T)) 3238 and then Present (Corresponding_Remote_Type (T)) 3239 and then Is_Access_Type (Corresponding_Remote_Type (T)); 3240 end Is_Remote_Access; 3241 3242 -- Start of processing for Specific_Type 3243 3244 begin 3245 if T1 = Any_Type or else T2 = Any_Type then 3246 return Any_Type; 3247 end if; 3248 3249 if B1 = B2 then 3250 return B1; 3251 3252 elsif (T1 = Universal_Integer and then Is_Integer_Type (T2)) 3253 or else (T1 = Universal_Real and then Is_Real_Type (T2)) 3254 or else (T1 = Universal_Fixed and then Is_Fixed_Point_Type (T2)) 3255 or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2)) 3256 then 3257 return B2; 3258 3259 elsif (T2 = Universal_Integer and then Is_Integer_Type (T1)) 3260 or else (T2 = Universal_Real and then Is_Real_Type (T1)) 3261 or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1)) 3262 or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1)) 3263 then 3264 return B1; 3265 3266 elsif T2 = Any_String and then Is_String_Type (T1) then 3267 return B1; 3268 3269 elsif T1 = Any_String and then Is_String_Type (T2) then 3270 return B2; 3271 3272 elsif T2 = Any_Character and then Is_Character_Type (T1) then 3273 return B1; 3274 3275 elsif T1 = Any_Character and then Is_Character_Type (T2) then 3276 return B2; 3277 3278 elsif T1 = Any_Access 3279 and then (Is_Access_Type (T2) or else Is_Remote_Access (T2)) 3280 then 3281 return T2; 3282 3283 elsif T2 = Any_Access 3284 and then (Is_Access_Type (T1) or else Is_Remote_Access (T1)) 3285 then 3286 return T1; 3287 3288 -- In an instance, the specific type may have a private view. Use full 3289 -- view to check legality. 3290 3291 elsif T2 = Any_Access 3292 and then Is_Private_Type (T1) 3293 and then Present (Full_View (T1)) 3294 and then Is_Access_Type (Full_View (T1)) 3295 and then In_Instance 3296 then 3297 return T1; 3298 3299 elsif T2 = Any_Composite and then Is_Aggregate_Type (T1) then 3300 return T1; 3301 3302 elsif T1 = Any_Composite and then Is_Aggregate_Type (T2) then 3303 return T2; 3304 3305 elsif T1 = Any_Modular and then Is_Modular_Integer_Type (T2) then 3306 return T2; 3307 3308 elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then 3309 return T1; 3310 3311 -- ---------------------------------------------------------- 3312 -- Special cases for equality operators (all other predefined 3313 -- operators can never apply to tagged types) 3314 -- ---------------------------------------------------------- 3315 3316 -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an 3317 -- interface 3318 3319 elsif Is_Class_Wide_Type (T1) 3320 and then Is_Class_Wide_Type (T2) 3321 and then Is_Interface (Etype (T2)) 3322 then 3323 return T1; 3324 3325 -- Ada 2005 (AI-251): T1 is a concrete type that implements the 3326 -- class-wide interface T2 3327 3328 elsif Is_Class_Wide_Type (T2) 3329 and then Is_Interface (Etype (T2)) 3330 and then Interface_Present_In_Ancestor (Typ => T1, 3331 Iface => Etype (T2)) 3332 then 3333 return T1; 3334 3335 elsif Is_Class_Wide_Type (T1) 3336 and then Is_Ancestor (Root_Type (T1), T2) 3337 then 3338 return T1; 3339 3340 elsif Is_Class_Wide_Type (T2) 3341 and then Is_Ancestor (Root_Type (T2), T1) 3342 then 3343 return T2; 3344 3345 elsif Ekind_In (B1, E_Access_Subprogram_Type, 3346 E_Access_Protected_Subprogram_Type) 3347 and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type 3348 and then Is_Access_Type (T2) 3349 then 3350 return T2; 3351 3352 elsif Ekind_In (B2, E_Access_Subprogram_Type, 3353 E_Access_Protected_Subprogram_Type) 3354 and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type 3355 and then Is_Access_Type (T1) 3356 then 3357 return T1; 3358 3359 elsif Ekind_In (T1, E_Allocator_Type, 3360 E_Access_Attribute_Type, 3361 E_Anonymous_Access_Type) 3362 and then Is_Access_Type (T2) 3363 then 3364 return T2; 3365 3366 elsif Ekind_In (T2, E_Allocator_Type, 3367 E_Access_Attribute_Type, 3368 E_Anonymous_Access_Type) 3369 and then Is_Access_Type (T1) 3370 then 3371 return T1; 3372 3373 -- If none of the above cases applies, types are not compatible 3374 3375 else 3376 return Any_Type; 3377 end if; 3378 end Specific_Type; 3379 3380 --------------------- 3381 -- Set_Abstract_Op -- 3382 --------------------- 3383 3384 procedure Set_Abstract_Op (I : Interp_Index; V : Entity_Id) is 3385 begin 3386 All_Interp.Table (I).Abstract_Op := V; 3387 end Set_Abstract_Op; 3388 3389 ----------------------- 3390 -- Valid_Boolean_Arg -- 3391 ----------------------- 3392 3393 -- In addition to booleans and arrays of booleans, we must include 3394 -- aggregates as valid boolean arguments, because in the first pass of 3395 -- resolution their components are not examined. If it turns out not to be 3396 -- an aggregate of booleans, this will be diagnosed in Resolve. 3397 -- Any_Composite must be checked for prior to the array type checks because 3398 -- Any_Composite does not have any associated indexes. 3399 3400 function Valid_Boolean_Arg (T : Entity_Id) return Boolean is 3401 begin 3402 if Is_Boolean_Type (T) 3403 or else Is_Modular_Integer_Type (T) 3404 or else T = Universal_Integer 3405 or else T = Any_Composite 3406 then 3407 return True; 3408 3409 elsif Is_Array_Type (T) 3410 and then T /= Any_String 3411 and then Number_Dimensions (T) = 1 3412 and then Is_Boolean_Type (Component_Type (T)) 3413 and then 3414 ((not Is_Private_Composite (T) and then not Is_Limited_Composite (T)) 3415 or else In_Instance 3416 or else Available_Full_View_Of_Component (T)) 3417 then 3418 return True; 3419 3420 else 3421 return False; 3422 end if; 3423 end Valid_Boolean_Arg; 3424 3425 -------------------------- 3426 -- Valid_Comparison_Arg -- 3427 -------------------------- 3428 3429 function Valid_Comparison_Arg (T : Entity_Id) return Boolean is 3430 begin 3431 3432 if T = Any_Composite then 3433 return False; 3434 3435 elsif Is_Discrete_Type (T) 3436 or else Is_Real_Type (T) 3437 then 3438 return True; 3439 3440 elsif Is_Array_Type (T) 3441 and then Number_Dimensions (T) = 1 3442 and then Is_Discrete_Type (Component_Type (T)) 3443 and then (not Is_Private_Composite (T) or else In_Instance) 3444 and then (not Is_Limited_Composite (T) or else In_Instance) 3445 then 3446 return True; 3447 3448 elsif Is_Array_Type (T) 3449 and then Number_Dimensions (T) = 1 3450 and then Is_Discrete_Type (Component_Type (T)) 3451 and then Available_Full_View_Of_Component (T) 3452 then 3453 return True; 3454 3455 elsif Is_String_Type (T) then 3456 return True; 3457 else 3458 return False; 3459 end if; 3460 end Valid_Comparison_Arg; 3461 3462 ------------------ 3463 -- Write_Interp -- 3464 ------------------ 3465 3466 procedure Write_Interp (It : Interp) is 3467 begin 3468 Write_Str ("Nam: "); 3469 Print_Tree_Node (It.Nam); 3470 Write_Str ("Typ: "); 3471 Print_Tree_Node (It.Typ); 3472 Write_Str ("Abstract_Op: "); 3473 Print_Tree_Node (It.Abstract_Op); 3474 end Write_Interp; 3475 3476 ---------------------- 3477 -- Write_Interp_Ref -- 3478 ---------------------- 3479 3480 procedure Write_Interp_Ref (Map_Ptr : Int) is 3481 begin 3482 Write_Str (" Node: "); 3483 Write_Int (Int (Interp_Map.Table (Map_Ptr).Node)); 3484 Write_Str (" Index: "); 3485 Write_Int (Int (Interp_Map.Table (Map_Ptr).Index)); 3486 Write_Str (" Next: "); 3487 Write_Int (Interp_Map.Table (Map_Ptr).Next); 3488 Write_Eol; 3489 end Write_Interp_Ref; 3490 3491 --------------------- 3492 -- Write_Overloads -- 3493 --------------------- 3494 3495 procedure Write_Overloads (N : Node_Id) is 3496 I : Interp_Index; 3497 It : Interp; 3498 Nam : Entity_Id; 3499 3500 begin 3501 Write_Str ("Overloads: "); 3502 Print_Node_Briefly (N); 3503 3504 if Nkind (N) not in N_Has_Entity then 3505 return; 3506 end if; 3507 3508 if not Is_Overloaded (N) then 3509 Write_Str ("Non-overloaded entity "); 3510 Write_Eol; 3511 Write_Entity_Info (Entity (N), " "); 3512 3513 else 3514 Get_First_Interp (N, I, It); 3515 Write_Str ("Overloaded entity "); 3516 Write_Eol; 3517 Write_Str (" Name Type Abstract Op"); 3518 Write_Eol; 3519 Write_Str ("==============================================="); 3520 Write_Eol; 3521 Nam := It.Nam; 3522 3523 while Present (Nam) loop 3524 Write_Int (Int (Nam)); 3525 Write_Str (" "); 3526 Write_Name (Chars (Nam)); 3527 Write_Str (" "); 3528 Write_Int (Int (It.Typ)); 3529 Write_Str (" "); 3530 Write_Name (Chars (It.Typ)); 3531 3532 if Present (It.Abstract_Op) then 3533 Write_Str (" "); 3534 Write_Int (Int (It.Abstract_Op)); 3535 Write_Str (" "); 3536 Write_Name (Chars (It.Abstract_Op)); 3537 end if; 3538 3539 Write_Eol; 3540 Get_Next_Interp (I, It); 3541 Nam := It.Nam; 3542 end loop; 3543 end if; 3544 end Write_Overloads; 3545 3546end Sem_Type; 3547