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