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