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