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