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