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