1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ C H 4 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2018, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Aspects; use Aspects; 27with Atree; use Atree; 28with Debug; use Debug; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Errout; use Errout; 32with Exp_Util; use Exp_Util; 33with Itypes; use Itypes; 34with Lib; use Lib; 35with Lib.Xref; use Lib.Xref; 36with Namet; use Namet; 37with Namet.Sp; use Namet.Sp; 38with Nlists; use Nlists; 39with Nmake; use Nmake; 40with Opt; use Opt; 41with Output; use Output; 42with Restrict; use Restrict; 43with Rident; use Rident; 44with Sem; use Sem; 45with Sem_Aux; use Sem_Aux; 46with Sem_Case; use Sem_Case; 47with Sem_Cat; use Sem_Cat; 48with Sem_Ch3; use Sem_Ch3; 49with Sem_Ch6; use Sem_Ch6; 50with Sem_Ch8; use Sem_Ch8; 51with Sem_Dim; use Sem_Dim; 52with Sem_Disp; use Sem_Disp; 53with Sem_Dist; use Sem_Dist; 54with Sem_Eval; use Sem_Eval; 55with Sem_Res; use Sem_Res; 56with Sem_Type; use Sem_Type; 57with Sem_Util; use Sem_Util; 58with Sem_Warn; use Sem_Warn; 59with Stand; use Stand; 60with Sinfo; use Sinfo; 61with Snames; use Snames; 62with Tbuild; use Tbuild; 63with Uintp; use Uintp; 64 65package body Sem_Ch4 is 66 67 -- Tables which speed up the identification of dangerous calls to Ada 2012 68 -- functions with writable actuals (AI05-0144). 69 70 -- The following table enumerates the Ada constructs which may evaluate in 71 -- arbitrary order. It does not cover all the language constructs which can 72 -- be evaluated in arbitrary order but the subset needed for AI05-0144. 73 74 Has_Arbitrary_Evaluation_Order : constant array (Node_Kind) of Boolean := 75 (N_Aggregate => True, 76 N_Assignment_Statement => True, 77 N_Entry_Call_Statement => True, 78 N_Extension_Aggregate => True, 79 N_Full_Type_Declaration => True, 80 N_Indexed_Component => True, 81 N_Object_Declaration => True, 82 N_Pragma => True, 83 N_Range => True, 84 N_Slice => True, 85 N_Array_Type_Definition => True, 86 N_Membership_Test => True, 87 N_Binary_Op => True, 88 N_Subprogram_Call => True, 89 others => False); 90 91 -- The following table enumerates the nodes on which we stop climbing when 92 -- locating the outermost Ada construct that can be evaluated in arbitrary 93 -- order. 94 95 Stop_Subtree_Climbing : constant array (Node_Kind) of Boolean := 96 (N_Aggregate => True, 97 N_Assignment_Statement => True, 98 N_Entry_Call_Statement => True, 99 N_Extended_Return_Statement => True, 100 N_Extension_Aggregate => True, 101 N_Full_Type_Declaration => True, 102 N_Object_Declaration => True, 103 N_Object_Renaming_Declaration => True, 104 N_Package_Specification => True, 105 N_Pragma => True, 106 N_Procedure_Call_Statement => True, 107 N_Simple_Return_Statement => True, 108 N_Has_Condition => True, 109 others => False); 110 111 ----------------------- 112 -- Local Subprograms -- 113 ----------------------- 114 115 procedure Analyze_Concatenation_Rest (N : Node_Id); 116 -- Does the "rest" of the work of Analyze_Concatenation, after the left 117 -- operand has been analyzed. See Analyze_Concatenation for details. 118 119 procedure Analyze_Expression (N : Node_Id); 120 -- For expressions that are not names, this is just a call to analyze. If 121 -- the expression is a name, it may be a call to a parameterless function, 122 -- and if so must be converted into an explicit call node and analyzed as 123 -- such. This deproceduring must be done during the first pass of overload 124 -- resolution, because otherwise a procedure call with overloaded actuals 125 -- may fail to resolve. 126 127 procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id); 128 -- Analyze a call of the form "+"(x, y), etc. The prefix of the call is an 129 -- operator name or an expanded name whose selector is an operator name, 130 -- and one possible interpretation is as a predefined operator. 131 132 procedure Analyze_Overloaded_Selected_Component (N : Node_Id); 133 -- If the prefix of a selected_component is overloaded, the proper 134 -- interpretation that yields a record type with the proper selector 135 -- name must be selected. 136 137 procedure Analyze_User_Defined_Binary_Op (N : Node_Id; Op_Id : Entity_Id); 138 -- Procedure to analyze a user defined binary operator, which is resolved 139 -- like a function, but instead of a list of actuals it is presented 140 -- with the left and right operands of an operator node. 141 142 procedure Analyze_User_Defined_Unary_Op (N : Node_Id; Op_Id : Entity_Id); 143 -- Procedure to analyze a user defined unary operator, which is resolved 144 -- like a function, but instead of a list of actuals, it is presented with 145 -- the operand of the operator node. 146 147 procedure Ambiguous_Operands (N : Node_Id); 148 -- For equality, membership, and comparison operators with overloaded 149 -- arguments, list possible interpretations. 150 151 procedure Analyze_One_Call 152 (N : Node_Id; 153 Nam : Entity_Id; 154 Report : Boolean; 155 Success : out Boolean; 156 Skip_First : Boolean := False); 157 -- Check one interpretation of an overloaded subprogram name for 158 -- compatibility with the types of the actuals in a call. If there is a 159 -- single interpretation which does not match, post error if Report is 160 -- set to True. 161 -- 162 -- Nam is the entity that provides the formals against which the actuals 163 -- are checked. Nam is either the name of a subprogram, or the internal 164 -- subprogram type constructed for an access_to_subprogram. If the actuals 165 -- are compatible with Nam, then Nam is added to the list of candidate 166 -- interpretations for N, and Success is set to True. 167 -- 168 -- The flag Skip_First is used when analyzing a call that was rewritten 169 -- from object notation. In this case the first actual may have to receive 170 -- an explicit dereference, depending on the first formal of the operation 171 -- being called. The caller will have verified that the object is legal 172 -- for the call. If the remaining parameters match, the first parameter 173 -- will rewritten as a dereference if needed, prior to completing analysis. 174 175 procedure Check_Misspelled_Selector 176 (Prefix : Entity_Id; 177 Sel : Node_Id); 178 -- Give possible misspelling message if Sel seems likely to be a mis- 179 -- spelling of one of the selectors of the Prefix. This is called by 180 -- Analyze_Selected_Component after producing an invalid selector error 181 -- message. 182 183 function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean; 184 -- Verify that type T is declared in scope S. Used to find interpretations 185 -- for operators given by expanded names. This is abstracted as a separate 186 -- function to handle extensions to System, where S is System, but T is 187 -- declared in the extension. 188 189 procedure Find_Arithmetic_Types 190 (L, R : Node_Id; 191 Op_Id : Entity_Id; 192 N : Node_Id); 193 -- L and R are the operands of an arithmetic operator. Find consistent 194 -- pairs of interpretations for L and R that have a numeric type consistent 195 -- with the semantics of the operator. 196 197 procedure Find_Comparison_Types 198 (L, R : Node_Id; 199 Op_Id : Entity_Id; 200 N : Node_Id); 201 -- L and R are operands of a comparison operator. Find consistent pairs of 202 -- interpretations for L and R. 203 204 procedure Find_Concatenation_Types 205 (L, R : Node_Id; 206 Op_Id : Entity_Id; 207 N : Node_Id); 208 -- For the four varieties of concatenation 209 210 procedure Find_Equality_Types 211 (L, R : Node_Id; 212 Op_Id : Entity_Id; 213 N : Node_Id); 214 -- Ditto for equality operators 215 216 procedure Find_Boolean_Types 217 (L, R : Node_Id; 218 Op_Id : Entity_Id; 219 N : Node_Id); 220 -- Ditto for binary logical operations 221 222 procedure Find_Negation_Types 223 (R : Node_Id; 224 Op_Id : Entity_Id; 225 N : Node_Id); 226 -- Find consistent interpretation for operand of negation operator 227 228 procedure Find_Non_Universal_Interpretations 229 (N : Node_Id; 230 R : Node_Id; 231 Op_Id : Entity_Id; 232 T1 : Entity_Id); 233 -- For equality and comparison operators, the result is always boolean, and 234 -- the legality of the operation is determined from the visibility of the 235 -- operand types. If one of the operands has a universal interpretation, 236 -- the legality check uses some compatible non-universal interpretation of 237 -- the other operand. N can be an operator node, or a function call whose 238 -- name is an operator designator. Any_Access, which is the initial type of 239 -- the literal NULL, is a universal type for the purpose of this routine. 240 241 function Find_Primitive_Operation (N : Node_Id) return Boolean; 242 -- Find candidate interpretations for the name Obj.Proc when it appears in 243 -- a subprogram renaming declaration. 244 245 procedure Find_Unary_Types 246 (R : Node_Id; 247 Op_Id : Entity_Id; 248 N : Node_Id); 249 -- Unary arithmetic types: plus, minus, abs 250 251 procedure Check_Arithmetic_Pair 252 (T1, T2 : Entity_Id; 253 Op_Id : Entity_Id; 254 N : Node_Id); 255 -- Subsidiary procedure to Find_Arithmetic_Types. T1 and T2 are valid types 256 -- for left and right operand. Determine whether they constitute a valid 257 -- pair for the given operator, and record the corresponding interpretation 258 -- of the operator node. The node N may be an operator node (the usual 259 -- case) or a function call whose prefix is an operator designator. In 260 -- both cases Op_Id is the operator name itself. 261 262 procedure Diagnose_Call (N : Node_Id; Nam : Node_Id); 263 -- Give detailed information on overloaded call where none of the 264 -- interpretations match. N is the call node, Nam the designator for 265 -- the overloaded entity being called. 266 267 function Junk_Operand (N : Node_Id) return Boolean; 268 -- Test for an operand that is an inappropriate entity (e.g. a package 269 -- name or a label). If so, issue an error message and return True. If 270 -- the operand is not an inappropriate entity kind, return False. 271 272 procedure Operator_Check (N : Node_Id); 273 -- Verify that an operator has received some valid interpretation. If none 274 -- was found, determine whether a use clause would make the operation 275 -- legal. The variable Candidate_Type (defined in Sem_Type) is set for 276 -- every type compatible with the operator, even if the operator for the 277 -- type is not directly visible. The routine uses this type to emit a more 278 -- informative message. 279 280 function Process_Implicit_Dereference_Prefix 281 (E : Entity_Id; 282 P : Node_Id) return Entity_Id; 283 -- Called when P is the prefix of an implicit dereference, denoting an 284 -- object E. The function returns the designated type of the prefix, taking 285 -- into account that the designated type of an anonymous access type may be 286 -- a limited view, when the nonlimited view is visible. 287 -- 288 -- If in semantics only mode (-gnatc or generic), the function also records 289 -- that the prefix is a reference to E, if any. Normally, such a reference 290 -- is generated only when the implicit dereference is expanded into an 291 -- explicit one, but for consistency we must generate the reference when 292 -- expansion is disabled as well. 293 294 procedure Remove_Abstract_Operations (N : Node_Id); 295 -- Ada 2005: implementation of AI-310. An abstract non-dispatching 296 -- operation is not a candidate interpretation. 297 298 function Try_Container_Indexing 299 (N : Node_Id; 300 Prefix : Node_Id; 301 Exprs : List_Id) return Boolean; 302 -- AI05-0139: Generalized indexing to support iterators over containers 303 304 function Try_Indexed_Call 305 (N : Node_Id; 306 Nam : Entity_Id; 307 Typ : Entity_Id; 308 Skip_First : Boolean) return Boolean; 309 -- If a function has defaults for all its actuals, a call to it may in fact 310 -- be an indexing on the result of the call. Try_Indexed_Call attempts the 311 -- interpretation as an indexing, prior to analysis as a call. If both are 312 -- possible, the node is overloaded with both interpretations (same symbol 313 -- but two different types). If the call is written in prefix form, the 314 -- prefix becomes the first parameter in the call, and only the remaining 315 -- actuals must be checked for the presence of defaults. 316 317 function Try_Indirect_Call 318 (N : Node_Id; 319 Nam : Entity_Id; 320 Typ : Entity_Id) return Boolean; 321 -- Similarly, a function F that needs no actuals can return an access to a 322 -- subprogram, and the call F (X) interpreted as F.all (X). In this case 323 -- the call may be overloaded with both interpretations. 324 325 procedure wpo (T : Entity_Id); 326 pragma Warnings (Off, wpo); 327 -- Used for debugging: obtain list of primitive operations even if 328 -- type is not frozen and dispatch table is not built yet. 329 330 ------------------------ 331 -- Ambiguous_Operands -- 332 ------------------------ 333 334 procedure Ambiguous_Operands (N : Node_Id) is 335 procedure List_Operand_Interps (Opnd : Node_Id); 336 337 -------------------------- 338 -- List_Operand_Interps -- 339 -------------------------- 340 341 procedure List_Operand_Interps (Opnd : Node_Id) is 342 Nam : Node_Id := Empty; 343 Err : Node_Id := N; 344 345 begin 346 if Is_Overloaded (Opnd) then 347 if Nkind (Opnd) in N_Op then 348 Nam := Opnd; 349 350 elsif Nkind (Opnd) = N_Function_Call then 351 Nam := Name (Opnd); 352 353 elsif Ada_Version >= Ada_2012 then 354 declare 355 It : Interp; 356 I : Interp_Index; 357 358 begin 359 Get_First_Interp (Opnd, I, It); 360 while Present (It.Nam) loop 361 if Has_Implicit_Dereference (It.Typ) then 362 Error_Msg_N 363 ("can be interpreted as implicit dereference", Opnd); 364 return; 365 end if; 366 367 Get_Next_Interp (I, It); 368 end loop; 369 end; 370 371 return; 372 end if; 373 374 else 375 return; 376 end if; 377 378 if Opnd = Left_Opnd (N) then 379 Error_Msg_N 380 ("\left operand has the following interpretations", N); 381 else 382 Error_Msg_N 383 ("\right operand has the following interpretations", N); 384 Err := Opnd; 385 end if; 386 387 List_Interps (Nam, Err); 388 end List_Operand_Interps; 389 390 -- Start of processing for Ambiguous_Operands 391 392 begin 393 if Nkind (N) in N_Membership_Test then 394 Error_Msg_N ("ambiguous operands for membership", N); 395 396 elsif Nkind_In (N, N_Op_Eq, N_Op_Ne) then 397 Error_Msg_N ("ambiguous operands for equality", N); 398 399 else 400 Error_Msg_N ("ambiguous operands for comparison", N); 401 end if; 402 403 if All_Errors_Mode then 404 List_Operand_Interps (Left_Opnd (N)); 405 List_Operand_Interps (Right_Opnd (N)); 406 else 407 Error_Msg_N ("\use -gnatf switch for details", N); 408 end if; 409 end Ambiguous_Operands; 410 411 ----------------------- 412 -- Analyze_Aggregate -- 413 ----------------------- 414 415 -- Most of the analysis of Aggregates requires that the type be known, and 416 -- is therefore put off until resolution of the context. Delta aggregates 417 -- have a base component that determines the enclosing aggregate type so 418 -- its type can be ascertained earlier. This also allows delta aggregates 419 -- to appear in the context of a record type with a private extension, as 420 -- per the latest update of AI12-0127. 421 422 procedure Analyze_Aggregate (N : Node_Id) is 423 begin 424 if No (Etype (N)) then 425 if Nkind (N) = N_Delta_Aggregate then 426 declare 427 Base : constant Node_Id := Expression (N); 428 429 I : Interp_Index; 430 It : Interp; 431 432 begin 433 Analyze (Base); 434 435 -- If the base is overloaded, propagate interpretations to the 436 -- enclosing aggregate. 437 438 if Is_Overloaded (Base) then 439 Get_First_Interp (Base, I, It); 440 Set_Etype (N, Any_Type); 441 442 while Present (It.Nam) loop 443 Add_One_Interp (N, It.Typ, It.Typ); 444 Get_Next_Interp (I, It); 445 end loop; 446 447 else 448 Set_Etype (N, Etype (Base)); 449 end if; 450 end; 451 452 else 453 Set_Etype (N, Any_Composite); 454 end if; 455 end if; 456 end Analyze_Aggregate; 457 458 ----------------------- 459 -- Analyze_Allocator -- 460 ----------------------- 461 462 procedure Analyze_Allocator (N : Node_Id) is 463 Loc : constant Source_Ptr := Sloc (N); 464 Sav_Errs : constant Nat := Serious_Errors_Detected; 465 E : Node_Id := Expression (N); 466 Acc_Type : Entity_Id; 467 Type_Id : Entity_Id; 468 P : Node_Id; 469 C : Node_Id; 470 Onode : Node_Id; 471 472 begin 473 Check_SPARK_05_Restriction ("allocator is not allowed", N); 474 475 -- Deal with allocator restrictions 476 477 -- In accordance with H.4(7), the No_Allocators restriction only applies 478 -- to user-written allocators. The same consideration applies to the 479 -- No_Standard_Allocators_Before_Elaboration restriction. 480 481 if Comes_From_Source (N) then 482 Check_Restriction (No_Allocators, N); 483 484 -- Processing for No_Standard_Allocators_After_Elaboration, loop to 485 -- look at enclosing context, checking task/main subprogram case. 486 487 C := N; 488 P := Parent (C); 489 while Present (P) loop 490 491 -- For the task case we need a handled sequence of statements, 492 -- where the occurrence of the allocator is within the statements 493 -- and the parent is a task body 494 495 if Nkind (P) = N_Handled_Sequence_Of_Statements 496 and then Is_List_Member (C) 497 and then List_Containing (C) = Statements (P) 498 then 499 Onode := Original_Node (Parent (P)); 500 501 -- Check for allocator within task body, this is a definite 502 -- violation of No_Allocators_After_Elaboration we can detect 503 -- at compile time. 504 505 if Nkind (Onode) = N_Task_Body then 506 Check_Restriction 507 (No_Standard_Allocators_After_Elaboration, N); 508 exit; 509 end if; 510 end if; 511 512 -- The other case is appearance in a subprogram body. This is 513 -- a violation if this is a library level subprogram with no 514 -- parameters. Note that this is now a static error even if the 515 -- subprogram is not the main program (this is a change, in an 516 -- earlier version only the main program was affected, and the 517 -- check had to be done in the binder. 518 519 if Nkind (P) = N_Subprogram_Body 520 and then Nkind (Parent (P)) = N_Compilation_Unit 521 and then No (Parameter_Specifications (Specification (P))) 522 then 523 Check_Restriction 524 (No_Standard_Allocators_After_Elaboration, N); 525 end if; 526 527 C := P; 528 P := Parent (C); 529 end loop; 530 end if; 531 532 -- Ada 2012 (AI05-0111-3): Analyze the subpool_specification, if 533 -- any. The expected type for the name is any type. A non-overloading 534 -- rule then requires it to be of a type descended from 535 -- System.Storage_Pools.Subpools.Subpool_Handle. 536 537 -- This isn't exactly what the AI says, but it seems to be the right 538 -- rule. The AI should be fixed.??? 539 540 declare 541 Subpool : constant Node_Id := Subpool_Handle_Name (N); 542 543 begin 544 if Present (Subpool) then 545 Analyze (Subpool); 546 547 if Is_Overloaded (Subpool) then 548 Error_Msg_N ("ambiguous subpool handle", Subpool); 549 end if; 550 551 -- Check that Etype (Subpool) is descended from Subpool_Handle 552 553 Resolve (Subpool); 554 end if; 555 end; 556 557 -- Analyze the qualified expression or subtype indication 558 559 if Nkind (E) = N_Qualified_Expression then 560 Acc_Type := Create_Itype (E_Allocator_Type, N); 561 Set_Etype (Acc_Type, Acc_Type); 562 Find_Type (Subtype_Mark (E)); 563 564 -- Analyze the qualified expression, and apply the name resolution 565 -- rule given in 4.7(3). 566 567 Analyze (E); 568 Type_Id := Etype (E); 569 Set_Directly_Designated_Type (Acc_Type, Type_Id); 570 571 -- A qualified expression requires an exact match of the type, 572 -- class-wide matching is not allowed. 573 574 -- if Is_Class_Wide_Type (Type_Id) 575 -- and then Base_Type 576 -- (Etype (Expression (E))) /= Base_Type (Type_Id) 577 -- then 578 -- Wrong_Type (Expression (E), Type_Id); 579 -- end if; 580 581 -- We don't analyze the qualified expression itself because it's 582 -- part of the allocator. It is fully analyzed and resolved when 583 -- the allocator is resolved with the context type. 584 585 Set_Etype (E, Type_Id); 586 587 -- Case where allocator has a subtype indication 588 589 else 590 declare 591 Def_Id : Entity_Id; 592 Base_Typ : Entity_Id; 593 594 begin 595 -- If the allocator includes a N_Subtype_Indication then a 596 -- constraint is present, otherwise the node is a subtype mark. 597 -- Introduce an explicit subtype declaration into the tree 598 -- defining some anonymous subtype and rewrite the allocator to 599 -- use this subtype rather than the subtype indication. 600 601 -- It is important to introduce the explicit subtype declaration 602 -- so that the bounds of the subtype indication are attached to 603 -- the tree in case the allocator is inside a generic unit. 604 605 -- Finally, if there is no subtype indication and the type is 606 -- a tagged unconstrained type with discriminants, the designated 607 -- object is constrained by their default values, and it is 608 -- simplest to introduce an explicit constraint now. In some cases 609 -- this is done during expansion, but freeze actions are certain 610 -- to be emitted in the proper order if constraint is explicit. 611 612 if Is_Entity_Name (E) and then Expander_Active then 613 Find_Type (E); 614 Type_Id := Entity (E); 615 616 if Is_Tagged_Type (Type_Id) 617 and then Has_Discriminants (Type_Id) 618 and then not Is_Constrained (Type_Id) 619 and then 620 Present 621 (Discriminant_Default_Value 622 (First_Discriminant (Type_Id))) 623 then 624 declare 625 Constr : constant List_Id := New_List; 626 Loc : constant Source_Ptr := Sloc (E); 627 Discr : Entity_Id := First_Discriminant (Type_Id); 628 629 begin 630 if Present (Discriminant_Default_Value (Discr)) then 631 while Present (Discr) loop 632 Append (Discriminant_Default_Value (Discr), Constr); 633 Next_Discriminant (Discr); 634 end loop; 635 636 Rewrite (E, 637 Make_Subtype_Indication (Loc, 638 Subtype_Mark => New_Occurrence_Of (Type_Id, Loc), 639 Constraint => 640 Make_Index_Or_Discriminant_Constraint (Loc, 641 Constraints => Constr))); 642 end if; 643 end; 644 end if; 645 end if; 646 647 if Nkind (E) = N_Subtype_Indication then 648 649 -- A constraint is only allowed for a composite type in Ada 650 -- 95. In Ada 83, a constraint is also allowed for an 651 -- access-to-composite type, but the constraint is ignored. 652 653 Find_Type (Subtype_Mark (E)); 654 Base_Typ := Entity (Subtype_Mark (E)); 655 656 if Is_Elementary_Type (Base_Typ) then 657 if not (Ada_Version = Ada_83 658 and then Is_Access_Type (Base_Typ)) 659 then 660 Error_Msg_N ("constraint not allowed here", E); 661 662 if Nkind (Constraint (E)) = 663 N_Index_Or_Discriminant_Constraint 664 then 665 Error_Msg_N -- CODEFIX 666 ("\if qualified expression was meant, " & 667 "use apostrophe", Constraint (E)); 668 end if; 669 end if; 670 671 -- Get rid of the bogus constraint: 672 673 Rewrite (E, New_Copy_Tree (Subtype_Mark (E))); 674 Analyze_Allocator (N); 675 return; 676 end if; 677 678 if Expander_Active then 679 Def_Id := Make_Temporary (Loc, 'S'); 680 681 Insert_Action (E, 682 Make_Subtype_Declaration (Loc, 683 Defining_Identifier => Def_Id, 684 Subtype_Indication => Relocate_Node (E))); 685 686 if Sav_Errs /= Serious_Errors_Detected 687 and then Nkind (Constraint (E)) = 688 N_Index_Or_Discriminant_Constraint 689 then 690 Error_Msg_N -- CODEFIX 691 ("if qualified expression was meant, " 692 & "use apostrophe!", Constraint (E)); 693 end if; 694 695 E := New_Occurrence_Of (Def_Id, Loc); 696 Rewrite (Expression (N), E); 697 end if; 698 end if; 699 700 Type_Id := Process_Subtype (E, N); 701 Acc_Type := Create_Itype (E_Allocator_Type, N); 702 Set_Etype (Acc_Type, Acc_Type); 703 Set_Directly_Designated_Type (Acc_Type, Type_Id); 704 Check_Fully_Declared (Type_Id, N); 705 706 -- Ada 2005 (AI-231): If the designated type is itself an access 707 -- type that excludes null, its default initialization will 708 -- be a null object, and we can insert an unconditional raise 709 -- before the allocator. 710 711 -- Ada 2012 (AI-104): A not null indication here is altogether 712 -- illegal. 713 714 if Can_Never_Be_Null (Type_Id) then 715 declare 716 Not_Null_Check : constant Node_Id := 717 Make_Raise_Constraint_Error (Sloc (E), 718 Reason => CE_Null_Not_Allowed); 719 720 begin 721 if Expander_Active then 722 Insert_Action (N, Not_Null_Check); 723 Analyze (Not_Null_Check); 724 725 elsif Warn_On_Ada_2012_Compatibility then 726 Error_Msg_N 727 ("null value not allowed here in Ada 2012?y?", E); 728 end if; 729 end; 730 end if; 731 732 -- Check for missing initialization. Skip this check if we already 733 -- had errors on analyzing the allocator, since in that case these 734 -- are probably cascaded errors. 735 736 if not Is_Definite_Subtype (Type_Id) 737 and then Serious_Errors_Detected = Sav_Errs 738 then 739 -- The build-in-place machinery may produce an allocator when 740 -- the designated type is indefinite but the underlying type is 741 -- not. In this case the unknown discriminants are meaningless 742 -- and should not trigger error messages. Check the parent node 743 -- because the allocator is marked as coming from source. 744 745 if Present (Underlying_Type (Type_Id)) 746 and then Is_Definite_Subtype (Underlying_Type (Type_Id)) 747 and then not Comes_From_Source (Parent (N)) 748 then 749 null; 750 751 -- An unusual case arises when the parent of a derived type is 752 -- a limited record extension with unknown discriminants, and 753 -- its full view has no discriminants. 754 -- 755 -- A more general fix might be to create the proper underlying 756 -- type for such a derived type, but it is a record type with 757 -- no private attributes, so this required extending the 758 -- meaning of this attribute. ??? 759 760 elsif Ekind (Etype (Type_Id)) = E_Record_Type_With_Private 761 and then Present (Underlying_Type (Etype (Type_Id))) 762 and then 763 not Has_Discriminants (Underlying_Type (Etype (Type_Id))) 764 and then not Comes_From_Source (Parent (N)) 765 then 766 null; 767 768 elsif Is_Class_Wide_Type (Type_Id) then 769 Error_Msg_N 770 ("initialization required in class-wide allocation", N); 771 772 else 773 if Ada_Version < Ada_2005 774 and then Is_Limited_Type (Type_Id) 775 then 776 Error_Msg_N ("unconstrained allocation not allowed", N); 777 778 if Is_Array_Type (Type_Id) then 779 Error_Msg_N 780 ("\constraint with array bounds required", N); 781 782 elsif Has_Unknown_Discriminants (Type_Id) then 783 null; 784 785 else pragma Assert (Has_Discriminants (Type_Id)); 786 Error_Msg_N 787 ("\constraint with discriminant values required", N); 788 end if; 789 790 -- Limited Ada 2005 and general nonlimited case 791 792 else 793 Error_Msg_N 794 ("uninitialized unconstrained allocation not " 795 & "allowed", N); 796 797 if Is_Array_Type (Type_Id) then 798 Error_Msg_N 799 ("\qualified expression or constraint with " 800 & "array bounds required", N); 801 802 elsif Has_Unknown_Discriminants (Type_Id) then 803 Error_Msg_N ("\qualified expression required", N); 804 805 else pragma Assert (Has_Discriminants (Type_Id)); 806 Error_Msg_N 807 ("\qualified expression or constraint with " 808 & "discriminant values required", N); 809 end if; 810 end if; 811 end if; 812 end if; 813 end; 814 end if; 815 816 if Is_Abstract_Type (Type_Id) then 817 Error_Msg_N ("cannot allocate abstract object", E); 818 end if; 819 820 if Has_Task (Designated_Type (Acc_Type)) then 821 Check_Restriction (No_Tasking, N); 822 Check_Restriction (Max_Tasks, N); 823 Check_Restriction (No_Task_Allocators, N); 824 end if; 825 826 -- Check restriction against dynamically allocated protected objects 827 828 if Has_Protected (Designated_Type (Acc_Type)) then 829 Check_Restriction (No_Protected_Type_Allocators, N); 830 end if; 831 832 -- AI05-0013-1: No_Nested_Finalization forbids allocators if the access 833 -- type is nested, and the designated type needs finalization. The rule 834 -- is conservative in that class-wide types need finalization. 835 836 if Needs_Finalization (Designated_Type (Acc_Type)) 837 and then not Is_Library_Level_Entity (Acc_Type) 838 then 839 Check_Restriction (No_Nested_Finalization, N); 840 end if; 841 842 -- Check that an allocator of a nested access type doesn't create a 843 -- protected object when restriction No_Local_Protected_Objects applies. 844 845 if Has_Protected (Designated_Type (Acc_Type)) 846 and then not Is_Library_Level_Entity (Acc_Type) 847 then 848 Check_Restriction (No_Local_Protected_Objects, N); 849 end if; 850 851 -- Likewise for No_Local_Timing_Events 852 853 if Has_Timing_Event (Designated_Type (Acc_Type)) 854 and then not Is_Library_Level_Entity (Acc_Type) 855 then 856 Check_Restriction (No_Local_Timing_Events, N); 857 end if; 858 859 -- If the No_Streams restriction is set, check that the type of the 860 -- object is not, and does not contain, any subtype derived from 861 -- Ada.Streams.Root_Stream_Type. Note that we guard the call to 862 -- Has_Stream just for efficiency reasons. There is no point in 863 -- spending time on a Has_Stream check if the restriction is not set. 864 865 if Restriction_Check_Required (No_Streams) then 866 if Has_Stream (Designated_Type (Acc_Type)) then 867 Check_Restriction (No_Streams, N); 868 end if; 869 end if; 870 871 Set_Etype (N, Acc_Type); 872 873 if not Is_Library_Level_Entity (Acc_Type) then 874 Check_Restriction (No_Local_Allocators, N); 875 end if; 876 877 if Serious_Errors_Detected > Sav_Errs then 878 Set_Error_Posted (N); 879 Set_Etype (N, Any_Type); 880 end if; 881 end Analyze_Allocator; 882 883 --------------------------- 884 -- Analyze_Arithmetic_Op -- 885 --------------------------- 886 887 procedure Analyze_Arithmetic_Op (N : Node_Id) is 888 L : constant Node_Id := Left_Opnd (N); 889 R : constant Node_Id := Right_Opnd (N); 890 Op_Id : Entity_Id; 891 892 begin 893 Candidate_Type := Empty; 894 Analyze_Expression (L); 895 Analyze_Expression (R); 896 897 -- If the entity is already set, the node is the instantiation of a 898 -- generic node with a non-local reference, or was manufactured by a 899 -- call to Make_Op_xxx. In either case the entity is known to be valid, 900 -- and we do not need to collect interpretations, instead we just get 901 -- the single possible interpretation. 902 903 Op_Id := Entity (N); 904 905 if Present (Op_Id) then 906 if Ekind (Op_Id) = E_Operator then 907 908 if Nkind_In (N, N_Op_Divide, N_Op_Mod, N_Op_Multiply, N_Op_Rem) 909 and then Treat_Fixed_As_Integer (N) 910 then 911 null; 912 else 913 Set_Etype (N, Any_Type); 914 Find_Arithmetic_Types (L, R, Op_Id, N); 915 end if; 916 917 else 918 Set_Etype (N, Any_Type); 919 Add_One_Interp (N, Op_Id, Etype (Op_Id)); 920 end if; 921 922 -- Entity is not already set, so we do need to collect interpretations 923 924 else 925 Set_Etype (N, Any_Type); 926 927 Op_Id := Get_Name_Entity_Id (Chars (N)); 928 while Present (Op_Id) loop 929 if Ekind (Op_Id) = E_Operator 930 and then Present (Next_Entity (First_Entity (Op_Id))) 931 then 932 Find_Arithmetic_Types (L, R, Op_Id, N); 933 934 -- The following may seem superfluous, because an operator cannot 935 -- be generic, but this ignores the cleverness of the author of 936 -- ACVC bc1013a. 937 938 elsif Is_Overloadable (Op_Id) then 939 Analyze_User_Defined_Binary_Op (N, Op_Id); 940 end if; 941 942 Op_Id := Homonym (Op_Id); 943 end loop; 944 end if; 945 946 Operator_Check (N); 947 Check_Function_Writable_Actuals (N); 948 end Analyze_Arithmetic_Op; 949 950 ------------------ 951 -- Analyze_Call -- 952 ------------------ 953 954 -- Function, procedure, and entry calls are checked here. The Name in 955 -- the call may be overloaded. The actuals have been analyzed and may 956 -- themselves be overloaded. On exit from this procedure, the node N 957 -- may have zero, one or more interpretations. In the first case an 958 -- error message is produced. In the last case, the node is flagged 959 -- as overloaded and the interpretations are collected in All_Interp. 960 961 -- If the name is an Access_To_Subprogram, it cannot be overloaded, but 962 -- the type-checking is similar to that of other calls. 963 964 procedure Analyze_Call (N : Node_Id) is 965 Actuals : constant List_Id := Parameter_Associations (N); 966 Loc : constant Source_Ptr := Sloc (N); 967 Nam : Node_Id; 968 X : Interp_Index; 969 It : Interp; 970 Nam_Ent : Entity_Id; 971 Success : Boolean := False; 972 973 Deref : Boolean := False; 974 -- Flag indicates whether an interpretation of the prefix is a 975 -- parameterless call that returns an access_to_subprogram. 976 977 procedure Check_Mixed_Parameter_And_Named_Associations; 978 -- Check that parameter and named associations are not mixed. This is 979 -- a restriction in SPARK mode. 980 981 procedure Check_Writable_Actuals (N : Node_Id); 982 -- If the call has out or in-out parameters then mark its outermost 983 -- enclosing construct as a node on which the writable actuals check 984 -- must be performed. 985 986 function Name_Denotes_Function return Boolean; 987 -- If the type of the name is an access to subprogram, this may be the 988 -- type of a name, or the return type of the function being called. If 989 -- the name is not an entity then it can denote a protected function. 990 -- Until we distinguish Etype from Return_Type, we must use this routine 991 -- to resolve the meaning of the name in the call. 992 993 procedure No_Interpretation; 994 -- Output error message when no valid interpretation exists 995 996 -------------------------------------------------- 997 -- Check_Mixed_Parameter_And_Named_Associations -- 998 -------------------------------------------------- 999 1000 procedure Check_Mixed_Parameter_And_Named_Associations is 1001 Actual : Node_Id; 1002 Named_Seen : Boolean; 1003 1004 begin 1005 Named_Seen := False; 1006 1007 Actual := First (Actuals); 1008 while Present (Actual) loop 1009 case Nkind (Actual) is 1010 when N_Parameter_Association => 1011 if Named_Seen then 1012 Check_SPARK_05_Restriction 1013 ("named association cannot follow positional one", 1014 Actual); 1015 exit; 1016 end if; 1017 1018 when others => 1019 Named_Seen := True; 1020 end case; 1021 1022 Next (Actual); 1023 end loop; 1024 end Check_Mixed_Parameter_And_Named_Associations; 1025 1026 ---------------------------- 1027 -- Check_Writable_Actuals -- 1028 ---------------------------- 1029 1030 -- The identification of conflicts in calls to functions with writable 1031 -- actuals is performed in the analysis phase of the front end to ensure 1032 -- that it reports exactly the same errors compiling with and without 1033 -- expansion enabled. It is performed in two stages: 1034 1035 -- 1) When a call to a function with out-mode parameters is found, 1036 -- we climb to the outermost enclosing construct that can be 1037 -- evaluated in arbitrary order and we mark it with the flag 1038 -- Check_Actuals. 1039 1040 -- 2) When the analysis of the marked node is complete, we traverse 1041 -- its decorated subtree searching for conflicts (see function 1042 -- Sem_Util.Check_Function_Writable_Actuals). 1043 1044 -- The unique exception to this general rule is for aggregates, since 1045 -- their analysis is performed by the front end in the resolution 1046 -- phase. For aggregates we do not climb to their enclosing construct: 1047 -- we restrict the analysis to the subexpressions initializing the 1048 -- aggregate components. 1049 1050 -- This implies that the analysis of expressions containing aggregates 1051 -- is not complete, since there may be conflicts on writable actuals 1052 -- involving subexpressions of the enclosing logical or arithmetic 1053 -- expressions. However, we cannot wait and perform the analysis when 1054 -- the whole subtree is resolved, since the subtrees may be transformed, 1055 -- thus adding extra complexity and computation cost to identify and 1056 -- report exactly the same errors compiling with and without expansion 1057 -- enabled. 1058 1059 procedure Check_Writable_Actuals (N : Node_Id) is 1060 begin 1061 if Comes_From_Source (N) 1062 and then Present (Get_Subprogram_Entity (N)) 1063 and then Has_Out_Or_In_Out_Parameter (Get_Subprogram_Entity (N)) 1064 then 1065 -- For procedures and entries there is no need to climb since 1066 -- we only need to check if the actuals of this call invoke 1067 -- functions whose out-mode parameters overlap. 1068 1069 if Nkind (N) /= N_Function_Call then 1070 Set_Check_Actuals (N); 1071 1072 -- For calls to functions we climb to the outermost enclosing 1073 -- construct where the out-mode actuals of this function may 1074 -- introduce conflicts. 1075 1076 else 1077 declare 1078 Outermost : Node_Id := Empty; -- init to avoid warning 1079 P : Node_Id := N; 1080 1081 begin 1082 while Present (P) loop 1083 -- For object declarations we can climb to the node from 1084 -- its object definition branch or from its initializing 1085 -- expression. We prefer to mark the child node as the 1086 -- outermost construct to avoid adding further complexity 1087 -- to the routine that will later take care of 1088 -- performing the writable actuals check. 1089 1090 if Has_Arbitrary_Evaluation_Order (Nkind (P)) 1091 and then not Nkind_In (P, N_Assignment_Statement, 1092 N_Object_Declaration) 1093 then 1094 Outermost := P; 1095 end if; 1096 1097 -- Avoid climbing more than needed 1098 1099 exit when Stop_Subtree_Climbing (Nkind (P)) 1100 or else (Nkind (P) = N_Range 1101 and then not 1102 Nkind_In (Parent (P), N_In, N_Not_In)); 1103 1104 P := Parent (P); 1105 end loop; 1106 1107 Set_Check_Actuals (Outermost); 1108 end; 1109 end if; 1110 end if; 1111 end Check_Writable_Actuals; 1112 1113 --------------------------- 1114 -- Name_Denotes_Function -- 1115 --------------------------- 1116 1117 function Name_Denotes_Function return Boolean is 1118 begin 1119 if Is_Entity_Name (Nam) then 1120 return Ekind (Entity (Nam)) = E_Function; 1121 elsif Nkind (Nam) = N_Selected_Component then 1122 return Ekind (Entity (Selector_Name (Nam))) = E_Function; 1123 else 1124 return False; 1125 end if; 1126 end Name_Denotes_Function; 1127 1128 ----------------------- 1129 -- No_Interpretation -- 1130 ----------------------- 1131 1132 procedure No_Interpretation is 1133 L : constant Boolean := Is_List_Member (N); 1134 K : constant Node_Kind := Nkind (Parent (N)); 1135 1136 begin 1137 -- If the node is in a list whose parent is not an expression then it 1138 -- must be an attempted procedure call. 1139 1140 if L and then K not in N_Subexpr then 1141 if Ekind (Entity (Nam)) = E_Generic_Procedure then 1142 Error_Msg_NE 1143 ("must instantiate generic procedure& before call", 1144 Nam, Entity (Nam)); 1145 else 1146 Error_Msg_N ("procedure or entry name expected", Nam); 1147 end if; 1148 1149 -- Check for tasking cases where only an entry call will do 1150 1151 elsif not L 1152 and then Nkind_In (K, N_Entry_Call_Alternative, 1153 N_Triggering_Alternative) 1154 then 1155 Error_Msg_N ("entry name expected", Nam); 1156 1157 -- Otherwise give general error message 1158 1159 else 1160 Error_Msg_N ("invalid prefix in call", Nam); 1161 end if; 1162 end No_Interpretation; 1163 1164 -- Start of processing for Analyze_Call 1165 1166 begin 1167 if Restriction_Check_Required (SPARK_05) then 1168 Check_Mixed_Parameter_And_Named_Associations; 1169 end if; 1170 1171 -- Initialize the type of the result of the call to the error type, 1172 -- which will be reset if the type is successfully resolved. 1173 1174 Set_Etype (N, Any_Type); 1175 1176 Nam := Name (N); 1177 1178 if not Is_Overloaded (Nam) then 1179 1180 -- Only one interpretation to check 1181 1182 if Ekind (Etype (Nam)) = E_Subprogram_Type then 1183 Nam_Ent := Etype (Nam); 1184 1185 -- If the prefix is an access_to_subprogram, this may be an indirect 1186 -- call. This is the case if the name in the call is not an entity 1187 -- name, or if it is a function name in the context of a procedure 1188 -- call. In this latter case, we have a call to a parameterless 1189 -- function that returns a pointer_to_procedure which is the entity 1190 -- being called. Finally, F (X) may be a call to a parameterless 1191 -- function that returns a pointer to a function with parameters. 1192 -- Note that if F returns an access-to-subprogram whose designated 1193 -- type is an array, F (X) cannot be interpreted as an indirect call 1194 -- through the result of the call to F. 1195 1196 elsif Is_Access_Type (Etype (Nam)) 1197 and then Ekind (Designated_Type (Etype (Nam))) = E_Subprogram_Type 1198 and then 1199 (not Name_Denotes_Function 1200 or else Nkind (N) = N_Procedure_Call_Statement 1201 or else 1202 (Nkind (Parent (N)) /= N_Explicit_Dereference 1203 and then Is_Entity_Name (Nam) 1204 and then No (First_Formal (Entity (Nam))) 1205 and then not 1206 Is_Array_Type (Etype (Designated_Type (Etype (Nam)))) 1207 and then Present (Actuals))) 1208 then 1209 Nam_Ent := Designated_Type (Etype (Nam)); 1210 Insert_Explicit_Dereference (Nam); 1211 1212 -- Selected component case. Simple entry or protected operation, 1213 -- where the entry name is given by the selector name. 1214 1215 elsif Nkind (Nam) = N_Selected_Component then 1216 Nam_Ent := Entity (Selector_Name (Nam)); 1217 1218 if not Ekind_In (Nam_Ent, E_Entry, 1219 E_Entry_Family, 1220 E_Function, 1221 E_Procedure) 1222 then 1223 Error_Msg_N ("name in call is not a callable entity", Nam); 1224 Set_Etype (N, Any_Type); 1225 return; 1226 end if; 1227 1228 -- If the name is an Indexed component, it can be a call to a member 1229 -- of an entry family. The prefix must be a selected component whose 1230 -- selector is the entry. Analyze_Procedure_Call normalizes several 1231 -- kinds of call into this form. 1232 1233 elsif Nkind (Nam) = N_Indexed_Component then 1234 if Nkind (Prefix (Nam)) = N_Selected_Component then 1235 Nam_Ent := Entity (Selector_Name (Prefix (Nam))); 1236 else 1237 Error_Msg_N ("name in call is not a callable entity", Nam); 1238 Set_Etype (N, Any_Type); 1239 return; 1240 end if; 1241 1242 elsif not Is_Entity_Name (Nam) then 1243 Error_Msg_N ("name in call is not a callable entity", Nam); 1244 Set_Etype (N, Any_Type); 1245 return; 1246 1247 else 1248 Nam_Ent := Entity (Nam); 1249 1250 -- If not overloadable, this may be a generalized indexing 1251 -- operation with named associations. Rewrite again as an 1252 -- indexed component and analyze as container indexing. 1253 1254 if not Is_Overloadable (Nam_Ent) then 1255 if Present 1256 (Find_Value_Of_Aspect 1257 (Etype (Nam_Ent), Aspect_Constant_Indexing)) 1258 then 1259 Replace (N, 1260 Make_Indexed_Component (Sloc (N), 1261 Prefix => Nam, 1262 Expressions => Parameter_Associations (N))); 1263 1264 if Try_Container_Indexing (N, Nam, Expressions (N)) then 1265 return; 1266 else 1267 No_Interpretation; 1268 end if; 1269 1270 else 1271 No_Interpretation; 1272 end if; 1273 1274 return; 1275 end if; 1276 end if; 1277 1278 -- Operations generated for RACW stub types are called only through 1279 -- dispatching, and can never be the static interpretation of a call. 1280 1281 if Is_RACW_Stub_Type_Operation (Nam_Ent) then 1282 No_Interpretation; 1283 return; 1284 end if; 1285 1286 Analyze_One_Call (N, Nam_Ent, True, Success); 1287 1288 -- If this is an indirect call, the return type of the access_to 1289 -- subprogram may be an incomplete type. At the point of the call, 1290 -- use the full type if available, and at the same time update the 1291 -- return type of the access_to_subprogram. 1292 1293 if Success 1294 and then Nkind (Nam) = N_Explicit_Dereference 1295 and then Ekind (Etype (N)) = E_Incomplete_Type 1296 and then Present (Full_View (Etype (N))) 1297 then 1298 Set_Etype (N, Full_View (Etype (N))); 1299 Set_Etype (Nam_Ent, Etype (N)); 1300 end if; 1301 1302 -- Overloaded call 1303 1304 else 1305 -- An overloaded selected component must denote overloaded operations 1306 -- of a concurrent type. The interpretations are attached to the 1307 -- simple name of those operations. 1308 1309 if Nkind (Nam) = N_Selected_Component then 1310 Nam := Selector_Name (Nam); 1311 end if; 1312 1313 Get_First_Interp (Nam, X, It); 1314 while Present (It.Nam) loop 1315 Nam_Ent := It.Nam; 1316 Deref := False; 1317 1318 -- Name may be call that returns an access to subprogram, or more 1319 -- generally an overloaded expression one of whose interpretations 1320 -- yields an access to subprogram. If the name is an entity, we do 1321 -- not dereference, because the node is a call that returns the 1322 -- access type: note difference between f(x), where the call may 1323 -- return an access subprogram type, and f(x)(y), where the type 1324 -- returned by the call to f is implicitly dereferenced to analyze 1325 -- the outer call. 1326 1327 if Is_Access_Type (Nam_Ent) then 1328 Nam_Ent := Designated_Type (Nam_Ent); 1329 1330 elsif Is_Access_Type (Etype (Nam_Ent)) 1331 and then 1332 (not Is_Entity_Name (Nam) 1333 or else Nkind (N) = N_Procedure_Call_Statement) 1334 and then Ekind (Designated_Type (Etype (Nam_Ent))) 1335 = E_Subprogram_Type 1336 then 1337 Nam_Ent := Designated_Type (Etype (Nam_Ent)); 1338 1339 if Is_Entity_Name (Nam) then 1340 Deref := True; 1341 end if; 1342 end if; 1343 1344 -- If the call has been rewritten from a prefixed call, the first 1345 -- parameter has been analyzed, but may need a subsequent 1346 -- dereference, so skip its analysis now. 1347 1348 if N /= Original_Node (N) 1349 and then Nkind (Original_Node (N)) = Nkind (N) 1350 and then Nkind (Name (N)) /= Nkind (Name (Original_Node (N))) 1351 and then Present (Parameter_Associations (N)) 1352 and then Present (Etype (First (Parameter_Associations (N)))) 1353 then 1354 Analyze_One_Call 1355 (N, Nam_Ent, False, Success, Skip_First => True); 1356 else 1357 Analyze_One_Call (N, Nam_Ent, False, Success); 1358 end if; 1359 1360 -- If the interpretation succeeds, mark the proper type of the 1361 -- prefix (any valid candidate will do). If not, remove the 1362 -- candidate interpretation. If this is a parameterless call 1363 -- on an anonymous access to subprogram, X is a variable with 1364 -- an access discriminant D, the entity in the interpretation is 1365 -- D, so rewrite X as X.D.all. 1366 1367 if Success then 1368 if Deref 1369 and then Nkind (Parent (N)) /= N_Explicit_Dereference 1370 then 1371 if Ekind (It.Nam) = E_Discriminant 1372 and then Has_Implicit_Dereference (It.Nam) 1373 then 1374 Rewrite (Name (N), 1375 Make_Explicit_Dereference (Loc, 1376 Prefix => 1377 Make_Selected_Component (Loc, 1378 Prefix => 1379 New_Occurrence_Of (Entity (Nam), Loc), 1380 Selector_Name => 1381 New_Occurrence_Of (It.Nam, Loc)))); 1382 1383 Analyze (N); 1384 return; 1385 1386 else 1387 Set_Entity (Nam, It.Nam); 1388 Insert_Explicit_Dereference (Nam); 1389 Set_Etype (Nam, Nam_Ent); 1390 end if; 1391 1392 else 1393 Set_Etype (Nam, It.Typ); 1394 end if; 1395 1396 elsif Nkind_In (Name (N), N_Function_Call, N_Selected_Component) 1397 then 1398 Remove_Interp (X); 1399 end if; 1400 1401 Get_Next_Interp (X, It); 1402 end loop; 1403 1404 -- If the name is the result of a function call, it can only be a 1405 -- call to a function returning an access to subprogram. Insert 1406 -- explicit dereference. 1407 1408 if Nkind (Nam) = N_Function_Call then 1409 Insert_Explicit_Dereference (Nam); 1410 end if; 1411 1412 if Etype (N) = Any_Type then 1413 1414 -- None of the interpretations is compatible with the actuals 1415 1416 Diagnose_Call (N, Nam); 1417 1418 -- Special checks for uninstantiated put routines 1419 1420 if Nkind (N) = N_Procedure_Call_Statement 1421 and then Is_Entity_Name (Nam) 1422 and then Chars (Nam) = Name_Put 1423 and then List_Length (Actuals) = 1 1424 then 1425 declare 1426 Arg : constant Node_Id := First (Actuals); 1427 Typ : Entity_Id; 1428 1429 begin 1430 if Nkind (Arg) = N_Parameter_Association then 1431 Typ := Etype (Explicit_Actual_Parameter (Arg)); 1432 else 1433 Typ := Etype (Arg); 1434 end if; 1435 1436 if Is_Signed_Integer_Type (Typ) then 1437 Error_Msg_N 1438 ("possible missing instantiation of " 1439 & "'Text_'I'O.'Integer_'I'O!", Nam); 1440 1441 elsif Is_Modular_Integer_Type (Typ) then 1442 Error_Msg_N 1443 ("possible missing instantiation of " 1444 & "'Text_'I'O.'Modular_'I'O!", Nam); 1445 1446 elsif Is_Floating_Point_Type (Typ) then 1447 Error_Msg_N 1448 ("possible missing instantiation of " 1449 & "'Text_'I'O.'Float_'I'O!", Nam); 1450 1451 elsif Is_Ordinary_Fixed_Point_Type (Typ) then 1452 Error_Msg_N 1453 ("possible missing instantiation of " 1454 & "'Text_'I'O.'Fixed_'I'O!", Nam); 1455 1456 elsif Is_Decimal_Fixed_Point_Type (Typ) then 1457 Error_Msg_N 1458 ("possible missing instantiation of " 1459 & "'Text_'I'O.'Decimal_'I'O!", Nam); 1460 1461 elsif Is_Enumeration_Type (Typ) then 1462 Error_Msg_N 1463 ("possible missing instantiation of " 1464 & "'Text_'I'O.'Enumeration_'I'O!", Nam); 1465 end if; 1466 end; 1467 end if; 1468 1469 elsif not Is_Overloaded (N) 1470 and then Is_Entity_Name (Nam) 1471 then 1472 -- Resolution yields a single interpretation. Verify that the 1473 -- reference has capitalization consistent with the declaration. 1474 1475 Set_Entity_With_Checks (Nam, Entity (Nam)); 1476 Generate_Reference (Entity (Nam), Nam); 1477 1478 Set_Etype (Nam, Etype (Entity (Nam))); 1479 else 1480 Remove_Abstract_Operations (N); 1481 end if; 1482 1483 End_Interp_List; 1484 end if; 1485 1486 if Ada_Version >= Ada_2012 then 1487 1488 -- Check if the call contains a function with writable actuals 1489 1490 Check_Writable_Actuals (N); 1491 1492 -- If found and the outermost construct that can be evaluated in 1493 -- an arbitrary order is precisely this call, then check all its 1494 -- actuals. 1495 1496 Check_Function_Writable_Actuals (N); 1497 1498 -- The return type of the function may be incomplete. This can be 1499 -- the case if the type is a generic formal, or a limited view. It 1500 -- can also happen when the function declaration appears before the 1501 -- full view of the type (which is legal in Ada 2012) and the call 1502 -- appears in a different unit, in which case the incomplete view 1503 -- must be replaced with the full view (or the nonlimited view) 1504 -- to prevent subsequent type errors. Note that the usual install/ 1505 -- removal of limited_with clauses is not sufficient to handle this 1506 -- case, because the limited view may have been captured in another 1507 -- compilation unit that defines the current function. 1508 1509 if Is_Incomplete_Type (Etype (N)) then 1510 if Present (Full_View (Etype (N))) then 1511 if Is_Entity_Name (Nam) then 1512 Set_Etype (Nam, Full_View (Etype (N))); 1513 Set_Etype (Entity (Nam), Full_View (Etype (N))); 1514 end if; 1515 1516 Set_Etype (N, Full_View (Etype (N))); 1517 1518 elsif From_Limited_With (Etype (N)) 1519 and then Present (Non_Limited_View (Etype (N))) 1520 then 1521 Set_Etype (N, Non_Limited_View (Etype (N))); 1522 1523 -- If there is no completion for the type, this may be because 1524 -- there is only a limited view of it and there is nothing in 1525 -- the context of the current unit that has required a regular 1526 -- compilation of the unit containing the type. We recognize 1527 -- this unusual case by the fact that that unit is not analyzed. 1528 -- Note that the call being analyzed is in a different unit from 1529 -- the function declaration, and nothing indicates that the type 1530 -- is a limited view. 1531 1532 elsif Ekind (Scope (Etype (N))) = E_Package 1533 and then Present (Limited_View (Scope (Etype (N)))) 1534 and then not Analyzed (Unit_Declaration_Node (Scope (Etype (N)))) 1535 then 1536 Error_Msg_NE 1537 ("cannot call function that returns limited view of}", 1538 N, Etype (N)); 1539 1540 Error_Msg_NE 1541 ("\there must be a regular with_clause for package & in the " 1542 & "current unit, or in some unit in its context", 1543 N, Scope (Etype (N))); 1544 1545 Set_Etype (N, Any_Type); 1546 end if; 1547 end if; 1548 end if; 1549 end Analyze_Call; 1550 1551 ----------------------------- 1552 -- Analyze_Case_Expression -- 1553 ----------------------------- 1554 1555 procedure Analyze_Case_Expression (N : Node_Id) is 1556 procedure Non_Static_Choice_Error (Choice : Node_Id); 1557 -- Error routine invoked by the generic instantiation below when 1558 -- the case expression has a non static choice. 1559 1560 package Case_Choices_Analysis is new 1561 Generic_Analyze_Choices 1562 (Process_Associated_Node => No_OP); 1563 use Case_Choices_Analysis; 1564 1565 package Case_Choices_Checking is new 1566 Generic_Check_Choices 1567 (Process_Empty_Choice => No_OP, 1568 Process_Non_Static_Choice => Non_Static_Choice_Error, 1569 Process_Associated_Node => No_OP); 1570 use Case_Choices_Checking; 1571 1572 ----------------------------- 1573 -- Non_Static_Choice_Error -- 1574 ----------------------------- 1575 1576 procedure Non_Static_Choice_Error (Choice : Node_Id) is 1577 begin 1578 Flag_Non_Static_Expr 1579 ("choice given in case expression is not static!", Choice); 1580 end Non_Static_Choice_Error; 1581 1582 -- Local variables 1583 1584 Expr : constant Node_Id := Expression (N); 1585 Alt : Node_Id; 1586 Exp_Type : Entity_Id; 1587 Exp_Btype : Entity_Id; 1588 1589 FirstX : Node_Id := Empty; 1590 -- First expression in the case for which there is some type information 1591 -- available, i.e. it is not Any_Type, which can happen because of some 1592 -- error, or from the use of e.g. raise Constraint_Error. 1593 1594 Others_Present : Boolean; 1595 -- Indicates if Others was present 1596 1597 Wrong_Alt : Node_Id := Empty; 1598 -- For error reporting 1599 1600 -- Start of processing for Analyze_Case_Expression 1601 1602 begin 1603 if Comes_From_Source (N) then 1604 Check_Compiler_Unit ("case expression", N); 1605 end if; 1606 1607 Analyze_And_Resolve (Expr, Any_Discrete); 1608 Check_Unset_Reference (Expr); 1609 Exp_Type := Etype (Expr); 1610 Exp_Btype := Base_Type (Exp_Type); 1611 1612 Alt := First (Alternatives (N)); 1613 while Present (Alt) loop 1614 if Error_Posted (Expression (Alt)) then 1615 return; 1616 end if; 1617 1618 Analyze (Expression (Alt)); 1619 1620 if No (FirstX) and then Etype (Expression (Alt)) /= Any_Type then 1621 FirstX := Expression (Alt); 1622 end if; 1623 1624 Next (Alt); 1625 end loop; 1626 1627 -- Get our initial type from the first expression for which we got some 1628 -- useful type information from the expression. 1629 1630 if No (FirstX) then 1631 return; 1632 end if; 1633 1634 if not Is_Overloaded (FirstX) then 1635 Set_Etype (N, Etype (FirstX)); 1636 1637 else 1638 declare 1639 I : Interp_Index; 1640 It : Interp; 1641 1642 begin 1643 Set_Etype (N, Any_Type); 1644 1645 Get_First_Interp (FirstX, I, It); 1646 while Present (It.Nam) loop 1647 1648 -- For each interpretation of the first expression, we only 1649 -- add the interpretation if every other expression in the 1650 -- case expression alternatives has a compatible type. 1651 1652 Alt := Next (First (Alternatives (N))); 1653 while Present (Alt) loop 1654 exit when not Has_Compatible_Type (Expression (Alt), It.Typ); 1655 Next (Alt); 1656 end loop; 1657 1658 if No (Alt) then 1659 Add_One_Interp (N, It.Typ, It.Typ); 1660 else 1661 Wrong_Alt := Alt; 1662 end if; 1663 1664 Get_Next_Interp (I, It); 1665 end loop; 1666 end; 1667 end if; 1668 1669 Exp_Btype := Base_Type (Exp_Type); 1670 1671 -- The expression must be of a discrete type which must be determinable 1672 -- independently of the context in which the expression occurs, but 1673 -- using the fact that the expression must be of a discrete type. 1674 -- Moreover, the type this expression must not be a character literal 1675 -- (which is always ambiguous). 1676 1677 -- If error already reported by Resolve, nothing more to do 1678 1679 if Exp_Btype = Any_Discrete or else Exp_Btype = Any_Type then 1680 return; 1681 1682 -- Special casee message for character literal 1683 1684 elsif Exp_Btype = Any_Character then 1685 Error_Msg_N 1686 ("character literal as case expression is ambiguous", Expr); 1687 return; 1688 end if; 1689 1690 if Etype (N) = Any_Type and then Present (Wrong_Alt) then 1691 Error_Msg_N 1692 ("type incompatible with that of previous alternatives", 1693 Expression (Wrong_Alt)); 1694 return; 1695 end if; 1696 1697 -- If the case expression is a formal object of mode in out, then 1698 -- treat it as having a nonstatic subtype by forcing use of the base 1699 -- type (which has to get passed to Check_Case_Choices below). Also 1700 -- use base type when the case expression is parenthesized. 1701 1702 if Paren_Count (Expr) > 0 1703 or else (Is_Entity_Name (Expr) 1704 and then Ekind (Entity (Expr)) = E_Generic_In_Out_Parameter) 1705 then 1706 Exp_Type := Exp_Btype; 1707 end if; 1708 1709 -- The case expression alternatives cover the range of a static subtype 1710 -- subject to aspect Static_Predicate. Do not check the choices when the 1711 -- case expression has not been fully analyzed yet because this may lead 1712 -- to bogus errors. 1713 1714 if Is_OK_Static_Subtype (Exp_Type) 1715 and then Has_Static_Predicate_Aspect (Exp_Type) 1716 and then In_Spec_Expression 1717 then 1718 null; 1719 1720 -- Call Analyze_Choices and Check_Choices to do the rest of the work 1721 1722 else 1723 Analyze_Choices (Alternatives (N), Exp_Type); 1724 Check_Choices (N, Alternatives (N), Exp_Type, Others_Present); 1725 1726 if Exp_Type = Universal_Integer and then not Others_Present then 1727 Error_Msg_N 1728 ("case on universal integer requires OTHERS choice", Expr); 1729 end if; 1730 end if; 1731 end Analyze_Case_Expression; 1732 1733 --------------------------- 1734 -- Analyze_Comparison_Op -- 1735 --------------------------- 1736 1737 procedure Analyze_Comparison_Op (N : Node_Id) is 1738 L : constant Node_Id := Left_Opnd (N); 1739 R : constant Node_Id := Right_Opnd (N); 1740 Op_Id : Entity_Id := Entity (N); 1741 1742 begin 1743 Set_Etype (N, Any_Type); 1744 Candidate_Type := Empty; 1745 1746 Analyze_Expression (L); 1747 Analyze_Expression (R); 1748 1749 if Present (Op_Id) then 1750 if Ekind (Op_Id) = E_Operator then 1751 Find_Comparison_Types (L, R, Op_Id, N); 1752 else 1753 Add_One_Interp (N, Op_Id, Etype (Op_Id)); 1754 end if; 1755 1756 if Is_Overloaded (L) then 1757 Set_Etype (L, Intersect_Types (L, R)); 1758 end if; 1759 1760 else 1761 Op_Id := Get_Name_Entity_Id (Chars (N)); 1762 while Present (Op_Id) loop 1763 if Ekind (Op_Id) = E_Operator then 1764 Find_Comparison_Types (L, R, Op_Id, N); 1765 else 1766 Analyze_User_Defined_Binary_Op (N, Op_Id); 1767 end if; 1768 1769 Op_Id := Homonym (Op_Id); 1770 end loop; 1771 end if; 1772 1773 Operator_Check (N); 1774 Check_Function_Writable_Actuals (N); 1775 end Analyze_Comparison_Op; 1776 1777 --------------------------- 1778 -- Analyze_Concatenation -- 1779 --------------------------- 1780 1781 procedure Analyze_Concatenation (N : Node_Id) is 1782 1783 -- We wish to avoid deep recursion, because concatenations are often 1784 -- deeply nested, as in A&B&...&Z. Therefore, we walk down the left 1785 -- operands nonrecursively until we find something that is not a 1786 -- concatenation (A in this case), or has already been analyzed. We 1787 -- analyze that, and then walk back up the tree following Parent 1788 -- pointers, calling Analyze_Concatenation_Rest to do the rest of the 1789 -- work at each level. The Parent pointers allow us to avoid recursion, 1790 -- and thus avoid running out of memory. 1791 1792 NN : Node_Id := N; 1793 L : Node_Id; 1794 1795 begin 1796 Candidate_Type := Empty; 1797 1798 -- The following code is equivalent to: 1799 1800 -- Set_Etype (N, Any_Type); 1801 -- Analyze_Expression (Left_Opnd (N)); 1802 -- Analyze_Concatenation_Rest (N); 1803 1804 -- where the Analyze_Expression call recurses back here if the left 1805 -- operand is a concatenation. 1806 1807 -- Walk down left operands 1808 1809 loop 1810 Set_Etype (NN, Any_Type); 1811 L := Left_Opnd (NN); 1812 exit when Nkind (L) /= N_Op_Concat or else Analyzed (L); 1813 NN := L; 1814 end loop; 1815 1816 -- Now (given the above example) NN is A&B and L is A 1817 1818 -- First analyze L ... 1819 1820 Analyze_Expression (L); 1821 1822 -- ... then walk NN back up until we reach N (where we started), calling 1823 -- Analyze_Concatenation_Rest along the way. 1824 1825 loop 1826 Analyze_Concatenation_Rest (NN); 1827 exit when NN = N; 1828 NN := Parent (NN); 1829 end loop; 1830 end Analyze_Concatenation; 1831 1832 -------------------------------- 1833 -- Analyze_Concatenation_Rest -- 1834 -------------------------------- 1835 1836 -- If the only one-dimensional array type in scope is String, 1837 -- this is the resulting type of the operation. Otherwise there 1838 -- will be a concatenation operation defined for each user-defined 1839 -- one-dimensional array. 1840 1841 procedure Analyze_Concatenation_Rest (N : Node_Id) is 1842 L : constant Node_Id := Left_Opnd (N); 1843 R : constant Node_Id := Right_Opnd (N); 1844 Op_Id : Entity_Id := Entity (N); 1845 LT : Entity_Id; 1846 RT : Entity_Id; 1847 1848 begin 1849 Analyze_Expression (R); 1850 1851 -- If the entity is present, the node appears in an instance, and 1852 -- denotes a predefined concatenation operation. The resulting type is 1853 -- obtained from the arguments when possible. If the arguments are 1854 -- aggregates, the array type and the concatenation type must be 1855 -- visible. 1856 1857 if Present (Op_Id) then 1858 if Ekind (Op_Id) = E_Operator then 1859 LT := Base_Type (Etype (L)); 1860 RT := Base_Type (Etype (R)); 1861 1862 if Is_Array_Type (LT) 1863 and then (RT = LT or else RT = Base_Type (Component_Type (LT))) 1864 then 1865 Add_One_Interp (N, Op_Id, LT); 1866 1867 elsif Is_Array_Type (RT) 1868 and then LT = Base_Type (Component_Type (RT)) 1869 then 1870 Add_One_Interp (N, Op_Id, RT); 1871 1872 -- If one operand is a string type or a user-defined array type, 1873 -- and the other is a literal, result is of the specific type. 1874 1875 elsif 1876 (Root_Type (LT) = Standard_String 1877 or else Scope (LT) /= Standard_Standard) 1878 and then Etype (R) = Any_String 1879 then 1880 Add_One_Interp (N, Op_Id, LT); 1881 1882 elsif 1883 (Root_Type (RT) = Standard_String 1884 or else Scope (RT) /= Standard_Standard) 1885 and then Etype (L) = Any_String 1886 then 1887 Add_One_Interp (N, Op_Id, RT); 1888 1889 elsif not Is_Generic_Type (Etype (Op_Id)) then 1890 Add_One_Interp (N, Op_Id, Etype (Op_Id)); 1891 1892 else 1893 -- Type and its operations must be visible 1894 1895 Set_Entity (N, Empty); 1896 Analyze_Concatenation (N); 1897 end if; 1898 1899 else 1900 Add_One_Interp (N, Op_Id, Etype (Op_Id)); 1901 end if; 1902 1903 else 1904 Op_Id := Get_Name_Entity_Id (Name_Op_Concat); 1905 while Present (Op_Id) loop 1906 if Ekind (Op_Id) = E_Operator then 1907 1908 -- Do not consider operators declared in dead code, they can 1909 -- not be part of the resolution. 1910 1911 if Is_Eliminated (Op_Id) then 1912 null; 1913 else 1914 Find_Concatenation_Types (L, R, Op_Id, N); 1915 end if; 1916 1917 else 1918 Analyze_User_Defined_Binary_Op (N, Op_Id); 1919 end if; 1920 1921 Op_Id := Homonym (Op_Id); 1922 end loop; 1923 end if; 1924 1925 Operator_Check (N); 1926 end Analyze_Concatenation_Rest; 1927 1928 ------------------------- 1929 -- Analyze_Equality_Op -- 1930 ------------------------- 1931 1932 procedure Analyze_Equality_Op (N : Node_Id) is 1933 Loc : constant Source_Ptr := Sloc (N); 1934 L : constant Node_Id := Left_Opnd (N); 1935 R : constant Node_Id := Right_Opnd (N); 1936 Op_Id : Entity_Id; 1937 1938 begin 1939 Set_Etype (N, Any_Type); 1940 Candidate_Type := Empty; 1941 1942 Analyze_Expression (L); 1943 Analyze_Expression (R); 1944 1945 -- If the entity is set, the node is a generic instance with a non-local 1946 -- reference to the predefined operator or to a user-defined function. 1947 -- It can also be an inequality that is expanded into the negation of a 1948 -- call to a user-defined equality operator. 1949 1950 -- For the predefined case, the result is Boolean, regardless of the 1951 -- type of the operands. The operands may even be limited, if they are 1952 -- generic actuals. If they are overloaded, label the left argument with 1953 -- the common type that must be present, or with the type of the formal 1954 -- of the user-defined function. 1955 1956 if Present (Entity (N)) then 1957 Op_Id := Entity (N); 1958 1959 if Ekind (Op_Id) = E_Operator then 1960 Add_One_Interp (N, Op_Id, Standard_Boolean); 1961 else 1962 Add_One_Interp (N, Op_Id, Etype (Op_Id)); 1963 end if; 1964 1965 if Is_Overloaded (L) then 1966 if Ekind (Op_Id) = E_Operator then 1967 Set_Etype (L, Intersect_Types (L, R)); 1968 else 1969 Set_Etype (L, Etype (First_Formal (Op_Id))); 1970 end if; 1971 end if; 1972 1973 else 1974 Op_Id := Get_Name_Entity_Id (Chars (N)); 1975 while Present (Op_Id) loop 1976 if Ekind (Op_Id) = E_Operator then 1977 Find_Equality_Types (L, R, Op_Id, N); 1978 else 1979 Analyze_User_Defined_Binary_Op (N, Op_Id); 1980 end if; 1981 1982 Op_Id := Homonym (Op_Id); 1983 end loop; 1984 end if; 1985 1986 -- If there was no match, and the operator is inequality, this may be 1987 -- a case where inequality has not been made explicit, as for tagged 1988 -- types. Analyze the node as the negation of an equality operation. 1989 -- This cannot be done earlier, because before analysis we cannot rule 1990 -- out the presence of an explicit inequality. 1991 1992 if Etype (N) = Any_Type 1993 and then Nkind (N) = N_Op_Ne 1994 then 1995 Op_Id := Get_Name_Entity_Id (Name_Op_Eq); 1996 while Present (Op_Id) loop 1997 if Ekind (Op_Id) = E_Operator then 1998 Find_Equality_Types (L, R, Op_Id, N); 1999 else 2000 Analyze_User_Defined_Binary_Op (N, Op_Id); 2001 end if; 2002 2003 Op_Id := Homonym (Op_Id); 2004 end loop; 2005 2006 if Etype (N) /= Any_Type then 2007 Op_Id := Entity (N); 2008 2009 Rewrite (N, 2010 Make_Op_Not (Loc, 2011 Right_Opnd => 2012 Make_Op_Eq (Loc, 2013 Left_Opnd => Left_Opnd (N), 2014 Right_Opnd => Right_Opnd (N)))); 2015 2016 Set_Entity (Right_Opnd (N), Op_Id); 2017 Analyze (N); 2018 end if; 2019 end if; 2020 2021 Operator_Check (N); 2022 Check_Function_Writable_Actuals (N); 2023 end Analyze_Equality_Op; 2024 2025 ---------------------------------- 2026 -- Analyze_Explicit_Dereference -- 2027 ---------------------------------- 2028 2029 procedure Analyze_Explicit_Dereference (N : Node_Id) is 2030 Loc : constant Source_Ptr := Sloc (N); 2031 P : constant Node_Id := Prefix (N); 2032 T : Entity_Id; 2033 I : Interp_Index; 2034 It : Interp; 2035 New_N : Node_Id; 2036 2037 function Is_Function_Type return Boolean; 2038 -- Check whether node may be interpreted as an implicit function call 2039 2040 ---------------------- 2041 -- Is_Function_Type -- 2042 ---------------------- 2043 2044 function Is_Function_Type return Boolean is 2045 I : Interp_Index; 2046 It : Interp; 2047 2048 begin 2049 if not Is_Overloaded (N) then 2050 return Ekind (Base_Type (Etype (N))) = E_Subprogram_Type 2051 and then Etype (Base_Type (Etype (N))) /= Standard_Void_Type; 2052 2053 else 2054 Get_First_Interp (N, I, It); 2055 while Present (It.Nam) loop 2056 if Ekind (Base_Type (It.Typ)) /= E_Subprogram_Type 2057 or else Etype (Base_Type (It.Typ)) = Standard_Void_Type 2058 then 2059 return False; 2060 end if; 2061 2062 Get_Next_Interp (I, It); 2063 end loop; 2064 2065 return True; 2066 end if; 2067 end Is_Function_Type; 2068 2069 -- Start of processing for Analyze_Explicit_Dereference 2070 2071 begin 2072 -- If source node, check SPARK restriction. We guard this with the 2073 -- source node check, because ??? 2074 2075 if Comes_From_Source (N) then 2076 Check_SPARK_05_Restriction ("explicit dereference is not allowed", N); 2077 end if; 2078 2079 -- In formal verification mode, keep track of all reads and writes 2080 -- through explicit dereferences. 2081 2082 if GNATprove_Mode then 2083 SPARK_Specific.Generate_Dereference (N); 2084 end if; 2085 2086 Analyze (P); 2087 Set_Etype (N, Any_Type); 2088 2089 -- Test for remote access to subprogram type, and if so return 2090 -- after rewriting the original tree. 2091 2092 if Remote_AST_E_Dereference (P) then 2093 return; 2094 end if; 2095 2096 -- Normal processing for other than remote access to subprogram type 2097 2098 if not Is_Overloaded (P) then 2099 if Is_Access_Type (Etype (P)) then 2100 2101 -- Set the Etype. We need to go through Is_For_Access_Subtypes to 2102 -- avoid other problems caused by the Private_Subtype and it is 2103 -- safe to go to the Base_Type because this is the same as 2104 -- converting the access value to its Base_Type. 2105 2106 declare 2107 DT : Entity_Id := Designated_Type (Etype (P)); 2108 2109 begin 2110 if Ekind (DT) = E_Private_Subtype 2111 and then Is_For_Access_Subtype (DT) 2112 then 2113 DT := Base_Type (DT); 2114 end if; 2115 2116 -- An explicit dereference is a legal occurrence of an 2117 -- incomplete type imported through a limited_with clause, if 2118 -- the full view is visible, or if we are within an instance 2119 -- body, where the enclosing body has a regular with_clause 2120 -- on the unit. 2121 2122 if From_Limited_With (DT) 2123 and then not From_Limited_With (Scope (DT)) 2124 and then 2125 (Is_Immediately_Visible (Scope (DT)) 2126 or else 2127 (Is_Child_Unit (Scope (DT)) 2128 and then Is_Visible_Lib_Unit (Scope (DT))) 2129 or else In_Instance_Body) 2130 then 2131 Set_Etype (N, Available_View (DT)); 2132 2133 else 2134 Set_Etype (N, DT); 2135 end if; 2136 end; 2137 2138 elsif Etype (P) /= Any_Type then 2139 Error_Msg_N ("prefix of dereference must be an access type", N); 2140 return; 2141 end if; 2142 2143 else 2144 Get_First_Interp (P, I, It); 2145 while Present (It.Nam) loop 2146 T := It.Typ; 2147 2148 if Is_Access_Type (T) then 2149 Add_One_Interp (N, Designated_Type (T), Designated_Type (T)); 2150 end if; 2151 2152 Get_Next_Interp (I, It); 2153 end loop; 2154 2155 -- Error if no interpretation of the prefix has an access type 2156 2157 if Etype (N) = Any_Type then 2158 Error_Msg_N 2159 ("access type required in prefix of explicit dereference", P); 2160 Set_Etype (N, Any_Type); 2161 return; 2162 end if; 2163 end if; 2164 2165 if Is_Function_Type 2166 and then Nkind (Parent (N)) /= N_Indexed_Component 2167 2168 and then (Nkind (Parent (N)) /= N_Function_Call 2169 or else N /= Name (Parent (N))) 2170 2171 and then (Nkind (Parent (N)) /= N_Procedure_Call_Statement 2172 or else N /= Name (Parent (N))) 2173 2174 and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration 2175 and then (Nkind (Parent (N)) /= N_Attribute_Reference 2176 or else 2177 (Attribute_Name (Parent (N)) /= Name_Address 2178 and then 2179 Attribute_Name (Parent (N)) /= Name_Access)) 2180 then 2181 -- Name is a function call with no actuals, in a context that 2182 -- requires deproceduring (including as an actual in an enclosing 2183 -- function or procedure call). There are some pathological cases 2184 -- where the prefix might include functions that return access to 2185 -- subprograms and others that return a regular type. Disambiguation 2186 -- of those has to take place in Resolve. 2187 2188 New_N := 2189 Make_Function_Call (Loc, 2190 Name => Make_Explicit_Dereference (Loc, P), 2191 Parameter_Associations => New_List); 2192 2193 -- If the prefix is overloaded, remove operations that have formals, 2194 -- we know that this is a parameterless call. 2195 2196 if Is_Overloaded (P) then 2197 Get_First_Interp (P, I, It); 2198 while Present (It.Nam) loop 2199 T := It.Typ; 2200 2201 if No (First_Formal (Base_Type (Designated_Type (T)))) then 2202 Set_Etype (P, T); 2203 else 2204 Remove_Interp (I); 2205 end if; 2206 2207 Get_Next_Interp (I, It); 2208 end loop; 2209 end if; 2210 2211 Rewrite (N, New_N); 2212 Analyze (N); 2213 2214 elsif not Is_Function_Type 2215 and then Is_Overloaded (N) 2216 then 2217 -- The prefix may include access to subprograms and other access 2218 -- types. If the context selects the interpretation that is a 2219 -- function call (not a procedure call) we cannot rewrite the node 2220 -- yet, but we include the result of the call interpretation. 2221 2222 Get_First_Interp (N, I, It); 2223 while Present (It.Nam) loop 2224 if Ekind (Base_Type (It.Typ)) = E_Subprogram_Type 2225 and then Etype (Base_Type (It.Typ)) /= Standard_Void_Type 2226 and then Nkind (Parent (N)) /= N_Procedure_Call_Statement 2227 then 2228 Add_One_Interp (N, Etype (It.Typ), Etype (It.Typ)); 2229 end if; 2230 2231 Get_Next_Interp (I, It); 2232 end loop; 2233 end if; 2234 2235 -- A value of remote access-to-class-wide must not be dereferenced 2236 -- (RM E.2.2(16)). 2237 2238 Validate_Remote_Access_To_Class_Wide_Type (N); 2239 end Analyze_Explicit_Dereference; 2240 2241 ------------------------ 2242 -- Analyze_Expression -- 2243 ------------------------ 2244 2245 procedure Analyze_Expression (N : Node_Id) is 2246 begin 2247 2248 -- If the expression is an indexed component that will be rewritten 2249 -- as a container indexing, it has already been analyzed. 2250 2251 if Nkind (N) = N_Indexed_Component 2252 and then Present (Generalized_Indexing (N)) 2253 then 2254 null; 2255 2256 else 2257 Analyze (N); 2258 Check_Parameterless_Call (N); 2259 end if; 2260 end Analyze_Expression; 2261 2262 ------------------------------------- 2263 -- Analyze_Expression_With_Actions -- 2264 ------------------------------------- 2265 2266 procedure Analyze_Expression_With_Actions (N : Node_Id) is 2267 A : Node_Id; 2268 2269 begin 2270 A := First (Actions (N)); 2271 while Present (A) loop 2272 Analyze (A); 2273 Next (A); 2274 end loop; 2275 2276 Analyze_Expression (Expression (N)); 2277 Set_Etype (N, Etype (Expression (N))); 2278 end Analyze_Expression_With_Actions; 2279 2280 --------------------------- 2281 -- Analyze_If_Expression -- 2282 --------------------------- 2283 2284 procedure Analyze_If_Expression (N : Node_Id) is 2285 Condition : constant Node_Id := First (Expressions (N)); 2286 Then_Expr : Node_Id; 2287 Else_Expr : Node_Id; 2288 2289 begin 2290 -- Defend against error of missing expressions from previous error 2291 2292 if No (Condition) then 2293 Check_Error_Detected; 2294 return; 2295 end if; 2296 2297 Then_Expr := Next (Condition); 2298 2299 if No (Then_Expr) then 2300 Check_Error_Detected; 2301 return; 2302 end if; 2303 2304 Else_Expr := Next (Then_Expr); 2305 2306 if Comes_From_Source (N) then 2307 Check_SPARK_05_Restriction ("if expression is not allowed", N); 2308 end if; 2309 2310 if Comes_From_Source (N) then 2311 Check_Compiler_Unit ("if expression", N); 2312 end if; 2313 2314 -- Analyze and resolve the condition. We need to resolve this now so 2315 -- that it gets folded to True/False if possible, before we analyze 2316 -- the THEN/ELSE branches, because when analyzing these branches, we 2317 -- may call Is_Statically_Unevaluated, which expects the condition of 2318 -- an enclosing IF to have been analyze/resolved/evaluated. 2319 2320 Analyze_Expression (Condition); 2321 Resolve (Condition, Any_Boolean); 2322 2323 -- Analyze THEN expression and (if present) ELSE expression. For those 2324 -- we delay resolution in the normal manner, because of overloading etc. 2325 2326 Analyze_Expression (Then_Expr); 2327 2328 if Present (Else_Expr) then 2329 Analyze_Expression (Else_Expr); 2330 end if; 2331 2332 -- If then expression not overloaded, then that decides the type 2333 2334 if not Is_Overloaded (Then_Expr) then 2335 Set_Etype (N, Etype (Then_Expr)); 2336 2337 -- Case where then expression is overloaded 2338 2339 else 2340 declare 2341 I : Interp_Index; 2342 It : Interp; 2343 2344 begin 2345 Set_Etype (N, Any_Type); 2346 2347 -- Loop through interpretations of Then_Expr 2348 2349 Get_First_Interp (Then_Expr, I, It); 2350 while Present (It.Nam) loop 2351 2352 -- Add possible interpretation of Then_Expr if no Else_Expr, or 2353 -- Else_Expr is present and has a compatible type. 2354 2355 if No (Else_Expr) 2356 or else Has_Compatible_Type (Else_Expr, It.Typ) 2357 then 2358 Add_One_Interp (N, It.Typ, It.Typ); 2359 end if; 2360 2361 Get_Next_Interp (I, It); 2362 end loop; 2363 2364 -- If no valid interpretation has been found, then the type of the 2365 -- ELSE expression does not match any interpretation of the THEN 2366 -- expression. 2367 2368 if Etype (N) = Any_Type then 2369 Error_Msg_N 2370 ("type incompatible with that of `THEN` expression", 2371 Else_Expr); 2372 return; 2373 end if; 2374 end; 2375 end if; 2376 end Analyze_If_Expression; 2377 2378 ------------------------------------ 2379 -- Analyze_Indexed_Component_Form -- 2380 ------------------------------------ 2381 2382 procedure Analyze_Indexed_Component_Form (N : Node_Id) is 2383 P : constant Node_Id := Prefix (N); 2384 Exprs : constant List_Id := Expressions (N); 2385 Exp : Node_Id; 2386 P_T : Entity_Id; 2387 E : Node_Id; 2388 U_N : Entity_Id; 2389 2390 procedure Process_Function_Call; 2391 -- Prefix in indexed component form is an overloadable entity, so the 2392 -- node is a function call. Reformat it as such. 2393 2394 procedure Process_Indexed_Component; 2395 -- Prefix in indexed component form is actually an indexed component. 2396 -- This routine processes it, knowing that the prefix is already 2397 -- resolved. 2398 2399 procedure Process_Indexed_Component_Or_Slice; 2400 -- An indexed component with a single index may designate a slice if 2401 -- the index is a subtype mark. This routine disambiguates these two 2402 -- cases by resolving the prefix to see if it is a subtype mark. 2403 2404 procedure Process_Overloaded_Indexed_Component; 2405 -- If the prefix of an indexed component is overloaded, the proper 2406 -- interpretation is selected by the index types and the context. 2407 2408 --------------------------- 2409 -- Process_Function_Call -- 2410 --------------------------- 2411 2412 procedure Process_Function_Call is 2413 Loc : constant Source_Ptr := Sloc (N); 2414 Actual : Node_Id; 2415 2416 begin 2417 Change_Node (N, N_Function_Call); 2418 Set_Name (N, P); 2419 Set_Parameter_Associations (N, Exprs); 2420 2421 -- Analyze actuals prior to analyzing the call itself 2422 2423 Actual := First (Parameter_Associations (N)); 2424 while Present (Actual) loop 2425 Analyze (Actual); 2426 Check_Parameterless_Call (Actual); 2427 2428 -- Move to next actual. Note that we use Next, not Next_Actual 2429 -- here. The reason for this is a bit subtle. If a function call 2430 -- includes named associations, the parser recognizes the node 2431 -- as a call, and it is analyzed as such. If all associations are 2432 -- positional, the parser builds an indexed_component node, and 2433 -- it is only after analysis of the prefix that the construct 2434 -- is recognized as a call, in which case Process_Function_Call 2435 -- rewrites the node and analyzes the actuals. If the list of 2436 -- actuals is malformed, the parser may leave the node as an 2437 -- indexed component (despite the presence of named associations). 2438 -- The iterator Next_Actual is equivalent to Next if the list is 2439 -- positional, but follows the normalized chain of actuals when 2440 -- named associations are present. In this case normalization has 2441 -- not taken place, and actuals remain unanalyzed, which leads to 2442 -- subsequent crashes or loops if there is an attempt to continue 2443 -- analysis of the program. 2444 2445 -- IF there is a single actual and it is a type name, the node 2446 -- can only be interpreted as a slice of a parameterless call. 2447 -- Rebuild the node as such and analyze. 2448 2449 if No (Next (Actual)) 2450 and then Is_Entity_Name (Actual) 2451 and then Is_Type (Entity (Actual)) 2452 and then Is_Discrete_Type (Entity (Actual)) 2453 then 2454 Replace (N, 2455 Make_Slice (Loc, 2456 Prefix => P, 2457 Discrete_Range => 2458 New_Occurrence_Of (Entity (Actual), Loc))); 2459 Analyze (N); 2460 return; 2461 2462 else 2463 Next (Actual); 2464 end if; 2465 end loop; 2466 2467 Analyze_Call (N); 2468 end Process_Function_Call; 2469 2470 ------------------------------- 2471 -- Process_Indexed_Component -- 2472 ------------------------------- 2473 2474 procedure Process_Indexed_Component is 2475 Exp : Node_Id; 2476 Array_Type : Entity_Id; 2477 Index : Node_Id; 2478 Pent : Entity_Id := Empty; 2479 2480 begin 2481 Exp := First (Exprs); 2482 2483 if Is_Overloaded (P) then 2484 Process_Overloaded_Indexed_Component; 2485 2486 else 2487 Array_Type := Etype (P); 2488 2489 if Is_Entity_Name (P) then 2490 Pent := Entity (P); 2491 elsif Nkind (P) = N_Selected_Component 2492 and then Is_Entity_Name (Selector_Name (P)) 2493 then 2494 Pent := Entity (Selector_Name (P)); 2495 end if; 2496 2497 -- Prefix must be appropriate for an array type, taking into 2498 -- account a possible implicit dereference. 2499 2500 if Is_Access_Type (Array_Type) then 2501 Error_Msg_NW 2502 (Warn_On_Dereference, "?d?implicit dereference", N); 2503 Array_Type := Process_Implicit_Dereference_Prefix (Pent, P); 2504 end if; 2505 2506 if Is_Array_Type (Array_Type) then 2507 2508 -- In order to correctly access First_Index component later, 2509 -- replace string literal subtype by its parent type. 2510 2511 if Ekind (Array_Type) = E_String_Literal_Subtype then 2512 Array_Type := Etype (Array_Type); 2513 end if; 2514 2515 elsif Present (Pent) and then Ekind (Pent) = E_Entry_Family then 2516 Analyze (Exp); 2517 Set_Etype (N, Any_Type); 2518 2519 if not Has_Compatible_Type (Exp, Entry_Index_Type (Pent)) then 2520 Error_Msg_N ("invalid index type in entry name", N); 2521 2522 elsif Present (Next (Exp)) then 2523 Error_Msg_N ("too many subscripts in entry reference", N); 2524 2525 else 2526 Set_Etype (N, Etype (P)); 2527 end if; 2528 2529 return; 2530 2531 elsif Is_Record_Type (Array_Type) 2532 and then Remote_AST_I_Dereference (P) 2533 then 2534 return; 2535 2536 elsif Try_Container_Indexing (N, P, Exprs) then 2537 return; 2538 2539 elsif Array_Type = Any_Type then 2540 Set_Etype (N, Any_Type); 2541 2542 -- In most cases the analysis of the prefix will have emitted 2543 -- an error already, but if the prefix may be interpreted as a 2544 -- call in prefixed notation, the report is left to the caller. 2545 -- To prevent cascaded errors, report only if no previous ones. 2546 2547 if Serious_Errors_Detected = 0 then 2548 Error_Msg_N ("invalid prefix in indexed component", P); 2549 2550 if Nkind (P) = N_Expanded_Name then 2551 Error_Msg_NE ("\& is not visible", P, Selector_Name (P)); 2552 end if; 2553 end if; 2554 2555 return; 2556 2557 -- Here we definitely have a bad indexing 2558 2559 else 2560 if Nkind (Parent (N)) = N_Requeue_Statement 2561 and then Present (Pent) and then Ekind (Pent) = E_Entry 2562 then 2563 Error_Msg_N 2564 ("REQUEUE does not permit parameters", First (Exprs)); 2565 2566 elsif Is_Entity_Name (P) 2567 and then Etype (P) = Standard_Void_Type 2568 then 2569 Error_Msg_NE ("incorrect use of &", P, Entity (P)); 2570 2571 else 2572 Error_Msg_N ("array type required in indexed component", P); 2573 end if; 2574 2575 Set_Etype (N, Any_Type); 2576 return; 2577 end if; 2578 2579 Index := First_Index (Array_Type); 2580 while Present (Index) and then Present (Exp) loop 2581 if not Has_Compatible_Type (Exp, Etype (Index)) then 2582 Wrong_Type (Exp, Etype (Index)); 2583 Set_Etype (N, Any_Type); 2584 return; 2585 end if; 2586 2587 Next_Index (Index); 2588 Next (Exp); 2589 end loop; 2590 2591 Set_Etype (N, Component_Type (Array_Type)); 2592 Check_Implicit_Dereference (N, Etype (N)); 2593 2594 if Present (Index) then 2595 Error_Msg_N 2596 ("too few subscripts in array reference", First (Exprs)); 2597 2598 elsif Present (Exp) then 2599 Error_Msg_N ("too many subscripts in array reference", Exp); 2600 end if; 2601 end if; 2602 end Process_Indexed_Component; 2603 2604 ---------------------------------------- 2605 -- Process_Indexed_Component_Or_Slice -- 2606 ---------------------------------------- 2607 2608 procedure Process_Indexed_Component_Or_Slice is 2609 begin 2610 Exp := First (Exprs); 2611 while Present (Exp) loop 2612 Analyze_Expression (Exp); 2613 Next (Exp); 2614 end loop; 2615 2616 Exp := First (Exprs); 2617 2618 -- If one index is present, and it is a subtype name, then the node 2619 -- denotes a slice (note that the case of an explicit range for a 2620 -- slice was already built as an N_Slice node in the first place, 2621 -- so that case is not handled here). 2622 2623 -- We use a replace rather than a rewrite here because this is one 2624 -- of the cases in which the tree built by the parser is plain wrong. 2625 2626 if No (Next (Exp)) 2627 and then Is_Entity_Name (Exp) 2628 and then Is_Type (Entity (Exp)) 2629 then 2630 Replace (N, 2631 Make_Slice (Sloc (N), 2632 Prefix => P, 2633 Discrete_Range => New_Copy (Exp))); 2634 Analyze (N); 2635 2636 -- Otherwise (more than one index present, or single index is not 2637 -- a subtype name), then we have the indexed component case. 2638 2639 else 2640 Process_Indexed_Component; 2641 end if; 2642 end Process_Indexed_Component_Or_Slice; 2643 2644 ------------------------------------------ 2645 -- Process_Overloaded_Indexed_Component -- 2646 ------------------------------------------ 2647 2648 procedure Process_Overloaded_Indexed_Component is 2649 Exp : Node_Id; 2650 I : Interp_Index; 2651 It : Interp; 2652 Typ : Entity_Id; 2653 Index : Node_Id; 2654 Found : Boolean; 2655 2656 begin 2657 Set_Etype (N, Any_Type); 2658 2659 Get_First_Interp (P, I, It); 2660 while Present (It.Nam) loop 2661 Typ := It.Typ; 2662 2663 if Is_Access_Type (Typ) then 2664 Typ := Designated_Type (Typ); 2665 Error_Msg_NW 2666 (Warn_On_Dereference, "?d?implicit dereference", N); 2667 end if; 2668 2669 if Is_Array_Type (Typ) then 2670 2671 -- Got a candidate: verify that index types are compatible 2672 2673 Index := First_Index (Typ); 2674 Found := True; 2675 Exp := First (Exprs); 2676 while Present (Index) and then Present (Exp) loop 2677 if Has_Compatible_Type (Exp, Etype (Index)) then 2678 null; 2679 else 2680 Found := False; 2681 Remove_Interp (I); 2682 exit; 2683 end if; 2684 2685 Next_Index (Index); 2686 Next (Exp); 2687 end loop; 2688 2689 if Found and then No (Index) and then No (Exp) then 2690 declare 2691 CT : constant Entity_Id := 2692 Base_Type (Component_Type (Typ)); 2693 begin 2694 Add_One_Interp (N, CT, CT); 2695 Check_Implicit_Dereference (N, CT); 2696 end; 2697 end if; 2698 2699 elsif Try_Container_Indexing (N, P, Exprs) then 2700 return; 2701 2702 end if; 2703 2704 Get_Next_Interp (I, It); 2705 end loop; 2706 2707 if Etype (N) = Any_Type then 2708 Error_Msg_N ("no legal interpretation for indexed component", N); 2709 Set_Is_Overloaded (N, False); 2710 end if; 2711 2712 End_Interp_List; 2713 end Process_Overloaded_Indexed_Component; 2714 2715 -- Start of processing for Analyze_Indexed_Component_Form 2716 2717 begin 2718 -- Get name of array, function or type 2719 2720 Analyze (P); 2721 2722 -- If P is an explicit dereference whose prefix is of a remote access- 2723 -- to-subprogram type, then N has already been rewritten as a subprogram 2724 -- call and analyzed. 2725 2726 if Nkind (N) in N_Subprogram_Call then 2727 return; 2728 2729 -- When the prefix is attribute 'Loop_Entry and the sole expression of 2730 -- the indexed component denotes a loop name, the indexed form is turned 2731 -- into an attribute reference. 2732 2733 elsif Nkind (N) = N_Attribute_Reference 2734 and then Attribute_Name (N) = Name_Loop_Entry 2735 then 2736 return; 2737 end if; 2738 2739 pragma Assert (Nkind (N) = N_Indexed_Component); 2740 2741 P_T := Base_Type (Etype (P)); 2742 2743 if Is_Entity_Name (P) and then Present (Entity (P)) then 2744 U_N := Entity (P); 2745 2746 if Is_Type (U_N) then 2747 2748 -- Reformat node as a type conversion 2749 2750 E := Remove_Head (Exprs); 2751 2752 if Present (First (Exprs)) then 2753 Error_Msg_N 2754 ("argument of type conversion must be single expression", N); 2755 end if; 2756 2757 Change_Node (N, N_Type_Conversion); 2758 Set_Subtype_Mark (N, P); 2759 Set_Etype (N, U_N); 2760 Set_Expression (N, E); 2761 2762 -- After changing the node, call for the specific Analysis 2763 -- routine directly, to avoid a double call to the expander. 2764 2765 Analyze_Type_Conversion (N); 2766 return; 2767 end if; 2768 2769 if Is_Overloadable (U_N) then 2770 Process_Function_Call; 2771 2772 elsif Ekind (Etype (P)) = E_Subprogram_Type 2773 or else (Is_Access_Type (Etype (P)) 2774 and then 2775 Ekind (Designated_Type (Etype (P))) = 2776 E_Subprogram_Type) 2777 then 2778 -- Call to access_to-subprogram with possible implicit dereference 2779 2780 Process_Function_Call; 2781 2782 elsif Is_Generic_Subprogram (U_N) then 2783 2784 -- A common beginner's (or C++ templates fan) error 2785 2786 Error_Msg_N ("generic subprogram cannot be called", N); 2787 Set_Etype (N, Any_Type); 2788 return; 2789 2790 else 2791 Process_Indexed_Component_Or_Slice; 2792 end if; 2793 2794 -- If not an entity name, prefix is an expression that may denote 2795 -- an array or an access-to-subprogram. 2796 2797 else 2798 if Ekind (P_T) = E_Subprogram_Type 2799 or else (Is_Access_Type (P_T) 2800 and then 2801 Ekind (Designated_Type (P_T)) = E_Subprogram_Type) 2802 then 2803 Process_Function_Call; 2804 2805 elsif Nkind (P) = N_Selected_Component 2806 and then Present (Entity (Selector_Name (P))) 2807 and then Is_Overloadable (Entity (Selector_Name (P))) 2808 then 2809 Process_Function_Call; 2810 2811 -- In ASIS mode within a generic, a prefixed call is analyzed and 2812 -- partially rewritten but the original indexed component has not 2813 -- yet been rewritten as a call. Perform the replacement now. 2814 2815 elsif Nkind (P) = N_Selected_Component 2816 and then Nkind (Parent (P)) = N_Function_Call 2817 and then ASIS_Mode 2818 then 2819 Rewrite (N, Parent (P)); 2820 Analyze (N); 2821 2822 else 2823 -- Indexed component, slice, or a call to a member of a family 2824 -- entry, which will be converted to an entry call later. 2825 2826 Process_Indexed_Component_Or_Slice; 2827 end if; 2828 end if; 2829 2830 Analyze_Dimension (N); 2831 end Analyze_Indexed_Component_Form; 2832 2833 ------------------------ 2834 -- Analyze_Logical_Op -- 2835 ------------------------ 2836 2837 procedure Analyze_Logical_Op (N : Node_Id) is 2838 L : constant Node_Id := Left_Opnd (N); 2839 R : constant Node_Id := Right_Opnd (N); 2840 Op_Id : Entity_Id := Entity (N); 2841 2842 begin 2843 Set_Etype (N, Any_Type); 2844 Candidate_Type := Empty; 2845 2846 Analyze_Expression (L); 2847 Analyze_Expression (R); 2848 2849 if Present (Op_Id) then 2850 2851 if Ekind (Op_Id) = E_Operator then 2852 Find_Boolean_Types (L, R, Op_Id, N); 2853 else 2854 Add_One_Interp (N, Op_Id, Etype (Op_Id)); 2855 end if; 2856 2857 else 2858 Op_Id := Get_Name_Entity_Id (Chars (N)); 2859 while Present (Op_Id) loop 2860 if Ekind (Op_Id) = E_Operator then 2861 Find_Boolean_Types (L, R, Op_Id, N); 2862 else 2863 Analyze_User_Defined_Binary_Op (N, Op_Id); 2864 end if; 2865 2866 Op_Id := Homonym (Op_Id); 2867 end loop; 2868 end if; 2869 2870 Operator_Check (N); 2871 Check_Function_Writable_Actuals (N); 2872 end Analyze_Logical_Op; 2873 2874 --------------------------- 2875 -- Analyze_Membership_Op -- 2876 --------------------------- 2877 2878 procedure Analyze_Membership_Op (N : Node_Id) is 2879 Loc : constant Source_Ptr := Sloc (N); 2880 L : constant Node_Id := Left_Opnd (N); 2881 R : constant Node_Id := Right_Opnd (N); 2882 2883 Index : Interp_Index; 2884 It : Interp; 2885 Found : Boolean := False; 2886 I_F : Interp_Index; 2887 T_F : Entity_Id; 2888 2889 procedure Try_One_Interp (T1 : Entity_Id); 2890 -- Routine to try one proposed interpretation. Note that the context 2891 -- of the operation plays no role in resolving the arguments, so that 2892 -- if there is more than one interpretation of the operands that is 2893 -- compatible with a membership test, the operation is ambiguous. 2894 2895 -------------------- 2896 -- Try_One_Interp -- 2897 -------------------- 2898 2899 procedure Try_One_Interp (T1 : Entity_Id) is 2900 begin 2901 if Has_Compatible_Type (R, T1) then 2902 if Found 2903 and then Base_Type (T1) /= Base_Type (T_F) 2904 then 2905 It := Disambiguate (L, I_F, Index, Any_Type); 2906 2907 if It = No_Interp then 2908 Ambiguous_Operands (N); 2909 Set_Etype (L, Any_Type); 2910 return; 2911 2912 else 2913 T_F := It.Typ; 2914 end if; 2915 2916 else 2917 Found := True; 2918 T_F := T1; 2919 I_F := Index; 2920 end if; 2921 2922 Set_Etype (L, T_F); 2923 end if; 2924 end Try_One_Interp; 2925 2926 procedure Analyze_Set_Membership; 2927 -- If a set of alternatives is present, analyze each and find the 2928 -- common type to which they must all resolve. 2929 2930 ---------------------------- 2931 -- Analyze_Set_Membership -- 2932 ---------------------------- 2933 2934 procedure Analyze_Set_Membership is 2935 Alt : Node_Id; 2936 Index : Interp_Index; 2937 It : Interp; 2938 Candidate_Interps : Node_Id; 2939 Common_Type : Entity_Id := Empty; 2940 2941 begin 2942 if Comes_From_Source (N) then 2943 Check_Compiler_Unit ("set membership", N); 2944 end if; 2945 2946 Analyze (L); 2947 Candidate_Interps := L; 2948 2949 if not Is_Overloaded (L) then 2950 Common_Type := Etype (L); 2951 2952 Alt := First (Alternatives (N)); 2953 while Present (Alt) loop 2954 Analyze (Alt); 2955 2956 if not Has_Compatible_Type (Alt, Common_Type) then 2957 Wrong_Type (Alt, Common_Type); 2958 end if; 2959 2960 Next (Alt); 2961 end loop; 2962 2963 else 2964 Alt := First (Alternatives (N)); 2965 while Present (Alt) loop 2966 Analyze (Alt); 2967 if not Is_Overloaded (Alt) then 2968 Common_Type := Etype (Alt); 2969 2970 else 2971 Get_First_Interp (Alt, Index, It); 2972 while Present (It.Typ) loop 2973 if not 2974 Has_Compatible_Type (Candidate_Interps, It.Typ) 2975 then 2976 Remove_Interp (Index); 2977 end if; 2978 2979 Get_Next_Interp (Index, It); 2980 end loop; 2981 2982 Get_First_Interp (Alt, Index, It); 2983 2984 if No (It.Typ) then 2985 Error_Msg_N ("alternative has no legal type", Alt); 2986 return; 2987 end if; 2988 2989 -- If alternative is not overloaded, we have a unique type 2990 -- for all of them. 2991 2992 Set_Etype (Alt, It.Typ); 2993 2994 -- If the alternative is an enumeration literal, use the one 2995 -- for this interpretation. 2996 2997 if Is_Entity_Name (Alt) then 2998 Set_Entity (Alt, It.Nam); 2999 end if; 3000 3001 Get_Next_Interp (Index, It); 3002 3003 if No (It.Typ) then 3004 Set_Is_Overloaded (Alt, False); 3005 Common_Type := Etype (Alt); 3006 end if; 3007 3008 Candidate_Interps := Alt; 3009 end if; 3010 3011 Next (Alt); 3012 end loop; 3013 end if; 3014 3015 Set_Etype (N, Standard_Boolean); 3016 3017 if Present (Common_Type) then 3018 Set_Etype (L, Common_Type); 3019 3020 -- The left operand may still be overloaded, to be resolved using 3021 -- the Common_Type. 3022 3023 else 3024 Error_Msg_N ("cannot resolve membership operation", N); 3025 end if; 3026 end Analyze_Set_Membership; 3027 3028 -- Start of processing for Analyze_Membership_Op 3029 3030 begin 3031 Analyze_Expression (L); 3032 3033 if No (R) and then Ada_Version >= Ada_2012 then 3034 Analyze_Set_Membership; 3035 Check_Function_Writable_Actuals (N); 3036 3037 return; 3038 end if; 3039 3040 if Nkind (R) = N_Range 3041 or else (Nkind (R) = N_Attribute_Reference 3042 and then Attribute_Name (R) = Name_Range) 3043 then 3044 Analyze (R); 3045 3046 if not Is_Overloaded (L) then 3047 Try_One_Interp (Etype (L)); 3048 3049 else 3050 Get_First_Interp (L, Index, It); 3051 while Present (It.Typ) loop 3052 Try_One_Interp (It.Typ); 3053 Get_Next_Interp (Index, It); 3054 end loop; 3055 end if; 3056 3057 -- If not a range, it can be a subtype mark, or else it is a degenerate 3058 -- membership test with a singleton value, i.e. a test for equality, 3059 -- if the types are compatible. 3060 3061 else 3062 Analyze (R); 3063 3064 if Is_Entity_Name (R) 3065 and then Is_Type (Entity (R)) 3066 then 3067 Find_Type (R); 3068 Check_Fully_Declared (Entity (R), R); 3069 3070 elsif Ada_Version >= Ada_2012 3071 and then Has_Compatible_Type (R, Etype (L)) 3072 then 3073 if Nkind (N) = N_In then 3074 Rewrite (N, 3075 Make_Op_Eq (Loc, 3076 Left_Opnd => L, 3077 Right_Opnd => R)); 3078 else 3079 Rewrite (N, 3080 Make_Op_Ne (Loc, 3081 Left_Opnd => L, 3082 Right_Opnd => R)); 3083 end if; 3084 3085 Analyze (N); 3086 return; 3087 3088 else 3089 -- In all versions of the language, if we reach this point there 3090 -- is a previous error that will be diagnosed below. 3091 3092 Find_Type (R); 3093 end if; 3094 end if; 3095 3096 -- Compatibility between expression and subtype mark or range is 3097 -- checked during resolution. The result of the operation is Boolean 3098 -- in any case. 3099 3100 Set_Etype (N, Standard_Boolean); 3101 3102 if Comes_From_Source (N) 3103 and then Present (Right_Opnd (N)) 3104 and then Is_CPP_Class (Etype (Etype (Right_Opnd (N)))) 3105 then 3106 Error_Msg_N ("membership test not applicable to cpp-class types", N); 3107 end if; 3108 3109 Check_Function_Writable_Actuals (N); 3110 end Analyze_Membership_Op; 3111 3112 ----------------- 3113 -- Analyze_Mod -- 3114 ----------------- 3115 3116 procedure Analyze_Mod (N : Node_Id) is 3117 begin 3118 -- A special warning check, if we have an expression of the form: 3119 -- expr mod 2 * literal 3120 -- where literal is 64 or less, then probably what was meant was 3121 -- expr mod 2 ** literal 3122 -- so issue an appropriate warning. 3123 3124 if Warn_On_Suspicious_Modulus_Value 3125 and then Nkind (Right_Opnd (N)) = N_Integer_Literal 3126 and then Intval (Right_Opnd (N)) = Uint_2 3127 and then Nkind (Parent (N)) = N_Op_Multiply 3128 and then Nkind (Right_Opnd (Parent (N))) = N_Integer_Literal 3129 and then Intval (Right_Opnd (Parent (N))) <= Uint_64 3130 then 3131 Error_Msg_N 3132 ("suspicious MOD value, was '*'* intended'??M?", Parent (N)); 3133 end if; 3134 3135 -- Remaining processing is same as for other arithmetic operators 3136 3137 Analyze_Arithmetic_Op (N); 3138 end Analyze_Mod; 3139 3140 ---------------------- 3141 -- Analyze_Negation -- 3142 ---------------------- 3143 3144 procedure Analyze_Negation (N : Node_Id) is 3145 R : constant Node_Id := Right_Opnd (N); 3146 Op_Id : Entity_Id := Entity (N); 3147 3148 begin 3149 Set_Etype (N, Any_Type); 3150 Candidate_Type := Empty; 3151 3152 Analyze_Expression (R); 3153 3154 if Present (Op_Id) then 3155 if Ekind (Op_Id) = E_Operator then 3156 Find_Negation_Types (R, Op_Id, N); 3157 else 3158 Add_One_Interp (N, Op_Id, Etype (Op_Id)); 3159 end if; 3160 3161 else 3162 Op_Id := Get_Name_Entity_Id (Chars (N)); 3163 while Present (Op_Id) loop 3164 if Ekind (Op_Id) = E_Operator then 3165 Find_Negation_Types (R, Op_Id, N); 3166 else 3167 Analyze_User_Defined_Unary_Op (N, Op_Id); 3168 end if; 3169 3170 Op_Id := Homonym (Op_Id); 3171 end loop; 3172 end if; 3173 3174 Operator_Check (N); 3175 end Analyze_Negation; 3176 3177 ------------------ 3178 -- Analyze_Null -- 3179 ------------------ 3180 3181 procedure Analyze_Null (N : Node_Id) is 3182 begin 3183 Check_SPARK_05_Restriction ("null is not allowed", N); 3184 3185 Set_Etype (N, Any_Access); 3186 end Analyze_Null; 3187 3188 ---------------------- 3189 -- Analyze_One_Call -- 3190 ---------------------- 3191 3192 procedure Analyze_One_Call 3193 (N : Node_Id; 3194 Nam : Entity_Id; 3195 Report : Boolean; 3196 Success : out Boolean; 3197 Skip_First : Boolean := False) 3198 is 3199 Actuals : constant List_Id := Parameter_Associations (N); 3200 Prev_T : constant Entity_Id := Etype (N); 3201 3202 Must_Skip : constant Boolean := Skip_First 3203 or else Nkind (Original_Node (N)) = N_Selected_Component 3204 or else 3205 (Nkind (Original_Node (N)) = N_Indexed_Component 3206 and then Nkind (Prefix (Original_Node (N))) 3207 = N_Selected_Component); 3208 -- The first formal must be omitted from the match when trying to find 3209 -- a primitive operation that is a possible interpretation, and also 3210 -- after the call has been rewritten, because the corresponding actual 3211 -- is already known to be compatible, and because this may be an 3212 -- indexing of a call with default parameters. 3213 3214 Formal : Entity_Id; 3215 Actual : Node_Id; 3216 Is_Indexed : Boolean := False; 3217 Is_Indirect : Boolean := False; 3218 Subp_Type : constant Entity_Id := Etype (Nam); 3219 Norm_OK : Boolean; 3220 3221 function Compatible_Types_In_Predicate 3222 (T1 : Entity_Id; 3223 T2 : Entity_Id) return Boolean; 3224 -- For an Ada 2012 predicate or invariant, a call may mention an 3225 -- incomplete type, while resolution of the corresponding predicate 3226 -- function may see the full view, as a consequence of the delayed 3227 -- resolution of the corresponding expressions. This may occur in 3228 -- the body of a predicate function, or in a call to such. Anomalies 3229 -- involving private and full views can also happen. In each case, 3230 -- rewrite node or add conversions to remove spurious type errors. 3231 3232 procedure Indicate_Name_And_Type; 3233 -- If candidate interpretation matches, indicate name and type of result 3234 -- on call node. 3235 3236 function Operator_Hidden_By (Fun : Entity_Id) return Boolean; 3237 -- There may be a user-defined operator that hides the current 3238 -- interpretation. We must check for this independently of the 3239 -- analysis of the call with the user-defined operation, because 3240 -- the parameter names may be wrong and yet the hiding takes place. 3241 -- This fixes a problem with ACATS test B34014O. 3242 -- 3243 -- When the type Address is a visible integer type, and the DEC 3244 -- system extension is visible, the predefined operator may be 3245 -- hidden as well, by one of the address operations in auxdec. 3246 -- Finally, The abstract operations on address do not hide the 3247 -- predefined operator (this is the purpose of making them abstract). 3248 3249 ----------------------------------- 3250 -- Compatible_Types_In_Predicate -- 3251 ----------------------------------- 3252 3253 function Compatible_Types_In_Predicate 3254 (T1 : Entity_Id; 3255 T2 : Entity_Id) return Boolean 3256 is 3257 function Common_Type (T : Entity_Id) return Entity_Id; 3258 -- Find non-private full view if any, without going to ancestor type 3259 -- (as opposed to Underlying_Type). 3260 3261 ----------------- 3262 -- Common_Type -- 3263 ----------------- 3264 3265 function Common_Type (T : Entity_Id) return Entity_Id is 3266 begin 3267 if Is_Private_Type (T) and then Present (Full_View (T)) then 3268 return Base_Type (Full_View (T)); 3269 else 3270 return Base_Type (T); 3271 end if; 3272 end Common_Type; 3273 3274 -- Start of processing for Compatible_Types_In_Predicate 3275 3276 begin 3277 if (Ekind (Current_Scope) = E_Function 3278 and then Is_Predicate_Function (Current_Scope)) 3279 or else 3280 (Ekind (Nam) = E_Function 3281 and then Is_Predicate_Function (Nam)) 3282 then 3283 if Is_Incomplete_Type (T1) 3284 and then Present (Full_View (T1)) 3285 and then Full_View (T1) = T2 3286 then 3287 Set_Etype (Formal, Etype (Actual)); 3288 return True; 3289 3290 elsif Common_Type (T1) = Common_Type (T2) then 3291 Rewrite (Actual, Unchecked_Convert_To (Etype (Formal), Actual)); 3292 return True; 3293 3294 else 3295 return False; 3296 end if; 3297 3298 else 3299 return False; 3300 end if; 3301 end Compatible_Types_In_Predicate; 3302 3303 ---------------------------- 3304 -- Indicate_Name_And_Type -- 3305 ---------------------------- 3306 3307 procedure Indicate_Name_And_Type is 3308 begin 3309 Add_One_Interp (N, Nam, Etype (Nam)); 3310 Check_Implicit_Dereference (N, Etype (Nam)); 3311 Success := True; 3312 3313 -- If the prefix of the call is a name, indicate the entity 3314 -- being called. If it is not a name, it is an expression that 3315 -- denotes an access to subprogram or else an entry or family. In 3316 -- the latter case, the name is a selected component, and the entity 3317 -- being called is noted on the selector. 3318 3319 if not Is_Type (Nam) then 3320 if Is_Entity_Name (Name (N)) then 3321 Set_Entity (Name (N), Nam); 3322 Set_Etype (Name (N), Etype (Nam)); 3323 3324 elsif Nkind (Name (N)) = N_Selected_Component then 3325 Set_Entity (Selector_Name (Name (N)), Nam); 3326 end if; 3327 end if; 3328 3329 if Debug_Flag_E and not Report then 3330 Write_Str (" Overloaded call "); 3331 Write_Int (Int (N)); 3332 Write_Str (" compatible with "); 3333 Write_Int (Int (Nam)); 3334 Write_Eol; 3335 end if; 3336 end Indicate_Name_And_Type; 3337 3338 ------------------------ 3339 -- Operator_Hidden_By -- 3340 ------------------------ 3341 3342 function Operator_Hidden_By (Fun : Entity_Id) return Boolean is 3343 Act1 : constant Node_Id := First_Actual (N); 3344 Act2 : constant Node_Id := Next_Actual (Act1); 3345 Form1 : constant Entity_Id := First_Formal (Fun); 3346 Form2 : constant Entity_Id := Next_Formal (Form1); 3347 3348 begin 3349 if Ekind (Fun) /= E_Function or else Is_Abstract_Subprogram (Fun) then 3350 return False; 3351 3352 elsif not Has_Compatible_Type (Act1, Etype (Form1)) then 3353 return False; 3354 3355 elsif Present (Form2) then 3356 if No (Act2) 3357 or else not Has_Compatible_Type (Act2, Etype (Form2)) 3358 then 3359 return False; 3360 end if; 3361 3362 elsif Present (Act2) then 3363 return False; 3364 end if; 3365 3366 -- Now we know that the arity of the operator matches the function, 3367 -- and the function call is a valid interpretation. The function 3368 -- hides the operator if it has the right signature, or if one of 3369 -- its operands is a non-abstract operation on Address when this is 3370 -- a visible integer type. 3371 3372 return Hides_Op (Fun, Nam) 3373 or else Is_Descendant_Of_Address (Etype (Form1)) 3374 or else 3375 (Present (Form2) 3376 and then Is_Descendant_Of_Address (Etype (Form2))); 3377 end Operator_Hidden_By; 3378 3379 -- Start of processing for Analyze_One_Call 3380 3381 begin 3382 Success := False; 3383 3384 -- If the subprogram has no formals or if all the formals have defaults, 3385 -- and the return type is an array type, the node may denote an indexing 3386 -- of the result of a parameterless call. In Ada 2005, the subprogram 3387 -- may have one non-defaulted formal, and the call may have been written 3388 -- in prefix notation, so that the rebuilt parameter list has more than 3389 -- one actual. 3390 3391 if not Is_Overloadable (Nam) 3392 and then Ekind (Nam) /= E_Subprogram_Type 3393 and then Ekind (Nam) /= E_Entry_Family 3394 then 3395 return; 3396 end if; 3397 3398 -- An indexing requires at least one actual. The name of the call cannot 3399 -- be an implicit indirect call, so it cannot be a generated explicit 3400 -- dereference. 3401 3402 if not Is_Empty_List (Actuals) 3403 and then 3404 (Needs_No_Actuals (Nam) 3405 or else 3406 (Needs_One_Actual (Nam) 3407 and then Present (Next_Actual (First (Actuals))))) 3408 then 3409 if Is_Array_Type (Subp_Type) 3410 and then 3411 (Nkind (Name (N)) /= N_Explicit_Dereference 3412 or else Comes_From_Source (Name (N))) 3413 then 3414 Is_Indexed := Try_Indexed_Call (N, Nam, Subp_Type, Must_Skip); 3415 3416 elsif Is_Access_Type (Subp_Type) 3417 and then Is_Array_Type (Designated_Type (Subp_Type)) 3418 then 3419 Is_Indexed := 3420 Try_Indexed_Call 3421 (N, Nam, Designated_Type (Subp_Type), Must_Skip); 3422 3423 -- The prefix can also be a parameterless function that returns an 3424 -- access to subprogram, in which case this is an indirect call. 3425 -- If this succeeds, an explicit dereference is added later on, 3426 -- in Analyze_Call or Resolve_Call. 3427 3428 elsif Is_Access_Type (Subp_Type) 3429 and then Ekind (Designated_Type (Subp_Type)) = E_Subprogram_Type 3430 then 3431 Is_Indirect := Try_Indirect_Call (N, Nam, Subp_Type); 3432 end if; 3433 3434 end if; 3435 3436 -- If the call has been transformed into a slice, it is of the form 3437 -- F (Subtype) where F is parameterless. The node has been rewritten in 3438 -- Try_Indexed_Call and there is nothing else to do. 3439 3440 if Is_Indexed 3441 and then Nkind (N) = N_Slice 3442 then 3443 return; 3444 end if; 3445 3446 Normalize_Actuals 3447 (N, Nam, (Report and not Is_Indexed and not Is_Indirect), Norm_OK); 3448 3449 if not Norm_OK then 3450 3451 -- If an indirect call is a possible interpretation, indicate 3452 -- success to the caller. This may be an indexing of an explicit 3453 -- dereference of a call that returns an access type (see above). 3454 3455 if Is_Indirect 3456 or else (Is_Indexed 3457 and then Nkind (Name (N)) = N_Explicit_Dereference 3458 and then Comes_From_Source (Name (N))) 3459 then 3460 Success := True; 3461 return; 3462 3463 -- Mismatch in number or names of parameters 3464 3465 elsif Debug_Flag_E then 3466 Write_Str (" normalization fails in call "); 3467 Write_Int (Int (N)); 3468 Write_Str (" with subprogram "); 3469 Write_Int (Int (Nam)); 3470 Write_Eol; 3471 end if; 3472 3473 -- If the context expects a function call, discard any interpretation 3474 -- that is a procedure. If the node is not overloaded, leave as is for 3475 -- better error reporting when type mismatch is found. 3476 3477 elsif Nkind (N) = N_Function_Call 3478 and then Is_Overloaded (Name (N)) 3479 and then Ekind (Nam) = E_Procedure 3480 then 3481 return; 3482 3483 -- Ditto for function calls in a procedure context 3484 3485 elsif Nkind (N) = N_Procedure_Call_Statement 3486 and then Is_Overloaded (Name (N)) 3487 and then Etype (Nam) /= Standard_Void_Type 3488 then 3489 return; 3490 3491 elsif No (Actuals) then 3492 3493 -- If Normalize succeeds, then there are default parameters for 3494 -- all formals. 3495 3496 Indicate_Name_And_Type; 3497 3498 elsif Ekind (Nam) = E_Operator then 3499 if Nkind (N) = N_Procedure_Call_Statement then 3500 return; 3501 end if; 3502 3503 -- This can occur when the prefix of the call is an operator 3504 -- name or an expanded name whose selector is an operator name. 3505 3506 Analyze_Operator_Call (N, Nam); 3507 3508 if Etype (N) /= Prev_T then 3509 3510 -- Check that operator is not hidden by a function interpretation 3511 3512 if Is_Overloaded (Name (N)) then 3513 declare 3514 I : Interp_Index; 3515 It : Interp; 3516 3517 begin 3518 Get_First_Interp (Name (N), I, It); 3519 while Present (It.Nam) loop 3520 if Operator_Hidden_By (It.Nam) then 3521 Set_Etype (N, Prev_T); 3522 return; 3523 end if; 3524 3525 Get_Next_Interp (I, It); 3526 end loop; 3527 end; 3528 end if; 3529 3530 -- If operator matches formals, record its name on the call. 3531 -- If the operator is overloaded, Resolve will select the 3532 -- correct one from the list of interpretations. The call 3533 -- node itself carries the first candidate. 3534 3535 Set_Entity (Name (N), Nam); 3536 Success := True; 3537 3538 elsif Report and then Etype (N) = Any_Type then 3539 Error_Msg_N ("incompatible arguments for operator", N); 3540 end if; 3541 3542 else 3543 -- Normalize_Actuals has chained the named associations in the 3544 -- correct order of the formals. 3545 3546 Actual := First_Actual (N); 3547 Formal := First_Formal (Nam); 3548 3549 -- If we are analyzing a call rewritten from object notation, skip 3550 -- first actual, which may be rewritten later as an explicit 3551 -- dereference. 3552 3553 if Must_Skip then 3554 Next_Actual (Actual); 3555 Next_Formal (Formal); 3556 end if; 3557 3558 while Present (Actual) and then Present (Formal) loop 3559 if Nkind (Parent (Actual)) /= N_Parameter_Association 3560 or else Chars (Selector_Name (Parent (Actual))) = Chars (Formal) 3561 then 3562 -- The actual can be compatible with the formal, but we must 3563 -- also check that the context is not an address type that is 3564 -- visibly an integer type. In this case the use of literals is 3565 -- illegal, except in the body of descendants of system, where 3566 -- arithmetic operations on address are of course used. 3567 3568 if Has_Compatible_Type (Actual, Etype (Formal)) 3569 and then 3570 (Etype (Actual) /= Universal_Integer 3571 or else not Is_Descendant_Of_Address (Etype (Formal)) 3572 or else In_Predefined_Unit (N)) 3573 then 3574 Next_Actual (Actual); 3575 Next_Formal (Formal); 3576 3577 -- In Allow_Integer_Address mode, we allow an actual integer to 3578 -- match a formal address type and vice versa. We only do this 3579 -- if we are certain that an error will otherwise be issued 3580 3581 elsif Address_Integer_Convert_OK 3582 (Etype (Actual), Etype (Formal)) 3583 and then (Report and not Is_Indexed and not Is_Indirect) 3584 then 3585 -- Handle this case by introducing an unchecked conversion 3586 3587 Rewrite (Actual, 3588 Unchecked_Convert_To (Etype (Formal), 3589 Relocate_Node (Actual))); 3590 Analyze_And_Resolve (Actual, Etype (Formal)); 3591 Next_Actual (Actual); 3592 Next_Formal (Formal); 3593 3594 -- Under relaxed RM semantics silently replace occurrences of 3595 -- null by System.Address_Null. We only do this if we know that 3596 -- an error will otherwise be issued. 3597 3598 elsif Null_To_Null_Address_Convert_OK (Actual, Etype (Formal)) 3599 and then (Report and not Is_Indexed and not Is_Indirect) 3600 then 3601 Replace_Null_By_Null_Address (Actual); 3602 Analyze_And_Resolve (Actual, Etype (Formal)); 3603 Next_Actual (Actual); 3604 Next_Formal (Formal); 3605 3606 elsif Compatible_Types_In_Predicate 3607 (Etype (Formal), Etype (Actual)) 3608 then 3609 Next_Actual (Actual); 3610 Next_Formal (Formal); 3611 3612 -- In a complex case where an enclosing generic and a nested 3613 -- generic package, both declared with partially parameterized 3614 -- formal subprograms with the same names, are instantiated 3615 -- with the same type, the types of the actual parameter and 3616 -- that of the formal may appear incompatible at first sight. 3617 3618 -- generic 3619 -- type Outer_T is private; 3620 -- with function Func (Formal : Outer_T) 3621 -- return ... is <>; 3622 3623 -- package Outer_Gen is 3624 -- generic 3625 -- type Inner_T is private; 3626 -- with function Func (Formal : Inner_T) -- (1) 3627 -- return ... is <>; 3628 3629 -- package Inner_Gen is 3630 -- function Inner_Func (Formal : Inner_T) -- (2) 3631 -- return ... is (Func (Formal)); 3632 -- end Inner_Gen; 3633 -- end Outer_Generic; 3634 3635 -- package Outer_Inst is new Outer_Gen (Actual_T); 3636 -- package Inner_Inst is new Outer_Inst.Inner_Gen (Actual_T); 3637 3638 -- In the example above, the type of parameter 3639 -- Inner_Func.Formal at (2) is incompatible with the type of 3640 -- Func.Formal at (1) in the context of instantiations 3641 -- Outer_Inst and Inner_Inst. In reality both types are generic 3642 -- actual subtypes renaming base type Actual_T as part of the 3643 -- generic prologues for the instantiations. 3644 3645 -- Recognize this case and add a type conversion to allow this 3646 -- kind of generic actual subtype conformance. Note that this 3647 -- is done only when the call is non-overloaded because the 3648 -- resolution mechanism already has the means to disambiguate 3649 -- similar cases. 3650 3651 elsif not Is_Overloaded (Name (N)) 3652 and then Is_Type (Etype (Actual)) 3653 and then Is_Type (Etype (Formal)) 3654 and then Is_Generic_Actual_Type (Etype (Actual)) 3655 and then Is_Generic_Actual_Type (Etype (Formal)) 3656 and then Base_Type (Etype (Actual)) = 3657 Base_Type (Etype (Formal)) 3658 then 3659 Rewrite (Actual, 3660 Convert_To (Etype (Formal), Relocate_Node (Actual))); 3661 Analyze_And_Resolve (Actual, Etype (Formal)); 3662 Next_Actual (Actual); 3663 Next_Formal (Formal); 3664 3665 -- Handle failed type check 3666 3667 else 3668 if Debug_Flag_E then 3669 Write_Str (" type checking fails in call "); 3670 Write_Int (Int (N)); 3671 Write_Str (" with formal "); 3672 Write_Int (Int (Formal)); 3673 Write_Str (" in subprogram "); 3674 Write_Int (Int (Nam)); 3675 Write_Eol; 3676 end if; 3677 3678 -- Comment needed on the following test??? 3679 3680 if Report and not Is_Indexed and not Is_Indirect then 3681 3682 -- Ada 2005 (AI-251): Complete the error notification 3683 -- to help new Ada 2005 users. 3684 3685 if Is_Class_Wide_Type (Etype (Formal)) 3686 and then Is_Interface (Etype (Etype (Formal))) 3687 and then not Interface_Present_In_Ancestor 3688 (Typ => Etype (Actual), 3689 Iface => Etype (Etype (Formal))) 3690 then 3691 Error_Msg_NE 3692 ("(Ada 2005) does not implement interface }", 3693 Actual, Etype (Etype (Formal))); 3694 end if; 3695 3696 Wrong_Type (Actual, Etype (Formal)); 3697 3698 if Nkind (Actual) = N_Op_Eq 3699 and then Nkind (Left_Opnd (Actual)) = N_Identifier 3700 then 3701 Formal := First_Formal (Nam); 3702 while Present (Formal) loop 3703 if Chars (Left_Opnd (Actual)) = Chars (Formal) then 3704 Error_Msg_N -- CODEFIX 3705 ("possible misspelling of `='>`!", Actual); 3706 exit; 3707 end if; 3708 3709 Next_Formal (Formal); 3710 end loop; 3711 end if; 3712 3713 if All_Errors_Mode then 3714 Error_Msg_Sloc := Sloc (Nam); 3715 3716 if Etype (Formal) = Any_Type then 3717 Error_Msg_N 3718 ("there is no legal actual parameter", Actual); 3719 end if; 3720 3721 if Is_Overloadable (Nam) 3722 and then Present (Alias (Nam)) 3723 and then not Comes_From_Source (Nam) 3724 then 3725 Error_Msg_NE 3726 ("\\ =='> in call to inherited operation & #!", 3727 Actual, Nam); 3728 3729 elsif Ekind (Nam) = E_Subprogram_Type then 3730 declare 3731 Access_To_Subprogram_Typ : 3732 constant Entity_Id := 3733 Defining_Identifier 3734 (Associated_Node_For_Itype (Nam)); 3735 begin 3736 Error_Msg_NE 3737 ("\\ =='> in call to dereference of &#!", 3738 Actual, Access_To_Subprogram_Typ); 3739 end; 3740 3741 else 3742 Error_Msg_NE 3743 ("\\ =='> in call to &#!", Actual, Nam); 3744 3745 end if; 3746 end if; 3747 end if; 3748 3749 return; 3750 end if; 3751 3752 else 3753 -- Normalize_Actuals has verified that a default value exists 3754 -- for this formal. Current actual names a subsequent formal. 3755 3756 Next_Formal (Formal); 3757 end if; 3758 end loop; 3759 3760 -- On exit, all actuals match 3761 3762 Indicate_Name_And_Type; 3763 end if; 3764 end Analyze_One_Call; 3765 3766 --------------------------- 3767 -- Analyze_Operator_Call -- 3768 --------------------------- 3769 3770 procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id) is 3771 Op_Name : constant Name_Id := Chars (Op_Id); 3772 Act1 : constant Node_Id := First_Actual (N); 3773 Act2 : constant Node_Id := Next_Actual (Act1); 3774 3775 begin 3776 -- Binary operator case 3777 3778 if Present (Act2) then 3779 3780 -- If more than two operands, then not binary operator after all 3781 3782 if Present (Next_Actual (Act2)) then 3783 return; 3784 end if; 3785 3786 -- Otherwise action depends on operator 3787 3788 case Op_Name is 3789 when Name_Op_Add 3790 | Name_Op_Divide 3791 | Name_Op_Expon 3792 | Name_Op_Mod 3793 | Name_Op_Multiply 3794 | Name_Op_Rem 3795 | Name_Op_Subtract 3796 => 3797 Find_Arithmetic_Types (Act1, Act2, Op_Id, N); 3798 3799 when Name_Op_And 3800 | Name_Op_Or 3801 | Name_Op_Xor 3802 => 3803 Find_Boolean_Types (Act1, Act2, Op_Id, N); 3804 3805 when Name_Op_Ge 3806 | Name_Op_Gt 3807 | Name_Op_Le 3808 | Name_Op_Lt 3809 => 3810 Find_Comparison_Types (Act1, Act2, Op_Id, N); 3811 3812 when Name_Op_Eq 3813 | Name_Op_Ne 3814 => 3815 Find_Equality_Types (Act1, Act2, Op_Id, N); 3816 3817 when Name_Op_Concat => 3818 Find_Concatenation_Types (Act1, Act2, Op_Id, N); 3819 3820 -- Is this when others, or should it be an abort??? 3821 3822 when others => 3823 null; 3824 end case; 3825 3826 -- Unary operator case 3827 3828 else 3829 case Op_Name is 3830 when Name_Op_Abs 3831 | Name_Op_Add 3832 | Name_Op_Subtract 3833 => 3834 Find_Unary_Types (Act1, Op_Id, N); 3835 3836 when Name_Op_Not => 3837 Find_Negation_Types (Act1, Op_Id, N); 3838 3839 -- Is this when others correct, or should it be an abort??? 3840 3841 when others => 3842 null; 3843 end case; 3844 end if; 3845 end Analyze_Operator_Call; 3846 3847 ------------------------------------------- 3848 -- Analyze_Overloaded_Selected_Component -- 3849 ------------------------------------------- 3850 3851 procedure Analyze_Overloaded_Selected_Component (N : Node_Id) is 3852 Nam : constant Node_Id := Prefix (N); 3853 Sel : constant Node_Id := Selector_Name (N); 3854 Comp : Entity_Id; 3855 I : Interp_Index; 3856 It : Interp; 3857 T : Entity_Id; 3858 3859 begin 3860 Set_Etype (Sel, Any_Type); 3861 3862 Get_First_Interp (Nam, I, It); 3863 while Present (It.Typ) loop 3864 if Is_Access_Type (It.Typ) then 3865 T := Designated_Type (It.Typ); 3866 Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N); 3867 else 3868 T := It.Typ; 3869 end if; 3870 3871 -- Locate the component. For a private prefix the selector can denote 3872 -- a discriminant. 3873 3874 if Is_Record_Type (T) or else Is_Private_Type (T) then 3875 3876 -- If the prefix is a class-wide type, the visible components are 3877 -- those of the base type. 3878 3879 if Is_Class_Wide_Type (T) then 3880 T := Etype (T); 3881 end if; 3882 3883 Comp := First_Entity (T); 3884 while Present (Comp) loop 3885 if Chars (Comp) = Chars (Sel) 3886 and then Is_Visible_Component (Comp) 3887 then 3888 3889 -- AI05-105: if the context is an object renaming with 3890 -- an anonymous access type, the expected type of the 3891 -- object must be anonymous. This is a name resolution rule. 3892 3893 if Nkind (Parent (N)) /= N_Object_Renaming_Declaration 3894 or else No (Access_Definition (Parent (N))) 3895 or else Ekind (Etype (Comp)) = E_Anonymous_Access_Type 3896 or else 3897 Ekind (Etype (Comp)) = E_Anonymous_Access_Subprogram_Type 3898 then 3899 Set_Entity (Sel, Comp); 3900 Set_Etype (Sel, Etype (Comp)); 3901 Add_One_Interp (N, Etype (Comp), Etype (Comp)); 3902 Check_Implicit_Dereference (N, Etype (Comp)); 3903 3904 -- This also specifies a candidate to resolve the name. 3905 -- Further overloading will be resolved from context. 3906 -- The selector name itself does not carry overloading 3907 -- information. 3908 3909 Set_Etype (Nam, It.Typ); 3910 3911 else 3912 -- Named access type in the context of a renaming 3913 -- declaration with an access definition. Remove 3914 -- inapplicable candidate. 3915 3916 Remove_Interp (I); 3917 end if; 3918 end if; 3919 3920 Next_Entity (Comp); 3921 end loop; 3922 3923 elsif Is_Concurrent_Type (T) then 3924 Comp := First_Entity (T); 3925 while Present (Comp) 3926 and then Comp /= First_Private_Entity (T) 3927 loop 3928 if Chars (Comp) = Chars (Sel) then 3929 if Is_Overloadable (Comp) then 3930 Add_One_Interp (Sel, Comp, Etype (Comp)); 3931 else 3932 Set_Entity_With_Checks (Sel, Comp); 3933 Generate_Reference (Comp, Sel); 3934 end if; 3935 3936 Set_Etype (Sel, Etype (Comp)); 3937 Set_Etype (N, Etype (Comp)); 3938 Set_Etype (Nam, It.Typ); 3939 3940 -- For access type case, introduce explicit dereference for 3941 -- more uniform treatment of entry calls. Do this only once 3942 -- if several interpretations yield an access type. 3943 3944 if Is_Access_Type (Etype (Nam)) 3945 and then Nkind (Nam) /= N_Explicit_Dereference 3946 then 3947 Insert_Explicit_Dereference (Nam); 3948 Error_Msg_NW 3949 (Warn_On_Dereference, "?d?implicit dereference", N); 3950 end if; 3951 end if; 3952 3953 Next_Entity (Comp); 3954 end loop; 3955 3956 Set_Is_Overloaded (N, Is_Overloaded (Sel)); 3957 end if; 3958 3959 Get_Next_Interp (I, It); 3960 end loop; 3961 3962 if Etype (N) = Any_Type 3963 and then not Try_Object_Operation (N) 3964 then 3965 Error_Msg_NE ("undefined selector& for overloaded prefix", N, Sel); 3966 Set_Entity (Sel, Any_Id); 3967 Set_Etype (Sel, Any_Type); 3968 end if; 3969 end Analyze_Overloaded_Selected_Component; 3970 3971 ---------------------------------- 3972 -- Analyze_Qualified_Expression -- 3973 ---------------------------------- 3974 3975 procedure Analyze_Qualified_Expression (N : Node_Id) is 3976 Mark : constant Entity_Id := Subtype_Mark (N); 3977 Expr : constant Node_Id := Expression (N); 3978 I : Interp_Index; 3979 It : Interp; 3980 T : Entity_Id; 3981 3982 begin 3983 Analyze_Expression (Expr); 3984 3985 Set_Etype (N, Any_Type); 3986 Find_Type (Mark); 3987 T := Entity (Mark); 3988 3989 if Nkind_In (Enclosing_Declaration (N), N_Formal_Type_Declaration, 3990 N_Full_Type_Declaration, 3991 N_Incomplete_Type_Declaration, 3992 N_Protected_Type_Declaration, 3993 N_Private_Extension_Declaration, 3994 N_Private_Type_Declaration, 3995 N_Subtype_Declaration, 3996 N_Task_Type_Declaration) 3997 and then T = Defining_Identifier (Enclosing_Declaration (N)) 3998 then 3999 Error_Msg_N ("current instance not allowed", Mark); 4000 T := Any_Type; 4001 end if; 4002 4003 Set_Etype (N, T); 4004 4005 if T = Any_Type then 4006 return; 4007 end if; 4008 4009 Check_Fully_Declared (T, N); 4010 4011 -- If expected type is class-wide, check for exact match before 4012 -- expansion, because if the expression is a dispatching call it 4013 -- may be rewritten as explicit dereference with class-wide result. 4014 -- If expression is overloaded, retain only interpretations that 4015 -- will yield exact matches. 4016 4017 if Is_Class_Wide_Type (T) then 4018 if not Is_Overloaded (Expr) then 4019 if Base_Type (Etype (Expr)) /= Base_Type (T) then 4020 if Nkind (Expr) = N_Aggregate then 4021 Error_Msg_N ("type of aggregate cannot be class-wide", Expr); 4022 else 4023 Wrong_Type (Expr, T); 4024 end if; 4025 end if; 4026 4027 else 4028 Get_First_Interp (Expr, I, It); 4029 4030 while Present (It.Nam) loop 4031 if Base_Type (It.Typ) /= Base_Type (T) then 4032 Remove_Interp (I); 4033 end if; 4034 4035 Get_Next_Interp (I, It); 4036 end loop; 4037 end if; 4038 end if; 4039 4040 Set_Etype (N, T); 4041 end Analyze_Qualified_Expression; 4042 4043 ----------------------------------- 4044 -- Analyze_Quantified_Expression -- 4045 ----------------------------------- 4046 4047 procedure Analyze_Quantified_Expression (N : Node_Id) is 4048 function Is_Empty_Range (Typ : Entity_Id) return Boolean; 4049 -- If the iterator is part of a quantified expression, and the range is 4050 -- known to be statically empty, emit a warning and replace expression 4051 -- with its static value. Returns True if the replacement occurs. 4052 4053 function No_Else_Or_Trivial_True (If_Expr : Node_Id) return Boolean; 4054 -- Determine whether if expression If_Expr lacks an else part or if it 4055 -- has one, it evaluates to True. 4056 4057 -------------------- 4058 -- Is_Empty_Range -- 4059 -------------------- 4060 4061 function Is_Empty_Range (Typ : Entity_Id) return Boolean is 4062 Loc : constant Source_Ptr := Sloc (N); 4063 4064 begin 4065 if Is_Array_Type (Typ) 4066 and then Compile_Time_Known_Bounds (Typ) 4067 and then 4068 (Expr_Value (Type_Low_Bound (Etype (First_Index (Typ)))) > 4069 Expr_Value (Type_High_Bound (Etype (First_Index (Typ))))) 4070 then 4071 Preanalyze_And_Resolve (Condition (N), Standard_Boolean); 4072 4073 if All_Present (N) then 4074 Error_Msg_N 4075 ("??quantified expression with ALL " 4076 & "over a null range has value True", N); 4077 Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); 4078 4079 else 4080 Error_Msg_N 4081 ("??quantified expression with SOME " 4082 & "over a null range has value False", N); 4083 Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); 4084 end if; 4085 4086 Analyze (N); 4087 return True; 4088 4089 else 4090 return False; 4091 end if; 4092 end Is_Empty_Range; 4093 4094 ----------------------------- 4095 -- No_Else_Or_Trivial_True -- 4096 ----------------------------- 4097 4098 function No_Else_Or_Trivial_True (If_Expr : Node_Id) return Boolean is 4099 Else_Expr : constant Node_Id := 4100 Next (Next (First (Expressions (If_Expr)))); 4101 begin 4102 return 4103 No (Else_Expr) 4104 or else (Compile_Time_Known_Value (Else_Expr) 4105 and then Is_True (Expr_Value (Else_Expr))); 4106 end No_Else_Or_Trivial_True; 4107 4108 -- Local variables 4109 4110 Cond : constant Node_Id := Condition (N); 4111 Loop_Id : Entity_Id; 4112 QE_Scop : Entity_Id; 4113 4114 -- Start of processing for Analyze_Quantified_Expression 4115 4116 begin 4117 Check_SPARK_05_Restriction ("quantified expression is not allowed", N); 4118 4119 -- Create a scope to emulate the loop-like behavior of the quantified 4120 -- expression. The scope is needed to provide proper visibility of the 4121 -- loop variable. 4122 4123 QE_Scop := New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), 'L'); 4124 Set_Etype (QE_Scop, Standard_Void_Type); 4125 Set_Scope (QE_Scop, Current_Scope); 4126 Set_Parent (QE_Scop, N); 4127 4128 Push_Scope (QE_Scop); 4129 4130 -- All constituents are preanalyzed and resolved to avoid untimely 4131 -- generation of various temporaries and types. Full analysis and 4132 -- expansion is carried out when the quantified expression is 4133 -- transformed into an expression with actions. 4134 4135 if Present (Iterator_Specification (N)) then 4136 Preanalyze (Iterator_Specification (N)); 4137 4138 -- Do not proceed with the analysis when the range of iteration is 4139 -- empty. The appropriate error is issued by Is_Empty_Range. 4140 4141 if Is_Entity_Name (Name (Iterator_Specification (N))) 4142 and then Is_Empty_Range (Etype (Name (Iterator_Specification (N)))) 4143 then 4144 return; 4145 end if; 4146 4147 else pragma Assert (Present (Loop_Parameter_Specification (N))); 4148 declare 4149 Loop_Par : constant Node_Id := Loop_Parameter_Specification (N); 4150 4151 begin 4152 Preanalyze (Loop_Par); 4153 4154 if Nkind (Discrete_Subtype_Definition (Loop_Par)) = N_Function_Call 4155 and then Parent (Loop_Par) /= N 4156 then 4157 -- The parser cannot distinguish between a loop specification 4158 -- and an iterator specification. If after preanalysis the 4159 -- proper form has been recognized, rewrite the expression to 4160 -- reflect the right kind. This is needed for proper ASIS 4161 -- navigation. If expansion is enabled, the transformation is 4162 -- performed when the expression is rewritten as a loop. 4163 4164 Set_Iterator_Specification (N, 4165 New_Copy_Tree (Iterator_Specification (Parent (Loop_Par)))); 4166 4167 Set_Defining_Identifier (Iterator_Specification (N), 4168 Relocate_Node (Defining_Identifier (Loop_Par))); 4169 Set_Name (Iterator_Specification (N), 4170 Relocate_Node (Discrete_Subtype_Definition (Loop_Par))); 4171 Set_Comes_From_Source (Iterator_Specification (N), 4172 Comes_From_Source (Loop_Parameter_Specification (N))); 4173 Set_Loop_Parameter_Specification (N, Empty); 4174 end if; 4175 end; 4176 end if; 4177 4178 Preanalyze_And_Resolve (Cond, Standard_Boolean); 4179 4180 End_Scope; 4181 Set_Etype (N, Standard_Boolean); 4182 4183 -- Verify that the loop variable is used within the condition of the 4184 -- quantified expression. 4185 4186 if Present (Iterator_Specification (N)) then 4187 Loop_Id := Defining_Identifier (Iterator_Specification (N)); 4188 else 4189 Loop_Id := Defining_Identifier (Loop_Parameter_Specification (N)); 4190 end if; 4191 4192 if Warn_On_Suspicious_Contract 4193 and then not Referenced (Loop_Id, Cond) 4194 then 4195 -- Generating C, this check causes spurious warnings on inlined 4196 -- postconditions; we can safely disable it because this check 4197 -- was previously performed when analyzing the internally built 4198 -- postconditions procedure. 4199 4200 if Modify_Tree_For_C and then In_Inlined_Body then 4201 null; 4202 else 4203 Error_Msg_N ("?T?unused variable &", Loop_Id); 4204 end if; 4205 end if; 4206 4207 -- Diagnose a possible misuse of the SOME existential quantifier. When 4208 -- we have a quantified expression of the form: 4209 4210 -- for some X => (if P then Q [else True]) 4211 4212 -- any value for X that makes P False results in the if expression being 4213 -- trivially True, and so also results in the quantified expression 4214 -- being trivially True. 4215 4216 if Warn_On_Suspicious_Contract 4217 and then not All_Present (N) 4218 and then Nkind (Cond) = N_If_Expression 4219 and then No_Else_Or_Trivial_True (Cond) 4220 then 4221 Error_Msg_N ("?T?suspicious expression", N); 4222 Error_Msg_N ("\\did you mean (for all X ='> (if P then Q))", N); 4223 Error_Msg_N ("\\or (for some X ='> P and then Q) instead'?", N); 4224 end if; 4225 end Analyze_Quantified_Expression; 4226 4227 ------------------- 4228 -- Analyze_Range -- 4229 ------------------- 4230 4231 procedure Analyze_Range (N : Node_Id) is 4232 L : constant Node_Id := Low_Bound (N); 4233 H : constant Node_Id := High_Bound (N); 4234 I1, I2 : Interp_Index; 4235 It1, It2 : Interp; 4236 4237 procedure Check_Common_Type (T1, T2 : Entity_Id); 4238 -- Verify the compatibility of two types, and choose the 4239 -- non universal one if the other is universal. 4240 4241 procedure Check_High_Bound (T : Entity_Id); 4242 -- Test one interpretation of the low bound against all those 4243 -- of the high bound. 4244 4245 procedure Check_Universal_Expression (N : Node_Id); 4246 -- In Ada 83, reject bounds of a universal range that are not literals 4247 -- or entity names. 4248 4249 ----------------------- 4250 -- Check_Common_Type -- 4251 ----------------------- 4252 4253 procedure Check_Common_Type (T1, T2 : Entity_Id) is 4254 begin 4255 if Covers (T1 => T1, T2 => T2) 4256 or else 4257 Covers (T1 => T2, T2 => T1) 4258 then 4259 if T1 = Universal_Integer 4260 or else T1 = Universal_Real 4261 or else T1 = Any_Character 4262 then 4263 Add_One_Interp (N, Base_Type (T2), Base_Type (T2)); 4264 4265 elsif T1 = T2 then 4266 Add_One_Interp (N, T1, T1); 4267 4268 else 4269 Add_One_Interp (N, Base_Type (T1), Base_Type (T1)); 4270 end if; 4271 end if; 4272 end Check_Common_Type; 4273 4274 ---------------------- 4275 -- Check_High_Bound -- 4276 ---------------------- 4277 4278 procedure Check_High_Bound (T : Entity_Id) is 4279 begin 4280 if not Is_Overloaded (H) then 4281 Check_Common_Type (T, Etype (H)); 4282 else 4283 Get_First_Interp (H, I2, It2); 4284 while Present (It2.Typ) loop 4285 Check_Common_Type (T, It2.Typ); 4286 Get_Next_Interp (I2, It2); 4287 end loop; 4288 end if; 4289 end Check_High_Bound; 4290 4291 ----------------------------- 4292 -- Is_Universal_Expression -- 4293 ----------------------------- 4294 4295 procedure Check_Universal_Expression (N : Node_Id) is 4296 begin 4297 if Etype (N) = Universal_Integer 4298 and then Nkind (N) /= N_Integer_Literal 4299 and then not Is_Entity_Name (N) 4300 and then Nkind (N) /= N_Attribute_Reference 4301 then 4302 Error_Msg_N ("illegal bound in discrete range", N); 4303 end if; 4304 end Check_Universal_Expression; 4305 4306 -- Start of processing for Analyze_Range 4307 4308 begin 4309 Set_Etype (N, Any_Type); 4310 Analyze_Expression (L); 4311 Analyze_Expression (H); 4312 4313 if Etype (L) = Any_Type or else Etype (H) = Any_Type then 4314 return; 4315 4316 else 4317 if not Is_Overloaded (L) then 4318 Check_High_Bound (Etype (L)); 4319 else 4320 Get_First_Interp (L, I1, It1); 4321 while Present (It1.Typ) loop 4322 Check_High_Bound (It1.Typ); 4323 Get_Next_Interp (I1, It1); 4324 end loop; 4325 end if; 4326 4327 -- If result is Any_Type, then we did not find a compatible pair 4328 4329 if Etype (N) = Any_Type then 4330 Error_Msg_N ("incompatible types in range ", N); 4331 end if; 4332 end if; 4333 4334 if Ada_Version = Ada_83 4335 and then 4336 (Nkind (Parent (N)) = N_Loop_Parameter_Specification 4337 or else Nkind (Parent (N)) = N_Constrained_Array_Definition) 4338 then 4339 Check_Universal_Expression (L); 4340 Check_Universal_Expression (H); 4341 end if; 4342 4343 Check_Function_Writable_Actuals (N); 4344 end Analyze_Range; 4345 4346 ----------------------------------- 4347 -- Analyze_Reduction_Expression -- 4348 ----------------------------------- 4349 4350 procedure Analyze_Reduction_Expression (N : Node_Id) is 4351 Expr : constant Node_Id := Expression (N); 4352 QE_Scop : Entity_Id; 4353 4354 begin 4355 QE_Scop := New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), 'L'); 4356 Set_Etype (QE_Scop, Standard_Void_Type); 4357 Set_Scope (QE_Scop, Current_Scope); 4358 Set_Parent (QE_Scop, N); 4359 4360 Push_Scope (QE_Scop); 4361 4362 -- All constituents are preanalyzed and resolved to avoid untimely 4363 -- generation of various temporaries and types. Full analysis and 4364 -- expansion is carried out when the reduction expression is 4365 -- transformed into an expression with actions. 4366 4367 if Present (Iterator_Specification (N)) then 4368 Preanalyze (Iterator_Specification (N)); 4369 4370 else pragma Assert (Present (Loop_Parameter_Specification (N))); 4371 declare 4372 Loop_Par : constant Node_Id := Loop_Parameter_Specification (N); 4373 4374 begin 4375 Preanalyze (Loop_Par); 4376 4377 if Nkind (Discrete_Subtype_Definition (Loop_Par)) = N_Function_Call 4378 and then Parent (Loop_Par) /= N 4379 then 4380 -- The parser cannot distinguish between a loop specification 4381 -- and an iterator specification. If after preanalysis the 4382 -- proper form has been recognized, rewrite the expression to 4383 -- reflect the right kind. This is needed for proper ASIS 4384 -- navigation. If expansion is enabled, the transformation is 4385 -- performed when the expression is rewritten as a loop. 4386 4387 Set_Iterator_Specification (N, 4388 New_Copy_Tree (Iterator_Specification (Parent (Loop_Par)))); 4389 4390 Set_Defining_Identifier (Iterator_Specification (N), 4391 Relocate_Node (Defining_Identifier (Loop_Par))); 4392 Set_Name (Iterator_Specification (N), 4393 Relocate_Node (Discrete_Subtype_Definition (Loop_Par))); 4394 Set_Comes_From_Source (Iterator_Specification (N), 4395 Comes_From_Source (Loop_Parameter_Specification (N))); 4396 Set_Loop_Parameter_Specification (N, Empty); 4397 end if; 4398 end; 4399 end if; 4400 4401 Preanalyze (Expr); 4402 End_Scope; 4403 4404 Set_Etype (N, Etype (Expr)); 4405 end Analyze_Reduction_Expression; 4406 4407 -------------------------------------------- 4408 -- Analyze_Reduction_Expression_Parameter -- 4409 -------------------------------------------- 4410 4411 procedure Analyze_Reduction_Expression_Parameter (N : Node_Id) is 4412 Expr : constant Node_Id := Expression (N); 4413 4414 begin 4415 Analyze (Expr); 4416 Set_Etype (N, Etype (Expr)); 4417 end Analyze_Reduction_Expression_Parameter; 4418 4419 ----------------------- 4420 -- Analyze_Reference -- 4421 ----------------------- 4422 4423 procedure Analyze_Reference (N : Node_Id) is 4424 P : constant Node_Id := Prefix (N); 4425 E : Entity_Id; 4426 T : Entity_Id; 4427 Acc_Type : Entity_Id; 4428 4429 begin 4430 Analyze (P); 4431 4432 -- An interesting error check, if we take the 'Ref of an object for 4433 -- which a pragma Atomic or Volatile has been given, and the type of the 4434 -- object is not Atomic or Volatile, then we are in trouble. The problem 4435 -- is that no trace of the atomic/volatile status will remain for the 4436 -- backend to respect when it deals with the resulting pointer, since 4437 -- the pointer type will not be marked atomic (it is a pointer to the 4438 -- base type of the object). 4439 4440 -- It is not clear if that can ever occur, but in case it does, we will 4441 -- generate an error message. Not clear if this message can ever be 4442 -- generated, and pretty clear that it represents a bug if it is, still 4443 -- seems worth checking, except in CodePeer mode where we do not really 4444 -- care and don't want to bother the user. 4445 4446 T := Etype (P); 4447 4448 if Is_Entity_Name (P) 4449 and then Is_Object_Reference (P) 4450 and then not CodePeer_Mode 4451 then 4452 E := Entity (P); 4453 T := Etype (P); 4454 4455 if (Has_Atomic_Components (E) 4456 and then not Has_Atomic_Components (T)) 4457 or else 4458 (Has_Volatile_Components (E) 4459 and then not Has_Volatile_Components (T)) 4460 or else (Is_Atomic (E) and then not Is_Atomic (T)) 4461 or else (Is_Volatile (E) and then not Is_Volatile (T)) 4462 then 4463 Error_Msg_N ("cannot take reference to Atomic/Volatile object", N); 4464 end if; 4465 end if; 4466 4467 -- Carry on with normal processing 4468 4469 Acc_Type := Create_Itype (E_Allocator_Type, N); 4470 Set_Etype (Acc_Type, Acc_Type); 4471 Set_Directly_Designated_Type (Acc_Type, Etype (P)); 4472 Set_Etype (N, Acc_Type); 4473 end Analyze_Reference; 4474 4475 -------------------------------- 4476 -- Analyze_Selected_Component -- 4477 -------------------------------- 4478 4479 -- Prefix is a record type or a task or protected type. In the latter case, 4480 -- the selector must denote a visible entry. 4481 4482 procedure Analyze_Selected_Component (N : Node_Id) is 4483 Name : constant Node_Id := Prefix (N); 4484 Sel : constant Node_Id := Selector_Name (N); 4485 Act_Decl : Node_Id; 4486 Comp : Entity_Id; 4487 Has_Candidate : Boolean := False; 4488 Hidden_Comp : Entity_Id; 4489 In_Scope : Boolean; 4490 Is_Private_Op : Boolean; 4491 Parent_N : Node_Id; 4492 Pent : Entity_Id := Empty; 4493 Prefix_Type : Entity_Id; 4494 4495 Type_To_Use : Entity_Id; 4496 -- In most cases this is the Prefix_Type, but if the Prefix_Type is 4497 -- a class-wide type, we use its root type, whose components are 4498 -- present in the class-wide type. 4499 4500 Is_Single_Concurrent_Object : Boolean; 4501 -- Set True if the prefix is a single task or a single protected object 4502 4503 procedure Find_Component_In_Instance (Rec : Entity_Id); 4504 -- In an instance, a component of a private extension may not be visible 4505 -- while it was visible in the generic. Search candidate scope for a 4506 -- component with the proper identifier. This is only done if all other 4507 -- searches have failed. If a match is found, the Etype of both N and 4508 -- Sel are set from this component, and the entity of Sel is set to 4509 -- reference this component. If no match is found, Entity (Sel) remains 4510 -- unset. For a derived type that is an actual of the instance, the 4511 -- desired component may be found in any ancestor. 4512 4513 function Has_Mode_Conformant_Spec (Comp : Entity_Id) return Boolean; 4514 -- It is known that the parent of N denotes a subprogram call. Comp 4515 -- is an overloadable component of the concurrent type of the prefix. 4516 -- Determine whether all formals of the parent of N and Comp are mode 4517 -- conformant. If the parent node is not analyzed yet it may be an 4518 -- indexed component rather than a function call. 4519 4520 function Has_Dereference (Nod : Node_Id) return Boolean; 4521 -- Check whether prefix includes a dereference at any level. 4522 4523 -------------------------------- 4524 -- Find_Component_In_Instance -- 4525 -------------------------------- 4526 4527 procedure Find_Component_In_Instance (Rec : Entity_Id) is 4528 Comp : Entity_Id; 4529 Typ : Entity_Id; 4530 4531 begin 4532 Typ := Rec; 4533 while Present (Typ) loop 4534 Comp := First_Component (Typ); 4535 while Present (Comp) loop 4536 if Chars (Comp) = Chars (Sel) then 4537 Set_Entity_With_Checks (Sel, Comp); 4538 Set_Etype (Sel, Etype (Comp)); 4539 Set_Etype (N, Etype (Comp)); 4540 return; 4541 end if; 4542 4543 Next_Component (Comp); 4544 end loop; 4545 4546 -- If not found, the component may be declared in the parent 4547 -- type or its full view, if any. 4548 4549 if Is_Derived_Type (Typ) then 4550 Typ := Etype (Typ); 4551 4552 if Is_Private_Type (Typ) then 4553 Typ := Full_View (Typ); 4554 end if; 4555 4556 else 4557 return; 4558 end if; 4559 end loop; 4560 4561 -- If we fall through, no match, so no changes made 4562 4563 return; 4564 end Find_Component_In_Instance; 4565 4566 ------------------------------ 4567 -- Has_Mode_Conformant_Spec -- 4568 ------------------------------ 4569 4570 function Has_Mode_Conformant_Spec (Comp : Entity_Id) return Boolean is 4571 Comp_Param : Entity_Id; 4572 Param : Node_Id; 4573 Param_Typ : Entity_Id; 4574 4575 begin 4576 Comp_Param := First_Formal (Comp); 4577 4578 if Nkind (Parent (N)) = N_Indexed_Component then 4579 Param := First (Expressions (Parent (N))); 4580 else 4581 Param := First (Parameter_Associations (Parent (N))); 4582 end if; 4583 4584 while Present (Comp_Param) 4585 and then Present (Param) 4586 loop 4587 Param_Typ := Find_Parameter_Type (Param); 4588 4589 if Present (Param_Typ) 4590 and then 4591 not Conforming_Types 4592 (Etype (Comp_Param), Param_Typ, Mode_Conformant) 4593 then 4594 return False; 4595 end if; 4596 4597 Next_Formal (Comp_Param); 4598 Next (Param); 4599 end loop; 4600 4601 -- One of the specs has additional formals; there is no match, unless 4602 -- this may be an indexing of a parameterless call. 4603 4604 -- Note that when expansion is disabled, the corresponding record 4605 -- type of synchronized types is not constructed, so that there is 4606 -- no point is attempting an interpretation as a prefixed call, as 4607 -- this is bound to fail because the primitive operations will not 4608 -- be properly located. 4609 4610 if Present (Comp_Param) or else Present (Param) then 4611 if Needs_No_Actuals (Comp) 4612 and then Is_Array_Type (Etype (Comp)) 4613 and then not Expander_Active 4614 then 4615 return True; 4616 else 4617 return False; 4618 end if; 4619 end if; 4620 4621 return True; 4622 end Has_Mode_Conformant_Spec; 4623 4624 --------------------- 4625 -- Has_Dereference -- 4626 --------------------- 4627 4628 function Has_Dereference (Nod : Node_Id) return Boolean is 4629 begin 4630 if Nkind (Nod) = N_Explicit_Dereference then 4631 return True; 4632 4633 -- When expansion is disabled an explicit dereference may not have 4634 -- been inserted, but if this is an access type the indirection makes 4635 -- the call safe. 4636 4637 elsif Is_Access_Type (Etype (Nod)) then 4638 return True; 4639 4640 elsif Nkind_In (Nod, N_Indexed_Component, N_Selected_Component) then 4641 return Has_Dereference (Prefix (Nod)); 4642 4643 else 4644 return False; 4645 end if; 4646 end Has_Dereference; 4647 4648 -- Start of processing for Analyze_Selected_Component 4649 4650 begin 4651 Set_Etype (N, Any_Type); 4652 4653 if Is_Overloaded (Name) then 4654 Analyze_Overloaded_Selected_Component (N); 4655 return; 4656 4657 elsif Etype (Name) = Any_Type then 4658 Set_Entity (Sel, Any_Id); 4659 Set_Etype (Sel, Any_Type); 4660 return; 4661 4662 else 4663 Prefix_Type := Etype (Name); 4664 end if; 4665 4666 if Is_Access_Type (Prefix_Type) then 4667 4668 -- A RACW object can never be used as prefix of a selected component 4669 -- since that means it is dereferenced without being a controlling 4670 -- operand of a dispatching operation (RM E.2.2(16/1)). Before 4671 -- reporting an error, we must check whether this is actually a 4672 -- dispatching call in prefix form. 4673 4674 if Is_Remote_Access_To_Class_Wide_Type (Prefix_Type) 4675 and then Comes_From_Source (N) 4676 then 4677 if Try_Object_Operation (N) then 4678 return; 4679 else 4680 Error_Msg_N 4681 ("invalid dereference of a remote access-to-class-wide value", 4682 N); 4683 end if; 4684 4685 -- Normal case of selected component applied to access type 4686 4687 else 4688 Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N); 4689 4690 if Is_Entity_Name (Name) then 4691 Pent := Entity (Name); 4692 elsif Nkind (Name) = N_Selected_Component 4693 and then Is_Entity_Name (Selector_Name (Name)) 4694 then 4695 Pent := Entity (Selector_Name (Name)); 4696 end if; 4697 4698 Prefix_Type := Process_Implicit_Dereference_Prefix (Pent, Name); 4699 end if; 4700 4701 -- If we have an explicit dereference of a remote access-to-class-wide 4702 -- value, then issue an error (see RM-E.2.2(16/1)). However we first 4703 -- have to check for the case of a prefix that is a controlling operand 4704 -- of a prefixed dispatching call, as the dereference is legal in that 4705 -- case. Normally this condition is checked in Validate_Remote_Access_ 4706 -- To_Class_Wide_Type, but we have to defer the checking for selected 4707 -- component prefixes because of the prefixed dispatching call case. 4708 -- Note that implicit dereferences are checked for this just above. 4709 4710 elsif Nkind (Name) = N_Explicit_Dereference 4711 and then Is_Remote_Access_To_Class_Wide_Type (Etype (Prefix (Name))) 4712 and then Comes_From_Source (N) 4713 then 4714 if Try_Object_Operation (N) then 4715 return; 4716 else 4717 Error_Msg_N 4718 ("invalid dereference of a remote access-to-class-wide value", 4719 N); 4720 end if; 4721 end if; 4722 4723 -- (Ada 2005): if the prefix is the limited view of a type, and 4724 -- the context already includes the full view, use the full view 4725 -- in what follows, either to retrieve a component of to find 4726 -- a primitive operation. If the prefix is an explicit dereference, 4727 -- set the type of the prefix to reflect this transformation. 4728 -- If the nonlimited view is itself an incomplete type, get the 4729 -- full view if available. 4730 4731 if From_Limited_With (Prefix_Type) 4732 and then Has_Non_Limited_View (Prefix_Type) 4733 then 4734 Prefix_Type := Get_Full_View (Non_Limited_View (Prefix_Type)); 4735 4736 if Nkind (N) = N_Explicit_Dereference then 4737 Set_Etype (Prefix (N), Prefix_Type); 4738 end if; 4739 end if; 4740 4741 if Ekind (Prefix_Type) = E_Private_Subtype then 4742 Prefix_Type := Base_Type (Prefix_Type); 4743 end if; 4744 4745 Type_To_Use := Prefix_Type; 4746 4747 -- For class-wide types, use the entity list of the root type. This 4748 -- indirection is specially important for private extensions because 4749 -- only the root type get switched (not the class-wide type). 4750 4751 if Is_Class_Wide_Type (Prefix_Type) then 4752 Type_To_Use := Root_Type (Prefix_Type); 4753 end if; 4754 4755 -- If the prefix is a single concurrent object, use its name in error 4756 -- messages, rather than that of its anonymous type. 4757 4758 Is_Single_Concurrent_Object := 4759 Is_Concurrent_Type (Prefix_Type) 4760 and then Is_Internal_Name (Chars (Prefix_Type)) 4761 and then not Is_Derived_Type (Prefix_Type) 4762 and then Is_Entity_Name (Name); 4763 4764 Comp := First_Entity (Type_To_Use); 4765 4766 -- If the selector has an original discriminant, the node appears in 4767 -- an instance. Replace the discriminant with the corresponding one 4768 -- in the current discriminated type. For nested generics, this must 4769 -- be done transitively, so note the new original discriminant. 4770 4771 if Nkind (Sel) = N_Identifier 4772 and then In_Instance 4773 and then Present (Original_Discriminant (Sel)) 4774 then 4775 Comp := Find_Corresponding_Discriminant (Sel, Prefix_Type); 4776 4777 -- Mark entity before rewriting, for completeness and because 4778 -- subsequent semantic checks might examine the original node. 4779 4780 Set_Entity (Sel, Comp); 4781 Rewrite (Selector_Name (N), New_Occurrence_Of (Comp, Sloc (N))); 4782 Set_Original_Discriminant (Selector_Name (N), Comp); 4783 Set_Etype (N, Etype (Comp)); 4784 Check_Implicit_Dereference (N, Etype (Comp)); 4785 4786 if Is_Access_Type (Etype (Name)) then 4787 Insert_Explicit_Dereference (Name); 4788 Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N); 4789 end if; 4790 4791 elsif Is_Record_Type (Prefix_Type) then 4792 4793 -- Find component with given name. In an instance, if the node is 4794 -- known as a prefixed call, do not examine components whose 4795 -- visibility may be accidental. 4796 4797 while Present (Comp) and then not Is_Prefixed_Call (N) loop 4798 if Chars (Comp) = Chars (Sel) 4799 and then Is_Visible_Component (Comp, N) 4800 then 4801 Set_Entity_With_Checks (Sel, Comp); 4802 Set_Etype (Sel, Etype (Comp)); 4803 4804 if Ekind (Comp) = E_Discriminant then 4805 if Is_Unchecked_Union (Base_Type (Prefix_Type)) then 4806 Error_Msg_N 4807 ("cannot reference discriminant of unchecked union", 4808 Sel); 4809 end if; 4810 4811 if Is_Generic_Type (Prefix_Type) 4812 or else 4813 Is_Generic_Type (Root_Type (Prefix_Type)) 4814 then 4815 Set_Original_Discriminant (Sel, Comp); 4816 end if; 4817 end if; 4818 4819 -- Resolve the prefix early otherwise it is not possible to 4820 -- build the actual subtype of the component: it may need 4821 -- to duplicate this prefix and duplication is only allowed 4822 -- on fully resolved expressions. 4823 4824 Resolve (Name); 4825 4826 -- Ada 2005 (AI-50217): Check wrong use of incomplete types or 4827 -- subtypes in a package specification. 4828 -- Example: 4829 4830 -- limited with Pkg; 4831 -- package Pkg is 4832 -- type Acc_Inc is access Pkg.T; 4833 -- X : Acc_Inc; 4834 -- N : Natural := X.all.Comp; -- ERROR, limited view 4835 -- end Pkg; -- Comp is not visible 4836 4837 if Nkind (Name) = N_Explicit_Dereference 4838 and then From_Limited_With (Etype (Prefix (Name))) 4839 and then not Is_Potentially_Use_Visible (Etype (Name)) 4840 and then Nkind (Parent (Cunit_Entity (Current_Sem_Unit))) = 4841 N_Package_Specification 4842 then 4843 Error_Msg_NE 4844 ("premature usage of incomplete}", Prefix (Name), 4845 Etype (Prefix (Name))); 4846 end if; 4847 4848 -- We never need an actual subtype for the case of a selection 4849 -- for a indexed component of a non-packed array, since in 4850 -- this case gigi generates all the checks and can find the 4851 -- necessary bounds information. 4852 4853 -- We also do not need an actual subtype for the case of a 4854 -- first, last, length, or range attribute applied to a 4855 -- non-packed array, since gigi can again get the bounds in 4856 -- these cases (gigi cannot handle the packed case, since it 4857 -- has the bounds of the packed array type, not the original 4858 -- bounds of the type). However, if the prefix is itself a 4859 -- selected component, as in a.b.c (i), gigi may regard a.b.c 4860 -- as a dynamic-sized temporary, so we do generate an actual 4861 -- subtype for this case. 4862 4863 Parent_N := Parent (N); 4864 4865 if not Is_Packed (Etype (Comp)) 4866 and then 4867 ((Nkind (Parent_N) = N_Indexed_Component 4868 and then Nkind (Name) /= N_Selected_Component) 4869 or else 4870 (Nkind (Parent_N) = N_Attribute_Reference 4871 and then 4872 Nam_In (Attribute_Name (Parent_N), Name_First, 4873 Name_Last, 4874 Name_Length, 4875 Name_Range))) 4876 then 4877 Set_Etype (N, Etype (Comp)); 4878 4879 -- If full analysis is not enabled, we do not generate an 4880 -- actual subtype, because in the absence of expansion 4881 -- reference to a formal of a protected type, for example, 4882 -- will not be properly transformed, and will lead to 4883 -- out-of-scope references in gigi. 4884 4885 -- In all other cases, we currently build an actual subtype. 4886 -- It seems likely that many of these cases can be avoided, 4887 -- but right now, the front end makes direct references to the 4888 -- bounds (e.g. in generating a length check), and if we do 4889 -- not make an actual subtype, we end up getting a direct 4890 -- reference to a discriminant, which will not do. 4891 4892 elsif Full_Analysis then 4893 Act_Decl := 4894 Build_Actual_Subtype_Of_Component (Etype (Comp), N); 4895 Insert_Action (N, Act_Decl); 4896 4897 if No (Act_Decl) then 4898 Set_Etype (N, Etype (Comp)); 4899 4900 else 4901 -- Component type depends on discriminants. Enter the 4902 -- main attributes of the subtype. 4903 4904 declare 4905 Subt : constant Entity_Id := 4906 Defining_Identifier (Act_Decl); 4907 4908 begin 4909 Set_Etype (Subt, Base_Type (Etype (Comp))); 4910 Set_Ekind (Subt, Ekind (Etype (Comp))); 4911 Set_Etype (N, Subt); 4912 end; 4913 end if; 4914 4915 -- If Full_Analysis not enabled, just set the Etype 4916 4917 else 4918 Set_Etype (N, Etype (Comp)); 4919 end if; 4920 4921 Check_Implicit_Dereference (N, Etype (N)); 4922 return; 4923 end if; 4924 4925 -- If the prefix is a private extension, check only the visible 4926 -- components of the partial view. This must include the tag, 4927 -- which can appear in expanded code in a tag check. 4928 4929 if Ekind (Type_To_Use) = E_Record_Type_With_Private 4930 and then Chars (Selector_Name (N)) /= Name_uTag 4931 then 4932 exit when Comp = Last_Entity (Type_To_Use); 4933 end if; 4934 4935 Next_Entity (Comp); 4936 end loop; 4937 4938 -- Ada 2005 (AI-252): The selected component can be interpreted as 4939 -- a prefixed view of a subprogram. Depending on the context, this is 4940 -- either a name that can appear in a renaming declaration, or part 4941 -- of an enclosing call given in prefix form. 4942 4943 -- Ada 2005 (AI05-0030): In the case of dispatching requeue, the 4944 -- selected component should resolve to a name. 4945 4946 if Ada_Version >= Ada_2005 4947 and then Is_Tagged_Type (Prefix_Type) 4948 and then not Is_Concurrent_Type (Prefix_Type) 4949 then 4950 if Nkind (Parent (N)) = N_Generic_Association 4951 or else Nkind (Parent (N)) = N_Requeue_Statement 4952 or else Nkind (Parent (N)) = N_Subprogram_Renaming_Declaration 4953 then 4954 if Find_Primitive_Operation (N) then 4955 return; 4956 end if; 4957 4958 elsif Try_Object_Operation (N) then 4959 return; 4960 end if; 4961 4962 -- If the transformation fails, it will be necessary to redo the 4963 -- analysis with all errors enabled, to indicate candidate 4964 -- interpretations and reasons for each failure ??? 4965 4966 end if; 4967 4968 elsif Is_Private_Type (Prefix_Type) then 4969 4970 -- Allow access only to discriminants of the type. If the type has 4971 -- no full view, gigi uses the parent type for the components, so we 4972 -- do the same here. 4973 4974 if No (Full_View (Prefix_Type)) then 4975 Type_To_Use := Root_Type (Base_Type (Prefix_Type)); 4976 Comp := First_Entity (Type_To_Use); 4977 end if; 4978 4979 while Present (Comp) loop 4980 if Chars (Comp) = Chars (Sel) then 4981 if Ekind (Comp) = E_Discriminant then 4982 Set_Entity_With_Checks (Sel, Comp); 4983 Generate_Reference (Comp, Sel); 4984 4985 Set_Etype (Sel, Etype (Comp)); 4986 Set_Etype (N, Etype (Comp)); 4987 Check_Implicit_Dereference (N, Etype (N)); 4988 4989 if Is_Generic_Type (Prefix_Type) 4990 or else Is_Generic_Type (Root_Type (Prefix_Type)) 4991 then 4992 Set_Original_Discriminant (Sel, Comp); 4993 end if; 4994 4995 -- Before declaring an error, check whether this is tagged 4996 -- private type and a call to a primitive operation. 4997 4998 elsif Ada_Version >= Ada_2005 4999 and then Is_Tagged_Type (Prefix_Type) 5000 and then Try_Object_Operation (N) 5001 then 5002 return; 5003 5004 else 5005 Error_Msg_Node_2 := First_Subtype (Prefix_Type); 5006 Error_Msg_NE ("invisible selector& for }", N, Sel); 5007 Set_Entity (Sel, Any_Id); 5008 Set_Etype (N, Any_Type); 5009 end if; 5010 5011 return; 5012 end if; 5013 5014 Next_Entity (Comp); 5015 end loop; 5016 5017 elsif Is_Concurrent_Type (Prefix_Type) then 5018 5019 -- Find visible operation with given name. For a protected type, 5020 -- the possible candidates are discriminants, entries or protected 5021 -- subprograms. For a task type, the set can only include entries or 5022 -- discriminants if the task type is not an enclosing scope. If it 5023 -- is an enclosing scope (e.g. in an inner task) then all entities 5024 -- are visible, but the prefix must denote the enclosing scope, i.e. 5025 -- can only be a direct name or an expanded name. 5026 5027 Set_Etype (Sel, Any_Type); 5028 Hidden_Comp := Empty; 5029 In_Scope := In_Open_Scopes (Prefix_Type); 5030 Is_Private_Op := False; 5031 5032 while Present (Comp) loop 5033 5034 -- Do not examine private operations of the type if not within 5035 -- its scope. 5036 5037 if Chars (Comp) = Chars (Sel) then 5038 if Is_Overloadable (Comp) 5039 and then (In_Scope 5040 or else Comp /= First_Private_Entity (Type_To_Use)) 5041 then 5042 Add_One_Interp (Sel, Comp, Etype (Comp)); 5043 if Comp = First_Private_Entity (Type_To_Use) then 5044 Is_Private_Op := True; 5045 end if; 5046 5047 -- If the prefix is tagged, the correct interpretation may 5048 -- lie in the primitive or class-wide operations of the 5049 -- type. Perform a simple conformance check to determine 5050 -- whether Try_Object_Operation should be invoked even if 5051 -- a visible entity is found. 5052 5053 if Is_Tagged_Type (Prefix_Type) 5054 and then Nkind_In (Parent (N), N_Function_Call, 5055 N_Indexed_Component, 5056 N_Procedure_Call_Statement) 5057 and then Has_Mode_Conformant_Spec (Comp) 5058 then 5059 Has_Candidate := True; 5060 end if; 5061 5062 -- Note: a selected component may not denote a component of a 5063 -- protected type (4.1.3(7)). 5064 5065 elsif Ekind_In (Comp, E_Discriminant, E_Entry_Family) 5066 or else (In_Scope 5067 and then not Is_Protected_Type (Prefix_Type) 5068 and then Is_Entity_Name (Name)) 5069 then 5070 Set_Entity_With_Checks (Sel, Comp); 5071 Generate_Reference (Comp, Sel); 5072 5073 -- The selector is not overloadable, so we have a candidate 5074 -- interpretation. 5075 5076 Has_Candidate := True; 5077 5078 else 5079 if Ekind (Comp) = E_Component then 5080 Hidden_Comp := Comp; 5081 end if; 5082 5083 goto Next_Comp; 5084 end if; 5085 5086 Set_Etype (Sel, Etype (Comp)); 5087 Set_Etype (N, Etype (Comp)); 5088 5089 if Ekind (Comp) = E_Discriminant then 5090 Set_Original_Discriminant (Sel, Comp); 5091 end if; 5092 5093 -- For access type case, introduce explicit dereference for 5094 -- more uniform treatment of entry calls. 5095 5096 if Is_Access_Type (Etype (Name)) then 5097 Insert_Explicit_Dereference (Name); 5098 Error_Msg_NW 5099 (Warn_On_Dereference, "?d?implicit dereference", N); 5100 end if; 5101 end if; 5102 5103 <<Next_Comp>> 5104 if Comp = First_Private_Entity (Type_To_Use) then 5105 if Etype (Sel) /= Any_Type then 5106 5107 -- We have a candiate 5108 5109 exit; 5110 5111 else 5112 -- Indicate that subsequent operations are private, 5113 -- for better error reporting. 5114 5115 Is_Private_Op := True; 5116 end if; 5117 end if; 5118 5119 -- Do not examine private operations if not within scope of 5120 -- the synchronized type. 5121 5122 exit when not In_Scope 5123 and then 5124 Comp = First_Private_Entity (Base_Type (Prefix_Type)); 5125 Next_Entity (Comp); 5126 end loop; 5127 5128 -- If the scope is a current instance, the prefix cannot be an 5129 -- expression of the same type, unless the selector designates a 5130 -- public operation (otherwise that would represent an attempt to 5131 -- reach an internal entity of another synchronized object). 5132 5133 -- This is legal if prefix is an access to such type and there is 5134 -- a dereference, or is a component with a dereferenced prefix. 5135 -- It is also legal if the prefix is a component of a task type, 5136 -- and the selector is one of the task operations. 5137 5138 if In_Scope 5139 and then not Is_Entity_Name (Name) 5140 and then not Has_Dereference (Name) 5141 then 5142 if Is_Task_Type (Prefix_Type) 5143 and then Present (Entity (Sel)) 5144 and then Ekind_In (Entity (Sel), E_Entry, E_Entry_Family) 5145 then 5146 null; 5147 5148 elsif Is_Protected_Type (Prefix_Type) 5149 and then Is_Overloadable (Entity (Sel)) 5150 and then not Is_Private_Op 5151 then 5152 null; 5153 5154 else 5155 Error_Msg_NE 5156 ("invalid reference to internal operation of some object of " 5157 & "type &", N, Type_To_Use); 5158 Set_Entity (Sel, Any_Id); 5159 Set_Etype (Sel, Any_Type); 5160 return; 5161 end if; 5162 5163 -- Another special case: the prefix may denote an object of the type 5164 -- (but not a type) in which case this is an external call and the 5165 -- operation must be public. 5166 5167 elsif In_Scope 5168 and then Is_Object_Reference (Original_Node (Prefix (N))) 5169 and then Comes_From_Source (N) 5170 and then Is_Private_Op 5171 then 5172 if Present (Hidden_Comp) then 5173 Error_Msg_NE 5174 ("invalid reference to private component of object of type " 5175 & "&", N, Type_To_Use); 5176 5177 else 5178 Error_Msg_NE 5179 ("invalid reference to private operation of some object of " 5180 & "type &", N, Type_To_Use); 5181 end if; 5182 5183 Set_Entity (Sel, Any_Id); 5184 Set_Etype (Sel, Any_Type); 5185 return; 5186 end if; 5187 5188 -- If there is no visible entity with the given name or none of the 5189 -- visible entities are plausible interpretations, check whether 5190 -- there is some other primitive operation with that name. 5191 5192 if Ada_Version >= Ada_2005 and then Is_Tagged_Type (Prefix_Type) then 5193 if (Etype (N) = Any_Type 5194 or else not Has_Candidate) 5195 and then Try_Object_Operation (N) 5196 then 5197 return; 5198 5199 -- If the context is not syntactically a procedure call, it 5200 -- may be a call to a primitive function declared outside of 5201 -- the synchronized type. 5202 5203 -- If the context is a procedure call, there might still be 5204 -- an overloading between an entry and a primitive procedure 5205 -- declared outside of the synchronized type, called in prefix 5206 -- notation. This is harder to disambiguate because in one case 5207 -- the controlling formal is implicit ??? 5208 5209 elsif Nkind (Parent (N)) /= N_Procedure_Call_Statement 5210 and then Nkind (Parent (N)) /= N_Indexed_Component 5211 and then Try_Object_Operation (N) 5212 then 5213 return; 5214 end if; 5215 5216 -- Ada 2012 (AI05-0090-1): If we found a candidate of a call to an 5217 -- entry or procedure of a tagged concurrent type we must check 5218 -- if there are class-wide subprograms covering the primitive. If 5219 -- true then Try_Object_Operation reports the error. 5220 5221 if Has_Candidate 5222 and then Is_Concurrent_Type (Prefix_Type) 5223 and then Nkind (Parent (N)) = N_Procedure_Call_Statement 5224 then 5225 -- Duplicate the call. This is required to avoid problems with 5226 -- the tree transformations performed by Try_Object_Operation. 5227 -- Set properly the parent of the copied call, because it is 5228 -- about to be reanalyzed. 5229 5230 declare 5231 Par : constant Node_Id := New_Copy_Tree (Parent (N)); 5232 5233 begin 5234 Set_Parent (Par, Parent (Parent (N))); 5235 5236 if Try_Object_Operation 5237 (Sinfo.Name (Par), CW_Test_Only => True) 5238 then 5239 return; 5240 end if; 5241 end; 5242 end if; 5243 end if; 5244 5245 if Etype (N) = Any_Type and then Is_Protected_Type (Prefix_Type) then 5246 5247 -- Case of a prefix of a protected type: selector might denote 5248 -- an invisible private component. 5249 5250 Comp := First_Private_Entity (Base_Type (Prefix_Type)); 5251 while Present (Comp) and then Chars (Comp) /= Chars (Sel) loop 5252 Next_Entity (Comp); 5253 end loop; 5254 5255 if Present (Comp) then 5256 if Is_Single_Concurrent_Object then 5257 Error_Msg_Node_2 := Entity (Name); 5258 Error_Msg_NE ("invisible selector& for &", N, Sel); 5259 5260 else 5261 Error_Msg_Node_2 := First_Subtype (Prefix_Type); 5262 Error_Msg_NE ("invisible selector& for }", N, Sel); 5263 end if; 5264 return; 5265 end if; 5266 end if; 5267 5268 Set_Is_Overloaded (N, Is_Overloaded (Sel)); 5269 5270 else 5271 -- Invalid prefix 5272 5273 Error_Msg_NE ("invalid prefix in selected component&", N, Sel); 5274 end if; 5275 5276 -- If N still has no type, the component is not defined in the prefix 5277 5278 if Etype (N) = Any_Type then 5279 5280 if Is_Single_Concurrent_Object then 5281 Error_Msg_Node_2 := Entity (Name); 5282 Error_Msg_NE ("no selector& for&", N, Sel); 5283 5284 Check_Misspelled_Selector (Type_To_Use, Sel); 5285 5286 -- If this is a derived formal type, the parent may have different 5287 -- visibility at this point. Try for an inherited component before 5288 -- reporting an error. 5289 5290 elsif Is_Generic_Type (Prefix_Type) 5291 and then Ekind (Prefix_Type) = E_Record_Type_With_Private 5292 and then Prefix_Type /= Etype (Prefix_Type) 5293 and then Is_Record_Type (Etype (Prefix_Type)) 5294 then 5295 Set_Etype (Prefix (N), Etype (Prefix_Type)); 5296 Analyze_Selected_Component (N); 5297 return; 5298 5299 -- Similarly, if this is the actual for a formal derived type, or 5300 -- a derived type thereof, the component inherited from the generic 5301 -- parent may not be visible in the actual, but the selected 5302 -- component is legal. Climb up the derivation chain of the generic 5303 -- parent type until we find the proper ancestor type. 5304 5305 elsif In_Instance and then Is_Tagged_Type (Prefix_Type) then 5306 declare 5307 Par : Entity_Id := Prefix_Type; 5308 begin 5309 -- Climb up derivation chain to generic actual subtype 5310 5311 while not Is_Generic_Actual_Type (Par) loop 5312 if Ekind (Par) = E_Record_Type then 5313 Par := Parent_Subtype (Par); 5314 exit when No (Par); 5315 else 5316 exit when Par = Etype (Par); 5317 Par := Etype (Par); 5318 end if; 5319 end loop; 5320 5321 if Present (Par) and then Is_Generic_Actual_Type (Par) then 5322 5323 -- Now look for component in ancestor types 5324 5325 Par := Generic_Parent_Type (Declaration_Node (Par)); 5326 loop 5327 Find_Component_In_Instance (Par); 5328 exit when Present (Entity (Sel)) 5329 or else Par = Etype (Par); 5330 Par := Etype (Par); 5331 end loop; 5332 5333 -- Another special case: the type is an extension of a private 5334 -- type T, is an actual in an instance, and we are in the body 5335 -- of the instance, so the generic body had a full view of the 5336 -- type declaration for T or of some ancestor that defines the 5337 -- component in question. 5338 5339 elsif Is_Derived_Type (Type_To_Use) 5340 and then Used_As_Generic_Actual (Type_To_Use) 5341 and then In_Instance_Body 5342 then 5343 Find_Component_In_Instance (Parent_Subtype (Type_To_Use)); 5344 5345 -- In ASIS mode the generic parent type may be absent. Examine 5346 -- the parent type directly for a component that may have been 5347 -- visible in a parent generic unit. 5348 5349 elsif Is_Derived_Type (Prefix_Type) then 5350 Par := Etype (Prefix_Type); 5351 Find_Component_In_Instance (Par); 5352 end if; 5353 end; 5354 5355 -- The search above must have eventually succeeded, since the 5356 -- selected component was legal in the generic. 5357 5358 if No (Entity (Sel)) then 5359 raise Program_Error; 5360 end if; 5361 5362 return; 5363 5364 -- Component not found, specialize error message when appropriate 5365 5366 else 5367 if Ekind (Prefix_Type) = E_Record_Subtype then 5368 5369 -- Check whether this is a component of the base type which 5370 -- is absent from a statically constrained subtype. This will 5371 -- raise constraint error at run time, but is not a compile- 5372 -- time error. When the selector is illegal for base type as 5373 -- well fall through and generate a compilation error anyway. 5374 5375 Comp := First_Component (Base_Type (Prefix_Type)); 5376 while Present (Comp) loop 5377 if Chars (Comp) = Chars (Sel) 5378 and then Is_Visible_Component (Comp) 5379 then 5380 Set_Entity_With_Checks (Sel, Comp); 5381 Generate_Reference (Comp, Sel); 5382 Set_Etype (Sel, Etype (Comp)); 5383 Set_Etype (N, Etype (Comp)); 5384 5385 -- Emit appropriate message. The node will be replaced 5386 -- by an appropriate raise statement. 5387 5388 -- Note that in SPARK mode, as with all calls to apply a 5389 -- compile time constraint error, this will be made into 5390 -- an error to simplify the processing of the formal 5391 -- verification backend. 5392 5393 Apply_Compile_Time_Constraint_Error 5394 (N, "component not present in }??", 5395 CE_Discriminant_Check_Failed, 5396 Ent => Prefix_Type, Rep => False); 5397 5398 Set_Raises_Constraint_Error (N); 5399 return; 5400 end if; 5401 5402 Next_Component (Comp); 5403 end loop; 5404 5405 end if; 5406 5407 Error_Msg_Node_2 := First_Subtype (Prefix_Type); 5408 Error_Msg_NE ("no selector& for}", N, Sel); 5409 5410 -- Add information in the case of an incomplete prefix 5411 5412 if Is_Incomplete_Type (Type_To_Use) then 5413 declare 5414 Inc : constant Entity_Id := First_Subtype (Type_To_Use); 5415 5416 begin 5417 if From_Limited_With (Scope (Type_To_Use)) then 5418 Error_Msg_NE 5419 ("\limited view of& has no components", N, Inc); 5420 5421 else 5422 Error_Msg_NE 5423 ("\premature usage of incomplete type&", N, Inc); 5424 5425 if Nkind (Parent (Inc)) = 5426 N_Incomplete_Type_Declaration 5427 then 5428 -- Record location of premature use in entity so that 5429 -- a continuation message is generated when the 5430 -- completion is seen. 5431 5432 Set_Premature_Use (Parent (Inc), N); 5433 end if; 5434 end if; 5435 end; 5436 end if; 5437 5438 Check_Misspelled_Selector (Type_To_Use, Sel); 5439 end if; 5440 5441 Set_Entity (Sel, Any_Id); 5442 Set_Etype (Sel, Any_Type); 5443 end if; 5444 end Analyze_Selected_Component; 5445 5446 --------------------------- 5447 -- Analyze_Short_Circuit -- 5448 --------------------------- 5449 5450 procedure Analyze_Short_Circuit (N : Node_Id) is 5451 L : constant Node_Id := Left_Opnd (N); 5452 R : constant Node_Id := Right_Opnd (N); 5453 Ind : Interp_Index; 5454 It : Interp; 5455 5456 begin 5457 Analyze_Expression (L); 5458 Analyze_Expression (R); 5459 Set_Etype (N, Any_Type); 5460 5461 if not Is_Overloaded (L) then 5462 if Root_Type (Etype (L)) = Standard_Boolean 5463 and then Has_Compatible_Type (R, Etype (L)) 5464 then 5465 Add_One_Interp (N, Etype (L), Etype (L)); 5466 end if; 5467 5468 else 5469 Get_First_Interp (L, Ind, It); 5470 while Present (It.Typ) loop 5471 if Root_Type (It.Typ) = Standard_Boolean 5472 and then Has_Compatible_Type (R, It.Typ) 5473 then 5474 Add_One_Interp (N, It.Typ, It.Typ); 5475 end if; 5476 5477 Get_Next_Interp (Ind, It); 5478 end loop; 5479 end if; 5480 5481 -- Here we have failed to find an interpretation. Clearly we know that 5482 -- it is not the case that both operands can have an interpretation of 5483 -- Boolean, but this is by far the most likely intended interpretation. 5484 -- So we simply resolve both operands as Booleans, and at least one of 5485 -- these resolutions will generate an error message, and we do not need 5486 -- to give another error message on the short circuit operation itself. 5487 5488 if Etype (N) = Any_Type then 5489 Resolve (L, Standard_Boolean); 5490 Resolve (R, Standard_Boolean); 5491 Set_Etype (N, Standard_Boolean); 5492 end if; 5493 end Analyze_Short_Circuit; 5494 5495 ------------------- 5496 -- Analyze_Slice -- 5497 ------------------- 5498 5499 procedure Analyze_Slice (N : Node_Id) is 5500 D : constant Node_Id := Discrete_Range (N); 5501 P : constant Node_Id := Prefix (N); 5502 Array_Type : Entity_Id; 5503 Index_Type : Entity_Id; 5504 5505 procedure Analyze_Overloaded_Slice; 5506 -- If the prefix is overloaded, select those interpretations that 5507 -- yield a one-dimensional array type. 5508 5509 ------------------------------ 5510 -- Analyze_Overloaded_Slice -- 5511 ------------------------------ 5512 5513 procedure Analyze_Overloaded_Slice is 5514 I : Interp_Index; 5515 It : Interp; 5516 Typ : Entity_Id; 5517 5518 begin 5519 Set_Etype (N, Any_Type); 5520 5521 Get_First_Interp (P, I, It); 5522 while Present (It.Nam) loop 5523 Typ := It.Typ; 5524 5525 if Is_Access_Type (Typ) then 5526 Typ := Designated_Type (Typ); 5527 Error_Msg_NW 5528 (Warn_On_Dereference, "?d?implicit dereference", N); 5529 end if; 5530 5531 if Is_Array_Type (Typ) 5532 and then Number_Dimensions (Typ) = 1 5533 and then Has_Compatible_Type (D, Etype (First_Index (Typ))) 5534 then 5535 Add_One_Interp (N, Typ, Typ); 5536 end if; 5537 5538 Get_Next_Interp (I, It); 5539 end loop; 5540 5541 if Etype (N) = Any_Type then 5542 Error_Msg_N ("expect array type in prefix of slice", N); 5543 end if; 5544 end Analyze_Overloaded_Slice; 5545 5546 -- Start of processing for Analyze_Slice 5547 5548 begin 5549 if Comes_From_Source (N) then 5550 Check_SPARK_05_Restriction ("slice is not allowed", N); 5551 end if; 5552 5553 Analyze (P); 5554 Analyze (D); 5555 5556 if Is_Overloaded (P) then 5557 Analyze_Overloaded_Slice; 5558 5559 else 5560 Array_Type := Etype (P); 5561 Set_Etype (N, Any_Type); 5562 5563 if Is_Access_Type (Array_Type) then 5564 Array_Type := Designated_Type (Array_Type); 5565 Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N); 5566 end if; 5567 5568 if not Is_Array_Type (Array_Type) then 5569 Wrong_Type (P, Any_Array); 5570 5571 elsif Number_Dimensions (Array_Type) > 1 then 5572 Error_Msg_N 5573 ("type is not one-dimensional array in slice prefix", N); 5574 5575 else 5576 if Ekind (Array_Type) = E_String_Literal_Subtype then 5577 Index_Type := Etype (String_Literal_Low_Bound (Array_Type)); 5578 else 5579 Index_Type := Etype (First_Index (Array_Type)); 5580 end if; 5581 5582 if not Has_Compatible_Type (D, Index_Type) then 5583 Wrong_Type (D, Index_Type); 5584 else 5585 Set_Etype (N, Array_Type); 5586 end if; 5587 end if; 5588 end if; 5589 end Analyze_Slice; 5590 5591 ----------------------------- 5592 -- Analyze_Type_Conversion -- 5593 ----------------------------- 5594 5595 procedure Analyze_Type_Conversion (N : Node_Id) is 5596 Expr : constant Node_Id := Expression (N); 5597 Typ : Entity_Id; 5598 5599 begin 5600 -- If Conversion_OK is set, then the Etype is already set, and the only 5601 -- processing required is to analyze the expression. This is used to 5602 -- construct certain "illegal" conversions which are not allowed by Ada 5603 -- semantics, but can be handled by Gigi, see Sinfo for further details. 5604 5605 if Conversion_OK (N) then 5606 Analyze (Expr); 5607 return; 5608 end if; 5609 5610 -- Otherwise full type analysis is required, as well as some semantic 5611 -- checks to make sure the argument of the conversion is appropriate. 5612 5613 Find_Type (Subtype_Mark (N)); 5614 Typ := Entity (Subtype_Mark (N)); 5615 Set_Etype (N, Typ); 5616 Check_Fully_Declared (Typ, N); 5617 Analyze_Expression (Expr); 5618 Validate_Remote_Type_Type_Conversion (N); 5619 5620 -- Only remaining step is validity checks on the argument. These 5621 -- are skipped if the conversion does not come from the source. 5622 5623 if not Comes_From_Source (N) then 5624 return; 5625 5626 -- If there was an error in a generic unit, no need to replicate the 5627 -- error message. Conversely, constant-folding in the generic may 5628 -- transform the argument of a conversion into a string literal, which 5629 -- is legal. Therefore the following tests are not performed in an 5630 -- instance. The same applies to an inlined body. 5631 5632 elsif In_Instance or In_Inlined_Body then 5633 return; 5634 5635 elsif Nkind (Expr) = N_Null then 5636 Error_Msg_N ("argument of conversion cannot be null", N); 5637 Error_Msg_N ("\use qualified expression instead", N); 5638 Set_Etype (N, Any_Type); 5639 5640 elsif Nkind (Expr) = N_Aggregate then 5641 Error_Msg_N ("argument of conversion cannot be aggregate", N); 5642 Error_Msg_N ("\use qualified expression instead", N); 5643 5644 elsif Nkind (Expr) = N_Allocator then 5645 Error_Msg_N ("argument of conversion cannot be an allocator", N); 5646 Error_Msg_N ("\use qualified expression instead", N); 5647 5648 elsif Nkind (Expr) = N_String_Literal then 5649 Error_Msg_N ("argument of conversion cannot be string literal", N); 5650 Error_Msg_N ("\use qualified expression instead", N); 5651 5652 elsif Nkind (Expr) = N_Character_Literal then 5653 if Ada_Version = Ada_83 then 5654 Resolve (Expr, Typ); 5655 else 5656 Error_Msg_N ("argument of conversion cannot be character literal", 5657 N); 5658 Error_Msg_N ("\use qualified expression instead", N); 5659 end if; 5660 5661 elsif Nkind (Expr) = N_Attribute_Reference 5662 and then Nam_In (Attribute_Name (Expr), Name_Access, 5663 Name_Unchecked_Access, 5664 Name_Unrestricted_Access) 5665 then 5666 Error_Msg_N ("argument of conversion cannot be access", N); 5667 Error_Msg_N ("\use qualified expression instead", N); 5668 end if; 5669 5670 -- A formal parameter of a specific tagged type whose related subprogram 5671 -- is subject to pragma Extensions_Visible with value "False" cannot 5672 -- appear in a class-wide conversion (SPARK RM 6.1.7(3)). Do not check 5673 -- internally generated expressions. 5674 5675 if Is_Class_Wide_Type (Typ) 5676 and then Comes_From_Source (Expr) 5677 and then Is_EVF_Expression (Expr) 5678 then 5679 Error_Msg_N 5680 ("formal parameter cannot be converted to class-wide type when " 5681 & "Extensions_Visible is False", Expr); 5682 end if; 5683 end Analyze_Type_Conversion; 5684 5685 ---------------------- 5686 -- Analyze_Unary_Op -- 5687 ---------------------- 5688 5689 procedure Analyze_Unary_Op (N : Node_Id) is 5690 R : constant Node_Id := Right_Opnd (N); 5691 Op_Id : Entity_Id := Entity (N); 5692 5693 begin 5694 Set_Etype (N, Any_Type); 5695 Candidate_Type := Empty; 5696 5697 Analyze_Expression (R); 5698 5699 if Present (Op_Id) then 5700 if Ekind (Op_Id) = E_Operator then 5701 Find_Unary_Types (R, Op_Id, N); 5702 else 5703 Add_One_Interp (N, Op_Id, Etype (Op_Id)); 5704 end if; 5705 5706 else 5707 Op_Id := Get_Name_Entity_Id (Chars (N)); 5708 while Present (Op_Id) loop 5709 if Ekind (Op_Id) = E_Operator then 5710 if No (Next_Entity (First_Entity (Op_Id))) then 5711 Find_Unary_Types (R, Op_Id, N); 5712 end if; 5713 5714 elsif Is_Overloadable (Op_Id) then 5715 Analyze_User_Defined_Unary_Op (N, Op_Id); 5716 end if; 5717 5718 Op_Id := Homonym (Op_Id); 5719 end loop; 5720 end if; 5721 5722 Operator_Check (N); 5723 end Analyze_Unary_Op; 5724 5725 ---------------------------------- 5726 -- Analyze_Unchecked_Expression -- 5727 ---------------------------------- 5728 5729 procedure Analyze_Unchecked_Expression (N : Node_Id) is 5730 begin 5731 Analyze (Expression (N), Suppress => All_Checks); 5732 Set_Etype (N, Etype (Expression (N))); 5733 Save_Interps (Expression (N), N); 5734 end Analyze_Unchecked_Expression; 5735 5736 --------------------------------------- 5737 -- Analyze_Unchecked_Type_Conversion -- 5738 --------------------------------------- 5739 5740 procedure Analyze_Unchecked_Type_Conversion (N : Node_Id) is 5741 begin 5742 Find_Type (Subtype_Mark (N)); 5743 Analyze_Expression (Expression (N)); 5744 Set_Etype (N, Entity (Subtype_Mark (N))); 5745 end Analyze_Unchecked_Type_Conversion; 5746 5747 ------------------------------------ 5748 -- Analyze_User_Defined_Binary_Op -- 5749 ------------------------------------ 5750 5751 procedure Analyze_User_Defined_Binary_Op 5752 (N : Node_Id; 5753 Op_Id : Entity_Id) 5754 is 5755 begin 5756 -- Only do analysis if the operator Comes_From_Source, since otherwise 5757 -- the operator was generated by the expander, and all such operators 5758 -- always refer to the operators in package Standard. 5759 5760 if Comes_From_Source (N) then 5761 declare 5762 F1 : constant Entity_Id := First_Formal (Op_Id); 5763 F2 : constant Entity_Id := Next_Formal (F1); 5764 5765 begin 5766 -- Verify that Op_Id is a visible binary function. Note that since 5767 -- we know Op_Id is overloaded, potentially use visible means use 5768 -- visible for sure (RM 9.4(11)). 5769 5770 if Ekind (Op_Id) = E_Function 5771 and then Present (F2) 5772 and then (Is_Immediately_Visible (Op_Id) 5773 or else Is_Potentially_Use_Visible (Op_Id)) 5774 and then Has_Compatible_Type (Left_Opnd (N), Etype (F1)) 5775 and then Has_Compatible_Type (Right_Opnd (N), Etype (F2)) 5776 then 5777 Add_One_Interp (N, Op_Id, Etype (Op_Id)); 5778 5779 -- If the left operand is overloaded, indicate that the current 5780 -- type is a viable candidate. This is redundant in most cases, 5781 -- but for equality and comparison operators where the context 5782 -- does not impose a type on the operands, setting the proper 5783 -- type is necessary to avoid subsequent ambiguities during 5784 -- resolution, when both user-defined and predefined operators 5785 -- may be candidates. 5786 5787 if Is_Overloaded (Left_Opnd (N)) then 5788 Set_Etype (Left_Opnd (N), Etype (F1)); 5789 end if; 5790 5791 if Debug_Flag_E then 5792 Write_Str ("user defined operator "); 5793 Write_Name (Chars (Op_Id)); 5794 Write_Str (" on node "); 5795 Write_Int (Int (N)); 5796 Write_Eol; 5797 end if; 5798 end if; 5799 end; 5800 end if; 5801 end Analyze_User_Defined_Binary_Op; 5802 5803 ----------------------------------- 5804 -- Analyze_User_Defined_Unary_Op -- 5805 ----------------------------------- 5806 5807 procedure Analyze_User_Defined_Unary_Op 5808 (N : Node_Id; 5809 Op_Id : Entity_Id) 5810 is 5811 begin 5812 -- Only do analysis if the operator Comes_From_Source, since otherwise 5813 -- the operator was generated by the expander, and all such operators 5814 -- always refer to the operators in package Standard. 5815 5816 if Comes_From_Source (N) then 5817 declare 5818 F : constant Entity_Id := First_Formal (Op_Id); 5819 5820 begin 5821 -- Verify that Op_Id is a visible unary function. Note that since 5822 -- we know Op_Id is overloaded, potentially use visible means use 5823 -- visible for sure (RM 9.4(11)). 5824 5825 if Ekind (Op_Id) = E_Function 5826 and then No (Next_Formal (F)) 5827 and then (Is_Immediately_Visible (Op_Id) 5828 or else Is_Potentially_Use_Visible (Op_Id)) 5829 and then Has_Compatible_Type (Right_Opnd (N), Etype (F)) 5830 then 5831 Add_One_Interp (N, Op_Id, Etype (Op_Id)); 5832 end if; 5833 end; 5834 end if; 5835 end Analyze_User_Defined_Unary_Op; 5836 5837 --------------------------- 5838 -- Check_Arithmetic_Pair -- 5839 --------------------------- 5840 5841 procedure Check_Arithmetic_Pair 5842 (T1, T2 : Entity_Id; 5843 Op_Id : Entity_Id; 5844 N : Node_Id) 5845 is 5846 Op_Name : constant Name_Id := Chars (Op_Id); 5847 5848 function Has_Fixed_Op (Typ : Entity_Id; Op : Entity_Id) return Boolean; 5849 -- Check whether the fixed-point type Typ has a user-defined operator 5850 -- (multiplication or division) that should hide the corresponding 5851 -- predefined operator. Used to implement Ada 2005 AI-264, to make 5852 -- such operators more visible and therefore useful. 5853 -- 5854 -- If the name of the operation is an expanded name with prefix 5855 -- Standard, the predefined universal fixed operator is available, 5856 -- as specified by AI-420 (RM 4.5.5 (19.1/2)). 5857 5858 function Specific_Type (T1, T2 : Entity_Id) return Entity_Id; 5859 -- Get specific type (i.e. non-universal type if there is one) 5860 5861 ------------------ 5862 -- Has_Fixed_Op -- 5863 ------------------ 5864 5865 function Has_Fixed_Op (Typ : Entity_Id; Op : Entity_Id) return Boolean is 5866 Bas : constant Entity_Id := Base_Type (Typ); 5867 Ent : Entity_Id; 5868 F1 : Entity_Id; 5869 F2 : Entity_Id; 5870 5871 begin 5872 -- If the universal_fixed operation is given explicitly the rule 5873 -- concerning primitive operations of the type do not apply. 5874 5875 if Nkind (N) = N_Function_Call 5876 and then Nkind (Name (N)) = N_Expanded_Name 5877 and then Entity (Prefix (Name (N))) = Standard_Standard 5878 then 5879 return False; 5880 end if; 5881 5882 -- The operation is treated as primitive if it is declared in the 5883 -- same scope as the type, and therefore on the same entity chain. 5884 5885 Ent := Next_Entity (Typ); 5886 while Present (Ent) loop 5887 if Chars (Ent) = Chars (Op) then 5888 F1 := First_Formal (Ent); 5889 F2 := Next_Formal (F1); 5890 5891 -- The operation counts as primitive if either operand or 5892 -- result are of the given base type, and both operands are 5893 -- fixed point types. 5894 5895 if (Base_Type (Etype (F1)) = Bas 5896 and then Is_Fixed_Point_Type (Etype (F2))) 5897 5898 or else 5899 (Base_Type (Etype (F2)) = Bas 5900 and then Is_Fixed_Point_Type (Etype (F1))) 5901 5902 or else 5903 (Base_Type (Etype (Ent)) = Bas 5904 and then Is_Fixed_Point_Type (Etype (F1)) 5905 and then Is_Fixed_Point_Type (Etype (F2))) 5906 then 5907 return True; 5908 end if; 5909 end if; 5910 5911 Next_Entity (Ent); 5912 end loop; 5913 5914 return False; 5915 end Has_Fixed_Op; 5916 5917 ------------------- 5918 -- Specific_Type -- 5919 ------------------- 5920 5921 function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is 5922 begin 5923 if T1 = Universal_Integer or else T1 = Universal_Real then 5924 return Base_Type (T2); 5925 else 5926 return Base_Type (T1); 5927 end if; 5928 end Specific_Type; 5929 5930 -- Start of processing for Check_Arithmetic_Pair 5931 5932 begin 5933 if Nam_In (Op_Name, Name_Op_Add, Name_Op_Subtract) then 5934 if Is_Numeric_Type (T1) 5935 and then Is_Numeric_Type (T2) 5936 and then (Covers (T1 => T1, T2 => T2) 5937 or else 5938 Covers (T1 => T2, T2 => T1)) 5939 then 5940 Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); 5941 end if; 5942 5943 elsif Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide) then 5944 if Is_Fixed_Point_Type (T1) 5945 and then (Is_Fixed_Point_Type (T2) or else T2 = Universal_Real) 5946 then 5947 -- If Treat_Fixed_As_Integer is set then the Etype is already set 5948 -- and no further processing is required (this is the case of an 5949 -- operator constructed by Exp_Fixd for a fixed point operation) 5950 -- Otherwise add one interpretation with universal fixed result 5951 -- If the operator is given in functional notation, it comes 5952 -- from source and Fixed_As_Integer cannot apply. 5953 5954 if (Nkind (N) not in N_Op 5955 or else not Treat_Fixed_As_Integer (N)) 5956 and then 5957 (not Has_Fixed_Op (T1, Op_Id) 5958 or else Nkind (Parent (N)) = N_Type_Conversion) 5959 then 5960 Add_One_Interp (N, Op_Id, Universal_Fixed); 5961 end if; 5962 5963 elsif Is_Fixed_Point_Type (T2) 5964 and then (Nkind (N) not in N_Op 5965 or else not Treat_Fixed_As_Integer (N)) 5966 and then T1 = Universal_Real 5967 and then 5968 (not Has_Fixed_Op (T1, Op_Id) 5969 or else Nkind (Parent (N)) = N_Type_Conversion) 5970 then 5971 Add_One_Interp (N, Op_Id, Universal_Fixed); 5972 5973 elsif Is_Numeric_Type (T1) 5974 and then Is_Numeric_Type (T2) 5975 and then (Covers (T1 => T1, T2 => T2) 5976 or else 5977 Covers (T1 => T2, T2 => T1)) 5978 then 5979 Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); 5980 5981 elsif Is_Fixed_Point_Type (T1) 5982 and then (Base_Type (T2) = Base_Type (Standard_Integer) 5983 or else T2 = Universal_Integer) 5984 then 5985 Add_One_Interp (N, Op_Id, T1); 5986 5987 elsif T2 = Universal_Real 5988 and then Base_Type (T1) = Base_Type (Standard_Integer) 5989 and then Op_Name = Name_Op_Multiply 5990 then 5991 Add_One_Interp (N, Op_Id, Any_Fixed); 5992 5993 elsif T1 = Universal_Real 5994 and then Base_Type (T2) = Base_Type (Standard_Integer) 5995 then 5996 Add_One_Interp (N, Op_Id, Any_Fixed); 5997 5998 elsif Is_Fixed_Point_Type (T2) 5999 and then (Base_Type (T1) = Base_Type (Standard_Integer) 6000 or else T1 = Universal_Integer) 6001 and then Op_Name = Name_Op_Multiply 6002 then 6003 Add_One_Interp (N, Op_Id, T2); 6004 6005 elsif T1 = Universal_Real and then T2 = Universal_Integer then 6006 Add_One_Interp (N, Op_Id, T1); 6007 6008 elsif T2 = Universal_Real 6009 and then T1 = Universal_Integer 6010 and then Op_Name = Name_Op_Multiply 6011 then 6012 Add_One_Interp (N, Op_Id, T2); 6013 end if; 6014 6015 elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then 6016 6017 -- Note: The fixed-point operands case with Treat_Fixed_As_Integer 6018 -- set does not require any special processing, since the Etype is 6019 -- already set (case of operation constructed by Exp_Fixed). 6020 6021 if Is_Integer_Type (T1) 6022 and then (Covers (T1 => T1, T2 => T2) 6023 or else 6024 Covers (T1 => T2, T2 => T1)) 6025 then 6026 Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); 6027 end if; 6028 6029 elsif Op_Name = Name_Op_Expon then 6030 if Is_Numeric_Type (T1) 6031 and then not Is_Fixed_Point_Type (T1) 6032 and then (Base_Type (T2) = Base_Type (Standard_Integer) 6033 or else T2 = Universal_Integer) 6034 then 6035 Add_One_Interp (N, Op_Id, Base_Type (T1)); 6036 end if; 6037 6038 else pragma Assert (Nkind (N) in N_Op_Shift); 6039 6040 -- If not one of the predefined operators, the node may be one 6041 -- of the intrinsic functions. Its kind is always specific, and 6042 -- we can use it directly, rather than the name of the operation. 6043 6044 if Is_Integer_Type (T1) 6045 and then (Base_Type (T2) = Base_Type (Standard_Integer) 6046 or else T2 = Universal_Integer) 6047 then 6048 Add_One_Interp (N, Op_Id, Base_Type (T1)); 6049 end if; 6050 end if; 6051 end Check_Arithmetic_Pair; 6052 6053 ------------------------------- 6054 -- Check_Misspelled_Selector -- 6055 ------------------------------- 6056 6057 procedure Check_Misspelled_Selector 6058 (Prefix : Entity_Id; 6059 Sel : Node_Id) 6060 is 6061 Max_Suggestions : constant := 2; 6062 Nr_Of_Suggestions : Natural := 0; 6063 6064 Suggestion_1 : Entity_Id := Empty; 6065 Suggestion_2 : Entity_Id := Empty; 6066 6067 Comp : Entity_Id; 6068 6069 begin 6070 -- All the components of the prefix of selector Sel are matched against 6071 -- Sel and a count is maintained of possible misspellings. When at 6072 -- the end of the analysis there are one or two (not more) possible 6073 -- misspellings, these misspellings will be suggested as possible 6074 -- correction. 6075 6076 if not (Is_Private_Type (Prefix) or else Is_Record_Type (Prefix)) then 6077 6078 -- Concurrent types should be handled as well ??? 6079 6080 return; 6081 end if; 6082 6083 Comp := First_Entity (Prefix); 6084 while Nr_Of_Suggestions <= Max_Suggestions and then Present (Comp) loop 6085 if Is_Visible_Component (Comp) then 6086 if Is_Bad_Spelling_Of (Chars (Comp), Chars (Sel)) then 6087 Nr_Of_Suggestions := Nr_Of_Suggestions + 1; 6088 6089 case Nr_Of_Suggestions is 6090 when 1 => Suggestion_1 := Comp; 6091 when 2 => Suggestion_2 := Comp; 6092 when others => null; 6093 end case; 6094 end if; 6095 end if; 6096 6097 Comp := Next_Entity (Comp); 6098 end loop; 6099 6100 -- Report at most two suggestions 6101 6102 if Nr_Of_Suggestions = 1 then 6103 Error_Msg_NE -- CODEFIX 6104 ("\possible misspelling of&", Sel, Suggestion_1); 6105 6106 elsif Nr_Of_Suggestions = 2 then 6107 Error_Msg_Node_2 := Suggestion_2; 6108 Error_Msg_NE -- CODEFIX 6109 ("\possible misspelling of& or&", Sel, Suggestion_1); 6110 end if; 6111 end Check_Misspelled_Selector; 6112 6113 ---------------------- 6114 -- Defined_In_Scope -- 6115 ---------------------- 6116 6117 function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean 6118 is 6119 S1 : constant Entity_Id := Scope (Base_Type (T)); 6120 begin 6121 return S1 = S 6122 or else (S1 = System_Aux_Id and then S = Scope (S1)); 6123 end Defined_In_Scope; 6124 6125 ------------------- 6126 -- Diagnose_Call -- 6127 ------------------- 6128 6129 procedure Diagnose_Call (N : Node_Id; Nam : Node_Id) is 6130 Actual : Node_Id; 6131 X : Interp_Index; 6132 It : Interp; 6133 Err_Mode : Boolean; 6134 New_Nam : Node_Id; 6135 Void_Interp_Seen : Boolean := False; 6136 6137 Success : Boolean; 6138 pragma Warnings (Off, Boolean); 6139 6140 begin 6141 if Ada_Version >= Ada_2005 then 6142 Actual := First_Actual (N); 6143 while Present (Actual) loop 6144 6145 -- Ada 2005 (AI-50217): Post an error in case of premature 6146 -- usage of an entity from the limited view. 6147 6148 if not Analyzed (Etype (Actual)) 6149 and then From_Limited_With (Etype (Actual)) 6150 then 6151 Error_Msg_Qual_Level := 1; 6152 Error_Msg_NE 6153 ("missing with_clause for scope of imported type&", 6154 Actual, Etype (Actual)); 6155 Error_Msg_Qual_Level := 0; 6156 end if; 6157 6158 Next_Actual (Actual); 6159 end loop; 6160 end if; 6161 6162 -- Before listing the possible candidates, check whether this is 6163 -- a prefix of a selected component that has been rewritten as a 6164 -- parameterless function call because there is a callable candidate 6165 -- interpretation. If there is a hidden package in the list of homonyms 6166 -- of the function name (bad programming style in any case) suggest that 6167 -- this is the intended entity. 6168 6169 if No (Parameter_Associations (N)) 6170 and then Nkind (Parent (N)) = N_Selected_Component 6171 and then Nkind (Parent (Parent (N))) in N_Declaration 6172 and then Is_Overloaded (Nam) 6173 then 6174 declare 6175 Ent : Entity_Id; 6176 6177 begin 6178 Ent := Current_Entity (Nam); 6179 while Present (Ent) loop 6180 if Ekind (Ent) = E_Package then 6181 Error_Msg_N 6182 ("no legal interpretations as function call,!", Nam); 6183 Error_Msg_NE ("\package& is not visible", N, Ent); 6184 6185 Rewrite (Parent (N), 6186 New_Occurrence_Of (Any_Type, Sloc (N))); 6187 return; 6188 end if; 6189 6190 Ent := Homonym (Ent); 6191 end loop; 6192 end; 6193 end if; 6194 6195 -- Analyze each candidate call again, with full error reporting for 6196 -- each. 6197 6198 Error_Msg_N 6199 ("no candidate interpretations match the actuals:!", Nam); 6200 Err_Mode := All_Errors_Mode; 6201 All_Errors_Mode := True; 6202 6203 -- If this is a call to an operation of a concurrent type, 6204 -- the failed interpretations have been removed from the 6205 -- name. Recover them to provide full diagnostics. 6206 6207 if Nkind (Parent (Nam)) = N_Selected_Component then 6208 Set_Entity (Nam, Empty); 6209 New_Nam := New_Copy_Tree (Parent (Nam)); 6210 Set_Is_Overloaded (New_Nam, False); 6211 Set_Is_Overloaded (Selector_Name (New_Nam), False); 6212 Set_Parent (New_Nam, Parent (Parent (Nam))); 6213 Analyze_Selected_Component (New_Nam); 6214 Get_First_Interp (Selector_Name (New_Nam), X, It); 6215 else 6216 Get_First_Interp (Nam, X, It); 6217 end if; 6218 6219 while Present (It.Nam) loop 6220 if Etype (It.Nam) = Standard_Void_Type then 6221 Void_Interp_Seen := True; 6222 end if; 6223 6224 Analyze_One_Call (N, It.Nam, True, Success); 6225 Get_Next_Interp (X, It); 6226 end loop; 6227 6228 if Nkind (N) = N_Function_Call then 6229 Get_First_Interp (Nam, X, It); 6230 while Present (It.Nam) loop 6231 if Ekind_In (It.Nam, E_Function, E_Operator) then 6232 return; 6233 else 6234 Get_Next_Interp (X, It); 6235 end if; 6236 end loop; 6237 6238 -- If all interpretations are procedures, this deserves a 6239 -- more precise message. Ditto if this appears as the prefix 6240 -- of a selected component, which may be a lexical error. 6241 6242 Error_Msg_N 6243 ("\context requires function call, found procedure name", Nam); 6244 6245 if Nkind (Parent (N)) = N_Selected_Component 6246 and then N = Prefix (Parent (N)) 6247 then 6248 Error_Msg_N -- CODEFIX 6249 ("\period should probably be semicolon", Parent (N)); 6250 end if; 6251 6252 elsif Nkind (N) = N_Procedure_Call_Statement 6253 and then not Void_Interp_Seen 6254 then 6255 Error_Msg_N ( 6256 "\function name found in procedure call", Nam); 6257 end if; 6258 6259 All_Errors_Mode := Err_Mode; 6260 end Diagnose_Call; 6261 6262 --------------------------- 6263 -- Find_Arithmetic_Types -- 6264 --------------------------- 6265 6266 procedure Find_Arithmetic_Types 6267 (L, R : Node_Id; 6268 Op_Id : Entity_Id; 6269 N : Node_Id) 6270 is 6271 Index1 : Interp_Index; 6272 Index2 : Interp_Index; 6273 It1 : Interp; 6274 It2 : Interp; 6275 6276 procedure Check_Right_Argument (T : Entity_Id); 6277 -- Check right operand of operator 6278 6279 -------------------------- 6280 -- Check_Right_Argument -- 6281 -------------------------- 6282 6283 procedure Check_Right_Argument (T : Entity_Id) is 6284 begin 6285 if not Is_Overloaded (R) then 6286 Check_Arithmetic_Pair (T, Etype (R), Op_Id, N); 6287 else 6288 Get_First_Interp (R, Index2, It2); 6289 while Present (It2.Typ) loop 6290 Check_Arithmetic_Pair (T, It2.Typ, Op_Id, N); 6291 Get_Next_Interp (Index2, It2); 6292 end loop; 6293 end if; 6294 end Check_Right_Argument; 6295 6296 -- Start of processing for Find_Arithmetic_Types 6297 6298 begin 6299 if not Is_Overloaded (L) then 6300 Check_Right_Argument (Etype (L)); 6301 6302 else 6303 Get_First_Interp (L, Index1, It1); 6304 while Present (It1.Typ) loop 6305 Check_Right_Argument (It1.Typ); 6306 Get_Next_Interp (Index1, It1); 6307 end loop; 6308 end if; 6309 6310 end Find_Arithmetic_Types; 6311 6312 ------------------------ 6313 -- Find_Boolean_Types -- 6314 ------------------------ 6315 6316 procedure Find_Boolean_Types 6317 (L, R : Node_Id; 6318 Op_Id : Entity_Id; 6319 N : Node_Id) 6320 is 6321 Index : Interp_Index; 6322 It : Interp; 6323 6324 procedure Check_Numeric_Argument (T : Entity_Id); 6325 -- Special case for logical operations one of whose operands is an 6326 -- integer literal. If both are literal the result is any modular type. 6327 6328 ---------------------------- 6329 -- Check_Numeric_Argument -- 6330 ---------------------------- 6331 6332 procedure Check_Numeric_Argument (T : Entity_Id) is 6333 begin 6334 if T = Universal_Integer then 6335 Add_One_Interp (N, Op_Id, Any_Modular); 6336 6337 elsif Is_Modular_Integer_Type (T) then 6338 Add_One_Interp (N, Op_Id, T); 6339 end if; 6340 end Check_Numeric_Argument; 6341 6342 -- Start of processing for Find_Boolean_Types 6343 6344 begin 6345 if not Is_Overloaded (L) then 6346 if Etype (L) = Universal_Integer 6347 or else Etype (L) = Any_Modular 6348 then 6349 if not Is_Overloaded (R) then 6350 Check_Numeric_Argument (Etype (R)); 6351 6352 else 6353 Get_First_Interp (R, Index, It); 6354 while Present (It.Typ) loop 6355 Check_Numeric_Argument (It.Typ); 6356 Get_Next_Interp (Index, It); 6357 end loop; 6358 end if; 6359 6360 -- If operands are aggregates, we must assume that they may be 6361 -- boolean arrays, and leave disambiguation for the second pass. 6362 -- If only one is an aggregate, verify that the other one has an 6363 -- interpretation as a boolean array 6364 6365 elsif Nkind (L) = N_Aggregate then 6366 if Nkind (R) = N_Aggregate then 6367 Add_One_Interp (N, Op_Id, Etype (L)); 6368 6369 elsif not Is_Overloaded (R) then 6370 if Valid_Boolean_Arg (Etype (R)) then 6371 Add_One_Interp (N, Op_Id, Etype (R)); 6372 end if; 6373 6374 else 6375 Get_First_Interp (R, Index, It); 6376 while Present (It.Typ) loop 6377 if Valid_Boolean_Arg (It.Typ) then 6378 Add_One_Interp (N, Op_Id, It.Typ); 6379 end if; 6380 6381 Get_Next_Interp (Index, It); 6382 end loop; 6383 end if; 6384 6385 elsif Valid_Boolean_Arg (Etype (L)) 6386 and then Has_Compatible_Type (R, Etype (L)) 6387 then 6388 Add_One_Interp (N, Op_Id, Etype (L)); 6389 end if; 6390 6391 else 6392 Get_First_Interp (L, Index, It); 6393 while Present (It.Typ) loop 6394 if Valid_Boolean_Arg (It.Typ) 6395 and then Has_Compatible_Type (R, It.Typ) 6396 then 6397 Add_One_Interp (N, Op_Id, It.Typ); 6398 end if; 6399 6400 Get_Next_Interp (Index, It); 6401 end loop; 6402 end if; 6403 end Find_Boolean_Types; 6404 6405 --------------------------- 6406 -- Find_Comparison_Types -- 6407 --------------------------- 6408 6409 procedure Find_Comparison_Types 6410 (L, R : Node_Id; 6411 Op_Id : Entity_Id; 6412 N : Node_Id) 6413 is 6414 Index : Interp_Index; 6415 It : Interp; 6416 Found : Boolean := False; 6417 I_F : Interp_Index; 6418 T_F : Entity_Id; 6419 Scop : Entity_Id := Empty; 6420 6421 procedure Try_One_Interp (T1 : Entity_Id); 6422 -- Routine to try one proposed interpretation. Note that the context 6423 -- of the operator plays no role in resolving the arguments, so that 6424 -- if there is more than one interpretation of the operands that is 6425 -- compatible with comparison, the operation is ambiguous. 6426 6427 -------------------- 6428 -- Try_One_Interp -- 6429 -------------------- 6430 6431 procedure Try_One_Interp (T1 : Entity_Id) is 6432 begin 6433 -- If the operator is an expanded name, then the type of the operand 6434 -- must be defined in the corresponding scope. If the type is 6435 -- universal, the context will impose the correct type. Note that we 6436 -- also avoid returning if we are currently within a generic instance 6437 -- due to the fact that the generic package declaration has already 6438 -- been successfully analyzed and Defined_In_Scope expects the base 6439 -- type to be defined within the instance which will never be the 6440 -- case. 6441 6442 if Present (Scop) 6443 and then not Defined_In_Scope (T1, Scop) 6444 and then not In_Instance 6445 and then T1 /= Universal_Integer 6446 and then T1 /= Universal_Real 6447 and then T1 /= Any_String 6448 and then T1 /= Any_Composite 6449 then 6450 return; 6451 end if; 6452 6453 if Valid_Comparison_Arg (T1) and then Has_Compatible_Type (R, T1) then 6454 if Found and then Base_Type (T1) /= Base_Type (T_F) then 6455 It := Disambiguate (L, I_F, Index, Any_Type); 6456 6457 if It = No_Interp then 6458 Ambiguous_Operands (N); 6459 Set_Etype (L, Any_Type); 6460 return; 6461 6462 else 6463 T_F := It.Typ; 6464 end if; 6465 else 6466 Found := True; 6467 T_F := T1; 6468 I_F := Index; 6469 end if; 6470 6471 Set_Etype (L, T_F); 6472 Find_Non_Universal_Interpretations (N, R, Op_Id, T1); 6473 end if; 6474 end Try_One_Interp; 6475 6476 -- Start of processing for Find_Comparison_Types 6477 6478 begin 6479 -- If left operand is aggregate, the right operand has to 6480 -- provide a usable type for it. 6481 6482 if Nkind (L) = N_Aggregate and then Nkind (R) /= N_Aggregate then 6483 Find_Comparison_Types (L => R, R => L, Op_Id => Op_Id, N => N); 6484 return; 6485 end if; 6486 6487 if Nkind (N) = N_Function_Call 6488 and then Nkind (Name (N)) = N_Expanded_Name 6489 then 6490 Scop := Entity (Prefix (Name (N))); 6491 6492 -- The prefix may be a package renaming, and the subsequent test 6493 -- requires the original package. 6494 6495 if Ekind (Scop) = E_Package 6496 and then Present (Renamed_Entity (Scop)) 6497 then 6498 Scop := Renamed_Entity (Scop); 6499 Set_Entity (Prefix (Name (N)), Scop); 6500 end if; 6501 end if; 6502 6503 if not Is_Overloaded (L) then 6504 Try_One_Interp (Etype (L)); 6505 6506 else 6507 Get_First_Interp (L, Index, It); 6508 while Present (It.Typ) loop 6509 Try_One_Interp (It.Typ); 6510 Get_Next_Interp (Index, It); 6511 end loop; 6512 end if; 6513 end Find_Comparison_Types; 6514 6515 ---------------------------------------- 6516 -- Find_Non_Universal_Interpretations -- 6517 ---------------------------------------- 6518 6519 procedure Find_Non_Universal_Interpretations 6520 (N : Node_Id; 6521 R : Node_Id; 6522 Op_Id : Entity_Id; 6523 T1 : Entity_Id) 6524 is 6525 Index : Interp_Index; 6526 It : Interp; 6527 6528 begin 6529 if T1 = Universal_Integer or else T1 = Universal_Real 6530 6531 -- If the left operand of an equality operator is null, the visibility 6532 -- of the operator must be determined from the interpretation of the 6533 -- right operand. This processing must be done for Any_Access, which 6534 -- is the internal representation of the type of the literal null. 6535 6536 or else T1 = Any_Access 6537 then 6538 if not Is_Overloaded (R) then 6539 Add_One_Interp (N, Op_Id, Standard_Boolean, Base_Type (Etype (R))); 6540 else 6541 Get_First_Interp (R, Index, It); 6542 while Present (It.Typ) loop 6543 if Covers (It.Typ, T1) then 6544 Add_One_Interp 6545 (N, Op_Id, Standard_Boolean, Base_Type (It.Typ)); 6546 end if; 6547 6548 Get_Next_Interp (Index, It); 6549 end loop; 6550 end if; 6551 else 6552 Add_One_Interp (N, Op_Id, Standard_Boolean, Base_Type (T1)); 6553 end if; 6554 end Find_Non_Universal_Interpretations; 6555 6556 ------------------------------ 6557 -- Find_Concatenation_Types -- 6558 ------------------------------ 6559 6560 procedure Find_Concatenation_Types 6561 (L, R : Node_Id; 6562 Op_Id : Entity_Id; 6563 N : Node_Id) 6564 is 6565 Is_String : constant Boolean := Nkind (L) = N_String_Literal 6566 or else 6567 Nkind (R) = N_String_Literal; 6568 Op_Type : constant Entity_Id := Etype (Op_Id); 6569 6570 begin 6571 if Is_Array_Type (Op_Type) 6572 6573 -- Small but very effective optimization: if at least one operand is a 6574 -- string literal, then the type of the operator must be either array 6575 -- of characters or array of strings. 6576 6577 and then (not Is_String 6578 or else 6579 Is_Character_Type (Component_Type (Op_Type)) 6580 or else 6581 Is_String_Type (Component_Type (Op_Type))) 6582 6583 and then not Is_Limited_Type (Op_Type) 6584 6585 and then (Has_Compatible_Type (L, Op_Type) 6586 or else 6587 Has_Compatible_Type (L, Component_Type (Op_Type))) 6588 6589 and then (Has_Compatible_Type (R, Op_Type) 6590 or else 6591 Has_Compatible_Type (R, Component_Type (Op_Type))) 6592 then 6593 Add_One_Interp (N, Op_Id, Op_Type); 6594 end if; 6595 end Find_Concatenation_Types; 6596 6597 ------------------------- 6598 -- Find_Equality_Types -- 6599 ------------------------- 6600 6601 procedure Find_Equality_Types 6602 (L, R : Node_Id; 6603 Op_Id : Entity_Id; 6604 N : Node_Id) 6605 is 6606 Index : Interp_Index; 6607 It : Interp; 6608 Found : Boolean := False; 6609 I_F : Interp_Index; 6610 T_F : Entity_Id; 6611 Scop : Entity_Id := Empty; 6612 6613 procedure Try_One_Interp (T1 : Entity_Id); 6614 -- The context of the equality operator plays no role in resolving the 6615 -- arguments, so that if there is more than one interpretation of the 6616 -- operands that is compatible with equality, the construct is ambiguous 6617 -- and an error can be emitted now, after trying to disambiguate, i.e. 6618 -- applying preference rules. 6619 6620 -------------------- 6621 -- Try_One_Interp -- 6622 -------------------- 6623 6624 procedure Try_One_Interp (T1 : Entity_Id) is 6625 Bas : Entity_Id; 6626 6627 begin 6628 -- Perform a sanity check in case of previous errors 6629 6630 if No (T1) then 6631 return; 6632 end if; 6633 6634 Bas := Base_Type (T1); 6635 6636 -- If the operator is an expanded name, then the type of the operand 6637 -- must be defined in the corresponding scope. If the type is 6638 -- universal, the context will impose the correct type. An anonymous 6639 -- type for a 'Access reference is also universal in this sense, as 6640 -- the actual type is obtained from context. 6641 6642 -- In Ada 2005, the equality operator for anonymous access types 6643 -- is declared in Standard, and preference rules apply to it. 6644 6645 if Present (Scop) then 6646 6647 -- Note that we avoid returning if we are currently within a 6648 -- generic instance due to the fact that the generic package 6649 -- declaration has already been successfully analyzed and 6650 -- Defined_In_Scope expects the base type to be defined within 6651 -- the instance which will never be the case. 6652 6653 if Defined_In_Scope (T1, Scop) 6654 or else In_Instance 6655 or else T1 = Universal_Integer 6656 or else T1 = Universal_Real 6657 or else T1 = Any_Access 6658 or else T1 = Any_String 6659 or else T1 = Any_Composite 6660 or else (Ekind (T1) = E_Access_Subprogram_Type 6661 and then not Comes_From_Source (T1)) 6662 then 6663 null; 6664 6665 elsif Ekind (T1) = E_Anonymous_Access_Type 6666 and then Scop = Standard_Standard 6667 then 6668 null; 6669 6670 else 6671 -- The scope does not contain an operator for the type 6672 6673 return; 6674 end if; 6675 6676 -- If we have infix notation, the operator must be usable. Within 6677 -- an instance, if the type is already established we know it is 6678 -- correct. If an operand is universal it is compatible with any 6679 -- numeric type. 6680 6681 elsif In_Open_Scopes (Scope (Bas)) 6682 or else Is_Potentially_Use_Visible (Bas) 6683 or else In_Use (Bas) 6684 or else (In_Use (Scope (Bas)) and then not Is_Hidden (Bas)) 6685 6686 -- In an instance, the type may have been immediately visible. 6687 -- Either the types are compatible, or one operand is universal 6688 -- (numeric or null). 6689 6690 or else 6691 ((In_Instance or else In_Inlined_Body) 6692 and then 6693 (First_Subtype (T1) = First_Subtype (Etype (R)) 6694 or else Nkind (R) = N_Null 6695 or else 6696 (Is_Numeric_Type (T1) 6697 and then Is_Universal_Numeric_Type (Etype (R))))) 6698 6699 -- In Ada 2005, the equality on anonymous access types is declared 6700 -- in Standard, and is always visible. 6701 6702 or else Ekind (T1) = E_Anonymous_Access_Type 6703 then 6704 null; 6705 6706 else 6707 -- Save candidate type for subsequent error message, if any 6708 6709 if not Is_Limited_Type (T1) then 6710 Candidate_Type := T1; 6711 end if; 6712 6713 return; 6714 end if; 6715 6716 -- Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95: 6717 -- Do not allow anonymous access types in equality operators. 6718 6719 if Ada_Version < Ada_2005 6720 and then Ekind (T1) = E_Anonymous_Access_Type 6721 then 6722 return; 6723 end if; 6724 6725 -- If the right operand has a type compatible with T1, check for an 6726 -- acceptable interpretation, unless T1 is limited (no predefined 6727 -- equality available), or this is use of a "/=" for a tagged type. 6728 -- In the latter case, possible interpretations of equality need 6729 -- to be considered, we don't want the default inequality declared 6730 -- in Standard to be chosen, and the "/=" will be rewritten as a 6731 -- negation of "=" (see the end of Analyze_Equality_Op). This ensures 6732 -- that rewriting happens during analysis rather than being 6733 -- delayed until expansion (this is needed for ASIS, which only sees 6734 -- the unexpanded tree). Note that if the node is N_Op_Ne, but Op_Id 6735 -- is Name_Op_Eq then we still proceed with the interpretation, 6736 -- because that indicates the potential rewriting case where the 6737 -- interpretation to consider is actually "=" and the node may be 6738 -- about to be rewritten by Analyze_Equality_Op. 6739 6740 if T1 /= Standard_Void_Type 6741 and then Has_Compatible_Type (R, T1) 6742 6743 and then 6744 ((not Is_Limited_Type (T1) 6745 and then not Is_Limited_Composite (T1)) 6746 6747 or else 6748 (Is_Array_Type (T1) 6749 and then not Is_Limited_Type (Component_Type (T1)) 6750 and then Available_Full_View_Of_Component (T1))) 6751 6752 and then 6753 (Nkind (N) /= N_Op_Ne 6754 or else not Is_Tagged_Type (T1) 6755 or else Chars (Op_Id) = Name_Op_Eq) 6756 then 6757 if Found 6758 and then Base_Type (T1) /= Base_Type (T_F) 6759 then 6760 It := Disambiguate (L, I_F, Index, Any_Type); 6761 6762 if It = No_Interp then 6763 Ambiguous_Operands (N); 6764 Set_Etype (L, Any_Type); 6765 return; 6766 6767 else 6768 T_F := It.Typ; 6769 end if; 6770 6771 else 6772 Found := True; 6773 T_F := T1; 6774 I_F := Index; 6775 end if; 6776 6777 if not Analyzed (L) then 6778 Set_Etype (L, T_F); 6779 end if; 6780 6781 Find_Non_Universal_Interpretations (N, R, Op_Id, T1); 6782 6783 -- Case of operator was not visible, Etype still set to Any_Type 6784 6785 if Etype (N) = Any_Type then 6786 Found := False; 6787 end if; 6788 6789 elsif Scop = Standard_Standard 6790 and then Ekind (T1) = E_Anonymous_Access_Type 6791 then 6792 Found := True; 6793 end if; 6794 end Try_One_Interp; 6795 6796 -- Start of processing for Find_Equality_Types 6797 6798 begin 6799 -- If left operand is aggregate, the right operand has to 6800 -- provide a usable type for it. 6801 6802 if Nkind (L) = N_Aggregate 6803 and then Nkind (R) /= N_Aggregate 6804 then 6805 Find_Equality_Types (L => R, R => L, Op_Id => Op_Id, N => N); 6806 return; 6807 end if; 6808 6809 if Nkind (N) = N_Function_Call 6810 and then Nkind (Name (N)) = N_Expanded_Name 6811 then 6812 Scop := Entity (Prefix (Name (N))); 6813 6814 -- The prefix may be a package renaming, and the subsequent test 6815 -- requires the original package. 6816 6817 if Ekind (Scop) = E_Package 6818 and then Present (Renamed_Entity (Scop)) 6819 then 6820 Scop := Renamed_Entity (Scop); 6821 Set_Entity (Prefix (Name (N)), Scop); 6822 end if; 6823 end if; 6824 6825 if not Is_Overloaded (L) then 6826 Try_One_Interp (Etype (L)); 6827 6828 else 6829 Get_First_Interp (L, Index, It); 6830 while Present (It.Typ) loop 6831 Try_One_Interp (It.Typ); 6832 Get_Next_Interp (Index, It); 6833 end loop; 6834 end if; 6835 end Find_Equality_Types; 6836 6837 ------------------------- 6838 -- Find_Negation_Types -- 6839 ------------------------- 6840 6841 procedure Find_Negation_Types 6842 (R : Node_Id; 6843 Op_Id : Entity_Id; 6844 N : Node_Id) 6845 is 6846 Index : Interp_Index; 6847 It : Interp; 6848 6849 begin 6850 if not Is_Overloaded (R) then 6851 if Etype (R) = Universal_Integer then 6852 Add_One_Interp (N, Op_Id, Any_Modular); 6853 elsif Valid_Boolean_Arg (Etype (R)) then 6854 Add_One_Interp (N, Op_Id, Etype (R)); 6855 end if; 6856 6857 else 6858 Get_First_Interp (R, Index, It); 6859 while Present (It.Typ) loop 6860 if Valid_Boolean_Arg (It.Typ) then 6861 Add_One_Interp (N, Op_Id, It.Typ); 6862 end if; 6863 6864 Get_Next_Interp (Index, It); 6865 end loop; 6866 end if; 6867 end Find_Negation_Types; 6868 6869 ------------------------------ 6870 -- Find_Primitive_Operation -- 6871 ------------------------------ 6872 6873 function Find_Primitive_Operation (N : Node_Id) return Boolean is 6874 Obj : constant Node_Id := Prefix (N); 6875 Op : constant Node_Id := Selector_Name (N); 6876 6877 Prim : Elmt_Id; 6878 Prims : Elist_Id; 6879 Typ : Entity_Id; 6880 6881 begin 6882 Set_Etype (Op, Any_Type); 6883 6884 if Is_Access_Type (Etype (Obj)) then 6885 Typ := Designated_Type (Etype (Obj)); 6886 else 6887 Typ := Etype (Obj); 6888 end if; 6889 6890 if Is_Class_Wide_Type (Typ) then 6891 Typ := Root_Type (Typ); 6892 end if; 6893 6894 Prims := Primitive_Operations (Typ); 6895 6896 Prim := First_Elmt (Prims); 6897 while Present (Prim) loop 6898 if Chars (Node (Prim)) = Chars (Op) then 6899 Add_One_Interp (Op, Node (Prim), Etype (Node (Prim))); 6900 Set_Etype (N, Etype (Node (Prim))); 6901 end if; 6902 6903 Next_Elmt (Prim); 6904 end loop; 6905 6906 -- Now look for class-wide operations of the type or any of its 6907 -- ancestors by iterating over the homonyms of the selector. 6908 6909 declare 6910 Cls_Type : constant Entity_Id := Class_Wide_Type (Typ); 6911 Hom : Entity_Id; 6912 6913 begin 6914 Hom := Current_Entity (Op); 6915 while Present (Hom) loop 6916 if (Ekind (Hom) = E_Procedure 6917 or else 6918 Ekind (Hom) = E_Function) 6919 and then Scope (Hom) = Scope (Typ) 6920 and then Present (First_Formal (Hom)) 6921 and then 6922 (Base_Type (Etype (First_Formal (Hom))) = Cls_Type 6923 or else 6924 (Is_Access_Type (Etype (First_Formal (Hom))) 6925 and then 6926 Ekind (Etype (First_Formal (Hom))) = 6927 E_Anonymous_Access_Type 6928 and then 6929 Base_Type 6930 (Designated_Type (Etype (First_Formal (Hom)))) = 6931 Cls_Type)) 6932 then 6933 Add_One_Interp (Op, Hom, Etype (Hom)); 6934 Set_Etype (N, Etype (Hom)); 6935 end if; 6936 6937 Hom := Homonym (Hom); 6938 end loop; 6939 end; 6940 6941 return Etype (Op) /= Any_Type; 6942 end Find_Primitive_Operation; 6943 6944 ---------------------- 6945 -- Find_Unary_Types -- 6946 ---------------------- 6947 6948 procedure Find_Unary_Types 6949 (R : Node_Id; 6950 Op_Id : Entity_Id; 6951 N : Node_Id) 6952 is 6953 Index : Interp_Index; 6954 It : Interp; 6955 6956 begin 6957 if not Is_Overloaded (R) then 6958 if Is_Numeric_Type (Etype (R)) then 6959 6960 -- In an instance a generic actual may be a numeric type even if 6961 -- the formal in the generic unit was not. In that case, the 6962 -- predefined operator was not a possible interpretation in the 6963 -- generic, and cannot be one in the instance, unless the operator 6964 -- is an actual of an instance. 6965 6966 if In_Instance 6967 and then 6968 not Is_Numeric_Type (Corresponding_Generic_Type (Etype (R))) 6969 then 6970 null; 6971 else 6972 Add_One_Interp (N, Op_Id, Base_Type (Etype (R))); 6973 end if; 6974 end if; 6975 6976 else 6977 Get_First_Interp (R, Index, It); 6978 while Present (It.Typ) loop 6979 if Is_Numeric_Type (It.Typ) then 6980 if In_Instance 6981 and then 6982 not Is_Numeric_Type 6983 (Corresponding_Generic_Type (Etype (It.Typ))) 6984 then 6985 null; 6986 6987 else 6988 Add_One_Interp (N, Op_Id, Base_Type (It.Typ)); 6989 end if; 6990 end if; 6991 6992 Get_Next_Interp (Index, It); 6993 end loop; 6994 end if; 6995 end Find_Unary_Types; 6996 6997 ------------------ 6998 -- Junk_Operand -- 6999 ------------------ 7000 7001 function Junk_Operand (N : Node_Id) return Boolean is 7002 Enode : Node_Id; 7003 7004 begin 7005 if Error_Posted (N) then 7006 return False; 7007 end if; 7008 7009 -- Get entity to be tested 7010 7011 if Is_Entity_Name (N) 7012 and then Present (Entity (N)) 7013 then 7014 Enode := N; 7015 7016 -- An odd case, a procedure name gets converted to a very peculiar 7017 -- function call, and here is where we detect this happening. 7018 7019 elsif Nkind (N) = N_Function_Call 7020 and then Is_Entity_Name (Name (N)) 7021 and then Present (Entity (Name (N))) 7022 then 7023 Enode := Name (N); 7024 7025 -- Another odd case, there are at least some cases of selected 7026 -- components where the selected component is not marked as having 7027 -- an entity, even though the selector does have an entity 7028 7029 elsif Nkind (N) = N_Selected_Component 7030 and then Present (Entity (Selector_Name (N))) 7031 then 7032 Enode := Selector_Name (N); 7033 7034 else 7035 return False; 7036 end if; 7037 7038 -- Now test the entity we got to see if it is a bad case 7039 7040 case Ekind (Entity (Enode)) is 7041 when E_Package => 7042 Error_Msg_N 7043 ("package name cannot be used as operand", Enode); 7044 7045 when Generic_Unit_Kind => 7046 Error_Msg_N 7047 ("generic unit name cannot be used as operand", Enode); 7048 7049 when Type_Kind => 7050 Error_Msg_N 7051 ("subtype name cannot be used as operand", Enode); 7052 7053 when Entry_Kind => 7054 Error_Msg_N 7055 ("entry name cannot be used as operand", Enode); 7056 7057 when E_Procedure => 7058 Error_Msg_N 7059 ("procedure name cannot be used as operand", Enode); 7060 7061 when E_Exception => 7062 Error_Msg_N 7063 ("exception name cannot be used as operand", Enode); 7064 7065 when E_Block 7066 | E_Label 7067 | E_Loop 7068 => 7069 Error_Msg_N 7070 ("label name cannot be used as operand", Enode); 7071 7072 when others => 7073 return False; 7074 end case; 7075 7076 return True; 7077 end Junk_Operand; 7078 7079 -------------------- 7080 -- Operator_Check -- 7081 -------------------- 7082 7083 procedure Operator_Check (N : Node_Id) is 7084 begin 7085 Remove_Abstract_Operations (N); 7086 7087 -- Test for case of no interpretation found for operator 7088 7089 if Etype (N) = Any_Type then 7090 declare 7091 L : Node_Id; 7092 R : Node_Id; 7093 Op_Id : Entity_Id := Empty; 7094 7095 begin 7096 R := Right_Opnd (N); 7097 7098 if Nkind (N) in N_Binary_Op then 7099 L := Left_Opnd (N); 7100 else 7101 L := Empty; 7102 end if; 7103 7104 -- If either operand has no type, then don't complain further, 7105 -- since this simply means that we have a propagated error. 7106 7107 if R = Error 7108 or else Etype (R) = Any_Type 7109 or else (Nkind (N) in N_Binary_Op and then Etype (L) = Any_Type) 7110 then 7111 -- For the rather unusual case where one of the operands is 7112 -- a Raise_Expression, whose initial type is Any_Type, use 7113 -- the type of the other operand. 7114 7115 if Nkind (L) = N_Raise_Expression then 7116 Set_Etype (L, Etype (R)); 7117 Set_Etype (N, Etype (R)); 7118 7119 elsif Nkind (R) = N_Raise_Expression then 7120 Set_Etype (R, Etype (L)); 7121 Set_Etype (N, Etype (L)); 7122 end if; 7123 7124 return; 7125 7126 -- We explicitly check for the case of concatenation of component 7127 -- with component to avoid reporting spurious matching array types 7128 -- that might happen to be lurking in distant packages (such as 7129 -- run-time packages). This also prevents inconsistencies in the 7130 -- messages for certain ACVC B tests, which can vary depending on 7131 -- types declared in run-time interfaces. Another improvement when 7132 -- aggregates are present is to look for a well-typed operand. 7133 7134 elsif Present (Candidate_Type) 7135 and then (Nkind (N) /= N_Op_Concat 7136 or else Is_Array_Type (Etype (L)) 7137 or else Is_Array_Type (Etype (R))) 7138 then 7139 if Nkind (N) = N_Op_Concat then 7140 if Etype (L) /= Any_Composite 7141 and then Is_Array_Type (Etype (L)) 7142 then 7143 Candidate_Type := Etype (L); 7144 7145 elsif Etype (R) /= Any_Composite 7146 and then Is_Array_Type (Etype (R)) 7147 then 7148 Candidate_Type := Etype (R); 7149 end if; 7150 end if; 7151 7152 Error_Msg_NE -- CODEFIX 7153 ("operator for} is not directly visible!", 7154 N, First_Subtype (Candidate_Type)); 7155 7156 declare 7157 U : constant Node_Id := 7158 Cunit (Get_Source_Unit (Candidate_Type)); 7159 begin 7160 if Unit_Is_Visible (U) then 7161 Error_Msg_N -- CODEFIX 7162 ("use clause would make operation legal!", N); 7163 else 7164 Error_Msg_NE -- CODEFIX 7165 ("add with_clause and use_clause for&!", 7166 N, Defining_Entity (Unit (U))); 7167 end if; 7168 end; 7169 return; 7170 7171 -- If either operand is a junk operand (e.g. package name), then 7172 -- post appropriate error messages, but do not complain further. 7173 7174 -- Note that the use of OR in this test instead of OR ELSE is 7175 -- quite deliberate, we may as well check both operands in the 7176 -- binary operator case. 7177 7178 elsif Junk_Operand (R) 7179 or -- really mean OR here and not OR ELSE, see above 7180 (Nkind (N) in N_Binary_Op and then Junk_Operand (L)) 7181 then 7182 return; 7183 7184 -- If we have a logical operator, one of whose operands is 7185 -- Boolean, then we know that the other operand cannot resolve to 7186 -- Boolean (since we got no interpretations), but in that case we 7187 -- pretty much know that the other operand should be Boolean, so 7188 -- resolve it that way (generating an error). 7189 7190 elsif Nkind_In (N, N_Op_And, N_Op_Or, N_Op_Xor) then 7191 if Etype (L) = Standard_Boolean then 7192 Resolve (R, Standard_Boolean); 7193 return; 7194 elsif Etype (R) = Standard_Boolean then 7195 Resolve (L, Standard_Boolean); 7196 return; 7197 end if; 7198 7199 -- For an arithmetic operator or comparison operator, if one 7200 -- of the operands is numeric, then we know the other operand 7201 -- is not the same numeric type. If it is a non-numeric type, 7202 -- then probably it is intended to match the other operand. 7203 7204 elsif Nkind_In (N, N_Op_Add, 7205 N_Op_Divide, 7206 N_Op_Ge, 7207 N_Op_Gt, 7208 N_Op_Le) 7209 or else 7210 Nkind_In (N, N_Op_Lt, 7211 N_Op_Mod, 7212 N_Op_Multiply, 7213 N_Op_Rem, 7214 N_Op_Subtract) 7215 then 7216 -- If Allow_Integer_Address is active, check whether the 7217 -- operation becomes legal after converting an operand. 7218 7219 if Is_Numeric_Type (Etype (L)) 7220 and then not Is_Numeric_Type (Etype (R)) 7221 then 7222 if Address_Integer_Convert_OK (Etype (R), Etype (L)) then 7223 Rewrite (R, 7224 Unchecked_Convert_To (Etype (L), Relocate_Node (R))); 7225 7226 if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then 7227 Analyze_Comparison_Op (N); 7228 else 7229 Analyze_Arithmetic_Op (N); 7230 end if; 7231 else 7232 Resolve (R, Etype (L)); 7233 end if; 7234 7235 return; 7236 7237 elsif Is_Numeric_Type (Etype (R)) 7238 and then not Is_Numeric_Type (Etype (L)) 7239 then 7240 if Address_Integer_Convert_OK (Etype (L), Etype (R)) then 7241 Rewrite (L, 7242 Unchecked_Convert_To (Etype (R), Relocate_Node (L))); 7243 7244 if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then 7245 Analyze_Comparison_Op (N); 7246 else 7247 Analyze_Arithmetic_Op (N); 7248 end if; 7249 7250 return; 7251 7252 else 7253 Resolve (L, Etype (R)); 7254 end if; 7255 7256 return; 7257 7258 elsif Allow_Integer_Address 7259 and then Is_Descendant_Of_Address (Etype (L)) 7260 and then Is_Descendant_Of_Address (Etype (R)) 7261 and then not Error_Posted (N) 7262 then 7263 declare 7264 Addr_Type : constant Entity_Id := Etype (L); 7265 7266 begin 7267 Rewrite (L, 7268 Unchecked_Convert_To ( 7269 Standard_Integer, Relocate_Node (L))); 7270 Rewrite (R, 7271 Unchecked_Convert_To ( 7272 Standard_Integer, Relocate_Node (R))); 7273 7274 if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then 7275 Analyze_Comparison_Op (N); 7276 else 7277 Analyze_Arithmetic_Op (N); 7278 end if; 7279 7280 -- If this is an operand in an enclosing arithmetic 7281 -- operation, Convert the result as an address so that 7282 -- arithmetic folding of address can continue. 7283 7284 if Nkind (Parent (N)) in N_Op then 7285 Rewrite (N, 7286 Unchecked_Convert_To (Addr_Type, Relocate_Node (N))); 7287 end if; 7288 7289 return; 7290 end; 7291 7292 -- Under relaxed RM semantics silently replace occurrences of 7293 -- null by System.Address_Null. 7294 7295 elsif Null_To_Null_Address_Convert_OK (N) then 7296 Replace_Null_By_Null_Address (N); 7297 7298 if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then 7299 Analyze_Comparison_Op (N); 7300 else 7301 Analyze_Arithmetic_Op (N); 7302 end if; 7303 7304 return; 7305 end if; 7306 7307 -- Comparisons on A'Access are common enough to deserve a 7308 -- special message. 7309 7310 elsif Nkind_In (N, N_Op_Eq, N_Op_Ne) 7311 and then Ekind (Etype (L)) = E_Access_Attribute_Type 7312 and then Ekind (Etype (R)) = E_Access_Attribute_Type 7313 then 7314 Error_Msg_N 7315 ("two access attributes cannot be compared directly", N); 7316 Error_Msg_N 7317 ("\use qualified expression for one of the operands", 7318 N); 7319 return; 7320 7321 -- Another one for C programmers 7322 7323 elsif Nkind (N) = N_Op_Concat 7324 and then Valid_Boolean_Arg (Etype (L)) 7325 and then Valid_Boolean_Arg (Etype (R)) 7326 then 7327 Error_Msg_N ("invalid operands for concatenation", N); 7328 Error_Msg_N -- CODEFIX 7329 ("\maybe AND was meant", N); 7330 return; 7331 7332 -- A special case for comparison of access parameter with null 7333 7334 elsif Nkind (N) = N_Op_Eq 7335 and then Is_Entity_Name (L) 7336 and then Nkind (Parent (Entity (L))) = N_Parameter_Specification 7337 and then Nkind (Parameter_Type (Parent (Entity (L)))) = 7338 N_Access_Definition 7339 and then Nkind (R) = N_Null 7340 then 7341 Error_Msg_N ("access parameter is not allowed to be null", L); 7342 Error_Msg_N ("\(call would raise Constraint_Error)", L); 7343 return; 7344 7345 -- Another special case for exponentiation, where the right 7346 -- operand must be Natural, independently of the base. 7347 7348 elsif Nkind (N) = N_Op_Expon 7349 and then Is_Numeric_Type (Etype (L)) 7350 and then not Is_Overloaded (R) 7351 and then 7352 First_Subtype (Base_Type (Etype (R))) /= Standard_Integer 7353 and then Base_Type (Etype (R)) /= Universal_Integer 7354 then 7355 if Ada_Version >= Ada_2012 7356 and then Has_Dimension_System (Etype (L)) 7357 then 7358 Error_Msg_NE 7359 ("exponent for dimensioned type must be a rational" & 7360 ", found}", R, Etype (R)); 7361 else 7362 Error_Msg_NE 7363 ("exponent must be of type Natural, found}", R, Etype (R)); 7364 end if; 7365 7366 return; 7367 7368 elsif Nkind_In (N, N_Op_Eq, N_Op_Ne) then 7369 if Address_Integer_Convert_OK (Etype (R), Etype (L)) then 7370 Rewrite (R, 7371 Unchecked_Convert_To (Etype (L), Relocate_Node (R))); 7372 Analyze_Equality_Op (N); 7373 return; 7374 7375 -- Under relaxed RM semantics silently replace occurrences of 7376 -- null by System.Address_Null. 7377 7378 elsif Null_To_Null_Address_Convert_OK (N) then 7379 Replace_Null_By_Null_Address (N); 7380 Analyze_Equality_Op (N); 7381 return; 7382 end if; 7383 end if; 7384 7385 -- If we fall through then just give general message. Note that in 7386 -- the following messages, if the operand is overloaded we choose 7387 -- an arbitrary type to complain about, but that is probably more 7388 -- useful than not giving a type at all. 7389 7390 if Nkind (N) in N_Unary_Op then 7391 Error_Msg_Node_2 := Etype (R); 7392 Error_Msg_N ("operator& not defined for}", N); 7393 return; 7394 7395 else 7396 if Nkind (N) in N_Binary_Op then 7397 if not Is_Overloaded (L) 7398 and then not Is_Overloaded (R) 7399 and then Base_Type (Etype (L)) = Base_Type (Etype (R)) 7400 then 7401 Error_Msg_Node_2 := First_Subtype (Etype (R)); 7402 Error_Msg_N ("there is no applicable operator& for}", N); 7403 7404 else 7405 -- Another attempt to find a fix: one of the candidate 7406 -- interpretations may not be use-visible. This has 7407 -- already been checked for predefined operators, so 7408 -- we examine only user-defined functions. 7409 7410 Op_Id := Get_Name_Entity_Id (Chars (N)); 7411 7412 while Present (Op_Id) loop 7413 if Ekind (Op_Id) /= E_Operator 7414 and then Is_Overloadable (Op_Id) 7415 then 7416 if not Is_Immediately_Visible (Op_Id) 7417 and then not In_Use (Scope (Op_Id)) 7418 and then not Is_Abstract_Subprogram (Op_Id) 7419 and then not Is_Hidden (Op_Id) 7420 and then Ekind (Scope (Op_Id)) = E_Package 7421 and then 7422 Has_Compatible_Type 7423 (L, Etype (First_Formal (Op_Id))) 7424 and then Present 7425 (Next_Formal (First_Formal (Op_Id))) 7426 and then 7427 Has_Compatible_Type 7428 (R, 7429 Etype (Next_Formal (First_Formal (Op_Id)))) 7430 then 7431 Error_Msg_N 7432 ("No legal interpretation for operator&", N); 7433 Error_Msg_NE 7434 ("\use clause on& would make operation legal", 7435 N, Scope (Op_Id)); 7436 exit; 7437 end if; 7438 end if; 7439 7440 Op_Id := Homonym (Op_Id); 7441 end loop; 7442 7443 if No (Op_Id) then 7444 Error_Msg_N ("invalid operand types for operator&", N); 7445 7446 if Nkind (N) /= N_Op_Concat then 7447 Error_Msg_NE ("\left operand has}!", N, Etype (L)); 7448 Error_Msg_NE ("\right operand has}!", N, Etype (R)); 7449 7450 -- For concatenation operators it is more difficult to 7451 -- determine which is the wrong operand. It is worth 7452 -- flagging explicitly an access type, for those who 7453 -- might think that a dereference happens here. 7454 7455 elsif Is_Access_Type (Etype (L)) then 7456 Error_Msg_N ("\left operand is access type", N); 7457 7458 elsif Is_Access_Type (Etype (R)) then 7459 Error_Msg_N ("\right operand is access type", N); 7460 end if; 7461 end if; 7462 end if; 7463 end if; 7464 end if; 7465 end; 7466 end if; 7467 end Operator_Check; 7468 7469 ----------------------------------------- 7470 -- Process_Implicit_Dereference_Prefix -- 7471 ----------------------------------------- 7472 7473 function Process_Implicit_Dereference_Prefix 7474 (E : Entity_Id; 7475 P : Entity_Id) return Entity_Id 7476 is 7477 Ref : Node_Id; 7478 Typ : constant Entity_Id := Designated_Type (Etype (P)); 7479 7480 begin 7481 if Present (E) 7482 and then (Operating_Mode = Check_Semantics or else not Expander_Active) 7483 then 7484 -- We create a dummy reference to E to ensure that the reference is 7485 -- not considered as part of an assignment (an implicit dereference 7486 -- can never assign to its prefix). The Comes_From_Source attribute 7487 -- needs to be propagated for accurate warnings. 7488 7489 Ref := New_Occurrence_Of (E, Sloc (P)); 7490 Set_Comes_From_Source (Ref, Comes_From_Source (P)); 7491 Generate_Reference (E, Ref); 7492 end if; 7493 7494 -- An implicit dereference is a legal occurrence of an incomplete type 7495 -- imported through a limited_with clause, if the full view is visible. 7496 7497 if From_Limited_With (Typ) 7498 and then not From_Limited_With (Scope (Typ)) 7499 and then 7500 (Is_Immediately_Visible (Scope (Typ)) 7501 or else 7502 (Is_Child_Unit (Scope (Typ)) 7503 and then Is_Visible_Lib_Unit (Scope (Typ)))) 7504 then 7505 return Available_View (Typ); 7506 else 7507 return Typ; 7508 end if; 7509 end Process_Implicit_Dereference_Prefix; 7510 7511 -------------------------------- 7512 -- Remove_Abstract_Operations -- 7513 -------------------------------- 7514 7515 procedure Remove_Abstract_Operations (N : Node_Id) is 7516 Abstract_Op : Entity_Id := Empty; 7517 Address_Descendant : Boolean := False; 7518 I : Interp_Index; 7519 It : Interp; 7520 7521 -- AI-310: If overloaded, remove abstract non-dispatching operations. We 7522 -- activate this if either extensions are enabled, or if the abstract 7523 -- operation in question comes from a predefined file. This latter test 7524 -- allows us to use abstract to make operations invisible to users. In 7525 -- particular, if type Address is non-private and abstract subprograms 7526 -- are used to hide its operators, they will be truly hidden. 7527 7528 type Operand_Position is (First_Op, Second_Op); 7529 Univ_Type : constant Entity_Id := Universal_Interpretation (N); 7530 7531 procedure Remove_Address_Interpretations (Op : Operand_Position); 7532 -- Ambiguities may arise when the operands are literal and the address 7533 -- operations in s-auxdec are visible. In that case, remove the 7534 -- interpretation of a literal as Address, to retain the semantics 7535 -- of Address as a private type. 7536 7537 ------------------------------------ 7538 -- Remove_Address_Interpretations -- 7539 ------------------------------------ 7540 7541 procedure Remove_Address_Interpretations (Op : Operand_Position) is 7542 Formal : Entity_Id; 7543 7544 begin 7545 if Is_Overloaded (N) then 7546 Get_First_Interp (N, I, It); 7547 while Present (It.Nam) loop 7548 Formal := First_Entity (It.Nam); 7549 7550 if Op = Second_Op then 7551 Formal := Next_Entity (Formal); 7552 end if; 7553 7554 if Is_Descendant_Of_Address (Etype (Formal)) then 7555 Address_Descendant := True; 7556 Remove_Interp (I); 7557 end if; 7558 7559 Get_Next_Interp (I, It); 7560 end loop; 7561 end if; 7562 end Remove_Address_Interpretations; 7563 7564 -- Start of processing for Remove_Abstract_Operations 7565 7566 begin 7567 if Is_Overloaded (N) then 7568 if Debug_Flag_V then 7569 Write_Str ("Remove_Abstract_Operations: "); 7570 Write_Overloads (N); 7571 end if; 7572 7573 Get_First_Interp (N, I, It); 7574 7575 while Present (It.Nam) loop 7576 if Is_Overloadable (It.Nam) 7577 and then Is_Abstract_Subprogram (It.Nam) 7578 and then not Is_Dispatching_Operation (It.Nam) 7579 then 7580 Abstract_Op := It.Nam; 7581 7582 if Is_Descendant_Of_Address (It.Typ) then 7583 Address_Descendant := True; 7584 Remove_Interp (I); 7585 exit; 7586 7587 -- In Ada 2005, this operation does not participate in overload 7588 -- resolution. If the operation is defined in a predefined 7589 -- unit, it is one of the operations declared abstract in some 7590 -- variants of System, and it must be removed as well. 7591 7592 elsif Ada_Version >= Ada_2005 7593 or else In_Predefined_Unit (It.Nam) 7594 then 7595 Remove_Interp (I); 7596 exit; 7597 end if; 7598 end if; 7599 7600 Get_Next_Interp (I, It); 7601 end loop; 7602 7603 if No (Abstract_Op) then 7604 7605 -- If some interpretation yields an integer type, it is still 7606 -- possible that there are address interpretations. Remove them 7607 -- if one operand is a literal, to avoid spurious ambiguities 7608 -- on systems where Address is a visible integer type. 7609 7610 if Is_Overloaded (N) 7611 and then Nkind (N) in N_Op 7612 and then Is_Integer_Type (Etype (N)) 7613 then 7614 if Nkind (N) in N_Binary_Op then 7615 if Nkind (Right_Opnd (N)) = N_Integer_Literal then 7616 Remove_Address_Interpretations (Second_Op); 7617 7618 elsif Nkind (Left_Opnd (N)) = N_Integer_Literal then 7619 Remove_Address_Interpretations (First_Op); 7620 end if; 7621 end if; 7622 end if; 7623 7624 elsif Nkind (N) in N_Op then 7625 7626 -- Remove interpretations that treat literals as addresses. This 7627 -- is never appropriate, even when Address is defined as a visible 7628 -- Integer type. The reason is that we would really prefer Address 7629 -- to behave as a private type, even in this case. If Address is a 7630 -- visible integer type, we get lots of overload ambiguities. 7631 7632 if Nkind (N) in N_Binary_Op then 7633 declare 7634 U1 : constant Boolean := 7635 Present (Universal_Interpretation (Right_Opnd (N))); 7636 U2 : constant Boolean := 7637 Present (Universal_Interpretation (Left_Opnd (N))); 7638 7639 begin 7640 if U1 then 7641 Remove_Address_Interpretations (Second_Op); 7642 end if; 7643 7644 if U2 then 7645 Remove_Address_Interpretations (First_Op); 7646 end if; 7647 7648 if not (U1 and U2) then 7649 7650 -- Remove corresponding predefined operator, which is 7651 -- always added to the overload set. 7652 7653 Get_First_Interp (N, I, It); 7654 while Present (It.Nam) loop 7655 if Scope (It.Nam) = Standard_Standard 7656 and then Base_Type (It.Typ) = 7657 Base_Type (Etype (Abstract_Op)) 7658 then 7659 Remove_Interp (I); 7660 end if; 7661 7662 Get_Next_Interp (I, It); 7663 end loop; 7664 7665 elsif Is_Overloaded (N) 7666 and then Present (Univ_Type) 7667 then 7668 -- If both operands have a universal interpretation, 7669 -- it is still necessary to remove interpretations that 7670 -- yield Address. Any remaining ambiguities will be 7671 -- removed in Disambiguate. 7672 7673 Get_First_Interp (N, I, It); 7674 while Present (It.Nam) loop 7675 if Is_Descendant_Of_Address (It.Typ) then 7676 Remove_Interp (I); 7677 7678 elsif not Is_Type (It.Nam) then 7679 Set_Entity (N, It.Nam); 7680 end if; 7681 7682 Get_Next_Interp (I, It); 7683 end loop; 7684 end if; 7685 end; 7686 end if; 7687 7688 elsif Nkind (N) = N_Function_Call 7689 and then 7690 (Nkind (Name (N)) = N_Operator_Symbol 7691 or else 7692 (Nkind (Name (N)) = N_Expanded_Name 7693 and then 7694 Nkind (Selector_Name (Name (N))) = N_Operator_Symbol)) 7695 then 7696 7697 declare 7698 Arg1 : constant Node_Id := First (Parameter_Associations (N)); 7699 U1 : constant Boolean := 7700 Present (Universal_Interpretation (Arg1)); 7701 U2 : constant Boolean := 7702 Present (Next (Arg1)) and then 7703 Present (Universal_Interpretation (Next (Arg1))); 7704 7705 begin 7706 if U1 then 7707 Remove_Address_Interpretations (First_Op); 7708 end if; 7709 7710 if U2 then 7711 Remove_Address_Interpretations (Second_Op); 7712 end if; 7713 7714 if not (U1 and U2) then 7715 Get_First_Interp (N, I, It); 7716 while Present (It.Nam) loop 7717 if Scope (It.Nam) = Standard_Standard 7718 and then It.Typ = Base_Type (Etype (Abstract_Op)) 7719 then 7720 Remove_Interp (I); 7721 end if; 7722 7723 Get_Next_Interp (I, It); 7724 end loop; 7725 end if; 7726 end; 7727 end if; 7728 7729 -- If the removal has left no valid interpretations, emit an error 7730 -- message now and label node as illegal. 7731 7732 if Present (Abstract_Op) then 7733 Get_First_Interp (N, I, It); 7734 7735 if No (It.Nam) then 7736 7737 -- Removal of abstract operation left no viable candidate 7738 7739 Set_Etype (N, Any_Type); 7740 Error_Msg_Sloc := Sloc (Abstract_Op); 7741 Error_Msg_NE 7742 ("cannot call abstract operation& declared#", N, Abstract_Op); 7743 7744 -- In Ada 2005, an abstract operation may disable predefined 7745 -- operators. Since the context is not yet known, we mark the 7746 -- predefined operators as potentially hidden. Do not include 7747 -- predefined operators when addresses are involved since this 7748 -- case is handled separately. 7749 7750 elsif Ada_Version >= Ada_2005 and then not Address_Descendant then 7751 while Present (It.Nam) loop 7752 if Is_Numeric_Type (It.Typ) 7753 and then Scope (It.Typ) = Standard_Standard 7754 then 7755 Set_Abstract_Op (I, Abstract_Op); 7756 end if; 7757 7758 Get_Next_Interp (I, It); 7759 end loop; 7760 end if; 7761 end if; 7762 7763 if Debug_Flag_V then 7764 Write_Str ("Remove_Abstract_Operations done: "); 7765 Write_Overloads (N); 7766 end if; 7767 end if; 7768 end Remove_Abstract_Operations; 7769 7770 ---------------------------- 7771 -- Try_Container_Indexing -- 7772 ---------------------------- 7773 7774 function Try_Container_Indexing 7775 (N : Node_Id; 7776 Prefix : Node_Id; 7777 Exprs : List_Id) return Boolean 7778 is 7779 Pref_Typ : constant Entity_Id := Etype (Prefix); 7780 7781 function Constant_Indexing_OK return Boolean; 7782 -- Constant_Indexing is legal if there is no Variable_Indexing defined 7783 -- for the type, or else node not a target of assignment, or an actual 7784 -- for an IN OUT or OUT formal (RM 4.1.6 (11)). 7785 7786 function Expr_Matches_In_Formal 7787 (Subp : Entity_Id; 7788 Par : Node_Id) return Boolean; 7789 -- Find formal corresponding to given indexed component that is an 7790 -- actual in a call. Note that the enclosing subprogram call has not 7791 -- been analyzed yet, and the parameter list is not normalized, so 7792 -- that if the argument is a parameter association we must match it 7793 -- by name and not by position. 7794 7795 function Find_Indexing_Operations 7796 (T : Entity_Id; 7797 Nam : Name_Id; 7798 Is_Constant : Boolean) return Node_Id; 7799 -- Return a reference to the primitive operation of type T denoted by 7800 -- name Nam. If the operation is overloaded, the reference carries all 7801 -- interpretations. Flag Is_Constant should be set when the context is 7802 -- constant indexing. 7803 7804 -------------------------- 7805 -- Constant_Indexing_OK -- 7806 -------------------------- 7807 7808 function Constant_Indexing_OK return Boolean is 7809 Par : Node_Id; 7810 7811 begin 7812 if No (Find_Value_Of_Aspect (Pref_Typ, Aspect_Variable_Indexing)) then 7813 return True; 7814 7815 elsif not Is_Variable (Prefix) then 7816 return True; 7817 end if; 7818 7819 Par := N; 7820 while Present (Par) loop 7821 if Nkind (Parent (Par)) = N_Assignment_Statement 7822 and then Par = Name (Parent (Par)) 7823 then 7824 return False; 7825 7826 -- The call may be overloaded, in which case we assume that its 7827 -- resolution does not depend on the type of the parameter that 7828 -- includes the indexing operation. 7829 7830 elsif Nkind_In (Parent (Par), N_Function_Call, 7831 N_Procedure_Call_Statement) 7832 and then Is_Entity_Name (Name (Parent (Par))) 7833 then 7834 declare 7835 Proc : Entity_Id; 7836 7837 begin 7838 -- We should look for an interpretation with the proper 7839 -- number of formals, and determine whether it is an 7840 -- In_Parameter, but for now we examine the formal that 7841 -- corresponds to the indexing, and assume that variable 7842 -- indexing is required if some interpretation has an 7843 -- assignable formal at that position. Still does not 7844 -- cover the most complex cases ??? 7845 7846 if Is_Overloaded (Name (Parent (Par))) then 7847 declare 7848 Proc : constant Node_Id := Name (Parent (Par)); 7849 I : Interp_Index; 7850 It : Interp; 7851 7852 begin 7853 Get_First_Interp (Proc, I, It); 7854 while Present (It.Nam) loop 7855 if not Expr_Matches_In_Formal (It.Nam, Par) then 7856 return False; 7857 end if; 7858 7859 Get_Next_Interp (I, It); 7860 end loop; 7861 end; 7862 7863 -- All interpretations have a matching in-mode formal 7864 7865 return True; 7866 7867 else 7868 Proc := Entity (Name (Parent (Par))); 7869 7870 -- If this is an indirect call, get formals from 7871 -- designated type. 7872 7873 if Is_Access_Subprogram_Type (Etype (Proc)) then 7874 Proc := Designated_Type (Etype (Proc)); 7875 end if; 7876 end if; 7877 7878 return Expr_Matches_In_Formal (Proc, Par); 7879 end; 7880 7881 elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then 7882 return False; 7883 7884 -- If the indexed component is a prefix it may be the first actual 7885 -- of a prefixed call. Retrieve the called entity, if any, and 7886 -- check its first formal. Determine if the context is a procedure 7887 -- or function call. 7888 7889 elsif Nkind (Parent (Par)) = N_Selected_Component then 7890 declare 7891 Sel : constant Node_Id := Selector_Name (Parent (Par)); 7892 Nam : constant Entity_Id := Current_Entity (Sel); 7893 7894 begin 7895 if Present (Nam) and then Is_Overloadable (Nam) then 7896 if Nkind (Parent (Parent (Par))) = 7897 N_Procedure_Call_Statement 7898 then 7899 return False; 7900 7901 elsif Ekind (Nam) = E_Function 7902 and then Present (First_Formal (Nam)) 7903 then 7904 return Ekind (First_Formal (Nam)) = E_In_Parameter; 7905 end if; 7906 end if; 7907 end; 7908 7909 elsif Nkind (Par) in N_Op then 7910 return True; 7911 end if; 7912 7913 Par := Parent (Par); 7914 end loop; 7915 7916 -- In all other cases, constant indexing is legal 7917 7918 return True; 7919 end Constant_Indexing_OK; 7920 7921 ---------------------------- 7922 -- Expr_Matches_In_Formal -- 7923 ---------------------------- 7924 7925 function Expr_Matches_In_Formal 7926 (Subp : Entity_Id; 7927 Par : Node_Id) return Boolean 7928 is 7929 Actual : Node_Id; 7930 Formal : Node_Id; 7931 7932 begin 7933 Formal := First_Formal (Subp); 7934 Actual := First (Parameter_Associations ((Parent (Par)))); 7935 7936 if Nkind (Par) /= N_Parameter_Association then 7937 7938 -- Match by position 7939 7940 while Present (Actual) and then Present (Formal) loop 7941 exit when Actual = Par; 7942 Next (Actual); 7943 7944 if Present (Formal) then 7945 Next_Formal (Formal); 7946 7947 -- Otherwise this is a parameter mismatch, the error is 7948 -- reported elsewhere, or else variable indexing is implied. 7949 7950 else 7951 return False; 7952 end if; 7953 end loop; 7954 7955 else 7956 -- Match by name 7957 7958 while Present (Formal) loop 7959 exit when Chars (Formal) = Chars (Selector_Name (Par)); 7960 Next_Formal (Formal); 7961 7962 if No (Formal) then 7963 return False; 7964 end if; 7965 end loop; 7966 end if; 7967 7968 return Present (Formal) and then Ekind (Formal) = E_In_Parameter; 7969 end Expr_Matches_In_Formal; 7970 7971 ------------------------------ 7972 -- Find_Indexing_Operations -- 7973 ------------------------------ 7974 7975 function Find_Indexing_Operations 7976 (T : Entity_Id; 7977 Nam : Name_Id; 7978 Is_Constant : Boolean) return Node_Id 7979 is 7980 procedure Inspect_Declarations 7981 (Typ : Entity_Id; 7982 Ref : in out Node_Id); 7983 -- Traverse the declarative list where type Typ resides and collect 7984 -- all suitable interpretations in node Ref. 7985 7986 procedure Inspect_Primitives 7987 (Typ : Entity_Id; 7988 Ref : in out Node_Id); 7989 -- Traverse the list of primitive operations of type Typ and collect 7990 -- all suitable interpretations in node Ref. 7991 7992 function Is_OK_Candidate 7993 (Subp_Id : Entity_Id; 7994 Typ : Entity_Id) return Boolean; 7995 -- Determine whether subprogram Subp_Id is a suitable indexing 7996 -- operation for type Typ. To qualify as such, the subprogram must 7997 -- be a function, have at least two parameters, and the type of the 7998 -- first parameter must be either Typ, or Typ'Class, or access [to 7999 -- constant] with designated type Typ or Typ'Class. 8000 8001 procedure Record_Interp (Subp_Id : Entity_Id; Ref : in out Node_Id); 8002 -- Store subprogram Subp_Id as an interpretation in node Ref 8003 8004 -------------------------- 8005 -- Inspect_Declarations -- 8006 -------------------------- 8007 8008 procedure Inspect_Declarations 8009 (Typ : Entity_Id; 8010 Ref : in out Node_Id) 8011 is 8012 Typ_Decl : constant Node_Id := Declaration_Node (Typ); 8013 Decl : Node_Id; 8014 Subp_Id : Entity_Id; 8015 8016 begin 8017 -- Ensure that the routine is not called with itypes, which lack a 8018 -- declarative node. 8019 8020 pragma Assert (Present (Typ_Decl)); 8021 pragma Assert (Is_List_Member (Typ_Decl)); 8022 8023 Decl := First (List_Containing (Typ_Decl)); 8024 while Present (Decl) loop 8025 if Nkind (Decl) = N_Subprogram_Declaration then 8026 Subp_Id := Defining_Entity (Decl); 8027 8028 if Is_OK_Candidate (Subp_Id, Typ) then 8029 Record_Interp (Subp_Id, Ref); 8030 end if; 8031 end if; 8032 8033 Next (Decl); 8034 end loop; 8035 end Inspect_Declarations; 8036 8037 ------------------------ 8038 -- Inspect_Primitives -- 8039 ------------------------ 8040 8041 procedure Inspect_Primitives 8042 (Typ : Entity_Id; 8043 Ref : in out Node_Id) 8044 is 8045 Prim_Elmt : Elmt_Id; 8046 Prim_Id : Entity_Id; 8047 8048 begin 8049 Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); 8050 while Present (Prim_Elmt) loop 8051 Prim_Id := Node (Prim_Elmt); 8052 8053 if Is_OK_Candidate (Prim_Id, Typ) then 8054 Record_Interp (Prim_Id, Ref); 8055 end if; 8056 8057 Next_Elmt (Prim_Elmt); 8058 end loop; 8059 end Inspect_Primitives; 8060 8061 --------------------- 8062 -- Is_OK_Candidate -- 8063 --------------------- 8064 8065 function Is_OK_Candidate 8066 (Subp_Id : Entity_Id; 8067 Typ : Entity_Id) return Boolean 8068 is 8069 Formal : Entity_Id; 8070 Formal_Typ : Entity_Id; 8071 Param_Typ : Node_Id; 8072 8073 begin 8074 -- To classify as a suitable candidate, the subprogram must be a 8075 -- function whose name matches the argument of aspect Constant or 8076 -- Variable_Indexing. 8077 8078 if Ekind (Subp_Id) = E_Function and then Chars (Subp_Id) = Nam then 8079 Formal := First_Formal (Subp_Id); 8080 8081 -- The candidate requires at least two parameters 8082 8083 if Present (Formal) and then Present (Next_Formal (Formal)) then 8084 Formal_Typ := Empty; 8085 Param_Typ := Parameter_Type (Parent (Formal)); 8086 8087 -- Use the designated type when the first parameter is of an 8088 -- access type. 8089 8090 if Nkind (Param_Typ) = N_Access_Definition 8091 and then Present (Subtype_Mark (Param_Typ)) 8092 then 8093 -- When the context is a constant indexing, the access 8094 -- definition must be access-to-constant. This does not 8095 -- apply to variable indexing. 8096 8097 if not Is_Constant 8098 or else Constant_Present (Param_Typ) 8099 then 8100 Formal_Typ := Etype (Subtype_Mark (Param_Typ)); 8101 end if; 8102 8103 -- Otherwise use the parameter type 8104 8105 else 8106 Formal_Typ := Etype (Param_Typ); 8107 end if; 8108 8109 if Present (Formal_Typ) then 8110 8111 -- Use the specific type when the parameter type is 8112 -- class-wide. 8113 8114 if Is_Class_Wide_Type (Formal_Typ) then 8115 Formal_Typ := Etype (Base_Type (Formal_Typ)); 8116 end if; 8117 8118 -- Use the full view when the parameter type is private 8119 -- or incomplete. 8120 8121 if Is_Incomplete_Or_Private_Type (Formal_Typ) 8122 and then Present (Full_View (Formal_Typ)) 8123 then 8124 Formal_Typ := Full_View (Formal_Typ); 8125 end if; 8126 8127 -- The type of the first parameter must denote the type 8128 -- of the container or acts as its ancestor type. 8129 8130 return 8131 Formal_Typ = Typ 8132 or else Is_Ancestor (Formal_Typ, Typ); 8133 end if; 8134 end if; 8135 end if; 8136 8137 return False; 8138 end Is_OK_Candidate; 8139 8140 ------------------- 8141 -- Record_Interp -- 8142 ------------------- 8143 8144 procedure Record_Interp (Subp_Id : Entity_Id; Ref : in out Node_Id) is 8145 begin 8146 if Present (Ref) then 8147 Add_One_Interp (Ref, Subp_Id, Etype (Subp_Id)); 8148 8149 -- Otherwise this is the first interpretation. Create a reference 8150 -- where all remaining interpretations will be collected. 8151 8152 else 8153 Ref := New_Occurrence_Of (Subp_Id, Sloc (T)); 8154 end if; 8155 end Record_Interp; 8156 8157 -- Local variables 8158 8159 Ref : Node_Id; 8160 Typ : Entity_Id; 8161 8162 -- Start of processing for Find_Indexing_Operations 8163 8164 begin 8165 Typ := T; 8166 8167 -- Use the specific type when the parameter type is class-wide 8168 8169 if Is_Class_Wide_Type (Typ) then 8170 Typ := Root_Type (Typ); 8171 end if; 8172 8173 Ref := Empty; 8174 Typ := Underlying_Type (Base_Type (Typ)); 8175 8176 Inspect_Primitives (Typ, Ref); 8177 8178 -- Now look for explicit declarations of an indexing operation. 8179 -- If the type is private the operation may be declared in the 8180 -- visible part that contains the partial view. 8181 8182 if Is_Private_Type (T) then 8183 Inspect_Declarations (T, Ref); 8184 end if; 8185 8186 Inspect_Declarations (Typ, Ref); 8187 8188 return Ref; 8189 end Find_Indexing_Operations; 8190 8191 -- Local variables 8192 8193 Loc : constant Source_Ptr := Sloc (N); 8194 Assoc : List_Id; 8195 C_Type : Entity_Id; 8196 Func : Entity_Id; 8197 Func_Name : Node_Id; 8198 Indexing : Node_Id; 8199 8200 Is_Constant_Indexing : Boolean := False; 8201 -- This flag reflects the nature of the container indexing. Note that 8202 -- the context may be suited for constant indexing, but the type may 8203 -- lack a Constant_Indexing annotation. 8204 8205 -- Start of processing for Try_Container_Indexing 8206 8207 begin 8208 -- Node may have been analyzed already when testing for a prefixed 8209 -- call, in which case do not redo analysis. 8210 8211 if Present (Generalized_Indexing (N)) then 8212 return True; 8213 end if; 8214 8215 C_Type := Pref_Typ; 8216 8217 -- If indexing a class-wide container, obtain indexing primitive from 8218 -- specific type. 8219 8220 if Is_Class_Wide_Type (C_Type) then 8221 C_Type := Etype (Base_Type (C_Type)); 8222 end if; 8223 8224 -- Check whether the type has a specified indexing aspect 8225 8226 Func_Name := Empty; 8227 8228 -- The context is suitable for constant indexing, so obtain the name of 8229 -- the indexing function from aspect Constant_Indexing. 8230 8231 if Constant_Indexing_OK then 8232 Func_Name := 8233 Find_Value_Of_Aspect (Pref_Typ, Aspect_Constant_Indexing); 8234 end if; 8235 8236 if Present (Func_Name) then 8237 Is_Constant_Indexing := True; 8238 8239 -- Otherwise attempt variable indexing 8240 8241 else 8242 Func_Name := 8243 Find_Value_Of_Aspect (Pref_Typ, Aspect_Variable_Indexing); 8244 end if; 8245 8246 -- The type is not subject to either form of indexing, therefore the 8247 -- indexed component does not denote container indexing. If this is a 8248 -- true error, it is diagnosed by the caller. 8249 8250 if No (Func_Name) then 8251 8252 -- The prefix itself may be an indexing of a container. Rewrite it 8253 -- as such and retry. 8254 8255 if Has_Implicit_Dereference (Pref_Typ) then 8256 Build_Explicit_Dereference (Prefix, First_Discriminant (Pref_Typ)); 8257 return Try_Container_Indexing (N, Prefix, Exprs); 8258 8259 -- Otherwise this is definitely not container indexing 8260 8261 else 8262 return False; 8263 end if; 8264 8265 -- If the container type is derived from another container type, the 8266 -- value of the inherited aspect is the Reference operation declared 8267 -- for the parent type. 8268 8269 -- However, Reference is also a primitive operation of the type, and the 8270 -- inherited operation has a different signature. We retrieve the right 8271 -- ones (the function may be overloaded) from the list of primitive 8272 -- operations of the derived type. 8273 8274 -- Note that predefined containers are typically all derived from one of 8275 -- the Controlled types. The code below is motivated by containers that 8276 -- are derived from other types with a Reference aspect. 8277 8278 elsif Is_Derived_Type (C_Type) 8279 and then Etype (First_Formal (Entity (Func_Name))) /= Pref_Typ 8280 then 8281 Func_Name := 8282 Find_Indexing_Operations 8283 (T => C_Type, 8284 Nam => Chars (Func_Name), 8285 Is_Constant => Is_Constant_Indexing); 8286 end if; 8287 8288 Assoc := New_List (Relocate_Node (Prefix)); 8289 8290 -- A generalized indexing may have nore than one index expression, so 8291 -- transfer all of them to the argument list to be used in the call. 8292 -- Note that there may be named associations, in which case the node 8293 -- was rewritten earlier as a call, and has been transformed back into 8294 -- an indexed expression to share the following processing. 8295 8296 -- The generalized indexing node is the one on which analysis and 8297 -- resolution take place. Before expansion the original node is replaced 8298 -- with the generalized indexing node, which is a call, possibly with a 8299 -- dereference operation. 8300 8301 if Comes_From_Source (N) then 8302 Check_Compiler_Unit ("generalized indexing", N); 8303 end if; 8304 8305 -- Create argument list for function call that represents generalized 8306 -- indexing. Note that indices (i.e. actuals) may themselves be 8307 -- overloaded. 8308 8309 declare 8310 Arg : Node_Id; 8311 New_Arg : Node_Id; 8312 8313 begin 8314 Arg := First (Exprs); 8315 while Present (Arg) loop 8316 New_Arg := Relocate_Node (Arg); 8317 8318 -- The arguments can be parameter associations, in which case the 8319 -- explicit actual parameter carries the overloadings. 8320 8321 if Nkind (New_Arg) /= N_Parameter_Association then 8322 Save_Interps (Arg, New_Arg); 8323 end if; 8324 8325 Append (New_Arg, Assoc); 8326 Next (Arg); 8327 end loop; 8328 end; 8329 8330 if not Is_Overloaded (Func_Name) then 8331 Func := Entity (Func_Name); 8332 8333 Indexing := 8334 Make_Function_Call (Loc, 8335 Name => New_Occurrence_Of (Func, Loc), 8336 Parameter_Associations => Assoc); 8337 8338 Set_Parent (Indexing, Parent (N)); 8339 Set_Generalized_Indexing (N, Indexing); 8340 Analyze (Indexing); 8341 Set_Etype (N, Etype (Indexing)); 8342 8343 -- If the return type of the indexing function is a reference type, 8344 -- add the dereference as a possible interpretation. Note that the 8345 -- indexing aspect may be a function that returns the element type 8346 -- with no intervening implicit dereference, and that the reference 8347 -- discriminant is not the first discriminant. 8348 8349 if Has_Discriminants (Etype (Func)) then 8350 Check_Implicit_Dereference (N, Etype (Func)); 8351 end if; 8352 8353 else 8354 -- If there are multiple indexing functions, build a function call 8355 -- and analyze it for each of the possible interpretations. 8356 8357 Indexing := 8358 Make_Function_Call (Loc, 8359 Name => 8360 Make_Identifier (Loc, Chars (Func_Name)), 8361 Parameter_Associations => Assoc); 8362 Set_Parent (Indexing, Parent (N)); 8363 Set_Generalized_Indexing (N, Indexing); 8364 Set_Etype (N, Any_Type); 8365 Set_Etype (Name (Indexing), Any_Type); 8366 8367 declare 8368 I : Interp_Index; 8369 It : Interp; 8370 Success : Boolean; 8371 8372 begin 8373 Get_First_Interp (Func_Name, I, It); 8374 Set_Etype (Indexing, Any_Type); 8375 8376 -- Analyze each candidate function with the given actuals 8377 8378 while Present (It.Nam) loop 8379 Analyze_One_Call (Indexing, It.Nam, False, Success); 8380 Get_Next_Interp (I, It); 8381 end loop; 8382 8383 -- If there are several successful candidates, resolution will 8384 -- be by result. Mark the interpretations of the function name 8385 -- itself. 8386 8387 if Is_Overloaded (Indexing) then 8388 Get_First_Interp (Indexing, I, It); 8389 8390 while Present (It.Nam) loop 8391 Add_One_Interp (Name (Indexing), It.Nam, It.Typ); 8392 Get_Next_Interp (I, It); 8393 end loop; 8394 8395 else 8396 Set_Etype (Name (Indexing), Etype (Indexing)); 8397 end if; 8398 8399 -- Now add the candidate interpretations to the indexing node 8400 -- itself, to be replaced later by the function call. 8401 8402 if Is_Overloaded (Name (Indexing)) then 8403 Get_First_Interp (Name (Indexing), I, It); 8404 8405 while Present (It.Nam) loop 8406 Add_One_Interp (N, It.Nam, It.Typ); 8407 8408 -- Add dereference interpretation if the result type has 8409 -- implicit reference discriminants. 8410 8411 if Has_Discriminants (Etype (It.Nam)) then 8412 Check_Implicit_Dereference (N, Etype (It.Nam)); 8413 end if; 8414 8415 Get_Next_Interp (I, It); 8416 end loop; 8417 8418 else 8419 Set_Etype (N, Etype (Name (Indexing))); 8420 if Has_Discriminants (Etype (N)) then 8421 Check_Implicit_Dereference (N, Etype (N)); 8422 end if; 8423 end if; 8424 end; 8425 end if; 8426 8427 if Etype (Indexing) = Any_Type then 8428 Error_Msg_NE 8429 ("container cannot be indexed with&", N, Etype (First (Exprs))); 8430 Rewrite (N, New_Occurrence_Of (Any_Id, Loc)); 8431 end if; 8432 8433 return True; 8434 end Try_Container_Indexing; 8435 8436 ----------------------- 8437 -- Try_Indirect_Call -- 8438 ----------------------- 8439 8440 function Try_Indirect_Call 8441 (N : Node_Id; 8442 Nam : Entity_Id; 8443 Typ : Entity_Id) return Boolean 8444 is 8445 Actual : Node_Id; 8446 Formal : Entity_Id; 8447 8448 Call_OK : Boolean; 8449 pragma Warnings (Off, Call_OK); 8450 8451 begin 8452 Normalize_Actuals (N, Designated_Type (Typ), False, Call_OK); 8453 8454 Actual := First_Actual (N); 8455 Formal := First_Formal (Designated_Type (Typ)); 8456 while Present (Actual) and then Present (Formal) loop 8457 if not Has_Compatible_Type (Actual, Etype (Formal)) then 8458 return False; 8459 end if; 8460 8461 Next (Actual); 8462 Next_Formal (Formal); 8463 end loop; 8464 8465 if No (Actual) and then No (Formal) then 8466 Add_One_Interp (N, Nam, Etype (Designated_Type (Typ))); 8467 8468 -- Nam is a candidate interpretation for the name in the call, 8469 -- if it is not an indirect call. 8470 8471 if not Is_Type (Nam) 8472 and then Is_Entity_Name (Name (N)) 8473 then 8474 Set_Entity (Name (N), Nam); 8475 end if; 8476 8477 return True; 8478 8479 else 8480 return False; 8481 end if; 8482 end Try_Indirect_Call; 8483 8484 ---------------------- 8485 -- Try_Indexed_Call -- 8486 ---------------------- 8487 8488 function Try_Indexed_Call 8489 (N : Node_Id; 8490 Nam : Entity_Id; 8491 Typ : Entity_Id; 8492 Skip_First : Boolean) return Boolean 8493 is 8494 Loc : constant Source_Ptr := Sloc (N); 8495 Actuals : constant List_Id := Parameter_Associations (N); 8496 Actual : Node_Id; 8497 Index : Entity_Id; 8498 8499 begin 8500 Actual := First (Actuals); 8501 8502 -- If the call was originally written in prefix form, skip the first 8503 -- actual, which is obviously not defaulted. 8504 8505 if Skip_First then 8506 Next (Actual); 8507 end if; 8508 8509 Index := First_Index (Typ); 8510 while Present (Actual) and then Present (Index) loop 8511 8512 -- If the parameter list has a named association, the expression 8513 -- is definitely a call and not an indexed component. 8514 8515 if Nkind (Actual) = N_Parameter_Association then 8516 return False; 8517 end if; 8518 8519 if Is_Entity_Name (Actual) 8520 and then Is_Type (Entity (Actual)) 8521 and then No (Next (Actual)) 8522 then 8523 -- A single actual that is a type name indicates a slice if the 8524 -- type is discrete, and an error otherwise. 8525 8526 if Is_Discrete_Type (Entity (Actual)) then 8527 Rewrite (N, 8528 Make_Slice (Loc, 8529 Prefix => 8530 Make_Function_Call (Loc, 8531 Name => Relocate_Node (Name (N))), 8532 Discrete_Range => 8533 New_Occurrence_Of (Entity (Actual), Sloc (Actual)))); 8534 8535 Analyze (N); 8536 8537 else 8538 Error_Msg_N ("invalid use of type in expression", Actual); 8539 Set_Etype (N, Any_Type); 8540 end if; 8541 8542 return True; 8543 8544 elsif not Has_Compatible_Type (Actual, Etype (Index)) then 8545 return False; 8546 end if; 8547 8548 Next (Actual); 8549 Next_Index (Index); 8550 end loop; 8551 8552 if No (Actual) and then No (Index) then 8553 Add_One_Interp (N, Nam, Component_Type (Typ)); 8554 8555 -- Nam is a candidate interpretation for the name in the call, 8556 -- if it is not an indirect call. 8557 8558 if not Is_Type (Nam) 8559 and then Is_Entity_Name (Name (N)) 8560 then 8561 Set_Entity (Name (N), Nam); 8562 end if; 8563 8564 return True; 8565 else 8566 return False; 8567 end if; 8568 end Try_Indexed_Call; 8569 8570 -------------------------- 8571 -- Try_Object_Operation -- 8572 -------------------------- 8573 8574 function Try_Object_Operation 8575 (N : Node_Id; CW_Test_Only : Boolean := False) return Boolean 8576 is 8577 K : constant Node_Kind := Nkind (Parent (N)); 8578 Is_Subprg_Call : constant Boolean := K in N_Subprogram_Call; 8579 Loc : constant Source_Ptr := Sloc (N); 8580 Obj : constant Node_Id := Prefix (N); 8581 8582 Subprog : constant Node_Id := 8583 Make_Identifier (Sloc (Selector_Name (N)), 8584 Chars => Chars (Selector_Name (N))); 8585 -- Identifier on which possible interpretations will be collected 8586 8587 Report_Error : Boolean := False; 8588 -- If no candidate interpretation matches the context, redo analysis 8589 -- with Report_Error True to provide additional information. 8590 8591 Actual : Node_Id; 8592 Candidate : Entity_Id := Empty; 8593 New_Call_Node : Node_Id := Empty; 8594 Node_To_Replace : Node_Id; 8595 Obj_Type : Entity_Id := Etype (Obj); 8596 Success : Boolean := False; 8597 8598 procedure Complete_Object_Operation 8599 (Call_Node : Node_Id; 8600 Node_To_Replace : Node_Id); 8601 -- Make Subprog the name of Call_Node, replace Node_To_Replace with 8602 -- Call_Node, insert the object (or its dereference) as the first actual 8603 -- in the call, and complete the analysis of the call. 8604 8605 procedure Report_Ambiguity (Op : Entity_Id); 8606 -- If a prefixed procedure call is ambiguous, indicate whether the call 8607 -- includes an implicit dereference or an implicit 'Access. 8608 8609 procedure Transform_Object_Operation 8610 (Call_Node : out Node_Id; 8611 Node_To_Replace : out Node_Id); 8612 -- Transform Obj.Operation (X, Y,,) into Operation (Obj, X, Y ..) 8613 -- Call_Node is the resulting subprogram call, Node_To_Replace is 8614 -- either N or the parent of N, and Subprog is a reference to the 8615 -- subprogram we are trying to match. 8616 8617 function Try_Class_Wide_Operation 8618 (Call_Node : Node_Id; 8619 Node_To_Replace : Node_Id) return Boolean; 8620 -- Traverse all ancestor types looking for a class-wide subprogram for 8621 -- which the current operation is a valid non-dispatching call. 8622 8623 procedure Try_One_Prefix_Interpretation (T : Entity_Id); 8624 -- If prefix is overloaded, its interpretation may include different 8625 -- tagged types, and we must examine the primitive operations and the 8626 -- class-wide operations of each in order to find candidate 8627 -- interpretations for the call as a whole. 8628 8629 function Try_Primitive_Operation 8630 (Call_Node : Node_Id; 8631 Node_To_Replace : Node_Id) return Boolean; 8632 -- Traverse the list of primitive subprograms looking for a dispatching 8633 -- operation for which the current node is a valid call. 8634 8635 function Valid_Candidate 8636 (Success : Boolean; 8637 Call : Node_Id; 8638 Subp : Entity_Id) return Entity_Id; 8639 -- If the subprogram is a valid interpretation, record it, and add to 8640 -- the list of interpretations of Subprog. Otherwise return Empty. 8641 8642 ------------------------------- 8643 -- Complete_Object_Operation -- 8644 ------------------------------- 8645 8646 procedure Complete_Object_Operation 8647 (Call_Node : Node_Id; 8648 Node_To_Replace : Node_Id) 8649 is 8650 Control : constant Entity_Id := First_Formal (Entity (Subprog)); 8651 Formal_Type : constant Entity_Id := Etype (Control); 8652 First_Actual : Node_Id; 8653 8654 begin 8655 -- Place the name of the operation, with its interpretations, 8656 -- on the rewritten call. 8657 8658 Set_Name (Call_Node, Subprog); 8659 8660 First_Actual := First (Parameter_Associations (Call_Node)); 8661 8662 -- For cross-reference purposes, treat the new node as being in the 8663 -- source if the original one is. Set entity and type, even though 8664 -- they may be overwritten during resolution if overloaded. 8665 8666 Set_Comes_From_Source (Subprog, Comes_From_Source (N)); 8667 Set_Comes_From_Source (Call_Node, Comes_From_Source (N)); 8668 8669 if Nkind (N) = N_Selected_Component 8670 and then not Inside_A_Generic 8671 then 8672 Set_Entity (Selector_Name (N), Entity (Subprog)); 8673 Set_Etype (Selector_Name (N), Etype (Entity (Subprog))); 8674 end if; 8675 8676 -- If need be, rewrite first actual as an explicit dereference. If 8677 -- the call is overloaded, the rewriting can only be done once the 8678 -- primitive operation is identified. 8679 8680 if Is_Overloaded (Subprog) then 8681 8682 -- The prefix itself may be overloaded, and its interpretations 8683 -- must be propagated to the new actual in the call. 8684 8685 if Is_Overloaded (Obj) then 8686 Save_Interps (Obj, First_Actual); 8687 end if; 8688 8689 Rewrite (First_Actual, Obj); 8690 8691 elsif not Is_Access_Type (Formal_Type) 8692 and then Is_Access_Type (Etype (Obj)) 8693 then 8694 Rewrite (First_Actual, 8695 Make_Explicit_Dereference (Sloc (Obj), Obj)); 8696 Analyze (First_Actual); 8697 8698 -- If we need to introduce an explicit dereference, verify that 8699 -- the resulting actual is compatible with the mode of the formal. 8700 8701 if Ekind (First_Formal (Entity (Subprog))) /= E_In_Parameter 8702 and then Is_Access_Constant (Etype (Obj)) 8703 then 8704 Error_Msg_NE 8705 ("expect variable in call to&", Prefix (N), Entity (Subprog)); 8706 end if; 8707 8708 -- Conversely, if the formal is an access parameter and the object is 8709 -- not an access type or a reference type (i.e. a type with the 8710 -- Implicit_Dereference aspect specified), replace the actual with a 8711 -- 'Access reference. Its analysis will check that the object is 8712 -- aliased. 8713 8714 elsif Is_Access_Type (Formal_Type) 8715 and then not Is_Access_Type (Etype (Obj)) 8716 and then 8717 (not Has_Implicit_Dereference (Etype (Obj)) 8718 or else 8719 not Is_Access_Type (Designated_Type (Etype 8720 (Get_Reference_Discriminant (Etype (Obj)))))) 8721 then 8722 -- A special case: A.all'Access is illegal if A is an access to a 8723 -- constant and the context requires an access to a variable. 8724 8725 if not Is_Access_Constant (Formal_Type) then 8726 if (Nkind (Obj) = N_Explicit_Dereference 8727 and then Is_Access_Constant (Etype (Prefix (Obj)))) 8728 or else not Is_Variable (Obj) 8729 then 8730 Error_Msg_NE 8731 ("actual for & must be a variable", Obj, Control); 8732 end if; 8733 end if; 8734 8735 Rewrite (First_Actual, 8736 Make_Attribute_Reference (Loc, 8737 Attribute_Name => Name_Access, 8738 Prefix => Relocate_Node (Obj))); 8739 8740 -- If the object is not overloaded verify that taking access of 8741 -- it is legal. Otherwise check is made during resolution. 8742 8743 if not Is_Overloaded (Obj) 8744 and then not Is_Aliased_View (Obj) 8745 then 8746 Error_Msg_NE 8747 ("object in prefixed call to & must be aliased " 8748 & "(RM 4.1.3 (13 1/2))", Prefix (First_Actual), Subprog); 8749 end if; 8750 8751 Analyze (First_Actual); 8752 8753 else 8754 if Is_Overloaded (Obj) then 8755 Save_Interps (Obj, First_Actual); 8756 end if; 8757 8758 Rewrite (First_Actual, Obj); 8759 end if; 8760 8761 -- The operation is obtained from the dispatch table and not by 8762 -- visibility, and may be declared in a unit that is not explicitly 8763 -- referenced in the source, but is nevertheless required in the 8764 -- context of the current unit. Indicate that operation and its scope 8765 -- are referenced, to prevent spurious and misleading warnings. If 8766 -- the operation is overloaded, all primitives are in the same scope 8767 -- and we can use any of them. 8768 8769 Set_Referenced (Entity (Subprog), True); 8770 Set_Referenced (Scope (Entity (Subprog)), True); 8771 8772 Rewrite (Node_To_Replace, Call_Node); 8773 8774 -- Propagate the interpretations collected in subprog to the new 8775 -- function call node, to be resolved from context. 8776 8777 if Is_Overloaded (Subprog) then 8778 Save_Interps (Subprog, Node_To_Replace); 8779 8780 else 8781 -- The type of the subprogram may be a limited view obtained 8782 -- transitively from another unit. If full view is available, 8783 -- use it to analyze call. If there is no nonlimited view, then 8784 -- this is diagnosed when analyzing the rewritten call. 8785 8786 declare 8787 T : constant Entity_Id := Etype (Subprog); 8788 begin 8789 if From_Limited_With (T) then 8790 Set_Etype (Entity (Subprog), Available_View (T)); 8791 end if; 8792 end; 8793 8794 Analyze (Node_To_Replace); 8795 8796 -- If the operation has been rewritten into a call, which may get 8797 -- subsequently an explicit dereference, preserve the type on the 8798 -- original node (selected component or indexed component) for 8799 -- subsequent legality tests, e.g. Is_Variable. which examines 8800 -- the original node. 8801 8802 if Nkind (Node_To_Replace) = N_Function_Call then 8803 Set_Etype 8804 (Original_Node (Node_To_Replace), Etype (Node_To_Replace)); 8805 end if; 8806 end if; 8807 end Complete_Object_Operation; 8808 8809 ---------------------- 8810 -- Report_Ambiguity -- 8811 ---------------------- 8812 8813 procedure Report_Ambiguity (Op : Entity_Id) is 8814 Access_Actual : constant Boolean := 8815 Is_Access_Type (Etype (Prefix (N))); 8816 Access_Formal : Boolean := False; 8817 8818 begin 8819 Error_Msg_Sloc := Sloc (Op); 8820 8821 if Present (First_Formal (Op)) then 8822 Access_Formal := Is_Access_Type (Etype (First_Formal (Op))); 8823 end if; 8824 8825 if Access_Formal and then not Access_Actual then 8826 if Nkind (Parent (Op)) = N_Full_Type_Declaration then 8827 Error_Msg_N 8828 ("\possible interpretation " 8829 & "(inherited, with implicit 'Access) #", N); 8830 else 8831 Error_Msg_N 8832 ("\possible interpretation (with implicit 'Access) #", N); 8833 end if; 8834 8835 elsif not Access_Formal and then Access_Actual then 8836 if Nkind (Parent (Op)) = N_Full_Type_Declaration then 8837 Error_Msg_N 8838 ("\possible interpretation " 8839 & "(inherited, with implicit dereference) #", N); 8840 else 8841 Error_Msg_N 8842 ("\possible interpretation (with implicit dereference) #", N); 8843 end if; 8844 8845 else 8846 if Nkind (Parent (Op)) = N_Full_Type_Declaration then 8847 Error_Msg_N ("\possible interpretation (inherited)#", N); 8848 else 8849 Error_Msg_N -- CODEFIX 8850 ("\possible interpretation#", N); 8851 end if; 8852 end if; 8853 end Report_Ambiguity; 8854 8855 -------------------------------- 8856 -- Transform_Object_Operation -- 8857 -------------------------------- 8858 8859 procedure Transform_Object_Operation 8860 (Call_Node : out Node_Id; 8861 Node_To_Replace : out Node_Id) 8862 is 8863 Dummy : constant Node_Id := New_Copy (Obj); 8864 -- Placeholder used as a first parameter in the call, replaced 8865 -- eventually by the proper object. 8866 8867 Parent_Node : constant Node_Id := Parent (N); 8868 8869 Actual : Node_Id; 8870 Actuals : List_Id; 8871 8872 begin 8873 -- Obj may already have been rewritten if it involves an implicit 8874 -- dereference (e.g. if it is an access to a limited view). Preserve 8875 -- a link to the original node for ASIS use. 8876 8877 if not Comes_From_Source (Obj) then 8878 Set_Original_Node (Dummy, Original_Node (Obj)); 8879 end if; 8880 8881 -- Common case covering 1) Call to a procedure and 2) Call to a 8882 -- function that has some additional actuals. 8883 8884 if Nkind (Parent_Node) in N_Subprogram_Call 8885 8886 -- N is a selected component node containing the name of the 8887 -- subprogram. If N is not the name of the parent node we must 8888 -- not replace the parent node by the new construct. This case 8889 -- occurs when N is a parameterless call to a subprogram that 8890 -- is an actual parameter of a call to another subprogram. For 8891 -- example: 8892 -- Some_Subprogram (..., Obj.Operation, ...) 8893 8894 and then Name (Parent_Node) = N 8895 then 8896 Node_To_Replace := Parent_Node; 8897 8898 Actuals := Parameter_Associations (Parent_Node); 8899 8900 if Present (Actuals) then 8901 Prepend (Dummy, Actuals); 8902 else 8903 Actuals := New_List (Dummy); 8904 end if; 8905 8906 if Nkind (Parent_Node) = N_Procedure_Call_Statement then 8907 Call_Node := 8908 Make_Procedure_Call_Statement (Loc, 8909 Name => New_Copy (Subprog), 8910 Parameter_Associations => Actuals); 8911 8912 else 8913 Call_Node := 8914 Make_Function_Call (Loc, 8915 Name => New_Copy (Subprog), 8916 Parameter_Associations => Actuals); 8917 end if; 8918 8919 -- Before analysis, a function call appears as an indexed component 8920 -- if there are no named associations. 8921 8922 elsif Nkind (Parent_Node) = N_Indexed_Component 8923 and then N = Prefix (Parent_Node) 8924 then 8925 Node_To_Replace := Parent_Node; 8926 Actuals := Expressions (Parent_Node); 8927 8928 Actual := First (Actuals); 8929 while Present (Actual) loop 8930 Analyze (Actual); 8931 Next (Actual); 8932 end loop; 8933 8934 Prepend (Dummy, Actuals); 8935 8936 Call_Node := 8937 Make_Function_Call (Loc, 8938 Name => New_Copy (Subprog), 8939 Parameter_Associations => Actuals); 8940 8941 -- Parameterless call: Obj.F is rewritten as F (Obj) 8942 8943 else 8944 Node_To_Replace := N; 8945 8946 Call_Node := 8947 Make_Function_Call (Loc, 8948 Name => New_Copy (Subprog), 8949 Parameter_Associations => New_List (Dummy)); 8950 end if; 8951 end Transform_Object_Operation; 8952 8953 ------------------------------ 8954 -- Try_Class_Wide_Operation -- 8955 ------------------------------ 8956 8957 function Try_Class_Wide_Operation 8958 (Call_Node : Node_Id; 8959 Node_To_Replace : Node_Id) return Boolean 8960 is 8961 Anc_Type : Entity_Id; 8962 Matching_Op : Entity_Id := Empty; 8963 Error : Boolean; 8964 8965 procedure Traverse_Homonyms 8966 (Anc_Type : Entity_Id; 8967 Error : out Boolean); 8968 -- Traverse the homonym chain of the subprogram searching for those 8969 -- homonyms whose first formal has the Anc_Type's class-wide type, 8970 -- or an anonymous access type designating the class-wide type. If 8971 -- an ambiguity is detected, then Error is set to True. 8972 8973 procedure Traverse_Interfaces 8974 (Anc_Type : Entity_Id; 8975 Error : out Boolean); 8976 -- Traverse the list of interfaces, if any, associated with Anc_Type 8977 -- and search for acceptable class-wide homonyms associated with each 8978 -- interface. If an ambiguity is detected, then Error is set to True. 8979 8980 ----------------------- 8981 -- Traverse_Homonyms -- 8982 ----------------------- 8983 8984 procedure Traverse_Homonyms 8985 (Anc_Type : Entity_Id; 8986 Error : out Boolean) 8987 is 8988 Cls_Type : Entity_Id; 8989 Hom : Entity_Id; 8990 Hom_Ref : Node_Id; 8991 Success : Boolean; 8992 8993 begin 8994 Error := False; 8995 8996 Cls_Type := Class_Wide_Type (Anc_Type); 8997 8998 Hom := Current_Entity (Subprog); 8999 9000 -- Find a non-hidden operation whose first parameter is of the 9001 -- class-wide type, a subtype thereof, or an anonymous access 9002 -- to same. If in an instance, the operation can be considered 9003 -- even if hidden (it may be hidden because the instantiation 9004 -- is expanded after the containing package has been analyzed). 9005 9006 while Present (Hom) loop 9007 if Ekind_In (Hom, E_Procedure, E_Function) 9008 and then (not Is_Hidden (Hom) or else In_Instance) 9009 and then Scope (Hom) = Scope (Base_Type (Anc_Type)) 9010 and then Present (First_Formal (Hom)) 9011 and then 9012 (Base_Type (Etype (First_Formal (Hom))) = Cls_Type 9013 or else 9014 (Is_Access_Type (Etype (First_Formal (Hom))) 9015 and then 9016 Ekind (Etype (First_Formal (Hom))) = 9017 E_Anonymous_Access_Type 9018 and then 9019 Base_Type 9020 (Designated_Type (Etype (First_Formal (Hom)))) = 9021 Cls_Type)) 9022 then 9023 -- If the context is a procedure call, ignore functions 9024 -- in the name of the call. 9025 9026 if Ekind (Hom) = E_Function 9027 and then Nkind (Parent (N)) = N_Procedure_Call_Statement 9028 and then N = Name (Parent (N)) 9029 then 9030 goto Next_Hom; 9031 9032 -- If the context is a function call, ignore procedures 9033 -- in the name of the call. 9034 9035 elsif Ekind (Hom) = E_Procedure 9036 and then Nkind (Parent (N)) /= N_Procedure_Call_Statement 9037 then 9038 goto Next_Hom; 9039 end if; 9040 9041 Set_Etype (Call_Node, Any_Type); 9042 Set_Is_Overloaded (Call_Node, False); 9043 Success := False; 9044 9045 if No (Matching_Op) then 9046 Hom_Ref := New_Occurrence_Of (Hom, Sloc (Subprog)); 9047 Set_Etype (Call_Node, Any_Type); 9048 Set_Parent (Call_Node, Parent (Node_To_Replace)); 9049 9050 Set_Name (Call_Node, Hom_Ref); 9051 9052 Analyze_One_Call 9053 (N => Call_Node, 9054 Nam => Hom, 9055 Report => Report_Error, 9056 Success => Success, 9057 Skip_First => True); 9058 9059 Matching_Op := 9060 Valid_Candidate (Success, Call_Node, Hom); 9061 9062 else 9063 Analyze_One_Call 9064 (N => Call_Node, 9065 Nam => Hom, 9066 Report => Report_Error, 9067 Success => Success, 9068 Skip_First => True); 9069 9070 -- The same operation may be encountered on two homonym 9071 -- traversals, before and after looking at interfaces. 9072 -- Check for this case before reporting a real ambiguity. 9073 9074 if Present (Valid_Candidate (Success, Call_Node, Hom)) 9075 and then Nkind (Call_Node) /= N_Function_Call 9076 and then Hom /= Matching_Op 9077 then 9078 Error_Msg_NE ("ambiguous call to&", N, Hom); 9079 Report_Ambiguity (Matching_Op); 9080 Report_Ambiguity (Hom); 9081 Error := True; 9082 return; 9083 end if; 9084 end if; 9085 end if; 9086 9087 <<Next_Hom>> 9088 Hom := Homonym (Hom); 9089 end loop; 9090 end Traverse_Homonyms; 9091 9092 ------------------------- 9093 -- Traverse_Interfaces -- 9094 ------------------------- 9095 9096 procedure Traverse_Interfaces 9097 (Anc_Type : Entity_Id; 9098 Error : out Boolean) 9099 is 9100 Intface_List : constant List_Id := 9101 Abstract_Interface_List (Anc_Type); 9102 Intface : Node_Id; 9103 9104 begin 9105 Error := False; 9106 9107 if Is_Non_Empty_List (Intface_List) then 9108 Intface := First (Intface_List); 9109 while Present (Intface) loop 9110 9111 -- Look for acceptable class-wide homonyms associated with 9112 -- the interface. 9113 9114 Traverse_Homonyms (Etype (Intface), Error); 9115 9116 if Error then 9117 return; 9118 end if; 9119 9120 -- Continue the search by looking at each of the interface's 9121 -- associated interface ancestors. 9122 9123 Traverse_Interfaces (Etype (Intface), Error); 9124 9125 if Error then 9126 return; 9127 end if; 9128 9129 Next (Intface); 9130 end loop; 9131 end if; 9132 end Traverse_Interfaces; 9133 9134 -- Start of processing for Try_Class_Wide_Operation 9135 9136 begin 9137 -- If we are searching only for conflicting class-wide subprograms 9138 -- then initialize directly Matching_Op with the target entity. 9139 9140 if CW_Test_Only then 9141 Matching_Op := Entity (Selector_Name (N)); 9142 end if; 9143 9144 -- Loop through ancestor types (including interfaces), traversing 9145 -- the homonym chain of the subprogram, trying out those homonyms 9146 -- whose first formal has the class-wide type of the ancestor, or 9147 -- an anonymous access type designating the class-wide type. 9148 9149 Anc_Type := Obj_Type; 9150 loop 9151 -- Look for a match among homonyms associated with the ancestor 9152 9153 Traverse_Homonyms (Anc_Type, Error); 9154 9155 if Error then 9156 return True; 9157 end if; 9158 9159 -- Continue the search for matches among homonyms associated with 9160 -- any interfaces implemented by the ancestor. 9161 9162 Traverse_Interfaces (Anc_Type, Error); 9163 9164 if Error then 9165 return True; 9166 end if; 9167 9168 exit when Etype (Anc_Type) = Anc_Type; 9169 Anc_Type := Etype (Anc_Type); 9170 end loop; 9171 9172 if Present (Matching_Op) then 9173 Set_Etype (Call_Node, Etype (Matching_Op)); 9174 end if; 9175 9176 return Present (Matching_Op); 9177 end Try_Class_Wide_Operation; 9178 9179 ----------------------------------- 9180 -- Try_One_Prefix_Interpretation -- 9181 ----------------------------------- 9182 9183 procedure Try_One_Prefix_Interpretation (T : Entity_Id) is 9184 Prev_Obj_Type : constant Entity_Id := Obj_Type; 9185 -- If the interpretation does not have a valid candidate type, 9186 -- preserve current value of Obj_Type for subsequent errors. 9187 9188 begin 9189 Obj_Type := T; 9190 9191 if Is_Access_Type (Obj_Type) then 9192 Obj_Type := Designated_Type (Obj_Type); 9193 end if; 9194 9195 if Ekind_In (Obj_Type, E_Private_Subtype, 9196 E_Record_Subtype_With_Private) 9197 then 9198 Obj_Type := Base_Type (Obj_Type); 9199 end if; 9200 9201 if Is_Class_Wide_Type (Obj_Type) then 9202 Obj_Type := Etype (Class_Wide_Type (Obj_Type)); 9203 end if; 9204 9205 -- The type may have be obtained through a limited_with clause, 9206 -- in which case the primitive operations are available on its 9207 -- nonlimited view. If still incomplete, retrieve full view. 9208 9209 if Ekind (Obj_Type) = E_Incomplete_Type 9210 and then From_Limited_With (Obj_Type) 9211 and then Has_Non_Limited_View (Obj_Type) 9212 then 9213 Obj_Type := Get_Full_View (Non_Limited_View (Obj_Type)); 9214 end if; 9215 9216 -- If the object is not tagged, or the type is still an incomplete 9217 -- type, this is not a prefixed call. Restore the previous type as 9218 -- the current one is not a legal candidate. 9219 9220 if not Is_Tagged_Type (Obj_Type) 9221 or else Is_Incomplete_Type (Obj_Type) 9222 then 9223 Obj_Type := Prev_Obj_Type; 9224 return; 9225 end if; 9226 9227 declare 9228 Dup_Call_Node : constant Node_Id := New_Copy (New_Call_Node); 9229 Ignore : Boolean; 9230 Prim_Result : Boolean := False; 9231 9232 begin 9233 if not CW_Test_Only then 9234 Prim_Result := 9235 Try_Primitive_Operation 9236 (Call_Node => New_Call_Node, 9237 Node_To_Replace => Node_To_Replace); 9238 end if; 9239 9240 -- Check if there is a class-wide subprogram covering the 9241 -- primitive. This check must be done even if a candidate 9242 -- was found in order to report ambiguous calls. 9243 9244 if not Prim_Result then 9245 Ignore := 9246 Try_Class_Wide_Operation 9247 (Call_Node => New_Call_Node, 9248 Node_To_Replace => Node_To_Replace); 9249 9250 -- If we found a primitive we search for class-wide subprograms 9251 -- using a duplicate of the call node (done to avoid missing its 9252 -- decoration if there is no ambiguity). 9253 9254 else 9255 Ignore := 9256 Try_Class_Wide_Operation 9257 (Call_Node => Dup_Call_Node, 9258 Node_To_Replace => Node_To_Replace); 9259 end if; 9260 end; 9261 end Try_One_Prefix_Interpretation; 9262 9263 ----------------------------- 9264 -- Try_Primitive_Operation -- 9265 ----------------------------- 9266 9267 function Try_Primitive_Operation 9268 (Call_Node : Node_Id; 9269 Node_To_Replace : Node_Id) return Boolean 9270 is 9271 Elmt : Elmt_Id; 9272 Prim_Op : Entity_Id; 9273 Matching_Op : Entity_Id := Empty; 9274 Prim_Op_Ref : Node_Id := Empty; 9275 9276 Corr_Type : Entity_Id := Empty; 9277 -- If the prefix is a synchronized type, the controlling type of 9278 -- the primitive operation is the corresponding record type, else 9279 -- this is the object type itself. 9280 9281 Success : Boolean := False; 9282 9283 function Collect_Generic_Type_Ops (T : Entity_Id) return Elist_Id; 9284 -- For tagged types the candidate interpretations are found in 9285 -- the list of primitive operations of the type and its ancestors. 9286 -- For formal tagged types we have to find the operations declared 9287 -- in the same scope as the type (including in the generic formal 9288 -- part) because the type itself carries no primitive operations, 9289 -- except for formal derived types that inherit the operations of 9290 -- the parent and progenitors. 9291 -- 9292 -- If the context is a generic subprogram body, the generic formals 9293 -- are visible by name, but are not in the entity list of the 9294 -- subprogram because that list starts with the subprogram formals. 9295 -- We retrieve the candidate operations from the generic declaration. 9296 9297 function Extended_Primitive_Ops (T : Entity_Id) return Elist_Id; 9298 -- Prefix notation can also be used on operations that are not 9299 -- primitives of the type, but are declared in the same immediate 9300 -- declarative part, which can only mean the corresponding package 9301 -- body (See RM 4.1.3 (9.2/3)). If we are in that body we extend the 9302 -- list of primitives with body operations with the same name that 9303 -- may be candidates, so that Try_Primitive_Operations can examine 9304 -- them if no real primitive is found. 9305 9306 function Is_Private_Overriding (Op : Entity_Id) return Boolean; 9307 -- An operation that overrides an inherited operation in the private 9308 -- part of its package may be hidden, but if the inherited operation 9309 -- is visible a direct call to it will dispatch to the private one, 9310 -- which is therefore a valid candidate. 9311 9312 function Names_Match 9313 (Obj_Type : Entity_Id; 9314 Prim_Op : Entity_Id; 9315 Subprog : Entity_Id) return Boolean; 9316 -- Return True if the names of Prim_Op and Subprog match. If Obj_Type 9317 -- is a protected type then compare also the original name of Prim_Op 9318 -- with the name of Subprog (since the expander may have added a 9319 -- prefix to its original name --see Exp_Ch9.Build_Selected_Name). 9320 9321 function Valid_First_Argument_Of (Op : Entity_Id) return Boolean; 9322 -- Verify that the prefix, dereferenced if need be, is a valid 9323 -- controlling argument in a call to Op. The remaining actuals 9324 -- are checked in the subsequent call to Analyze_One_Call. 9325 9326 ------------------------------ 9327 -- Collect_Generic_Type_Ops -- 9328 ------------------------------ 9329 9330 function Collect_Generic_Type_Ops (T : Entity_Id) return Elist_Id is 9331 Bas : constant Entity_Id := Base_Type (T); 9332 Candidates : constant Elist_Id := New_Elmt_List; 9333 Subp : Entity_Id; 9334 Formal : Entity_Id; 9335 9336 procedure Check_Candidate; 9337 -- The operation is a candidate if its first parameter is a 9338 -- controlling operand of the desired type. 9339 9340 ----------------------- 9341 -- Check_Candidate; -- 9342 ----------------------- 9343 9344 procedure Check_Candidate is 9345 begin 9346 Formal := First_Formal (Subp); 9347 9348 if Present (Formal) 9349 and then Is_Controlling_Formal (Formal) 9350 and then 9351 (Base_Type (Etype (Formal)) = Bas 9352 or else 9353 (Is_Access_Type (Etype (Formal)) 9354 and then Designated_Type (Etype (Formal)) = Bas)) 9355 then 9356 Append_Elmt (Subp, Candidates); 9357 end if; 9358 end Check_Candidate; 9359 9360 -- Start of processing for Collect_Generic_Type_Ops 9361 9362 begin 9363 if Is_Derived_Type (T) then 9364 return Primitive_Operations (T); 9365 9366 elsif Ekind_In (Scope (T), E_Procedure, E_Function) then 9367 9368 -- Scan the list of generic formals to find subprograms 9369 -- that may have a first controlling formal of the type. 9370 9371 if Nkind (Unit_Declaration_Node (Scope (T))) = 9372 N_Generic_Subprogram_Declaration 9373 then 9374 declare 9375 Decl : Node_Id; 9376 9377 begin 9378 Decl := 9379 First (Generic_Formal_Declarations 9380 (Unit_Declaration_Node (Scope (T)))); 9381 while Present (Decl) loop 9382 if Nkind (Decl) in N_Formal_Subprogram_Declaration then 9383 Subp := Defining_Entity (Decl); 9384 Check_Candidate; 9385 end if; 9386 9387 Next (Decl); 9388 end loop; 9389 end; 9390 end if; 9391 return Candidates; 9392 9393 else 9394 -- Scan the list of entities declared in the same scope as 9395 -- the type. In general this will be an open scope, given that 9396 -- the call we are analyzing can only appear within a generic 9397 -- declaration or body (either the one that declares T, or a 9398 -- child unit). 9399 9400 -- For a subtype representing a generic actual type, go to the 9401 -- base type. 9402 9403 if Is_Generic_Actual_Type (T) then 9404 Subp := First_Entity (Scope (Base_Type (T))); 9405 else 9406 Subp := First_Entity (Scope (T)); 9407 end if; 9408 9409 while Present (Subp) loop 9410 if Is_Overloadable (Subp) then 9411 Check_Candidate; 9412 end if; 9413 9414 Next_Entity (Subp); 9415 end loop; 9416 9417 return Candidates; 9418 end if; 9419 end Collect_Generic_Type_Ops; 9420 9421 ---------------------------- 9422 -- Extended_Primitive_Ops -- 9423 ---------------------------- 9424 9425 function Extended_Primitive_Ops (T : Entity_Id) return Elist_Id is 9426 Type_Scope : constant Entity_Id := Scope (T); 9427 9428 Body_Decls : List_Id; 9429 Op_Found : Boolean; 9430 Op : Entity_Id; 9431 Op_List : Elist_Id; 9432 9433 begin 9434 Op_List := Primitive_Operations (T); 9435 9436 if Ekind (Type_Scope) = E_Package 9437 and then In_Package_Body (Type_Scope) 9438 and then In_Open_Scopes (Type_Scope) 9439 then 9440 -- Retrieve list of declarations of package body. 9441 9442 Body_Decls := 9443 Declarations 9444 (Unit_Declaration_Node 9445 (Corresponding_Body 9446 (Unit_Declaration_Node (Type_Scope)))); 9447 9448 Op := Current_Entity (Subprog); 9449 Op_Found := False; 9450 while Present (Op) loop 9451 if Comes_From_Source (Op) 9452 and then Is_Overloadable (Op) 9453 9454 -- Exclude overriding primitive operations of a type 9455 -- extension declared in the package body, to prevent 9456 -- duplicates in extended list. 9457 9458 and then not Is_Primitive (Op) 9459 and then Is_List_Member (Unit_Declaration_Node (Op)) 9460 and then List_Containing (Unit_Declaration_Node (Op)) = 9461 Body_Decls 9462 then 9463 if not Op_Found then 9464 9465 -- Copy list of primitives so it is not affected for 9466 -- other uses. 9467 9468 Op_List := New_Copy_Elist (Op_List); 9469 Op_Found := True; 9470 end if; 9471 9472 Append_Elmt (Op, Op_List); 9473 end if; 9474 9475 Op := Homonym (Op); 9476 end loop; 9477 end if; 9478 9479 return Op_List; 9480 end Extended_Primitive_Ops; 9481 9482 --------------------------- 9483 -- Is_Private_Overriding -- 9484 --------------------------- 9485 9486 function Is_Private_Overriding (Op : Entity_Id) return Boolean is 9487 Visible_Op : Entity_Id; 9488 9489 begin 9490 -- The subprogram may be overloaded with both visible and private 9491 -- entities with the same name. We have to scan the chain of 9492 -- homonyms to determine whether there is a previous implicit 9493 -- declaration in the same scope that is overridden by the 9494 -- private candidate. 9495 9496 Visible_Op := Homonym (Op); 9497 while Present (Visible_Op) loop 9498 if Scope (Op) /= Scope (Visible_Op) then 9499 return False; 9500 9501 elsif not Comes_From_Source (Visible_Op) 9502 and then Alias (Visible_Op) = Op 9503 and then not Is_Hidden (Visible_Op) 9504 then 9505 return True; 9506 end if; 9507 9508 Visible_Op := Homonym (Visible_Op); 9509 end loop; 9510 9511 return False; 9512 end Is_Private_Overriding; 9513 9514 ----------------- 9515 -- Names_Match -- 9516 ----------------- 9517 9518 function Names_Match 9519 (Obj_Type : Entity_Id; 9520 Prim_Op : Entity_Id; 9521 Subprog : Entity_Id) return Boolean is 9522 begin 9523 -- Common case: exact match 9524 9525 if Chars (Prim_Op) = Chars (Subprog) then 9526 return True; 9527 9528 -- For protected type primitives the expander may have built the 9529 -- name of the dispatching primitive prepending the type name to 9530 -- avoid conflicts with the name of the protected subprogram (see 9531 -- Exp_Ch9.Build_Selected_Name). 9532 9533 elsif Is_Protected_Type (Obj_Type) then 9534 return 9535 Present (Original_Protected_Subprogram (Prim_Op)) 9536 and then Chars (Original_Protected_Subprogram (Prim_Op)) = 9537 Chars (Subprog); 9538 end if; 9539 9540 return False; 9541 end Names_Match; 9542 9543 ----------------------------- 9544 -- Valid_First_Argument_Of -- 9545 ----------------------------- 9546 9547 function Valid_First_Argument_Of (Op : Entity_Id) return Boolean is 9548 Typ : Entity_Id := Etype (First_Formal (Op)); 9549 9550 begin 9551 if Is_Concurrent_Type (Typ) 9552 and then Present (Corresponding_Record_Type (Typ)) 9553 then 9554 Typ := Corresponding_Record_Type (Typ); 9555 end if; 9556 9557 -- Simple case. Object may be a subtype of the tagged type or may 9558 -- be the corresponding record of a synchronized type. 9559 9560 return Obj_Type = Typ 9561 or else Base_Type (Obj_Type) = Typ 9562 or else Corr_Type = Typ 9563 9564 -- Object may be of a derived type whose parent has unknown 9565 -- discriminants, in which case the type matches the underlying 9566 -- record view of its base. 9567 9568 or else 9569 (Has_Unknown_Discriminants (Typ) 9570 and then Typ = Underlying_Record_View (Base_Type (Obj_Type))) 9571 9572 -- Prefix can be dereferenced 9573 9574 or else 9575 (Is_Access_Type (Corr_Type) 9576 and then Designated_Type (Corr_Type) = Typ) 9577 9578 -- Formal is an access parameter, for which the object can 9579 -- provide an access. 9580 9581 or else 9582 (Ekind (Typ) = E_Anonymous_Access_Type 9583 and then 9584 Base_Type (Designated_Type (Typ)) = Base_Type (Corr_Type)); 9585 end Valid_First_Argument_Of; 9586 9587 -- Start of processing for Try_Primitive_Operation 9588 9589 begin 9590 -- Look for subprograms in the list of primitive operations. The name 9591 -- must be identical, and the kind of call indicates the expected 9592 -- kind of operation (function or procedure). If the type is a 9593 -- (tagged) synchronized type, the primitive ops are attached to the 9594 -- corresponding record (base) type. 9595 9596 if Is_Concurrent_Type (Obj_Type) then 9597 if Present (Corresponding_Record_Type (Obj_Type)) then 9598 Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type)); 9599 Elmt := First_Elmt (Primitive_Operations (Corr_Type)); 9600 else 9601 Corr_Type := Obj_Type; 9602 Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type)); 9603 end if; 9604 9605 elsif not Is_Generic_Type (Obj_Type) then 9606 Corr_Type := Obj_Type; 9607 Elmt := First_Elmt (Extended_Primitive_Ops (Obj_Type)); 9608 9609 else 9610 Corr_Type := Obj_Type; 9611 Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type)); 9612 end if; 9613 9614 while Present (Elmt) loop 9615 Prim_Op := Node (Elmt); 9616 9617 if Names_Match (Obj_Type, Prim_Op, Subprog) 9618 and then Present (First_Formal (Prim_Op)) 9619 and then Valid_First_Argument_Of (Prim_Op) 9620 and then 9621 (Nkind (Call_Node) = N_Function_Call) 9622 = 9623 (Ekind (Prim_Op) = E_Function) 9624 then 9625 -- Ada 2005 (AI-251): If this primitive operation corresponds 9626 -- to an immediate ancestor interface there is no need to add 9627 -- it to the list of interpretations; the corresponding aliased 9628 -- primitive is also in this list of primitive operations and 9629 -- will be used instead. 9630 9631 if (Present (Interface_Alias (Prim_Op)) 9632 and then Is_Ancestor (Find_Dispatching_Type 9633 (Alias (Prim_Op)), Corr_Type)) 9634 9635 -- Do not consider hidden primitives unless the type is in an 9636 -- open scope or we are within an instance, where visibility 9637 -- is known to be correct, or else if this is an overriding 9638 -- operation in the private part for an inherited operation. 9639 9640 or else (Is_Hidden (Prim_Op) 9641 and then not Is_Immediately_Visible (Obj_Type) 9642 and then not In_Instance 9643 and then not Is_Private_Overriding (Prim_Op)) 9644 then 9645 goto Continue; 9646 end if; 9647 9648 Set_Etype (Call_Node, Any_Type); 9649 Set_Is_Overloaded (Call_Node, False); 9650 9651 if No (Matching_Op) then 9652 Prim_Op_Ref := New_Occurrence_Of (Prim_Op, Sloc (Subprog)); 9653 Candidate := Prim_Op; 9654 9655 Set_Parent (Call_Node, Parent (Node_To_Replace)); 9656 9657 Set_Name (Call_Node, Prim_Op_Ref); 9658 Success := False; 9659 9660 Analyze_One_Call 9661 (N => Call_Node, 9662 Nam => Prim_Op, 9663 Report => Report_Error, 9664 Success => Success, 9665 Skip_First => True); 9666 9667 Matching_Op := Valid_Candidate (Success, Call_Node, Prim_Op); 9668 9669 -- More than one interpretation, collect for subsequent 9670 -- disambiguation. If this is a procedure call and there 9671 -- is another match, report ambiguity now. 9672 9673 else 9674 Analyze_One_Call 9675 (N => Call_Node, 9676 Nam => Prim_Op, 9677 Report => Report_Error, 9678 Success => Success, 9679 Skip_First => True); 9680 9681 if Present (Valid_Candidate (Success, Call_Node, Prim_Op)) 9682 and then Nkind (Call_Node) /= N_Function_Call 9683 then 9684 Error_Msg_NE ("ambiguous call to&", N, Prim_Op); 9685 Report_Ambiguity (Matching_Op); 9686 Report_Ambiguity (Prim_Op); 9687 return True; 9688 end if; 9689 end if; 9690 end if; 9691 9692 <<Continue>> 9693 Next_Elmt (Elmt); 9694 end loop; 9695 9696 if Present (Matching_Op) then 9697 Set_Etype (Call_Node, Etype (Matching_Op)); 9698 end if; 9699 9700 return Present (Matching_Op); 9701 end Try_Primitive_Operation; 9702 9703 --------------------- 9704 -- Valid_Candidate -- 9705 --------------------- 9706 9707 function Valid_Candidate 9708 (Success : Boolean; 9709 Call : Node_Id; 9710 Subp : Entity_Id) return Entity_Id 9711 is 9712 Arr_Type : Entity_Id; 9713 Comp_Type : Entity_Id; 9714 9715 begin 9716 -- If the subprogram is a valid interpretation, record it in global 9717 -- variable Subprog, to collect all possible overloadings. 9718 9719 if Success then 9720 if Subp /= Entity (Subprog) then 9721 Add_One_Interp (Subprog, Subp, Etype (Subp)); 9722 end if; 9723 end if; 9724 9725 -- If the call may be an indexed call, retrieve component type of 9726 -- resulting expression, and add possible interpretation. 9727 9728 Arr_Type := Empty; 9729 Comp_Type := Empty; 9730 9731 if Nkind (Call) = N_Function_Call 9732 and then Nkind (Parent (N)) = N_Indexed_Component 9733 and then Needs_One_Actual (Subp) 9734 then 9735 if Is_Array_Type (Etype (Subp)) then 9736 Arr_Type := Etype (Subp); 9737 9738 elsif Is_Access_Type (Etype (Subp)) 9739 and then Is_Array_Type (Designated_Type (Etype (Subp))) 9740 then 9741 Arr_Type := Designated_Type (Etype (Subp)); 9742 end if; 9743 end if; 9744 9745 if Present (Arr_Type) then 9746 9747 -- Verify that the actuals (excluding the object) match the types 9748 -- of the indexes. 9749 9750 declare 9751 Actual : Node_Id; 9752 Index : Node_Id; 9753 9754 begin 9755 Actual := Next (First_Actual (Call)); 9756 Index := First_Index (Arr_Type); 9757 while Present (Actual) and then Present (Index) loop 9758 if not Has_Compatible_Type (Actual, Etype (Index)) then 9759 Arr_Type := Empty; 9760 exit; 9761 end if; 9762 9763 Next_Actual (Actual); 9764 Next_Index (Index); 9765 end loop; 9766 9767 if No (Actual) 9768 and then No (Index) 9769 and then Present (Arr_Type) 9770 then 9771 Comp_Type := Component_Type (Arr_Type); 9772 end if; 9773 end; 9774 9775 if Present (Comp_Type) 9776 and then Etype (Subprog) /= Comp_Type 9777 then 9778 Add_One_Interp (Subprog, Subp, Comp_Type); 9779 end if; 9780 end if; 9781 9782 if Etype (Call) /= Any_Type then 9783 return Subp; 9784 else 9785 return Empty; 9786 end if; 9787 end Valid_Candidate; 9788 9789 -- Start of processing for Try_Object_Operation 9790 9791 begin 9792 Analyze_Expression (Obj); 9793 9794 -- Analyze the actuals if node is known to be a subprogram call 9795 9796 if Is_Subprg_Call and then N = Name (Parent (N)) then 9797 Actual := First (Parameter_Associations (Parent (N))); 9798 while Present (Actual) loop 9799 Analyze_Expression (Actual); 9800 Next (Actual); 9801 end loop; 9802 end if; 9803 9804 -- Build a subprogram call node, using a copy of Obj as its first 9805 -- actual. This is a placeholder, to be replaced by an explicit 9806 -- dereference when needed. 9807 9808 Transform_Object_Operation 9809 (Call_Node => New_Call_Node, 9810 Node_To_Replace => Node_To_Replace); 9811 9812 Set_Etype (New_Call_Node, Any_Type); 9813 Set_Etype (Subprog, Any_Type); 9814 Set_Parent (New_Call_Node, Parent (Node_To_Replace)); 9815 9816 if not Is_Overloaded (Obj) then 9817 Try_One_Prefix_Interpretation (Obj_Type); 9818 9819 else 9820 declare 9821 I : Interp_Index; 9822 It : Interp; 9823 begin 9824 Get_First_Interp (Obj, I, It); 9825 while Present (It.Nam) loop 9826 Try_One_Prefix_Interpretation (It.Typ); 9827 Get_Next_Interp (I, It); 9828 end loop; 9829 end; 9830 end if; 9831 9832 if Etype (New_Call_Node) /= Any_Type then 9833 9834 -- No need to complete the tree transformations if we are only 9835 -- searching for conflicting class-wide subprograms 9836 9837 if CW_Test_Only then 9838 return False; 9839 else 9840 Complete_Object_Operation 9841 (Call_Node => New_Call_Node, 9842 Node_To_Replace => Node_To_Replace); 9843 return True; 9844 end if; 9845 9846 elsif Present (Candidate) then 9847 9848 -- The argument list is not type correct. Re-analyze with error 9849 -- reporting enabled, and use one of the possible candidates. 9850 -- In All_Errors_Mode, re-analyze all failed interpretations. 9851 9852 if All_Errors_Mode then 9853 Report_Error := True; 9854 if Try_Primitive_Operation 9855 (Call_Node => New_Call_Node, 9856 Node_To_Replace => Node_To_Replace) 9857 9858 or else 9859 Try_Class_Wide_Operation 9860 (Call_Node => New_Call_Node, 9861 Node_To_Replace => Node_To_Replace) 9862 then 9863 null; 9864 end if; 9865 9866 else 9867 Analyze_One_Call 9868 (N => New_Call_Node, 9869 Nam => Candidate, 9870 Report => True, 9871 Success => Success, 9872 Skip_First => True); 9873 end if; 9874 9875 -- No need for further errors 9876 9877 return True; 9878 9879 else 9880 -- There was no candidate operation, so report it as an error 9881 -- in the caller: Analyze_Selected_Component. 9882 9883 return False; 9884 end if; 9885 end Try_Object_Operation; 9886 9887 --------- 9888 -- wpo -- 9889 --------- 9890 9891 procedure wpo (T : Entity_Id) is 9892 Op : Entity_Id; 9893 E : Elmt_Id; 9894 9895 begin 9896 if not Is_Tagged_Type (T) then 9897 return; 9898 end if; 9899 9900 E := First_Elmt (Primitive_Operations (Base_Type (T))); 9901 while Present (E) loop 9902 Op := Node (E); 9903 Write_Int (Int (Op)); 9904 Write_Str (" === "); 9905 Write_Name (Chars (Op)); 9906 Write_Str (" in "); 9907 Write_Name (Chars (Scope (Op))); 9908 Next_Elmt (E); 9909 Write_Eol; 9910 end loop; 9911 end wpo; 9912 9913end Sem_Ch4; 9914