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-2003 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Atree; use Atree; 28with Alloc; 29with Debug; use Debug; 30with Einfo; use Einfo; 31with Errout; use Errout; 32with Lib; use Lib; 33with Opt; use Opt; 34with Output; use Output; 35with Sem; use Sem; 36with Sem_Ch6; use Sem_Ch6; 37with Sem_Ch8; use Sem_Ch8; 38with Sem_Util; use Sem_Util; 39with Stand; use Stand; 40with Sinfo; use Sinfo; 41with Snames; use Snames; 42with Table; 43with Uintp; use Uintp; 44 45package body Sem_Type is 46 47 --------------------- 48 -- Data Structures -- 49 --------------------- 50 51 -- The following data structures establish a mapping between nodes and 52 -- their interpretations. An overloaded node has an entry in Interp_Map, 53 -- which in turn contains a pointer into the All_Interp array. The 54 -- interpretations of a given node are contiguous in All_Interp. Each 55 -- set of interpretations is terminated with the marker No_Interp. 56 -- In order to speed up the retrieval of the interpretations of an 57 -- overloaded node, the Interp_Map table is accessed by means of a simple 58 -- hashing scheme, and the entries in Interp_Map are chained. The heads 59 -- of clash lists are stored in array Headers. 60 61 -- Headers Interp_Map All_Interp 62 -- 63 -- _ ------- ---------- 64 -- |_| |_____| --->|interp1 | 65 -- |_|---------->|node | | |interp2 | 66 -- |_| |index|---------| |nointerp| 67 -- |_| |next | | | 68 -- |-----| | | 69 -- ------- ---------- 70 71 -- This scheme does not currently reclaim interpretations. In principle, 72 -- after a unit is compiled, all overloadings have been resolved, and the 73 -- candidate interpretations should be deleted. This should be easier 74 -- now than with the previous scheme??? 75 76 package All_Interp is new Table.Table ( 77 Table_Component_Type => Interp, 78 Table_Index_Type => Int, 79 Table_Low_Bound => 0, 80 Table_Initial => Alloc.All_Interp_Initial, 81 Table_Increment => Alloc.All_Interp_Increment, 82 Table_Name => "All_Interp"); 83 84 type Interp_Ref is record 85 Node : Node_Id; 86 Index : Interp_Index; 87 Next : Int; 88 end record; 89 90 Header_Size : constant Int := 2 ** 12; 91 No_Entry : constant Int := -1; 92 Headers : array (0 .. Header_Size) of Int := (others => No_Entry); 93 94 package Interp_Map is new Table.Table ( 95 Table_Component_Type => Interp_Ref, 96 Table_Index_Type => Int, 97 Table_Low_Bound => 0, 98 Table_Initial => Alloc.Interp_Map_Initial, 99 Table_Increment => Alloc.Interp_Map_Increment, 100 Table_Name => "Interp_Map"); 101 102 function Hash (N : Node_Id) return Int; 103 -- A trivial hashing function for nodes, used to insert an overloaded 104 -- node into the Interp_Map table. 105 106 ------------------------------------- 107 -- Handling of Overload Resolution -- 108 ------------------------------------- 109 110 -- Overload resolution uses two passes over the syntax tree of a complete 111 -- context. In the first, bottom-up pass, the types of actuals in calls 112 -- are used to resolve possibly overloaded subprogram and operator names. 113 -- In the second top-down pass, the type of the context (for example the 114 -- condition in a while statement) is used to resolve a possibly ambiguous 115 -- call, and the unique subprogram name in turn imposes a specific context 116 -- on each of its actuals. 117 118 -- Most expressions are in fact unambiguous, and the bottom-up pass is 119 -- sufficient to resolve most everything. To simplify the common case, 120 -- names and expressions carry a flag Is_Overloaded to indicate whether 121 -- they have more than one interpretation. If the flag is off, then each 122 -- name has already a unique meaning and type, and the bottom-up pass is 123 -- sufficient (and much simpler). 124 125 -------------------------- 126 -- Operator Overloading -- 127 -------------------------- 128 129 -- The visibility of operators is handled differently from that of 130 -- other entities. We do not introduce explicit versions of primitive 131 -- operators for each type definition. As a result, there is only one 132 -- entity corresponding to predefined addition on all numeric types, etc. 133 -- The back-end resolves predefined operators according to their type. 134 -- The visibility of primitive operations then reduces to the visibility 135 -- of the resulting type: (a + b) is a legal interpretation of some 136 -- primitive operator + if the type of the result (which must also be 137 -- the type of a and b) is directly visible (i.e. either immediately 138 -- visible or use-visible.) 139 140 -- User-defined operators are treated like other functions, but the 141 -- visibility of these user-defined operations must be special-cased 142 -- to determine whether they hide or are hidden by predefined operators. 143 -- The form P."+" (x, y) requires additional handling. 144 -- 145 -- Concatenation is treated more conventionally: for every one-dimensional 146 -- array type we introduce a explicit concatenation operator. This is 147 -- necessary to handle the case of (element & element => array) which 148 -- cannot be handled conveniently if there is no explicit instance of 149 -- resulting type of the operation. 150 151 ----------------------- 152 -- Local Subprograms -- 153 ----------------------- 154 155 procedure All_Overloads; 156 pragma Warnings (Off, All_Overloads); 157 -- Debugging procedure: list full contents of Overloads table. 158 159 procedure New_Interps (N : Node_Id); 160 -- Initialize collection of interpretations for the given node, which is 161 -- either an overloaded entity, or an operation whose arguments have 162 -- multiple intepretations. Interpretations can be added to only one 163 -- node at a time. 164 165 function Specific_Type (T1, T2 : Entity_Id) return Entity_Id; 166 -- If T1 and T2 are compatible, return the one that is not 167 -- universal or is not a "class" type (any_character, etc). 168 169 -------------------- 170 -- Add_One_Interp -- 171 -------------------- 172 173 procedure Add_One_Interp 174 (N : Node_Id; 175 E : Entity_Id; 176 T : Entity_Id; 177 Opnd_Type : Entity_Id := Empty) 178 is 179 Vis_Type : Entity_Id; 180 181 procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id); 182 -- Add one interpretation to node. Node is already known to be 183 -- overloaded. Add new interpretation if not hidden by previous 184 -- one, and remove previous one if hidden by new one. 185 186 function Is_Universal_Operation (Op : Entity_Id) return Boolean; 187 -- True if the entity is a predefined operator and the operands have 188 -- a universal Interpretation. 189 190 --------------- 191 -- Add_Entry -- 192 --------------- 193 194 procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is 195 Index : Interp_Index; 196 It : Interp; 197 198 begin 199 Get_First_Interp (N, Index, It); 200 201 while Present (It.Nam) loop 202 203 -- A user-defined subprogram hides another declared at an outer 204 -- level, or one that is use-visible. So return if previous 205 -- definition hides new one (which is either in an outer 206 -- scope, or use-visible). Note that for functions use-visible 207 -- is the same as potentially use-visible. If new one hides 208 -- previous one, replace entry in table of interpretations. 209 -- If this is a universal operation, retain the operator in case 210 -- preference rule applies. 211 212 if (((Ekind (Name) = E_Function or else Ekind (Name) = E_Procedure) 213 and then Ekind (Name) = Ekind (It.Nam)) 214 or else (Ekind (Name) = E_Operator 215 and then Ekind (It.Nam) = E_Function)) 216 217 and then Is_Immediately_Visible (It.Nam) 218 and then Type_Conformant (Name, It.Nam) 219 and then Base_Type (It.Typ) = Base_Type (T) 220 then 221 if Is_Universal_Operation (Name) then 222 exit; 223 224 -- If node is an operator symbol, we have no actuals with 225 -- which to check hiding, and this is done in full in the 226 -- caller (Analyze_Subprogram_Renaming) so we include the 227 -- predefined operator in any case. 228 229 elsif Nkind (N) = N_Operator_Symbol 230 or else (Nkind (N) = N_Expanded_Name 231 and then 232 Nkind (Selector_Name (N)) = N_Operator_Symbol) 233 then 234 exit; 235 236 elsif not In_Open_Scopes (Scope (Name)) 237 or else Scope_Depth (Scope (Name)) 238 <= Scope_Depth (Scope (It.Nam)) 239 then 240 -- If ambiguity within instance, and entity is not an 241 -- implicit operation, save for later disambiguation. 242 243 if Scope (Name) = Scope (It.Nam) 244 and then not Is_Inherited_Operation (Name) 245 and then In_Instance 246 then 247 exit; 248 else 249 return; 250 end if; 251 252 else 253 All_Interp.Table (Index).Nam := Name; 254 return; 255 end if; 256 257 -- Avoid making duplicate entries in overloads 258 259 elsif Name = It.Nam 260 and then Base_Type (It.Typ) = Base_Type (T) 261 then 262 return; 263 264 -- Otherwise keep going 265 266 else 267 Get_Next_Interp (Index, It); 268 end if; 269 270 end loop; 271 272 -- On exit, enter new interpretation. The context, or a preference 273 -- rule, will resolve the ambiguity on the second pass. 274 275 All_Interp.Table (All_Interp.Last) := (Name, Typ); 276 All_Interp.Increment_Last; 277 All_Interp.Table (All_Interp.Last) := No_Interp; 278 end Add_Entry; 279 280 ---------------------------- 281 -- Is_Universal_Operation -- 282 ---------------------------- 283 284 function Is_Universal_Operation (Op : Entity_Id) return Boolean is 285 Arg : Node_Id; 286 287 begin 288 if Ekind (Op) /= E_Operator then 289 return False; 290 291 elsif Nkind (N) in N_Binary_Op then 292 return Present (Universal_Interpretation (Left_Opnd (N))) 293 and then Present (Universal_Interpretation (Right_Opnd (N))); 294 295 elsif Nkind (N) in N_Unary_Op then 296 return Present (Universal_Interpretation (Right_Opnd (N))); 297 298 elsif Nkind (N) = N_Function_Call then 299 Arg := First_Actual (N); 300 301 while Present (Arg) loop 302 303 if No (Universal_Interpretation (Arg)) then 304 return False; 305 end if; 306 307 Next_Actual (Arg); 308 end loop; 309 310 return True; 311 312 else 313 return False; 314 end if; 315 end Is_Universal_Operation; 316 317 -- Start of processing for Add_One_Interp 318 319 begin 320 -- If the interpretation is a predefined operator, verify that the 321 -- result type is visible, or that the entity has already been 322 -- resolved (case of an instantiation node that refers to a predefined 323 -- operation, or an internally generated operator node, or an operator 324 -- given as an expanded name). If the operator is a comparison or 325 -- equality, it is the type of the operand that matters to determine 326 -- whether the operator is visible. In an instance, the check is not 327 -- performed, given that the operator was visible in the generic. 328 329 if Ekind (E) = E_Operator then 330 331 if Present (Opnd_Type) then 332 Vis_Type := Opnd_Type; 333 else 334 Vis_Type := Base_Type (T); 335 end if; 336 337 if In_Open_Scopes (Scope (Vis_Type)) 338 or else Is_Potentially_Use_Visible (Vis_Type) 339 or else In_Use (Vis_Type) 340 or else (In_Use (Scope (Vis_Type)) 341 and then not Is_Hidden (Vis_Type)) 342 or else Nkind (N) = N_Expanded_Name 343 or else (Nkind (N) in N_Op and then E = Entity (N)) 344 or else In_Instance 345 then 346 null; 347 348 -- If the node is given in functional notation and the prefix 349 -- is an expanded name, then the operator is visible if the 350 -- prefix is the scope of the result type as well. If the 351 -- operator is (implicitly) defined in an extension of system, 352 -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb). 353 354 elsif Nkind (N) = N_Function_Call 355 and then Nkind (Name (N)) = N_Expanded_Name 356 and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T)) 357 or else Entity (Prefix (Name (N))) = Scope (Vis_Type) 358 or else Scope (Vis_Type) = System_Aux_Id) 359 then 360 null; 361 362 -- Save type for subsequent error message, in case no other 363 -- interpretation is found. 364 365 else 366 Candidate_Type := Vis_Type; 367 return; 368 end if; 369 370 -- In an instance, an abstract non-dispatching operation cannot 371 -- be a candidate interpretation, because it could not have been 372 -- one in the generic (it may be a spurious overloading in the 373 -- instance). 374 375 elsif In_Instance 376 and then Is_Abstract (E) 377 and then not Is_Dispatching_Operation (E) 378 then 379 return; 380 end if; 381 382 -- If this is the first interpretation of N, N has type Any_Type. 383 -- In that case place the new type on the node. If one interpretation 384 -- already exists, indicate that the node is overloaded, and store 385 -- both the previous and the new interpretation in All_Interp. If 386 -- this is a later interpretation, just add it to the set. 387 388 if Etype (N) = Any_Type then 389 if Is_Type (E) then 390 Set_Etype (N, T); 391 392 else 393 -- Record both the operator or subprogram name, and its type. 394 395 if Nkind (N) in N_Op or else Is_Entity_Name (N) then 396 Set_Entity (N, E); 397 end if; 398 399 Set_Etype (N, T); 400 end if; 401 402 -- Either there is no current interpretation in the table for any 403 -- node or the interpretation that is present is for a different 404 -- node. In both cases add a new interpretation to the table. 405 406 elsif Interp_Map.Last < 0 407 or else 408 (Interp_Map.Table (Interp_Map.Last).Node /= N 409 and then not Is_Overloaded (N)) 410 then 411 New_Interps (N); 412 413 if (Nkind (N) in N_Op or else Is_Entity_Name (N)) 414 and then Present (Entity (N)) 415 then 416 Add_Entry (Entity (N), Etype (N)); 417 418 elsif (Nkind (N) = N_Function_Call 419 or else Nkind (N) = N_Procedure_Call_Statement) 420 and then (Nkind (Name (N)) = N_Operator_Symbol 421 or else Is_Entity_Name (Name (N))) 422 then 423 Add_Entry (Entity (Name (N)), Etype (N)); 424 425 else 426 -- Overloaded prefix in indexed or selected component, 427 -- or call whose name is an expresion or another call. 428 429 Add_Entry (Etype (N), Etype (N)); 430 end if; 431 432 Add_Entry (E, T); 433 434 else 435 Add_Entry (E, T); 436 end if; 437 end Add_One_Interp; 438 439 ------------------- 440 -- All_Overloads -- 441 ------------------- 442 443 procedure All_Overloads is 444 begin 445 for J in All_Interp.First .. All_Interp.Last loop 446 447 if Present (All_Interp.Table (J).Nam) then 448 Write_Entity_Info (All_Interp.Table (J). Nam, " "); 449 else 450 Write_Str ("No Interp"); 451 end if; 452 453 Write_Str ("================="); 454 Write_Eol; 455 end loop; 456 end All_Overloads; 457 458 --------------------- 459 -- Collect_Interps -- 460 --------------------- 461 462 procedure Collect_Interps (N : Node_Id) is 463 Ent : constant Entity_Id := Entity (N); 464 H : Entity_Id; 465 First_Interp : Interp_Index; 466 467 begin 468 New_Interps (N); 469 470 -- Unconditionally add the entity that was initially matched 471 472 First_Interp := All_Interp.Last; 473 Add_One_Interp (N, Ent, Etype (N)); 474 475 -- For expanded name, pick up all additional entities from the 476 -- same scope, since these are obviously also visible. Note that 477 -- these are not necessarily contiguous on the homonym chain. 478 479 if Nkind (N) = N_Expanded_Name then 480 H := Homonym (Ent); 481 while Present (H) loop 482 if Scope (H) = Scope (Entity (N)) then 483 Add_One_Interp (N, H, Etype (H)); 484 end if; 485 486 H := Homonym (H); 487 end loop; 488 489 -- Case of direct name 490 491 else 492 -- First, search the homonym chain for directly visible entities 493 494 H := Current_Entity (Ent); 495 while Present (H) loop 496 exit when (not Is_Overloadable (H)) 497 and then Is_Immediately_Visible (H); 498 499 if Is_Immediately_Visible (H) 500 and then H /= Ent 501 then 502 -- Only add interpretation if not hidden by an inner 503 -- immediately visible one. 504 505 for J in First_Interp .. All_Interp.Last - 1 loop 506 507 -- Current homograph is not hidden. Add to overloads. 508 509 if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then 510 exit; 511 512 -- Homograph is hidden, unless it is a predefined operator. 513 514 elsif Type_Conformant (H, All_Interp.Table (J).Nam) then 515 516 -- A homograph in the same scope can occur within an 517 -- instantiation, the resulting ambiguity has to be 518 -- resolved later. 519 520 if Scope (H) = Scope (Ent) 521 and then In_Instance 522 and then not Is_Inherited_Operation (H) 523 then 524 All_Interp.Table (All_Interp.Last) := (H, Etype (H)); 525 All_Interp.Increment_Last; 526 All_Interp.Table (All_Interp.Last) := No_Interp; 527 goto Next_Homograph; 528 529 elsif Scope (H) /= Standard_Standard then 530 goto Next_Homograph; 531 end if; 532 end if; 533 end loop; 534 535 -- On exit, we know that current homograph is not hidden. 536 537 Add_One_Interp (N, H, Etype (H)); 538 539 if Debug_Flag_E then 540 Write_Str ("Add overloaded Interpretation "); 541 Write_Int (Int (H)); 542 Write_Eol; 543 end if; 544 end if; 545 546 <<Next_Homograph>> 547 H := Homonym (H); 548 end loop; 549 550 -- Scan list of homographs for use-visible entities only. 551 552 H := Current_Entity (Ent); 553 554 while Present (H) loop 555 if Is_Potentially_Use_Visible (H) 556 and then H /= Ent 557 and then Is_Overloadable (H) 558 then 559 for J in First_Interp .. All_Interp.Last - 1 loop 560 561 if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then 562 exit; 563 564 elsif Type_Conformant (H, All_Interp.Table (J).Nam) then 565 goto Next_Use_Homograph; 566 end if; 567 end loop; 568 569 Add_One_Interp (N, H, Etype (H)); 570 end if; 571 572 <<Next_Use_Homograph>> 573 H := Homonym (H); 574 end loop; 575 end if; 576 577 if All_Interp.Last = First_Interp + 1 then 578 579 -- The original interpretation is in fact not overloaded. 580 581 Set_Is_Overloaded (N, False); 582 end if; 583 end Collect_Interps; 584 585 ------------ 586 -- Covers -- 587 ------------ 588 589 function Covers (T1, T2 : Entity_Id) return Boolean is 590 591 function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean; 592 -- In an instance the proper view may not always be correct for 593 -- private types, but private and full view are compatible. This 594 -- removes spurious errors from nested instantiations that involve, 595 -- among other things, types derived from private types. 596 597 ---------------------- 598 -- Full_View_Covers -- 599 ---------------------- 600 601 function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean is 602 begin 603 return 604 Is_Private_Type (Typ1) 605 and then 606 ((Present (Full_View (Typ1)) 607 and then Covers (Full_View (Typ1), Typ2)) 608 or else Base_Type (Typ1) = Typ2 609 or else Base_Type (Typ2) = Typ1); 610 end Full_View_Covers; 611 612 -- Start of processing for Covers 613 614 begin 615 -- If either operand missing, then this is an error, but ignore 616 -- it (and pretend we have a cover) if errors already detected, 617 -- since this may simply mean we have malformed trees. 618 619 if No (T1) or else No (T2) then 620 if Total_Errors_Detected /= 0 then 621 return True; 622 else 623 raise Program_Error; 624 end if; 625 end if; 626 627 -- Simplest case: same types are compatible, and types that have the 628 -- same base type and are not generic actuals are compatible. Generic 629 -- actuals belong to their class but are not compatible with other 630 -- types of their class, and in particular with other generic actuals. 631 -- They are however compatible with their own subtypes, and itypes 632 -- with the same base are compatible as well. Similary, constrained 633 -- subtypes obtained from expressions of an unconstrained nominal type 634 -- are compatible with the base type (may lead to spurious ambiguities 635 -- in obscure cases ???) 636 637 -- Generic actuals require special treatment to avoid spurious ambi- 638 -- guities in an instance, when two formal types are instantiated with 639 -- the same actual, so that different subprograms end up with the same 640 -- signature in the instance. 641 642 if T1 = T2 then 643 return True; 644 645 elsif Base_Type (T1) = Base_Type (T2) then 646 if not Is_Generic_Actual_Type (T1) then 647 return True; 648 else 649 return (not Is_Generic_Actual_Type (T2) 650 or else Is_Itype (T1) 651 or else Is_Itype (T2) 652 or else Is_Constr_Subt_For_U_Nominal (T1) 653 or else Is_Constr_Subt_For_U_Nominal (T2) 654 or else Scope (T1) /= Scope (T2)); 655 end if; 656 657 -- Literals are compatible with types in a given "class" 658 659 elsif (T2 = Universal_Integer and then Is_Integer_Type (T1)) 660 or else (T2 = Universal_Real and then Is_Real_Type (T1)) 661 or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1)) 662 or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1)) 663 or else (T2 = Any_String and then Is_String_Type (T1)) 664 or else (T2 = Any_Character and then Is_Character_Type (T1)) 665 or else (T2 = Any_Access and then Is_Access_Type (T1)) 666 then 667 return True; 668 669 -- The context may be class wide. 670 671 elsif Is_Class_Wide_Type (T1) 672 and then Is_Ancestor (Root_Type (T1), T2) 673 then 674 return True; 675 676 elsif Is_Class_Wide_Type (T1) 677 and then Is_Class_Wide_Type (T2) 678 and then Base_Type (Etype (T1)) = Base_Type (Etype (T2)) 679 then 680 return True; 681 682 -- In a dispatching call the actual may be class-wide 683 684 elsif Is_Class_Wide_Type (T2) 685 and then Base_Type (Root_Type (T2)) = Base_Type (T1) 686 then 687 return True; 688 689 -- Some contexts require a class of types rather than a specific type 690 691 elsif (T1 = Any_Integer and then Is_Integer_Type (T2)) 692 or else (T1 = Any_Boolean and then Is_Boolean_Type (T2)) 693 or else (T1 = Any_Real and then Is_Real_Type (T2)) 694 or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2)) 695 or else (T1 = Any_Discrete and then Is_Discrete_Type (T2)) 696 then 697 return True; 698 699 -- An aggregate is compatible with an array or record type 700 701 elsif T2 = Any_Composite 702 and then Ekind (T1) in E_Array_Type .. E_Record_Subtype 703 then 704 return True; 705 706 -- If the expected type is an anonymous access, the designated 707 -- type must cover that of the expression. 708 709 elsif Ekind (T1) = E_Anonymous_Access_Type 710 and then Is_Access_Type (T2) 711 and then Covers (Designated_Type (T1), Designated_Type (T2)) 712 then 713 return True; 714 715 -- An Access_To_Subprogram is compatible with itself, or with an 716 -- anonymous type created for an attribute reference Access. 717 718 elsif (Ekind (Base_Type (T1)) = E_Access_Subprogram_Type 719 or else 720 Ekind (Base_Type (T1)) = E_Access_Protected_Subprogram_Type) 721 and then Is_Access_Type (T2) 722 and then (not Comes_From_Source (T1) 723 or else not Comes_From_Source (T2)) 724 and then (Is_Overloadable (Designated_Type (T2)) 725 or else 726 Ekind (Designated_Type (T2)) = E_Subprogram_Type) 727 and then 728 Type_Conformant (Designated_Type (T1), Designated_Type (T2)) 729 and then 730 Mode_Conformant (Designated_Type (T1), Designated_Type (T2)) 731 then 732 return True; 733 734 -- The context can be a remote access type, and the expression the 735 -- corresponding source type declared in a categorized package, or 736 -- viceversa. 737 738 elsif Is_Record_Type (T1) 739 and then (Is_Remote_Call_Interface (T1) 740 or else Is_Remote_Types (T1)) 741 and then Present (Corresponding_Remote_Type (T1)) 742 then 743 return Covers (Corresponding_Remote_Type (T1), T2); 744 745 elsif Is_Record_Type (T2) 746 and then (Is_Remote_Call_Interface (T2) 747 or else Is_Remote_Types (T2)) 748 and then Present (Corresponding_Remote_Type (T2)) 749 then 750 return Covers (Corresponding_Remote_Type (T2), T1); 751 752 elsif Ekind (T2) = E_Access_Attribute_Type 753 and then (Ekind (Base_Type (T1)) = E_General_Access_Type 754 or else Ekind (Base_Type (T1)) = E_Access_Type) 755 and then Covers (Designated_Type (T1), Designated_Type (T2)) 756 then 757 -- If the target type is a RACW type while the source is an access 758 -- attribute type, we are building a RACW that may be exported. 759 760 if Is_Remote_Access_To_Class_Wide_Type (Base_Type (T1)) then 761 Set_Has_RACW (Current_Sem_Unit); 762 end if; 763 764 return True; 765 766 elsif Ekind (T2) = E_Allocator_Type 767 and then Is_Access_Type (T1) 768 then 769 return Covers (Designated_Type (T1), Designated_Type (T2)) 770 or else 771 (From_With_Type (Designated_Type (T1)) 772 and then Covers (Designated_Type (T2), Designated_Type (T1))); 773 774 -- A boolean operation on integer literals is compatible with a 775 -- modular context. 776 777 elsif T2 = Any_Modular 778 and then Is_Modular_Integer_Type (T1) 779 then 780 return True; 781 782 -- The actual type may be the result of a previous error 783 784 elsif Base_Type (T2) = Any_Type then 785 return True; 786 787 -- A packed array type covers its corresponding non-packed type. 788 -- This is not legitimate Ada, but allows the omission of a number 789 -- of otherwise useless unchecked conversions, and since this can 790 -- only arise in (known correct) expanded code, no harm is done 791 792 elsif Is_Array_Type (T2) 793 and then Is_Packed (T2) 794 and then T1 = Packed_Array_Type (T2) 795 then 796 return True; 797 798 -- Similarly an array type covers its corresponding packed array type 799 800 elsif Is_Array_Type (T1) 801 and then Is_Packed (T1) 802 and then T2 = Packed_Array_Type (T1) 803 then 804 return True; 805 806 elsif In_Instance 807 and then 808 (Full_View_Covers (T1, T2) 809 or else Full_View_Covers (T2, T1)) 810 then 811 return True; 812 813 -- In the expansion of inlined bodies, types are compatible if they 814 -- are structurally equivalent. 815 816 elsif In_Inlined_Body 817 and then (Underlying_Type (T1) = Underlying_Type (T2) 818 or else (Is_Access_Type (T1) 819 and then Is_Access_Type (T2) 820 and then 821 Designated_Type (T1) = Designated_Type (T2)) 822 or else (T1 = Any_Access 823 and then Is_Access_Type (Underlying_Type (T2)))) 824 then 825 return True; 826 827 -- Ada0Y (AI-50217): Additional branches to make the shadow entity 828 -- compatible with its real entity. 829 830 elsif From_With_Type (T1) then 831 832 -- If the expected type is the non-limited view of a type, the 833 -- expression may have the limited view. 834 835 if Ekind (T1) = E_Incomplete_Type then 836 return Covers (Non_Limited_View (T1), T2); 837 838 elsif Ekind (T1) = E_Class_Wide_Type then 839 return 840 Covers (Class_Wide_Type (Non_Limited_View (Etype (T1))), T2); 841 else 842 return False; 843 end if; 844 845 elsif From_With_Type (T2) then 846 847 -- If units in the context have Limited_With clauses on each other, 848 -- either type might have a limited view. Checks performed elsewhere 849 -- verify that the context type is the non-limited view. 850 851 if Ekind (T2) = E_Incomplete_Type then 852 return Covers (T1, Non_Limited_View (T2)); 853 854 elsif Ekind (T2) = E_Class_Wide_Type then 855 return 856 Covers (T1, Class_Wide_Type (Non_Limited_View (Etype (T2)))); 857 else 858 return False; 859 end if; 860 861 -- Otherwise it doesn't cover! 862 863 else 864 return False; 865 end if; 866 end Covers; 867 868 ------------------ 869 -- Disambiguate -- 870 ------------------ 871 872 function Disambiguate 873 (N : Node_Id; 874 I1, I2 : Interp_Index; 875 Typ : Entity_Id) 876 return Interp 877 is 878 I : Interp_Index; 879 It : Interp; 880 It1, It2 : Interp; 881 Nam1, Nam2 : Entity_Id; 882 Predef_Subp : Entity_Id; 883 User_Subp : Entity_Id; 884 885 function Is_Actual_Subprogram (S : Entity_Id) return Boolean; 886 -- Determine whether a subprogram is an actual in an enclosing 887 -- instance. An overloading between such a subprogram and one 888 -- declared outside the instance is resolved in favor of the first, 889 -- because it resolved in the generic. 890 891 function Matches (Actual, Formal : Node_Id) return Boolean; 892 -- Look for exact type match in an instance, to remove spurious 893 -- ambiguities when two formal types have the same actual. 894 895 function Standard_Operator return Boolean; 896 897 function Remove_Conversions return Interp; 898 -- Last chance for pathological cases involving comparisons on 899 -- literals, and user overloadings of the same operator. Such 900 -- pathologies have been removed from the ACVC, but still appear in 901 -- two DEC tests, with the following notable quote from Ben Brosgol: 902 -- 903 -- [Note: I disclaim all credit/responsibility/blame for coming up with 904 -- this example; Robert Dewar brought it to our attention, since it 905 -- is apparently found in the ACVC 1.5. I did not attempt to find 906 -- the reason in the Reference Manual that makes the example legal, 907 -- since I was too nauseated by it to want to pursue it further.] 908 -- 909 -- Accordingly, this is not a fully recursive solution, but it handles 910 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes 911 -- pathology in the other direction with calls whose multiple overloaded 912 -- actuals make them truly unresolvable. 913 914 function Is_Actual_Subprogram (S : Entity_Id) return Boolean is 915 begin 916 return In_Open_Scopes (Scope (S)) 917 and then 918 (Is_Generic_Instance (Scope (S)) 919 or else Is_Wrapper_Package (Scope (S))); 920 end Is_Actual_Subprogram; 921 922 ------------- 923 -- Matches -- 924 ------------- 925 926 function Matches (Actual, Formal : Node_Id) return Boolean is 927 T1 : constant Entity_Id := Etype (Actual); 928 T2 : constant Entity_Id := Etype (Formal); 929 930 begin 931 return T1 = T2 932 or else 933 (Is_Numeric_Type (T2) 934 and then 935 (T1 = Universal_Real or else T1 = Universal_Integer)); 936 end Matches; 937 938 ------------------------ 939 -- Remove_Conversions -- 940 ------------------------ 941 942 function Remove_Conversions return Interp is 943 I : Interp_Index; 944 It : Interp; 945 It1 : Interp; 946 F1 : Entity_Id; 947 Act1 : Node_Id; 948 Act2 : Node_Id; 949 950 begin 951 It1 := No_Interp; 952 Get_First_Interp (N, I, It); 953 954 while Present (It.Typ) loop 955 956 if not Is_Overloadable (It.Nam) then 957 return No_Interp; 958 end if; 959 960 F1 := First_Formal (It.Nam); 961 962 if No (F1) then 963 return It1; 964 965 else 966 if Nkind (N) = N_Function_Call 967 or else Nkind (N) = N_Procedure_Call_Statement 968 then 969 Act1 := First_Actual (N); 970 971 if Present (Act1) then 972 Act2 := Next_Actual (Act1); 973 else 974 Act2 := Empty; 975 end if; 976 977 elsif Nkind (N) in N_Unary_Op then 978 Act1 := Right_Opnd (N); 979 Act2 := Empty; 980 981 elsif Nkind (N) in N_Binary_Op then 982 Act1 := Left_Opnd (N); 983 Act2 := Right_Opnd (N); 984 985 else 986 return It1; 987 end if; 988 989 if Nkind (Act1) in N_Op 990 and then Is_Overloaded (Act1) 991 and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal 992 or else Nkind (Right_Opnd (Act1)) = N_Real_Literal) 993 and then Has_Compatible_Type (Act1, Standard_Boolean) 994 and then Etype (F1) = Standard_Boolean 995 then 996 -- If the two candidates are the original ones, the 997 -- ambiguity is real. Otherwise keep the original, 998 -- further calls to Disambiguate will take care of 999 -- others in the list of candidates. 1000 1001 if It1 /= No_Interp then 1002 if It = Disambiguate.It1 1003 or else It = Disambiguate.It2 1004 then 1005 if It1 = Disambiguate.It1 1006 or else It1 = Disambiguate.It2 1007 then 1008 return No_Interp; 1009 else 1010 It1 := It; 1011 end if; 1012 end if; 1013 1014 elsif Present (Act2) 1015 and then Nkind (Act2) in N_Op 1016 and then Is_Overloaded (Act2) 1017 and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal 1018 or else 1019 Nkind (Right_Opnd (Act1)) = N_Real_Literal) 1020 and then Has_Compatible_Type (Act2, Standard_Boolean) 1021 then 1022 -- The preference rule on the first actual is not 1023 -- sufficient to disambiguate. 1024 1025 goto Next_Interp; 1026 1027 else 1028 It1 := It; 1029 end if; 1030 end if; 1031 end if; 1032 1033 <<Next_Interp>> 1034 Get_Next_Interp (I, It); 1035 end loop; 1036 1037 if Serious_Errors_Detected > 0 then 1038 1039 -- After some error, a formal may have Any_Type and yield 1040 -- a spurious match. To avoid cascaded errors if possible, 1041 -- check for such a formal in either candidate. 1042 1043 declare 1044 Formal : Entity_Id; 1045 1046 begin 1047 Formal := First_Formal (Nam1); 1048 while Present (Formal) loop 1049 if Etype (Formal) = Any_Type then 1050 return Disambiguate.It2; 1051 end if; 1052 1053 Next_Formal (Formal); 1054 end loop; 1055 1056 Formal := First_Formal (Nam2); 1057 while Present (Formal) loop 1058 if Etype (Formal) = Any_Type then 1059 return Disambiguate.It1; 1060 end if; 1061 1062 Next_Formal (Formal); 1063 end loop; 1064 end; 1065 end if; 1066 1067 return It1; 1068 end Remove_Conversions; 1069 1070 ----------------------- 1071 -- Standard_Operator -- 1072 ----------------------- 1073 1074 function Standard_Operator return Boolean is 1075 Nam : Node_Id; 1076 1077 begin 1078 if Nkind (N) in N_Op then 1079 return True; 1080 1081 elsif Nkind (N) = N_Function_Call then 1082 Nam := Name (N); 1083 1084 if Nkind (Nam) /= N_Expanded_Name then 1085 return True; 1086 else 1087 return Entity (Prefix (Nam)) = Standard_Standard; 1088 end if; 1089 else 1090 return False; 1091 end if; 1092 end Standard_Operator; 1093 1094 -- Start of processing for Disambiguate 1095 1096 begin 1097 -- Recover the two legal interpretations. 1098 1099 Get_First_Interp (N, I, It); 1100 1101 while I /= I1 loop 1102 Get_Next_Interp (I, It); 1103 end loop; 1104 1105 It1 := It; 1106 Nam1 := It.Nam; 1107 1108 while I /= I2 loop 1109 Get_Next_Interp (I, It); 1110 end loop; 1111 1112 It2 := It; 1113 Nam2 := It.Nam; 1114 1115 -- If the context is universal, the predefined operator is preferred. 1116 -- This includes bounds in numeric type declarations, and expressions 1117 -- in type conversions. If no interpretation yields a universal type, 1118 -- then we must check whether the user-defined entity hides the prede- 1119 -- fined one. 1120 1121 if Chars (Nam1) in Any_Operator_Name 1122 and then Standard_Operator 1123 then 1124 if Typ = Universal_Integer 1125 or else Typ = Universal_Real 1126 or else Typ = Any_Integer 1127 or else Typ = Any_Discrete 1128 or else Typ = Any_Real 1129 or else Typ = Any_Type 1130 then 1131 -- Find an interpretation that yields the universal type, or else 1132 -- a predefined operator that yields a predefined numeric type. 1133 1134 declare 1135 Candidate : Interp := No_Interp; 1136 begin 1137 Get_First_Interp (N, I, It); 1138 1139 while Present (It.Typ) loop 1140 if (Covers (Typ, It.Typ) 1141 or else Typ = Any_Type) 1142 and then 1143 (It.Typ = Universal_Integer 1144 or else It.Typ = Universal_Real) 1145 then 1146 return It; 1147 1148 elsif Covers (Typ, It.Typ) 1149 and then Scope (It.Typ) = Standard_Standard 1150 and then Scope (It.Nam) = Standard_Standard 1151 and then Is_Numeric_Type (It.Typ) 1152 then 1153 Candidate := It; 1154 end if; 1155 1156 Get_Next_Interp (I, It); 1157 end loop; 1158 1159 if Candidate /= No_Interp then 1160 return Candidate; 1161 end if; 1162 end; 1163 1164 elsif Chars (Nam1) /= Name_Op_Not 1165 and then (Typ = Standard_Boolean 1166 or else Typ = Any_Boolean) 1167 then 1168 -- Equality or comparison operation. Choose predefined operator 1169 -- if arguments are universal. The node may be an operator, a 1170 -- name, or a function call, so unpack arguments accordingly. 1171 1172 declare 1173 Arg1, Arg2 : Node_Id; 1174 1175 begin 1176 if Nkind (N) in N_Op then 1177 Arg1 := Left_Opnd (N); 1178 Arg2 := Right_Opnd (N); 1179 1180 elsif Is_Entity_Name (N) 1181 or else Nkind (N) = N_Operator_Symbol 1182 then 1183 Arg1 := First_Entity (Entity (N)); 1184 Arg2 := Next_Entity (Arg1); 1185 1186 else 1187 Arg1 := First_Actual (N); 1188 Arg2 := Next_Actual (Arg1); 1189 end if; 1190 1191 if Present (Arg2) 1192 and then Present (Universal_Interpretation (Arg1)) 1193 and then Universal_Interpretation (Arg2) = 1194 Universal_Interpretation (Arg1) 1195 then 1196 Get_First_Interp (N, I, It); 1197 1198 while Scope (It.Nam) /= Standard_Standard loop 1199 Get_Next_Interp (I, It); 1200 end loop; 1201 1202 return It; 1203 end if; 1204 end; 1205 end if; 1206 end if; 1207 1208 -- If no universal interpretation, check whether user-defined operator 1209 -- hides predefined one, as well as other special cases. If the node 1210 -- is a range, then one or both bounds are ambiguous. Each will have 1211 -- to be disambiguated w.r.t. the context type. The type of the range 1212 -- itself is imposed by the context, so we can return either legal 1213 -- interpretation. 1214 1215 if Ekind (Nam1) = E_Operator then 1216 Predef_Subp := Nam1; 1217 User_Subp := Nam2; 1218 1219 elsif Ekind (Nam2) = E_Operator then 1220 Predef_Subp := Nam2; 1221 User_Subp := Nam1; 1222 1223 elsif Nkind (N) = N_Range then 1224 return It1; 1225 1226 -- If two user defined-subprograms are visible, it is a true ambiguity, 1227 -- unless one of them is an entry and the context is a conditional or 1228 -- timed entry call, or unless we are within an instance and this is 1229 -- results from two formals types with the same actual. 1230 1231 else 1232 if Nkind (N) = N_Procedure_Call_Statement 1233 and then Nkind (Parent (N)) = N_Entry_Call_Alternative 1234 and then N = Entry_Call_Statement (Parent (N)) 1235 then 1236 if Ekind (Nam2) = E_Entry then 1237 return It2; 1238 elsif Ekind (Nam1) = E_Entry then 1239 return It1; 1240 else 1241 return No_Interp; 1242 end if; 1243 1244 -- If the ambiguity occurs within an instance, it is due to several 1245 -- formal types with the same actual. Look for an exact match 1246 -- between the types of the formals of the overloadable entities, 1247 -- and the actuals in the call, to recover the unambiguous match 1248 -- in the original generic. 1249 1250 -- The ambiguity can also be due to an overloading between a formal 1251 -- subprogram and a subprogram declared outside the generic. If the 1252 -- node is overloaded, it did not resolve to the global entity in 1253 -- the generic, and we choose the formal subprogram. 1254 1255 elsif In_Instance then 1256 if Nkind (N) = N_Function_Call 1257 or else Nkind (N) = N_Procedure_Call_Statement 1258 then 1259 declare 1260 Actual : Node_Id; 1261 Formal : Entity_Id; 1262 Is_Act1 : constant Boolean := Is_Actual_Subprogram (Nam1); 1263 Is_Act2 : constant Boolean := Is_Actual_Subprogram (Nam2); 1264 1265 begin 1266 if Is_Act1 and then not Is_Act2 then 1267 return It1; 1268 1269 elsif Is_Act2 and then not Is_Act1 then 1270 return It2; 1271 end if; 1272 1273 Actual := First_Actual (N); 1274 Formal := First_Formal (Nam1); 1275 while Present (Actual) loop 1276 if Etype (Actual) /= Etype (Formal) then 1277 return It2; 1278 end if; 1279 1280 Next_Actual (Actual); 1281 Next_Formal (Formal); 1282 end loop; 1283 1284 return It1; 1285 end; 1286 1287 elsif Nkind (N) in N_Binary_Op then 1288 1289 if Matches (Left_Opnd (N), First_Formal (Nam1)) 1290 and then 1291 Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1))) 1292 then 1293 return It1; 1294 else 1295 return It2; 1296 end if; 1297 1298 elsif Nkind (N) in N_Unary_Op then 1299 1300 if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then 1301 return It1; 1302 else 1303 return It2; 1304 end if; 1305 1306 else 1307 return Remove_Conversions; 1308 end if; 1309 else 1310 return Remove_Conversions; 1311 end if; 1312 end if; 1313 1314 -- an implicit concatenation operator on a string type cannot be 1315 -- disambiguated from the predefined concatenation. This can only 1316 -- happen with concatenation of string literals. 1317 1318 if Chars (User_Subp) = Name_Op_Concat 1319 and then Ekind (User_Subp) = E_Operator 1320 and then Is_String_Type (Etype (First_Formal (User_Subp))) 1321 then 1322 return No_Interp; 1323 1324 -- If the user-defined operator is in an open scope, or in the scope 1325 -- of the resulting type, or given by an expanded name that names its 1326 -- scope, it hides the predefined operator for the type. Exponentiation 1327 -- has to be special-cased because the implicit operator does not have 1328 -- a symmetric signature, and may not be hidden by the explicit one. 1329 1330 elsif (Nkind (N) = N_Function_Call 1331 and then Nkind (Name (N)) = N_Expanded_Name 1332 and then (Chars (Predef_Subp) /= Name_Op_Expon 1333 or else Hides_Op (User_Subp, Predef_Subp)) 1334 and then Scope (User_Subp) = Entity (Prefix (Name (N)))) 1335 or else Hides_Op (User_Subp, Predef_Subp) 1336 then 1337 if It1.Nam = User_Subp then 1338 return It1; 1339 else 1340 return It2; 1341 end if; 1342 1343 -- Otherwise, the predefined operator has precedence, or if the 1344 -- user-defined operation is directly visible we have a true ambiguity. 1345 -- If this is a fixed-point multiplication and division in Ada83 mode, 1346 -- exclude the universal_fixed operator, which often causes ambiguities 1347 -- in legacy code. 1348 1349 else 1350 if (In_Open_Scopes (Scope (User_Subp)) 1351 or else Is_Potentially_Use_Visible (User_Subp)) 1352 and then not In_Instance 1353 then 1354 if Is_Fixed_Point_Type (Typ) 1355 and then (Chars (Nam1) = Name_Op_Multiply 1356 or else Chars (Nam1) = Name_Op_Divide) 1357 and then Ada_83 1358 then 1359 if It2.Nam = Predef_Subp then 1360 return It1; 1361 1362 else 1363 return It2; 1364 end if; 1365 else 1366 return No_Interp; 1367 end if; 1368 1369 elsif It1.Nam = Predef_Subp then 1370 return It1; 1371 1372 else 1373 return It2; 1374 end if; 1375 end if; 1376 1377 end Disambiguate; 1378 1379 --------------------- 1380 -- End_Interp_List -- 1381 --------------------- 1382 1383 procedure End_Interp_List is 1384 begin 1385 All_Interp.Table (All_Interp.Last) := No_Interp; 1386 All_Interp.Increment_Last; 1387 end End_Interp_List; 1388 1389 ------------------------- 1390 -- Entity_Matches_Spec -- 1391 ------------------------- 1392 1393 function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is 1394 begin 1395 -- Simple case: same entity kinds, type conformance is required. 1396 -- A parameterless function can also rename a literal. 1397 1398 if Ekind (Old_S) = Ekind (New_S) 1399 or else (Ekind (New_S) = E_Function 1400 and then Ekind (Old_S) = E_Enumeration_Literal) 1401 then 1402 return Type_Conformant (New_S, Old_S); 1403 1404 elsif Ekind (New_S) = E_Function 1405 and then Ekind (Old_S) = E_Operator 1406 then 1407 return Operator_Matches_Spec (Old_S, New_S); 1408 1409 elsif Ekind (New_S) = E_Procedure 1410 and then Is_Entry (Old_S) 1411 then 1412 return Type_Conformant (New_S, Old_S); 1413 1414 else 1415 return False; 1416 end if; 1417 end Entity_Matches_Spec; 1418 1419 ---------------------- 1420 -- Find_Unique_Type -- 1421 ---------------------- 1422 1423 function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is 1424 T : constant Entity_Id := Etype (L); 1425 I : Interp_Index; 1426 It : Interp; 1427 TR : Entity_Id := Any_Type; 1428 1429 begin 1430 if Is_Overloaded (R) then 1431 Get_First_Interp (R, I, It); 1432 1433 while Present (It.Typ) loop 1434 if Covers (T, It.Typ) or else Covers (It.Typ, T) then 1435 1436 -- If several interpretations are possible and L is universal, 1437 -- apply preference rule. 1438 1439 if TR /= Any_Type then 1440 1441 if (T = Universal_Integer or else T = Universal_Real) 1442 and then It.Typ = T 1443 then 1444 TR := It.Typ; 1445 end if; 1446 1447 else 1448 TR := It.Typ; 1449 end if; 1450 end if; 1451 1452 Get_Next_Interp (I, It); 1453 end loop; 1454 1455 Set_Etype (R, TR); 1456 1457 -- In the non-overloaded case, the Etype of R is already set 1458 -- correctly. 1459 1460 else 1461 null; 1462 end if; 1463 1464 -- If one of the operands is Universal_Fixed, the type of the 1465 -- other operand provides the context. 1466 1467 if Etype (R) = Universal_Fixed then 1468 return T; 1469 1470 elsif T = Universal_Fixed then 1471 return Etype (R); 1472 1473 else 1474 return Specific_Type (T, Etype (R)); 1475 end if; 1476 1477 end Find_Unique_Type; 1478 1479 ---------------------- 1480 -- Get_First_Interp -- 1481 ---------------------- 1482 1483 procedure Get_First_Interp 1484 (N : Node_Id; 1485 I : out Interp_Index; 1486 It : out Interp) 1487 is 1488 Map_Ptr : Int; 1489 Int_Ind : Interp_Index; 1490 O_N : Node_Id; 1491 1492 begin 1493 -- If a selected component is overloaded because the selector has 1494 -- multiple interpretations, the node is a call to a protected 1495 -- operation or an indirect call. Retrieve the interpretation from 1496 -- the selector name. The selected component may be overloaded as well 1497 -- if the prefix is overloaded. That case is unchanged. 1498 1499 if Nkind (N) = N_Selected_Component 1500 and then Is_Overloaded (Selector_Name (N)) 1501 then 1502 O_N := Selector_Name (N); 1503 else 1504 O_N := N; 1505 end if; 1506 1507 Map_Ptr := Headers (Hash (O_N)); 1508 1509 while Present (Interp_Map.Table (Map_Ptr).Node) loop 1510 if Interp_Map.Table (Map_Ptr).Node = O_N then 1511 Int_Ind := Interp_Map.Table (Map_Ptr).Index; 1512 It := All_Interp.Table (Int_Ind); 1513 I := Int_Ind; 1514 return; 1515 else 1516 Map_Ptr := Interp_Map.Table (Map_Ptr).Next; 1517 end if; 1518 end loop; 1519 1520 -- Procedure should never be called if the node has no interpretations 1521 1522 raise Program_Error; 1523 end Get_First_Interp; 1524 1525 ---------------------- 1526 -- Get_Next_Interp -- 1527 ---------------------- 1528 1529 procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is 1530 begin 1531 I := I + 1; 1532 It := All_Interp.Table (I); 1533 end Get_Next_Interp; 1534 1535 ------------------------- 1536 -- Has_Compatible_Type -- 1537 ------------------------- 1538 1539 function Has_Compatible_Type 1540 (N : Node_Id; 1541 Typ : Entity_Id) 1542 return Boolean 1543 is 1544 I : Interp_Index; 1545 It : Interp; 1546 1547 begin 1548 if N = Error then 1549 return False; 1550 end if; 1551 1552 if Nkind (N) = N_Subtype_Indication 1553 or else not Is_Overloaded (N) 1554 then 1555 return 1556 Covers (Typ, Etype (N)) 1557 or else 1558 (not Is_Tagged_Type (Typ) 1559 and then Ekind (Typ) /= E_Anonymous_Access_Type 1560 and then Covers (Etype (N), Typ)); 1561 1562 else 1563 Get_First_Interp (N, I, It); 1564 1565 while Present (It.Typ) loop 1566 if (Covers (Typ, It.Typ) 1567 and then 1568 (Scope (It.Nam) /= Standard_Standard 1569 or else not Is_Invisible_Operator (N, Base_Type (Typ)))) 1570 1571 or else (not Is_Tagged_Type (Typ) 1572 and then Ekind (Typ) /= E_Anonymous_Access_Type 1573 and then Covers (It.Typ, Typ)) 1574 then 1575 return True; 1576 end if; 1577 1578 Get_Next_Interp (I, It); 1579 end loop; 1580 1581 return False; 1582 end if; 1583 end Has_Compatible_Type; 1584 1585 ---------- 1586 -- Hash -- 1587 ---------- 1588 1589 function Hash (N : Node_Id) return Int is 1590 begin 1591 -- Nodes have a size that is power of two, so to select significant 1592 -- bits only we remove the low-order bits. 1593 1594 return ((Int (N) / 2 ** 5) mod Header_Size); 1595 end Hash; 1596 1597 -------------- 1598 -- Hides_Op -- 1599 -------------- 1600 1601 function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean is 1602 Btyp : constant Entity_Id := Base_Type (Etype (First_Formal (F))); 1603 1604 begin 1605 return Operator_Matches_Spec (Op, F) 1606 and then (In_Open_Scopes (Scope (F)) 1607 or else Scope (F) = Scope (Btyp) 1608 or else (not In_Open_Scopes (Scope (Btyp)) 1609 and then not In_Use (Btyp) 1610 and then not In_Use (Scope (Btyp)))); 1611 end Hides_Op; 1612 1613 ------------------------ 1614 -- Init_Interp_Tables -- 1615 ------------------------ 1616 1617 procedure Init_Interp_Tables is 1618 begin 1619 All_Interp.Init; 1620 Interp_Map.Init; 1621 Headers := (others => No_Entry); 1622 end Init_Interp_Tables; 1623 1624 --------------------- 1625 -- Intersect_Types -- 1626 --------------------- 1627 1628 function Intersect_Types (L, R : Node_Id) return Entity_Id is 1629 Index : Interp_Index; 1630 It : Interp; 1631 Typ : Entity_Id; 1632 1633 function Check_Right_Argument (T : Entity_Id) return Entity_Id; 1634 -- Find interpretation of right arg that has type compatible with T 1635 1636 -------------------------- 1637 -- Check_Right_Argument -- 1638 -------------------------- 1639 1640 function Check_Right_Argument (T : Entity_Id) return Entity_Id is 1641 Index : Interp_Index; 1642 It : Interp; 1643 T2 : Entity_Id; 1644 1645 begin 1646 if not Is_Overloaded (R) then 1647 return Specific_Type (T, Etype (R)); 1648 1649 else 1650 Get_First_Interp (R, Index, It); 1651 1652 loop 1653 T2 := Specific_Type (T, It.Typ); 1654 1655 if T2 /= Any_Type then 1656 return T2; 1657 end if; 1658 1659 Get_Next_Interp (Index, It); 1660 exit when No (It.Typ); 1661 end loop; 1662 1663 return Any_Type; 1664 end if; 1665 end Check_Right_Argument; 1666 1667 -- Start processing for Intersect_Types 1668 1669 begin 1670 if Etype (L) = Any_Type or else Etype (R) = Any_Type then 1671 return Any_Type; 1672 end if; 1673 1674 if not Is_Overloaded (L) then 1675 Typ := Check_Right_Argument (Etype (L)); 1676 1677 else 1678 Typ := Any_Type; 1679 Get_First_Interp (L, Index, It); 1680 1681 while Present (It.Typ) loop 1682 Typ := Check_Right_Argument (It.Typ); 1683 exit when Typ /= Any_Type; 1684 Get_Next_Interp (Index, It); 1685 end loop; 1686 1687 end if; 1688 1689 -- If Typ is Any_Type, it means no compatible pair of types was found 1690 1691 if Typ = Any_Type then 1692 1693 if Nkind (Parent (L)) in N_Op then 1694 Error_Msg_N ("incompatible types for operator", Parent (L)); 1695 1696 elsif Nkind (Parent (L)) = N_Range then 1697 Error_Msg_N ("incompatible types given in constraint", Parent (L)); 1698 1699 else 1700 Error_Msg_N ("incompatible types", Parent (L)); 1701 end if; 1702 end if; 1703 1704 return Typ; 1705 end Intersect_Types; 1706 1707 ----------------- 1708 -- Is_Ancestor -- 1709 ----------------- 1710 1711 function Is_Ancestor (T1, T2 : Entity_Id) return Boolean is 1712 Par : Entity_Id; 1713 1714 begin 1715 if Base_Type (T1) = Base_Type (T2) then 1716 return True; 1717 1718 elsif Is_Private_Type (T1) 1719 and then Present (Full_View (T1)) 1720 and then Base_Type (T2) = Base_Type (Full_View (T1)) 1721 then 1722 return True; 1723 1724 else 1725 Par := Etype (T2); 1726 1727 loop 1728 -- If there was a error on the type declaration, do not recurse 1729 1730 if Error_Posted (Par) then 1731 return False; 1732 1733 elsif Base_Type (T1) = Base_Type (Par) 1734 or else (Is_Private_Type (T1) 1735 and then Present (Full_View (T1)) 1736 and then Base_Type (Par) = Base_Type (Full_View (T1))) 1737 then 1738 return True; 1739 1740 elsif Is_Private_Type (Par) 1741 and then Present (Full_View (Par)) 1742 and then Full_View (Par) = Base_Type (T1) 1743 then 1744 return True; 1745 1746 elsif Etype (Par) /= Par then 1747 Par := Etype (Par); 1748 else 1749 return False; 1750 end if; 1751 end loop; 1752 end if; 1753 end Is_Ancestor; 1754 1755 --------------------------- 1756 -- Is_Invisible_Operator -- 1757 --------------------------- 1758 1759 function Is_Invisible_Operator 1760 (N : Node_Id; 1761 T : Entity_Id) 1762 return Boolean 1763 is 1764 Orig_Node : constant Node_Id := Original_Node (N); 1765 1766 begin 1767 if Nkind (N) not in N_Op then 1768 return False; 1769 1770 elsif not Comes_From_Source (N) then 1771 return False; 1772 1773 elsif No (Universal_Interpretation (Right_Opnd (N))) then 1774 return False; 1775 1776 elsif Nkind (N) in N_Binary_Op 1777 and then No (Universal_Interpretation (Left_Opnd (N))) 1778 then 1779 return False; 1780 1781 else return 1782 Is_Numeric_Type (T) 1783 and then not In_Open_Scopes (Scope (T)) 1784 and then not Is_Potentially_Use_Visible (T) 1785 and then not In_Use (T) 1786 and then not In_Use (Scope (T)) 1787 and then 1788 (Nkind (Orig_Node) /= N_Function_Call 1789 or else Nkind (Name (Orig_Node)) /= N_Expanded_Name 1790 or else Entity (Prefix (Name (Orig_Node))) /= Scope (T)) 1791 1792 and then not In_Instance; 1793 end if; 1794 end Is_Invisible_Operator; 1795 1796 ------------------- 1797 -- Is_Subtype_Of -- 1798 ------------------- 1799 1800 function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is 1801 S : Entity_Id; 1802 1803 begin 1804 S := Ancestor_Subtype (T1); 1805 while Present (S) loop 1806 if S = T2 then 1807 return True; 1808 else 1809 S := Ancestor_Subtype (S); 1810 end if; 1811 end loop; 1812 1813 return False; 1814 end Is_Subtype_Of; 1815 1816 ------------------ 1817 -- List_Interps -- 1818 ------------------ 1819 1820 procedure List_Interps (Nam : Node_Id; Err : Node_Id) is 1821 Index : Interp_Index; 1822 It : Interp; 1823 1824 begin 1825 Get_First_Interp (Nam, Index, It); 1826 while Present (It.Nam) loop 1827 if Scope (It.Nam) = Standard_Standard 1828 and then Scope (It.Typ) /= Standard_Standard 1829 then 1830 Error_Msg_Sloc := Sloc (Parent (It.Typ)); 1831 Error_Msg_NE (" & (inherited) declared#!", Err, It.Nam); 1832 1833 else 1834 Error_Msg_Sloc := Sloc (It.Nam); 1835 Error_Msg_NE (" & declared#!", Err, It.Nam); 1836 end if; 1837 1838 Get_Next_Interp (Index, It); 1839 end loop; 1840 end List_Interps; 1841 1842 ----------------- 1843 -- New_Interps -- 1844 ----------------- 1845 1846 procedure New_Interps (N : Node_Id) is 1847 Map_Ptr : Int; 1848 1849 begin 1850 All_Interp.Increment_Last; 1851 All_Interp.Table (All_Interp.Last) := No_Interp; 1852 1853 Map_Ptr := Headers (Hash (N)); 1854 1855 if Map_Ptr = No_Entry then 1856 1857 -- Place new node at end of table 1858 1859 Interp_Map.Increment_Last; 1860 Headers (Hash (N)) := Interp_Map.Last; 1861 1862 else 1863 -- Place node at end of chain, or locate its previous entry. 1864 1865 loop 1866 if Interp_Map.Table (Map_Ptr).Node = N then 1867 1868 -- Node is already in the table, and is being rewritten. 1869 -- Start a new interp section, retain hash link. 1870 1871 Interp_Map.Table (Map_Ptr).Node := N; 1872 Interp_Map.Table (Map_Ptr).Index := All_Interp.Last; 1873 Set_Is_Overloaded (N, True); 1874 return; 1875 1876 else 1877 exit when Interp_Map.Table (Map_Ptr).Next = No_Entry; 1878 Map_Ptr := Interp_Map.Table (Map_Ptr).Next; 1879 end if; 1880 end loop; 1881 1882 -- Chain the new node. 1883 1884 Interp_Map.Increment_Last; 1885 Interp_Map.Table (Map_Ptr).Next := Interp_Map.Last; 1886 end if; 1887 1888 Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last, No_Entry); 1889 Set_Is_Overloaded (N, True); 1890 end New_Interps; 1891 1892 --------------------------- 1893 -- Operator_Matches_Spec -- 1894 --------------------------- 1895 1896 function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is 1897 Op_Name : constant Name_Id := Chars (Op); 1898 T : constant Entity_Id := Etype (New_S); 1899 New_F : Entity_Id; 1900 Old_F : Entity_Id; 1901 Num : Int; 1902 T1 : Entity_Id; 1903 T2 : Entity_Id; 1904 1905 begin 1906 -- To verify that a predefined operator matches a given signature, 1907 -- do a case analysis of the operator classes. Function can have one 1908 -- or two formals and must have the proper result type. 1909 1910 New_F := First_Formal (New_S); 1911 Old_F := First_Formal (Op); 1912 Num := 0; 1913 1914 while Present (New_F) and then Present (Old_F) loop 1915 Num := Num + 1; 1916 Next_Formal (New_F); 1917 Next_Formal (Old_F); 1918 end loop; 1919 1920 -- Definite mismatch if different number of parameters 1921 1922 if Present (Old_F) or else Present (New_F) then 1923 return False; 1924 1925 -- Unary operators 1926 1927 elsif Num = 1 then 1928 T1 := Etype (First_Formal (New_S)); 1929 1930 if Op_Name = Name_Op_Subtract 1931 or else Op_Name = Name_Op_Add 1932 or else Op_Name = Name_Op_Abs 1933 then 1934 return Base_Type (T1) = Base_Type (T) 1935 and then Is_Numeric_Type (T); 1936 1937 elsif Op_Name = Name_Op_Not then 1938 return Base_Type (T1) = Base_Type (T) 1939 and then Valid_Boolean_Arg (Base_Type (T)); 1940 1941 else 1942 return False; 1943 end if; 1944 1945 -- Binary operators 1946 1947 else 1948 T1 := Etype (First_Formal (New_S)); 1949 T2 := Etype (Next_Formal (First_Formal (New_S))); 1950 1951 if Op_Name = Name_Op_And or else Op_Name = Name_Op_Or 1952 or else Op_Name = Name_Op_Xor 1953 then 1954 return Base_Type (T1) = Base_Type (T2) 1955 and then Base_Type (T1) = Base_Type (T) 1956 and then Valid_Boolean_Arg (Base_Type (T)); 1957 1958 elsif Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne then 1959 return Base_Type (T1) = Base_Type (T2) 1960 and then not Is_Limited_Type (T1) 1961 and then Is_Boolean_Type (T); 1962 1963 elsif Op_Name = Name_Op_Lt or else Op_Name = Name_Op_Le 1964 or else Op_Name = Name_Op_Gt or else Op_Name = Name_Op_Ge 1965 then 1966 return Base_Type (T1) = Base_Type (T2) 1967 and then Valid_Comparison_Arg (T1) 1968 and then Is_Boolean_Type (T); 1969 1970 elsif Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then 1971 return Base_Type (T1) = Base_Type (T2) 1972 and then Base_Type (T1) = Base_Type (T) 1973 and then Is_Numeric_Type (T); 1974 1975 -- for division and multiplication, a user-defined function does 1976 -- not match the predefined universal_fixed operation, except in 1977 -- Ada83 mode. 1978 1979 elsif Op_Name = Name_Op_Divide then 1980 return (Base_Type (T1) = Base_Type (T2) 1981 and then Base_Type (T1) = Base_Type (T) 1982 and then Is_Numeric_Type (T) 1983 and then (not Is_Fixed_Point_Type (T) 1984 or else Ada_83)) 1985 1986 -- Mixed_Mode operations on fixed-point types. 1987 1988 or else (Base_Type (T1) = Base_Type (T) 1989 and then Base_Type (T2) = Base_Type (Standard_Integer) 1990 and then Is_Fixed_Point_Type (T)) 1991 1992 -- A user defined operator can also match (and hide) a mixed 1993 -- operation on universal literals. 1994 1995 or else (Is_Integer_Type (T2) 1996 and then Is_Floating_Point_Type (T1) 1997 and then Base_Type (T1) = Base_Type (T)); 1998 1999 elsif Op_Name = Name_Op_Multiply then 2000 return (Base_Type (T1) = Base_Type (T2) 2001 and then Base_Type (T1) = Base_Type (T) 2002 and then Is_Numeric_Type (T) 2003 and then (not Is_Fixed_Point_Type (T) 2004 or else Ada_83)) 2005 2006 -- Mixed_Mode operations on fixed-point types. 2007 2008 or else (Base_Type (T1) = Base_Type (T) 2009 and then Base_Type (T2) = Base_Type (Standard_Integer) 2010 and then Is_Fixed_Point_Type (T)) 2011 2012 or else (Base_Type (T2) = Base_Type (T) 2013 and then Base_Type (T1) = Base_Type (Standard_Integer) 2014 and then Is_Fixed_Point_Type (T)) 2015 2016 or else (Is_Integer_Type (T2) 2017 and then Is_Floating_Point_Type (T1) 2018 and then Base_Type (T1) = Base_Type (T)) 2019 2020 or else (Is_Integer_Type (T1) 2021 and then Is_Floating_Point_Type (T2) 2022 and then Base_Type (T2) = Base_Type (T)); 2023 2024 elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then 2025 return Base_Type (T1) = Base_Type (T2) 2026 and then Base_Type (T1) = Base_Type (T) 2027 and then Is_Integer_Type (T); 2028 2029 elsif Op_Name = Name_Op_Expon then 2030 return Base_Type (T1) = Base_Type (T) 2031 and then Is_Numeric_Type (T) 2032 and then Base_Type (T2) = Base_Type (Standard_Integer); 2033 2034 elsif Op_Name = Name_Op_Concat then 2035 return Is_Array_Type (T) 2036 and then (Base_Type (T) = Base_Type (Etype (Op))) 2037 and then (Base_Type (T1) = Base_Type (T) 2038 or else 2039 Base_Type (T1) = Base_Type (Component_Type (T))) 2040 and then (Base_Type (T2) = Base_Type (T) 2041 or else 2042 Base_Type (T2) = Base_Type (Component_Type (T))); 2043 2044 else 2045 return False; 2046 end if; 2047 end if; 2048 end Operator_Matches_Spec; 2049 2050 ------------------- 2051 -- Remove_Interp -- 2052 ------------------- 2053 2054 procedure Remove_Interp (I : in out Interp_Index) is 2055 II : Interp_Index; 2056 2057 begin 2058 -- Find end of Interp list and copy downward to erase the discarded one 2059 2060 II := I + 1; 2061 2062 while Present (All_Interp.Table (II).Typ) loop 2063 II := II + 1; 2064 end loop; 2065 2066 for J in I + 1 .. II loop 2067 All_Interp.Table (J - 1) := All_Interp.Table (J); 2068 end loop; 2069 2070 -- Back up interp. index to insure that iterator will pick up next 2071 -- available interpretation. 2072 2073 I := I - 1; 2074 end Remove_Interp; 2075 2076 ------------------ 2077 -- Save_Interps -- 2078 ------------------ 2079 2080 procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is 2081 Map_Ptr : Int; 2082 O_N : Node_Id := Old_N; 2083 2084 begin 2085 if Is_Overloaded (Old_N) then 2086 if Nkind (Old_N) = N_Selected_Component 2087 and then Is_Overloaded (Selector_Name (Old_N)) 2088 then 2089 O_N := Selector_Name (Old_N); 2090 end if; 2091 2092 Map_Ptr := Headers (Hash (O_N)); 2093 2094 while Interp_Map.Table (Map_Ptr).Node /= O_N loop 2095 Map_Ptr := Interp_Map.Table (Map_Ptr).Next; 2096 pragma Assert (Map_Ptr /= No_Entry); 2097 end loop; 2098 2099 New_Interps (New_N); 2100 Interp_Map.Table (Interp_Map.Last).Index := 2101 Interp_Map.Table (Map_Ptr).Index; 2102 end if; 2103 end Save_Interps; 2104 2105 ------------------- 2106 -- Specific_Type -- 2107 ------------------- 2108 2109 function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is 2110 B1 : constant Entity_Id := Base_Type (T1); 2111 B2 : constant Entity_Id := Base_Type (T2); 2112 2113 function Is_Remote_Access (T : Entity_Id) return Boolean; 2114 -- Check whether T is the equivalent type of a remote access type. 2115 -- If distribution is enabled, T is a legal context for Null. 2116 2117 ---------------------- 2118 -- Is_Remote_Access -- 2119 ---------------------- 2120 2121 function Is_Remote_Access (T : Entity_Id) return Boolean is 2122 begin 2123 return Is_Record_Type (T) 2124 and then (Is_Remote_Call_Interface (T) 2125 or else Is_Remote_Types (T)) 2126 and then Present (Corresponding_Remote_Type (T)) 2127 and then Is_Access_Type (Corresponding_Remote_Type (T)); 2128 end Is_Remote_Access; 2129 2130 -- Start of processing for Specific_Type 2131 2132 begin 2133 if T1 = Any_Type or else T2 = Any_Type then 2134 return Any_Type; 2135 end if; 2136 2137 if B1 = B2 then 2138 return B1; 2139 2140 elsif False 2141 or else (T1 = Universal_Integer and then Is_Integer_Type (T2)) 2142 or else (T1 = Universal_Real and then Is_Real_Type (T2)) 2143 or else (T1 = Universal_Fixed and then Is_Fixed_Point_Type (T2)) 2144 or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2)) 2145 then 2146 return B2; 2147 2148 elsif False 2149 or else (T2 = Universal_Integer and then Is_Integer_Type (T1)) 2150 or else (T2 = Universal_Real and then Is_Real_Type (T1)) 2151 or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1)) 2152 or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1)) 2153 then 2154 return B1; 2155 2156 elsif T2 = Any_String and then Is_String_Type (T1) then 2157 return B1; 2158 2159 elsif T1 = Any_String and then Is_String_Type (T2) then 2160 return B2; 2161 2162 elsif T2 = Any_Character and then Is_Character_Type (T1) then 2163 return B1; 2164 2165 elsif T1 = Any_Character and then Is_Character_Type (T2) then 2166 return B2; 2167 2168 elsif T1 = Any_Access 2169 and then (Is_Access_Type (T2) or else Is_Remote_Access (T2)) 2170 then 2171 return T2; 2172 2173 elsif T2 = Any_Access 2174 and then (Is_Access_Type (T1) or else Is_Remote_Access (T1)) 2175 then 2176 return T1; 2177 2178 elsif T2 = Any_Composite 2179 and then Ekind (T1) in E_Array_Type .. E_Record_Subtype 2180 then 2181 return T1; 2182 2183 elsif T1 = Any_Composite 2184 and then Ekind (T2) in E_Array_Type .. E_Record_Subtype 2185 then 2186 return T2; 2187 2188 elsif T1 = Any_Modular and then Is_Modular_Integer_Type (T2) then 2189 return T2; 2190 2191 elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then 2192 return T1; 2193 2194 -- Special cases for equality operators (all other predefined 2195 -- operators can never apply to tagged types) 2196 2197 elsif Is_Class_Wide_Type (T1) 2198 and then Is_Ancestor (Root_Type (T1), T2) 2199 then 2200 return T1; 2201 2202 elsif Is_Class_Wide_Type (T2) 2203 and then Is_Ancestor (Root_Type (T2), T1) 2204 then 2205 return T2; 2206 2207 elsif (Ekind (B1) = E_Access_Subprogram_Type 2208 or else 2209 Ekind (B1) = E_Access_Protected_Subprogram_Type) 2210 and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type 2211 and then Is_Access_Type (T2) 2212 then 2213 return T2; 2214 2215 elsif (Ekind (B2) = E_Access_Subprogram_Type 2216 or else 2217 Ekind (B2) = E_Access_Protected_Subprogram_Type) 2218 and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type 2219 and then Is_Access_Type (T1) 2220 then 2221 return T1; 2222 2223 elsif (Ekind (T1) = E_Allocator_Type 2224 or else Ekind (T1) = E_Access_Attribute_Type 2225 or else Ekind (T1) = E_Anonymous_Access_Type) 2226 and then Is_Access_Type (T2) 2227 then 2228 return T2; 2229 2230 elsif (Ekind (T2) = E_Allocator_Type 2231 or else Ekind (T2) = E_Access_Attribute_Type 2232 or else Ekind (T2) = E_Anonymous_Access_Type) 2233 and then Is_Access_Type (T1) 2234 then 2235 return T1; 2236 2237 -- If none of the above cases applies, types are not compatible. 2238 2239 else 2240 return Any_Type; 2241 end if; 2242 end Specific_Type; 2243 2244 ----------------------- 2245 -- Valid_Boolean_Arg -- 2246 ----------------------- 2247 2248 -- In addition to booleans and arrays of booleans, we must include 2249 -- aggregates as valid boolean arguments, because in the first pass 2250 -- of resolution their components are not examined. If it turns out not 2251 -- to be an aggregate of booleans, this will be diagnosed in Resolve. 2252 -- Any_Composite must be checked for prior to the array type checks 2253 -- because Any_Composite does not have any associated indexes. 2254 2255 function Valid_Boolean_Arg (T : Entity_Id) return Boolean is 2256 begin 2257 return Is_Boolean_Type (T) 2258 or else T = Any_Composite 2259 or else (Is_Array_Type (T) 2260 and then T /= Any_String 2261 and then Number_Dimensions (T) = 1 2262 and then Is_Boolean_Type (Component_Type (T)) 2263 and then (not Is_Private_Composite (T) 2264 or else In_Instance) 2265 and then (not Is_Limited_Composite (T) 2266 or else In_Instance)) 2267 or else Is_Modular_Integer_Type (T) 2268 or else T = Universal_Integer; 2269 end Valid_Boolean_Arg; 2270 2271 -------------------------- 2272 -- Valid_Comparison_Arg -- 2273 -------------------------- 2274 2275 function Valid_Comparison_Arg (T : Entity_Id) return Boolean is 2276 begin 2277 2278 if T = Any_Composite then 2279 return False; 2280 elsif Is_Discrete_Type (T) 2281 or else Is_Real_Type (T) 2282 then 2283 return True; 2284 elsif Is_Array_Type (T) 2285 and then Number_Dimensions (T) = 1 2286 and then Is_Discrete_Type (Component_Type (T)) 2287 and then (not Is_Private_Composite (T) 2288 or else In_Instance) 2289 and then (not Is_Limited_Composite (T) 2290 or else In_Instance) 2291 then 2292 return True; 2293 elsif Is_String_Type (T) then 2294 return True; 2295 else 2296 return False; 2297 end if; 2298 end Valid_Comparison_Arg; 2299 2300 --------------------- 2301 -- Write_Overloads -- 2302 --------------------- 2303 2304 procedure Write_Overloads (N : Node_Id) is 2305 I : Interp_Index; 2306 It : Interp; 2307 Nam : Entity_Id; 2308 2309 begin 2310 if not Is_Overloaded (N) then 2311 Write_Str ("Non-overloaded entity "); 2312 Write_Eol; 2313 Write_Entity_Info (Entity (N), " "); 2314 2315 else 2316 Get_First_Interp (N, I, It); 2317 Write_Str ("Overloaded entity "); 2318 Write_Eol; 2319 Nam := It.Nam; 2320 2321 while Present (Nam) loop 2322 Write_Entity_Info (Nam, " "); 2323 Write_Str ("================="); 2324 Write_Eol; 2325 Get_Next_Interp (I, It); 2326 Nam := It.Nam; 2327 end loop; 2328 end if; 2329 end Write_Overloads; 2330 2331 ----------------------- 2332 -- Write_Interp_Ref -- 2333 ----------------------- 2334 2335 procedure Write_Interp_Ref (Map_Ptr : Int) is 2336 begin 2337 Write_Str (" Node: "); 2338 Write_Int (Int (Interp_Map.Table (Map_Ptr).Node)); 2339 Write_Str (" Index: "); 2340 Write_Int (Int (Interp_Map.Table (Map_Ptr).Index)); 2341 Write_Str (" Next: "); 2342 Write_Int (Int (Interp_Map.Table (Map_Ptr).Next)); 2343 Write_Eol; 2344 end Write_Interp_Ref; 2345 2346end Sem_Type; 2347