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