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