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