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