1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ R E S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2004, 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Atree; use Atree; 28with Checks; use Checks; 29with Debug; use Debug; 30with Debug_A; use Debug_A; 31with Einfo; use Einfo; 32with Errout; use Errout; 33with Expander; use Expander; 34with Exp_Ch7; use Exp_Ch7; 35with Exp_Tss; use Exp_Tss; 36with Exp_Util; use Exp_Util; 37with Freeze; use Freeze; 38with Itypes; use Itypes; 39with Lib; use Lib; 40with Lib.Xref; use Lib.Xref; 41with Namet; use Namet; 42with Nmake; use Nmake; 43with Nlists; use Nlists; 44with Opt; use Opt; 45with Output; use Output; 46with Restrict; use Restrict; 47with Rtsfind; use Rtsfind; 48with Sem; use Sem; 49with Sem_Aggr; use Sem_Aggr; 50with Sem_Attr; use Sem_Attr; 51with Sem_Cat; use Sem_Cat; 52with Sem_Ch4; use Sem_Ch4; 53with Sem_Ch6; use Sem_Ch6; 54with Sem_Ch8; use Sem_Ch8; 55with Sem_Disp; use Sem_Disp; 56with Sem_Dist; use Sem_Dist; 57with Sem_Elab; use Sem_Elab; 58with Sem_Eval; use Sem_Eval; 59with Sem_Intr; use Sem_Intr; 60with Sem_Util; use Sem_Util; 61with Sem_Type; use Sem_Type; 62with Sem_Warn; use Sem_Warn; 63with Sinfo; use Sinfo; 64with Snames; use Snames; 65with Stand; use Stand; 66with Stringt; use Stringt; 67with Targparm; use Targparm; 68with Tbuild; use Tbuild; 69with Uintp; use Uintp; 70with Urealp; use Urealp; 71 72package body Sem_Res is 73 74 ----------------------- 75 -- Local Subprograms -- 76 ----------------------- 77 78 -- Second pass (top-down) type checking and overload resolution procedures 79 -- Typ is the type required by context. These procedures propagate the 80 -- type information recursively to the descendants of N. If the node 81 -- is not overloaded, its Etype is established in the first pass. If 82 -- overloaded, the Resolve routines set the correct type. For arith. 83 -- operators, the Etype is the base type of the context. 84 85 -- Note that Resolve_Attribute is separated off in Sem_Attr 86 87 procedure Ambiguous_Character (C : Node_Id); 88 -- Give list of candidate interpretations when a character literal cannot 89 -- be resolved. 90 91 procedure Check_Direct_Boolean_Op (N : Node_Id); 92 -- N is a binary operator node which may possibly operate on Boolean 93 -- operands. If the operator does have Boolean operands, then a call is 94 -- made to check the restriction No_Direct_Boolean_Operators. 95 96 procedure Check_Discriminant_Use (N : Node_Id); 97 -- Enforce the restrictions on the use of discriminants when constraining 98 -- a component of a discriminated type (record or concurrent type). 99 100 procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id); 101 -- Given a node for an operator associated with type T, check that 102 -- the operator is visible. Operators all of whose operands are 103 -- universal must be checked for visibility during resolution 104 -- because their type is not determinable based on their operands. 105 106 function Check_Infinite_Recursion (N : Node_Id) return Boolean; 107 -- Given a call node, N, which is known to occur immediately within the 108 -- subprogram being called, determines whether it is a detectable case of 109 -- an infinite recursion, and if so, outputs appropriate messages. Returns 110 -- True if an infinite recursion is detected, and False otherwise. 111 112 procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id); 113 -- If the type of the object being initialized uses the secondary stack 114 -- directly or indirectly, create a transient scope for the call to the 115 -- init proc. This is because we do not create transient scopes for the 116 -- initialization of individual components within the init proc itself. 117 -- Could be optimized away perhaps? 118 119 function Is_Predefined_Op (Nam : Entity_Id) return Boolean; 120 -- Utility to check whether the name in the call is a predefined 121 -- operator, in which case the call is made into an operator node. 122 -- An instance of an intrinsic conversion operation may be given 123 -- an operator name, but is not treated like an operator. 124 125 procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id); 126 -- If a default expression in entry call N depends on the discriminants 127 -- of the task, it must be replaced with a reference to the discriminant 128 -- of the task being called. 129 130 procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id); 131 procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id); 132 procedure Resolve_Call (N : Node_Id; Typ : Entity_Id); 133 procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id); 134 procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id); 135 procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id); 136 procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id); 137 procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id); 138 procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id); 139 procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id); 140 procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id); 141 procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id); 142 procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id); 143 procedure Resolve_Null (N : Node_Id; Typ : Entity_Id); 144 procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id); 145 procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id); 146 procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id); 147 procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id); 148 procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id); 149 procedure Resolve_Range (N : Node_Id; Typ : Entity_Id); 150 procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id); 151 procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id); 152 procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id); 153 procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id); 154 procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id); 155 procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id); 156 procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id); 157 procedure Resolve_Subprogram_Info (N : Node_Id; Typ : Entity_Id); 158 procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id); 159 procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id); 160 procedure Resolve_Unchecked_Expression (N : Node_Id; Typ : Entity_Id); 161 procedure Resolve_Unchecked_Type_Conversion (N : Node_Id; Typ : Entity_Id); 162 163 function Operator_Kind 164 (Op_Name : Name_Id; 165 Is_Binary : Boolean) 166 return Node_Kind; 167 -- Utility to map the name of an operator into the corresponding Node. Used 168 -- by other node rewriting procedures. 169 170 procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id); 171 -- Resolve actuals of call, and add default expressions for missing ones. 172 173 procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id); 174 -- Called from Resolve_Call, when the prefix denotes an entry or element 175 -- of entry family. Actuals are resolved as for subprograms, and the node 176 -- is rebuilt as an entry call. Also called for protected operations. Typ 177 -- is the context type, which is used when the operation is a protected 178 -- function with no arguments, and the return value is indexed. 179 180 procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id); 181 -- A call to a user-defined intrinsic operator is rewritten as a call 182 -- to the corresponding predefined operator, with suitable conversions. 183 184 procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id); 185 -- Ditto, for unary operators (only arithmetic ones). 186 187 procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id); 188 -- If an operator node resolves to a call to a user-defined operator, 189 -- rewrite the node as a function call. 190 191 procedure Make_Call_Into_Operator 192 (N : Node_Id; 193 Typ : Entity_Id; 194 Op_Id : Entity_Id); 195 -- Inverse transformation: if an operator is given in functional notation, 196 -- then after resolving the node, transform into an operator node, so 197 -- that operands are resolved properly. Recall that predefined operators 198 -- do not have a full signature and special resolution rules apply. 199 200 procedure Rewrite_Renamed_Operator (N : Node_Id; Op : Entity_Id); 201 -- An operator can rename another, e.g. in an instantiation. In that 202 -- case, the proper operator node must be constructed. 203 204 procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id); 205 -- The String_Literal_Subtype is built for all strings that are not 206 -- operands of a static concatenation operation. If the argument is 207 -- not a N_String_Literal node, then the call has no effect. 208 209 procedure Set_Slice_Subtype (N : Node_Id); 210 -- Build subtype of array type, with the range specified by the slice 211 212 function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id; 213 -- A universal_fixed expression in an universal context is unambiguous 214 -- if there is only one applicable fixed point type. Determining whether 215 -- there is only one requires a search over all visible entities, and 216 -- happens only in very pathological cases (see 6115-006). 217 218 function Valid_Conversion 219 (N : Node_Id; 220 Target : Entity_Id; 221 Operand : Node_Id) 222 return Boolean; 223 -- Verify legality rules given in 4.6 (8-23). Target is the target 224 -- type of the conversion, which may be an implicit conversion of 225 -- an actual parameter to an anonymous access type (in which case 226 -- N denotes the actual parameter and N = Operand). 227 228 ------------------------- 229 -- Ambiguous_Character -- 230 ------------------------- 231 232 procedure Ambiguous_Character (C : Node_Id) is 233 E : Entity_Id; 234 235 begin 236 if Nkind (C) = N_Character_Literal then 237 Error_Msg_N ("ambiguous character literal", C); 238 Error_Msg_N 239 ("\possible interpretations: Character, Wide_Character!", C); 240 241 E := Current_Entity (C); 242 243 if Present (E) then 244 245 while Present (E) loop 246 Error_Msg_NE ("\possible interpretation:}!", C, Etype (E)); 247 E := Homonym (E); 248 end loop; 249 end if; 250 end if; 251 end Ambiguous_Character; 252 253 ------------------------- 254 -- Analyze_And_Resolve -- 255 ------------------------- 256 257 procedure Analyze_And_Resolve (N : Node_Id) is 258 begin 259 Analyze (N); 260 Resolve (N); 261 end Analyze_And_Resolve; 262 263 procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id) is 264 begin 265 Analyze (N); 266 Resolve (N, Typ); 267 end Analyze_And_Resolve; 268 269 -- Version withs check(s) suppressed 270 271 procedure Analyze_And_Resolve 272 (N : Node_Id; 273 Typ : Entity_Id; 274 Suppress : Check_Id) 275 is 276 Scop : constant Entity_Id := Current_Scope; 277 278 begin 279 if Suppress = All_Checks then 280 declare 281 Svg : constant Suppress_Array := Scope_Suppress; 282 283 begin 284 Scope_Suppress := (others => True); 285 Analyze_And_Resolve (N, Typ); 286 Scope_Suppress := Svg; 287 end; 288 289 else 290 declare 291 Svg : constant Boolean := Scope_Suppress (Suppress); 292 293 begin 294 Scope_Suppress (Suppress) := True; 295 Analyze_And_Resolve (N, Typ); 296 Scope_Suppress (Suppress) := Svg; 297 end; 298 end if; 299 300 if Current_Scope /= Scop 301 and then Scope_Is_Transient 302 then 303 -- This can only happen if a transient scope was created 304 -- for an inner expression, which will be removed upon 305 -- completion of the analysis of an enclosing construct. 306 -- The transient scope must have the suppress status of 307 -- the enclosing environment, not of this Analyze call. 308 309 Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress := 310 Scope_Suppress; 311 end if; 312 end Analyze_And_Resolve; 313 314 procedure Analyze_And_Resolve 315 (N : Node_Id; 316 Suppress : Check_Id) 317 is 318 Scop : constant Entity_Id := Current_Scope; 319 320 begin 321 if Suppress = All_Checks then 322 declare 323 Svg : constant Suppress_Array := Scope_Suppress; 324 325 begin 326 Scope_Suppress := (others => True); 327 Analyze_And_Resolve (N); 328 Scope_Suppress := Svg; 329 end; 330 331 else 332 declare 333 Svg : constant Boolean := Scope_Suppress (Suppress); 334 335 begin 336 Scope_Suppress (Suppress) := True; 337 Analyze_And_Resolve (N); 338 Scope_Suppress (Suppress) := Svg; 339 end; 340 end if; 341 342 if Current_Scope /= Scop 343 and then Scope_Is_Transient 344 then 345 Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress := 346 Scope_Suppress; 347 end if; 348 end Analyze_And_Resolve; 349 350 ----------------------------- 351 -- Check_Direct_Boolean_Op -- 352 ----------------------------- 353 354 procedure Check_Direct_Boolean_Op (N : Node_Id) is 355 begin 356 if Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean then 357 Check_Restriction (No_Direct_Boolean_Operators, N); 358 end if; 359 end Check_Direct_Boolean_Op; 360 361 ---------------------------- 362 -- Check_Discriminant_Use -- 363 ---------------------------- 364 365 procedure Check_Discriminant_Use (N : Node_Id) is 366 PN : constant Node_Id := Parent (N); 367 Disc : constant Entity_Id := Entity (N); 368 P : Node_Id; 369 D : Node_Id; 370 371 begin 372 -- Any use in a default expression is legal. 373 374 if In_Default_Expression then 375 null; 376 377 elsif Nkind (PN) = N_Range then 378 379 -- Discriminant cannot be used to constrain a scalar type. 380 381 P := Parent (PN); 382 383 if Nkind (P) = N_Range_Constraint 384 and then Nkind (Parent (P)) = N_Subtype_Indication 385 and then Nkind (Parent (Parent (P))) = N_Component_Definition 386 then 387 Error_Msg_N ("discriminant cannot constrain scalar type", N); 388 389 elsif Nkind (P) = N_Index_Or_Discriminant_Constraint then 390 391 -- The following check catches the unusual case where 392 -- a discriminant appears within an index constraint 393 -- that is part of a larger expression within a constraint 394 -- on a component, e.g. "C : Int range 1 .. F (new A(1 .. D))". 395 -- For now we only check case of record components, and 396 -- note that a similar check should also apply in the 397 -- case of discriminant constraints below. ??? 398 399 -- Note that the check for N_Subtype_Declaration below is to 400 -- detect the valid use of discriminants in the constraints of a 401 -- subtype declaration when this subtype declaration appears 402 -- inside the scope of a record type (which is syntactically 403 -- illegal, but which may be created as part of derived type 404 -- processing for records). See Sem_Ch3.Build_Derived_Record_Type 405 -- for more info. 406 407 if Ekind (Current_Scope) = E_Record_Type 408 and then Scope (Disc) = Current_Scope 409 and then not 410 (Nkind (Parent (P)) = N_Subtype_Indication 411 and then 412 (Nkind (Parent (Parent (P))) = N_Component_Definition 413 or else 414 Nkind (Parent (Parent (P))) = N_Subtype_Declaration) 415 and then Paren_Count (N) = 0) 416 then 417 Error_Msg_N 418 ("discriminant must appear alone in component constraint", N); 419 return; 420 end if; 421 422 -- Detect a common beginner error: 423 424 -- type R (D : Positive := 100) is record 425 -- Name : String (1 .. D); 426 -- end record; 427 428 -- The default value causes an object of type R to be 429 -- allocated with room for Positive'Last characters. 430 431 declare 432 SI : Node_Id; 433 T : Entity_Id; 434 TB : Node_Id; 435 CB : Entity_Id; 436 437 function Large_Storage_Type (T : Entity_Id) return Boolean; 438 -- Return True if type T has a large enough range that 439 -- any array whose index type covered the whole range of 440 -- the type would likely raise Storage_Error. 441 442 ------------------------ 443 -- Large_Storage_Type -- 444 ------------------------ 445 446 function Large_Storage_Type (T : Entity_Id) return Boolean is 447 begin 448 return 449 T = Standard_Integer 450 or else 451 T = Standard_Positive 452 or else 453 T = Standard_Natural; 454 end Large_Storage_Type; 455 456 begin 457 -- Check that the Disc has a large range 458 459 if not Large_Storage_Type (Etype (Disc)) then 460 goto No_Danger; 461 end if; 462 463 -- If the enclosing type is limited, we allocate only the 464 -- default value, not the maximum, and there is no need for 465 -- a warning. 466 467 if Is_Limited_Type (Scope (Disc)) then 468 goto No_Danger; 469 end if; 470 471 -- Check that it is the high bound 472 473 if N /= High_Bound (PN) 474 or else not Present (Discriminant_Default_Value (Disc)) 475 then 476 goto No_Danger; 477 end if; 478 479 -- Check the array allows a large range at this bound. 480 -- First find the array 481 482 SI := Parent (P); 483 484 if Nkind (SI) /= N_Subtype_Indication then 485 goto No_Danger; 486 end if; 487 488 T := Entity (Subtype_Mark (SI)); 489 490 if not Is_Array_Type (T) then 491 goto No_Danger; 492 end if; 493 494 -- Next, find the dimension 495 496 TB := First_Index (T); 497 CB := First (Constraints (P)); 498 while True 499 and then Present (TB) 500 and then Present (CB) 501 and then CB /= PN 502 loop 503 Next_Index (TB); 504 Next (CB); 505 end loop; 506 507 if CB /= PN then 508 goto No_Danger; 509 end if; 510 511 -- Now, check the dimension has a large range 512 513 if not Large_Storage_Type (Etype (TB)) then 514 goto No_Danger; 515 end if; 516 517 -- Warn about the danger 518 519 Error_Msg_N 520 ("creation of & object may raise Storage_Error?", 521 Scope (Disc)); 522 523 <<No_Danger>> 524 null; 525 526 end; 527 end if; 528 529 -- Legal case is in index or discriminant constraint 530 531 elsif Nkind (PN) = N_Index_Or_Discriminant_Constraint 532 or else Nkind (PN) = N_Discriminant_Association 533 then 534 if Paren_Count (N) > 0 then 535 Error_Msg_N 536 ("discriminant in constraint must appear alone", N); 537 end if; 538 539 return; 540 541 -- Otherwise, context is an expression. It should not be within 542 -- (i.e. a subexpression of) a constraint for a component. 543 544 else 545 D := PN; 546 P := Parent (PN); 547 548 while Nkind (P) /= N_Component_Declaration 549 and then Nkind (P) /= N_Subtype_Indication 550 and then Nkind (P) /= N_Entry_Declaration 551 loop 552 D := P; 553 P := Parent (P); 554 exit when No (P); 555 end loop; 556 557 -- If the discriminant is used in an expression that is a bound 558 -- of a scalar type, an Itype is created and the bounds are attached 559 -- to its range, not to the original subtype indication. Such use 560 -- is of course a double fault. 561 562 if (Nkind (P) = N_Subtype_Indication 563 and then 564 (Nkind (Parent (P)) = N_Component_Definition 565 or else 566 Nkind (Parent (P)) = N_Derived_Type_Definition) 567 and then D = Constraint (P)) 568 569 -- The constraint itself may be given by a subtype indication, 570 -- rather than by a more common discrete range. 571 572 or else (Nkind (P) = N_Subtype_Indication 573 and then 574 Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint) 575 or else Nkind (P) = N_Entry_Declaration 576 or else Nkind (D) = N_Defining_Identifier 577 then 578 Error_Msg_N 579 ("discriminant in constraint must appear alone", N); 580 end if; 581 end if; 582 end Check_Discriminant_Use; 583 584 -------------------------------- 585 -- Check_For_Visible_Operator -- 586 -------------------------------- 587 588 procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is 589 begin 590 if Is_Invisible_Operator (N, T) then 591 Error_Msg_NE 592 ("operator for} is not directly visible!", N, First_Subtype (T)); 593 Error_Msg_N ("use clause would make operation legal!", N); 594 end if; 595 end Check_For_Visible_Operator; 596 597 ------------------------------ 598 -- Check_Infinite_Recursion -- 599 ------------------------------ 600 601 function Check_Infinite_Recursion (N : Node_Id) return Boolean is 602 P : Node_Id; 603 C : Node_Id; 604 605 function Same_Argument_List return Boolean; 606 -- Check whether list of actuals is identical to list of formals 607 -- of called function (which is also the enclosing scope). 608 609 ------------------------ 610 -- Same_Argument_List -- 611 ------------------------ 612 613 function Same_Argument_List return Boolean is 614 A : Node_Id; 615 F : Entity_Id; 616 Subp : Entity_Id; 617 618 begin 619 if not Is_Entity_Name (Name (N)) then 620 return False; 621 else 622 Subp := Entity (Name (N)); 623 end if; 624 625 F := First_Formal (Subp); 626 A := First_Actual (N); 627 628 while Present (F) and then Present (A) loop 629 if not Is_Entity_Name (A) 630 or else Entity (A) /= F 631 then 632 return False; 633 end if; 634 635 Next_Actual (A); 636 Next_Formal (F); 637 end loop; 638 639 return True; 640 end Same_Argument_List; 641 642 -- Start of processing for Check_Infinite_Recursion 643 644 begin 645 -- Loop moving up tree, quitting if something tells us we are 646 -- definitely not in an infinite recursion situation. 647 648 C := N; 649 loop 650 P := Parent (C); 651 exit when Nkind (P) = N_Subprogram_Body; 652 653 if Nkind (P) = N_Or_Else or else 654 Nkind (P) = N_And_Then or else 655 Nkind (P) = N_If_Statement or else 656 Nkind (P) = N_Case_Statement 657 then 658 return False; 659 660 elsif Nkind (P) = N_Handled_Sequence_Of_Statements 661 and then C /= First (Statements (P)) 662 then 663 -- If the call is the expression of a return statement and 664 -- the actuals are identical to the formals, it's worth a 665 -- warning. However, we skip this if there is an immediately 666 -- preceding raise statement, since the call is never executed. 667 668 -- Furthermore, this corresponds to a common idiom: 669 670 -- function F (L : Thing) return Boolean is 671 -- begin 672 -- raise Program_Error; 673 -- return F (L); 674 -- end F; 675 676 -- for generating a stub function 677 678 if Nkind (Parent (N)) = N_Return_Statement 679 and then Same_Argument_List 680 then 681 exit when not Is_List_Member (Parent (N)) 682 or else (Nkind (Prev (Parent (N))) /= N_Raise_Statement 683 and then 684 (Nkind (Prev (Parent (N))) not in N_Raise_xxx_Error 685 or else 686 Present (Condition (Prev (Parent (N)))))); 687 end if; 688 689 return False; 690 691 else 692 C := P; 693 end if; 694 end loop; 695 696 Error_Msg_N ("possible infinite recursion?", N); 697 Error_Msg_N ("\Storage_Error may be raised at run time?", N); 698 699 return True; 700 end Check_Infinite_Recursion; 701 702 ------------------------------- 703 -- Check_Initialization_Call -- 704 ------------------------------- 705 706 procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is 707 Typ : constant Entity_Id := Etype (First_Formal (Nam)); 708 709 function Uses_SS (T : Entity_Id) return Boolean; 710 -- Check whether the creation of an object of the type will involve 711 -- use of the secondary stack. If T is a record type, this is true 712 -- if the expression for some component uses the secondary stack, eg. 713 -- through a call to a function that returns an unconstrained value. 714 -- False if T is controlled, because cleanups occur elsewhere. 715 716 ------------- 717 -- Uses_SS -- 718 ------------- 719 720 function Uses_SS (T : Entity_Id) return Boolean is 721 Comp : Entity_Id; 722 Expr : Node_Id; 723 724 begin 725 if Is_Controlled (T) then 726 return False; 727 728 elsif Is_Array_Type (T) then 729 return Uses_SS (Component_Type (T)); 730 731 elsif Is_Record_Type (T) then 732 Comp := First_Component (T); 733 734 while Present (Comp) loop 735 736 if Ekind (Comp) = E_Component 737 and then Nkind (Parent (Comp)) = N_Component_Declaration 738 then 739 Expr := Expression (Parent (Comp)); 740 741 -- The expression for a dynamic component may be 742 -- rewritten as a dereference. Retrieve original 743 -- call. 744 745 if Nkind (Original_Node (Expr)) = N_Function_Call 746 and then Requires_Transient_Scope (Etype (Expr)) 747 then 748 return True; 749 750 elsif Uses_SS (Etype (Comp)) then 751 return True; 752 end if; 753 end if; 754 755 Next_Component (Comp); 756 end loop; 757 758 return False; 759 760 else 761 return False; 762 end if; 763 end Uses_SS; 764 765 -- Start of processing for Check_Initialization_Call 766 767 begin 768 -- Nothing to do if functions do not use the secondary stack for 769 -- returns (i.e. they use a depressed stack pointer instead). 770 771 if Functions_Return_By_DSP_On_Target then 772 return; 773 774 -- Otherwise establish a transient scope if the type needs it 775 776 elsif Uses_SS (Typ) then 777 Establish_Transient_Scope (First_Actual (N), Sec_Stack => True); 778 end if; 779 end Check_Initialization_Call; 780 781 ------------------------------ 782 -- Check_Parameterless_Call -- 783 ------------------------------ 784 785 procedure Check_Parameterless_Call (N : Node_Id) is 786 Nam : Node_Id; 787 788 begin 789 -- Defend against junk stuff if errors already detected 790 791 if Total_Errors_Detected /= 0 then 792 if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then 793 return; 794 elsif Nkind (N) in N_Has_Chars 795 and then Chars (N) in Error_Name_Or_No_Name 796 then 797 return; 798 end if; 799 800 Require_Entity (N); 801 end if; 802 803 -- Rewrite as call if overloadable entity that is (or could be, in 804 -- the overloaded case) a function call. If we know for sure that 805 -- the entity is an enumeration literal, we do not rewrite it. 806 807 if (Is_Entity_Name (N) 808 and then Is_Overloadable (Entity (N)) 809 and then (Ekind (Entity (N)) /= E_Enumeration_Literal 810 or else Is_Overloaded (N))) 811 812 -- Rewrite as call if it is an explicit deference of an expression of 813 -- a subprogram access type, and the suprogram type is not that of a 814 -- procedure or entry. 815 816 or else 817 (Nkind (N) = N_Explicit_Dereference 818 and then Ekind (Etype (N)) = E_Subprogram_Type 819 and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type) 820 821 -- Rewrite as call if it is a selected component which is a function, 822 -- this is the case of a call to a protected function (which may be 823 -- overloaded with other protected operations). 824 825 or else 826 (Nkind (N) = N_Selected_Component 827 and then (Ekind (Entity (Selector_Name (N))) = E_Function 828 or else 829 ((Ekind (Entity (Selector_Name (N))) = E_Entry 830 or else 831 Ekind (Entity (Selector_Name (N))) = E_Procedure) 832 and then Is_Overloaded (Selector_Name (N))))) 833 834 -- If one of the above three conditions is met, rewrite as call. 835 -- Apply the rewriting only once. 836 837 then 838 if Nkind (Parent (N)) /= N_Function_Call 839 or else N /= Name (Parent (N)) 840 then 841 Nam := New_Copy (N); 842 843 -- If overloaded, overload set belongs to new copy. 844 845 Save_Interps (N, Nam); 846 847 -- Change node to parameterless function call (note that the 848 -- Parameter_Associations associations field is left set to Empty, 849 -- its normal default value since there are no parameters) 850 851 Change_Node (N, N_Function_Call); 852 Set_Name (N, Nam); 853 Set_Sloc (N, Sloc (Nam)); 854 Analyze_Call (N); 855 end if; 856 857 elsif Nkind (N) = N_Parameter_Association then 858 Check_Parameterless_Call (Explicit_Actual_Parameter (N)); 859 end if; 860 end Check_Parameterless_Call; 861 862 ---------------------- 863 -- Is_Predefined_Op -- 864 ---------------------- 865 866 function Is_Predefined_Op (Nam : Entity_Id) return Boolean is 867 begin 868 return Is_Intrinsic_Subprogram (Nam) 869 and then not Is_Generic_Instance (Nam) 870 and then Chars (Nam) in Any_Operator_Name 871 and then (No (Alias (Nam)) 872 or else Is_Predefined_Op (Alias (Nam))); 873 end Is_Predefined_Op; 874 875 ----------------------------- 876 -- Make_Call_Into_Operator -- 877 ----------------------------- 878 879 procedure Make_Call_Into_Operator 880 (N : Node_Id; 881 Typ : Entity_Id; 882 Op_Id : Entity_Id) 883 is 884 Op_Name : constant Name_Id := Chars (Op_Id); 885 Act1 : Node_Id := First_Actual (N); 886 Act2 : Node_Id := Next_Actual (Act1); 887 Error : Boolean := False; 888 Is_Binary : constant Boolean := Present (Act2); 889 Op_Node : Node_Id; 890 Opnd_Type : Entity_Id; 891 Orig_Type : Entity_Id := Empty; 892 Pack : Entity_Id; 893 894 type Kind_Test is access function (E : Entity_Id) return Boolean; 895 896 function Is_Definite_Access_Type (E : Entity_Id) return Boolean; 897 -- Determine whether E is an access type declared by an access decla- 898 -- ration, and not an (anonymous) allocator type. 899 900 function Operand_Type_In_Scope (S : Entity_Id) return Boolean; 901 -- If the operand is not universal, and the operator is given by a 902 -- expanded name, verify that the operand has an interpretation with 903 -- a type defined in the given scope of the operator. 904 905 function Type_In_P (Test : Kind_Test) return Entity_Id; 906 -- Find a type of the given class in the package Pack that contains 907 -- the operator. 908 909 ----------------------------- 910 -- Is_Definite_Access_Type -- 911 ----------------------------- 912 913 function Is_Definite_Access_Type (E : Entity_Id) return Boolean is 914 Btyp : constant Entity_Id := Base_Type (E); 915 begin 916 return Ekind (Btyp) = E_Access_Type 917 or else (Ekind (Btyp) = E_Access_Subprogram_Type 918 and then Comes_From_Source (Btyp)); 919 end Is_Definite_Access_Type; 920 921 --------------------------- 922 -- Operand_Type_In_Scope -- 923 --------------------------- 924 925 function Operand_Type_In_Scope (S : Entity_Id) return Boolean is 926 Nod : constant Node_Id := Right_Opnd (Op_Node); 927 I : Interp_Index; 928 It : Interp; 929 930 begin 931 if not Is_Overloaded (Nod) then 932 return Scope (Base_Type (Etype (Nod))) = S; 933 934 else 935 Get_First_Interp (Nod, I, It); 936 937 while Present (It.Typ) loop 938 939 if Scope (Base_Type (It.Typ)) = S then 940 return True; 941 end if; 942 943 Get_Next_Interp (I, It); 944 end loop; 945 946 return False; 947 end if; 948 end Operand_Type_In_Scope; 949 950 --------------- 951 -- Type_In_P -- 952 --------------- 953 954 function Type_In_P (Test : Kind_Test) return Entity_Id is 955 E : Entity_Id; 956 957 function In_Decl return Boolean; 958 -- Verify that node is not part of the type declaration for the 959 -- candidate type, which would otherwise be invisible. 960 961 ------------- 962 -- In_Decl -- 963 ------------- 964 965 function In_Decl return Boolean is 966 Decl_Node : constant Node_Id := Parent (E); 967 N2 : Node_Id; 968 969 begin 970 N2 := N; 971 972 if Etype (E) = Any_Type then 973 return True; 974 975 elsif No (Decl_Node) then 976 return False; 977 978 else 979 while Present (N2) 980 and then Nkind (N2) /= N_Compilation_Unit 981 loop 982 if N2 = Decl_Node then 983 return True; 984 else 985 N2 := Parent (N2); 986 end if; 987 end loop; 988 989 return False; 990 end if; 991 end In_Decl; 992 993 -- Start of processing for Type_In_P 994 995 begin 996 -- If the context type is declared in the prefix package, this 997 -- is the desired base type. 998 999 if Scope (Base_Type (Typ)) = Pack 1000 and then Test (Typ) 1001 then 1002 return Base_Type (Typ); 1003 1004 else 1005 E := First_Entity (Pack); 1006 1007 while Present (E) loop 1008 1009 if Test (E) 1010 and then not In_Decl 1011 then 1012 return E; 1013 end if; 1014 1015 Next_Entity (E); 1016 end loop; 1017 1018 return Empty; 1019 end if; 1020 end Type_In_P; 1021 1022 -- Start of processing for Make_Call_Into_Operator 1023 1024 begin 1025 Op_Node := New_Node (Operator_Kind (Op_Name, Is_Binary), Sloc (N)); 1026 1027 -- Binary operator 1028 1029 if Is_Binary then 1030 Set_Left_Opnd (Op_Node, Relocate_Node (Act1)); 1031 Set_Right_Opnd (Op_Node, Relocate_Node (Act2)); 1032 Save_Interps (Act1, Left_Opnd (Op_Node)); 1033 Save_Interps (Act2, Right_Opnd (Op_Node)); 1034 Act1 := Left_Opnd (Op_Node); 1035 Act2 := Right_Opnd (Op_Node); 1036 1037 -- Unary operator 1038 1039 else 1040 Set_Right_Opnd (Op_Node, Relocate_Node (Act1)); 1041 Save_Interps (Act1, Right_Opnd (Op_Node)); 1042 Act1 := Right_Opnd (Op_Node); 1043 end if; 1044 1045 -- If the operator is denoted by an expanded name, and the prefix is 1046 -- not Standard, but the operator is a predefined one whose scope is 1047 -- Standard, then this is an implicit_operator, inserted as an 1048 -- interpretation by the procedure of the same name. This procedure 1049 -- overestimates the presence of implicit operators, because it does 1050 -- not examine the type of the operands. Verify now that the operand 1051 -- type appears in the given scope. If right operand is universal, 1052 -- check the other operand. In the case of concatenation, either 1053 -- argument can be the component type, so check the type of the result. 1054 -- If both arguments are literals, look for a type of the right kind 1055 -- defined in the given scope. This elaborate nonsense is brought to 1056 -- you courtesy of b33302a. The type itself must be frozen, so we must 1057 -- find the type of the proper class in the given scope. 1058 1059 -- A final wrinkle is the multiplication operator for fixed point 1060 -- types, which is defined in Standard only, and not in the scope of 1061 -- the fixed_point type itself. 1062 1063 if Nkind (Name (N)) = N_Expanded_Name then 1064 Pack := Entity (Prefix (Name (N))); 1065 1066 -- If the entity being called is defined in the given package, 1067 -- it is a renaming of a predefined operator, and known to be 1068 -- legal. 1069 1070 if Scope (Entity (Name (N))) = Pack 1071 and then Pack /= Standard_Standard 1072 then 1073 null; 1074 1075 elsif (Op_Name = Name_Op_Multiply 1076 or else Op_Name = Name_Op_Divide) 1077 and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node))) 1078 and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node))) 1079 then 1080 if Pack /= Standard_Standard then 1081 Error := True; 1082 end if; 1083 1084 else 1085 Opnd_Type := Base_Type (Etype (Right_Opnd (Op_Node))); 1086 1087 if Op_Name = Name_Op_Concat then 1088 Opnd_Type := Base_Type (Typ); 1089 1090 elsif (Scope (Opnd_Type) = Standard_Standard 1091 and then Is_Binary) 1092 or else (Nkind (Right_Opnd (Op_Node)) = N_Attribute_Reference 1093 and then Is_Binary 1094 and then not Comes_From_Source (Opnd_Type)) 1095 then 1096 Opnd_Type := Base_Type (Etype (Left_Opnd (Op_Node))); 1097 end if; 1098 1099 if Scope (Opnd_Type) = Standard_Standard then 1100 1101 -- Verify that the scope contains a type that corresponds to 1102 -- the given literal. Optimize the case where Pack is Standard. 1103 1104 if Pack /= Standard_Standard then 1105 1106 if Opnd_Type = Universal_Integer then 1107 Orig_Type := Type_In_P (Is_Integer_Type'Access); 1108 1109 elsif Opnd_Type = Universal_Real then 1110 Orig_Type := Type_In_P (Is_Real_Type'Access); 1111 1112 elsif Opnd_Type = Any_String then 1113 Orig_Type := Type_In_P (Is_String_Type'Access); 1114 1115 elsif Opnd_Type = Any_Access then 1116 Orig_Type := Type_In_P (Is_Definite_Access_Type'Access); 1117 1118 elsif Opnd_Type = Any_Composite then 1119 Orig_Type := Type_In_P (Is_Composite_Type'Access); 1120 1121 if Present (Orig_Type) then 1122 if Has_Private_Component (Orig_Type) then 1123 Orig_Type := Empty; 1124 else 1125 Set_Etype (Act1, Orig_Type); 1126 1127 if Is_Binary then 1128 Set_Etype (Act2, Orig_Type); 1129 end if; 1130 end if; 1131 end if; 1132 1133 else 1134 Orig_Type := Empty; 1135 end if; 1136 1137 Error := No (Orig_Type); 1138 end if; 1139 1140 elsif Ekind (Opnd_Type) = E_Allocator_Type 1141 and then No (Type_In_P (Is_Definite_Access_Type'Access)) 1142 then 1143 Error := True; 1144 1145 -- If the type is defined elsewhere, and the operator is not 1146 -- defined in the given scope (by a renaming declaration, e.g.) 1147 -- then this is an error as well. If an extension of System is 1148 -- present, and the type may be defined there, Pack must be 1149 -- System itself. 1150 1151 elsif Scope (Opnd_Type) /= Pack 1152 and then Scope (Op_Id) /= Pack 1153 and then (No (System_Aux_Id) 1154 or else Scope (Opnd_Type) /= System_Aux_Id 1155 or else Pack /= Scope (System_Aux_Id)) 1156 then 1157 Error := True; 1158 1159 elsif Pack = Standard_Standard 1160 and then not Operand_Type_In_Scope (Standard_Standard) 1161 then 1162 Error := True; 1163 end if; 1164 end if; 1165 1166 if Error then 1167 Error_Msg_Node_2 := Pack; 1168 Error_Msg_NE 1169 ("& not declared in&", N, Selector_Name (Name (N))); 1170 Set_Etype (N, Any_Type); 1171 return; 1172 end if; 1173 end if; 1174 1175 Set_Chars (Op_Node, Op_Name); 1176 1177 if not Is_Private_Type (Etype (N)) then 1178 Set_Etype (Op_Node, Base_Type (Etype (N))); 1179 else 1180 Set_Etype (Op_Node, Etype (N)); 1181 end if; 1182 1183 Set_Entity (Op_Node, Op_Id); 1184 Generate_Reference (Op_Id, N, ' '); 1185 Rewrite (N, Op_Node); 1186 1187 -- If this is an arithmetic operator and the result type is private, 1188 -- the operands and the result must be wrapped in conversion to 1189 -- expose the underlying numeric type and expand the proper checks, 1190 -- e.g. on division. 1191 1192 if Is_Private_Type (Typ) then 1193 case Nkind (N) is 1194 when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide | 1195 N_Op_Expon | N_Op_Mod | N_Op_Rem => 1196 Resolve_Intrinsic_Operator (N, Typ); 1197 1198 when N_Op_Plus | N_Op_Minus | N_Op_Abs => 1199 Resolve_Intrinsic_Unary_Operator (N, Typ); 1200 1201 when others => 1202 Resolve (N, Typ); 1203 end case; 1204 else 1205 Resolve (N, Typ); 1206 end if; 1207 1208 -- For predefined operators on literals, the operation freezes 1209 -- their type. 1210 1211 if Present (Orig_Type) then 1212 Set_Etype (Act1, Orig_Type); 1213 Freeze_Expression (Act1); 1214 end if; 1215 end Make_Call_Into_Operator; 1216 1217 ------------------- 1218 -- Operator_Kind -- 1219 ------------------- 1220 1221 function Operator_Kind 1222 (Op_Name : Name_Id; 1223 Is_Binary : Boolean) 1224 return Node_Kind 1225 is 1226 Kind : Node_Kind; 1227 1228 begin 1229 if Is_Binary then 1230 if Op_Name = Name_Op_And then Kind := N_Op_And; 1231 elsif Op_Name = Name_Op_Or then Kind := N_Op_Or; 1232 elsif Op_Name = Name_Op_Xor then Kind := N_Op_Xor; 1233 elsif Op_Name = Name_Op_Eq then Kind := N_Op_Eq; 1234 elsif Op_Name = Name_Op_Ne then Kind := N_Op_Ne; 1235 elsif Op_Name = Name_Op_Lt then Kind := N_Op_Lt; 1236 elsif Op_Name = Name_Op_Le then Kind := N_Op_Le; 1237 elsif Op_Name = Name_Op_Gt then Kind := N_Op_Gt; 1238 elsif Op_Name = Name_Op_Ge then Kind := N_Op_Ge; 1239 elsif Op_Name = Name_Op_Add then Kind := N_Op_Add; 1240 elsif Op_Name = Name_Op_Subtract then Kind := N_Op_Subtract; 1241 elsif Op_Name = Name_Op_Concat then Kind := N_Op_Concat; 1242 elsif Op_Name = Name_Op_Multiply then Kind := N_Op_Multiply; 1243 elsif Op_Name = Name_Op_Divide then Kind := N_Op_Divide; 1244 elsif Op_Name = Name_Op_Mod then Kind := N_Op_Mod; 1245 elsif Op_Name = Name_Op_Rem then Kind := N_Op_Rem; 1246 elsif Op_Name = Name_Op_Expon then Kind := N_Op_Expon; 1247 else 1248 raise Program_Error; 1249 end if; 1250 1251 -- Unary operators 1252 1253 else 1254 if Op_Name = Name_Op_Add then Kind := N_Op_Plus; 1255 elsif Op_Name = Name_Op_Subtract then Kind := N_Op_Minus; 1256 elsif Op_Name = Name_Op_Abs then Kind := N_Op_Abs; 1257 elsif Op_Name = Name_Op_Not then Kind := N_Op_Not; 1258 else 1259 raise Program_Error; 1260 end if; 1261 end if; 1262 1263 return Kind; 1264 end Operator_Kind; 1265 1266 ----------------------------- 1267 -- Pre_Analyze_And_Resolve -- 1268 ----------------------------- 1269 1270 procedure Pre_Analyze_And_Resolve (N : Node_Id; T : Entity_Id) is 1271 Save_Full_Analysis : constant Boolean := Full_Analysis; 1272 1273 begin 1274 Full_Analysis := False; 1275 Expander_Mode_Save_And_Set (False); 1276 1277 -- We suppress all checks for this analysis, since the checks will 1278 -- be applied properly, and in the right location, when the default 1279 -- expression is reanalyzed and reexpanded later on. 1280 1281 Analyze_And_Resolve (N, T, Suppress => All_Checks); 1282 1283 Expander_Mode_Restore; 1284 Full_Analysis := Save_Full_Analysis; 1285 end Pre_Analyze_And_Resolve; 1286 1287 -- Version without context type. 1288 1289 procedure Pre_Analyze_And_Resolve (N : Node_Id) is 1290 Save_Full_Analysis : constant Boolean := Full_Analysis; 1291 1292 begin 1293 Full_Analysis := False; 1294 Expander_Mode_Save_And_Set (False); 1295 1296 Analyze (N); 1297 Resolve (N, Etype (N), Suppress => All_Checks); 1298 1299 Expander_Mode_Restore; 1300 Full_Analysis := Save_Full_Analysis; 1301 end Pre_Analyze_And_Resolve; 1302 1303 ---------------------------------- 1304 -- Replace_Actual_Discriminants -- 1305 ---------------------------------- 1306 1307 procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id) is 1308 Loc : constant Source_Ptr := Sloc (N); 1309 Tsk : Node_Id := Empty; 1310 1311 function Process_Discr (Nod : Node_Id) return Traverse_Result; 1312 1313 ------------------- 1314 -- Process_Discr -- 1315 ------------------- 1316 1317 function Process_Discr (Nod : Node_Id) return Traverse_Result is 1318 Ent : Entity_Id; 1319 1320 begin 1321 if Nkind (Nod) = N_Identifier then 1322 Ent := Entity (Nod); 1323 1324 if Present (Ent) 1325 and then Ekind (Ent) = E_Discriminant 1326 then 1327 Rewrite (Nod, 1328 Make_Selected_Component (Loc, 1329 Prefix => New_Copy_Tree (Tsk, New_Sloc => Loc), 1330 Selector_Name => Make_Identifier (Loc, Chars (Ent)))); 1331 1332 Set_Etype (Nod, Etype (Ent)); 1333 end if; 1334 1335 end if; 1336 1337 return OK; 1338 end Process_Discr; 1339 1340 procedure Replace_Discrs is new Traverse_Proc (Process_Discr); 1341 1342 -- Start of processing for Replace_Actual_Discriminants 1343 1344 begin 1345 if not Expander_Active then 1346 return; 1347 end if; 1348 1349 if Nkind (Name (N)) = N_Selected_Component then 1350 Tsk := Prefix (Name (N)); 1351 1352 elsif Nkind (Name (N)) = N_Indexed_Component then 1353 Tsk := Prefix (Prefix (Name (N))); 1354 end if; 1355 1356 if No (Tsk) then 1357 return; 1358 else 1359 Replace_Discrs (Default); 1360 end if; 1361 end Replace_Actual_Discriminants; 1362 1363 ------------- 1364 -- Resolve -- 1365 ------------- 1366 1367 procedure Resolve (N : Node_Id; Typ : Entity_Id) is 1368 I : Interp_Index; 1369 I1 : Interp_Index := 0; -- prevent junk warning 1370 It : Interp; 1371 It1 : Interp; 1372 Found : Boolean := False; 1373 Seen : Entity_Id := Empty; -- prevent junk warning 1374 Ctx_Type : Entity_Id := Typ; 1375 Expr_Type : Entity_Id := Empty; -- prevent junk warning 1376 Err_Type : Entity_Id := Empty; 1377 Ambiguous : Boolean := False; 1378 1379 procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id); 1380 -- Try and fix up a literal so that it matches its expected type. New 1381 -- literals are manufactured if necessary to avoid cascaded errors. 1382 1383 procedure Resolution_Failed; 1384 -- Called when attempt at resolving current expression fails 1385 1386 -------------------- 1387 -- Patch_Up_Value -- 1388 -------------------- 1389 1390 procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id) is 1391 begin 1392 if Nkind (N) = N_Integer_Literal 1393 and then Is_Real_Type (Typ) 1394 then 1395 Rewrite (N, 1396 Make_Real_Literal (Sloc (N), 1397 Realval => UR_From_Uint (Intval (N)))); 1398 Set_Etype (N, Universal_Real); 1399 Set_Is_Static_Expression (N); 1400 1401 elsif Nkind (N) = N_Real_Literal 1402 and then Is_Integer_Type (Typ) 1403 then 1404 Rewrite (N, 1405 Make_Integer_Literal (Sloc (N), 1406 Intval => UR_To_Uint (Realval (N)))); 1407 Set_Etype (N, Universal_Integer); 1408 Set_Is_Static_Expression (N); 1409 elsif Nkind (N) = N_String_Literal 1410 and then Is_Character_Type (Typ) 1411 then 1412 Set_Character_Literal_Name (Char_Code (Character'Pos ('A'))); 1413 Rewrite (N, 1414 Make_Character_Literal (Sloc (N), 1415 Chars => Name_Find, 1416 Char_Literal_Value => Char_Code (Character'Pos ('A')))); 1417 Set_Etype (N, Any_Character); 1418 Set_Is_Static_Expression (N); 1419 1420 elsif Nkind (N) /= N_String_Literal 1421 and then Is_String_Type (Typ) 1422 then 1423 Rewrite (N, 1424 Make_String_Literal (Sloc (N), 1425 Strval => End_String)); 1426 1427 elsif Nkind (N) = N_Range then 1428 Patch_Up_Value (Low_Bound (N), Typ); 1429 Patch_Up_Value (High_Bound (N), Typ); 1430 end if; 1431 end Patch_Up_Value; 1432 1433 ----------------------- 1434 -- Resolution_Failed -- 1435 ----------------------- 1436 1437 procedure Resolution_Failed is 1438 begin 1439 Patch_Up_Value (N, Typ); 1440 Set_Etype (N, Typ); 1441 Debug_A_Exit ("resolving ", N, " (done, resolution failed)"); 1442 Set_Is_Overloaded (N, False); 1443 1444 -- The caller will return without calling the expander, so we need 1445 -- to set the analyzed flag. Note that it is fine to set Analyzed 1446 -- to True even if we are in the middle of a shallow analysis, 1447 -- (see the spec of sem for more details) since this is an error 1448 -- situation anyway, and there is no point in repeating the 1449 -- analysis later (indeed it won't work to repeat it later, since 1450 -- we haven't got a clear resolution of which entity is being 1451 -- referenced.) 1452 1453 Set_Analyzed (N, True); 1454 return; 1455 end Resolution_Failed; 1456 1457 -- Start of processing for Resolve 1458 1459 begin 1460 if N = Error then 1461 return; 1462 end if; 1463 1464 -- Access attribute on remote subprogram cannot be used for 1465 -- a non-remote access-to-subprogram type. 1466 1467 if Nkind (N) = N_Attribute_Reference 1468 and then (Attribute_Name (N) = Name_Access 1469 or else Attribute_Name (N) = Name_Unrestricted_Access 1470 or else Attribute_Name (N) = Name_Unchecked_Access) 1471 and then Comes_From_Source (N) 1472 and then Is_Entity_Name (Prefix (N)) 1473 and then Is_Subprogram (Entity (Prefix (N))) 1474 and then Is_Remote_Call_Interface (Entity (Prefix (N))) 1475 and then not Is_Remote_Access_To_Subprogram_Type (Typ) 1476 then 1477 Error_Msg_N 1478 ("prefix must statically denote a non-remote subprogram", N); 1479 end if; 1480 1481 -- If the context is a Remote_Access_To_Subprogram, access attributes 1482 -- must be resolved with the corresponding fat pointer. There is no need 1483 -- to check for the attribute name since the return type of an 1484 -- attribute is never a remote type. 1485 1486 if Nkind (N) = N_Attribute_Reference 1487 and then Comes_From_Source (N) 1488 and then (Is_Remote_Call_Interface (Typ) 1489 or else Is_Remote_Types (Typ)) 1490 then 1491 declare 1492 Attr : constant Attribute_Id := 1493 Get_Attribute_Id (Attribute_Name (N)); 1494 Pref : constant Node_Id := Prefix (N); 1495 Decl : Node_Id; 1496 Spec : Node_Id; 1497 Is_Remote : Boolean := True; 1498 1499 begin 1500 -- Check that Typ is a fat pointer with a reference to a RAS as 1501 -- original access type. 1502 1503 if 1504 (Ekind (Typ) = E_Access_Subprogram_Type 1505 and then Present (Equivalent_Type (Typ))) 1506 or else 1507 (Ekind (Typ) = E_Record_Type 1508 and then Present (Corresponding_Remote_Type (Typ))) 1509 1510 then 1511 -- Prefix (N) must statically denote a remote subprogram 1512 -- declared in a package specification. 1513 1514 if Attr = Attribute_Access then 1515 Decl := Unit_Declaration_Node (Entity (Pref)); 1516 1517 if Nkind (Decl) = N_Subprogram_Body then 1518 Spec := Corresponding_Spec (Decl); 1519 1520 if not No (Spec) then 1521 Decl := Unit_Declaration_Node (Spec); 1522 end if; 1523 end if; 1524 1525 Spec := Parent (Decl); 1526 1527 if not Is_Entity_Name (Prefix (N)) 1528 or else Nkind (Spec) /= N_Package_Specification 1529 or else 1530 not Is_Remote_Call_Interface (Defining_Entity (Spec)) 1531 then 1532 Is_Remote := False; 1533 Error_Msg_N 1534 ("prefix must statically denote a remote subprogram ", 1535 N); 1536 end if; 1537 end if; 1538 1539 -- If we are generating code for a distributed program. 1540 -- perform semantic checks against the corresponding 1541 -- remote entities. 1542 1543 if (Attr = Attribute_Access 1544 or else Attr = Attribute_Unchecked_Access 1545 or else Attr = Attribute_Unrestricted_Access) 1546 and then Expander_Active 1547 then 1548 Check_Subtype_Conformant 1549 (New_Id => Entity (Prefix (N)), 1550 Old_Id => Designated_Type 1551 (Corresponding_Remote_Type (Typ)), 1552 Err_Loc => N); 1553 if Is_Remote then 1554 Process_Remote_AST_Attribute (N, Typ); 1555 end if; 1556 end if; 1557 end if; 1558 end; 1559 end if; 1560 1561 Debug_A_Entry ("resolving ", N); 1562 1563 if Comes_From_Source (N) then 1564 if Is_Fixed_Point_Type (Typ) then 1565 Check_Restriction (No_Fixed_Point, N); 1566 1567 elsif Is_Floating_Point_Type (Typ) 1568 and then Typ /= Universal_Real 1569 and then Typ /= Any_Real 1570 then 1571 Check_Restriction (No_Floating_Point, N); 1572 end if; 1573 end if; 1574 1575 -- Return if already analyzed 1576 1577 if Analyzed (N) then 1578 Debug_A_Exit ("resolving ", N, " (done, already analyzed)"); 1579 return; 1580 1581 -- Return if type = Any_Type (previous error encountered) 1582 1583 elsif Etype (N) = Any_Type then 1584 Debug_A_Exit ("resolving ", N, " (done, Etype = Any_Type)"); 1585 return; 1586 end if; 1587 1588 Check_Parameterless_Call (N); 1589 1590 -- If not overloaded, then we know the type, and all that needs doing 1591 -- is to check that this type is compatible with the context. 1592 1593 if not Is_Overloaded (N) then 1594 Found := Covers (Typ, Etype (N)); 1595 Expr_Type := Etype (N); 1596 1597 -- In the overloaded case, we must select the interpretation that 1598 -- is compatible with the context (i.e. the type passed to Resolve) 1599 1600 else 1601 Get_First_Interp (N, I, It); 1602 1603 -- Loop through possible interpretations 1604 1605 Interp_Loop : while Present (It.Typ) loop 1606 1607 -- We are only interested in interpretations that are compatible 1608 -- with the expected type, any other interpretations are ignored 1609 1610 if not Covers (Typ, It.Typ) then 1611 if Debug_Flag_V then 1612 Write_Str (" interpretation incompatible with context"); 1613 Write_Eol; 1614 end if; 1615 1616 else 1617 -- First matching interpretation 1618 1619 if not Found then 1620 Found := True; 1621 I1 := I; 1622 Seen := It.Nam; 1623 Expr_Type := It.Typ; 1624 1625 -- Matching interpretation that is not the first, maybe an 1626 -- error, but there are some cases where preference rules are 1627 -- used to choose between the two possibilities. These and 1628 -- some more obscure cases are handled in Disambiguate. 1629 1630 else 1631 Error_Msg_Sloc := Sloc (Seen); 1632 It1 := Disambiguate (N, I1, I, Typ); 1633 1634 -- Disambiguation has succeeded. Skip the remaining 1635 -- interpretations. 1636 1637 if It1 /= No_Interp then 1638 Seen := It1.Nam; 1639 Expr_Type := It1.Typ; 1640 1641 while Present (It.Typ) loop 1642 Get_Next_Interp (I, It); 1643 end loop; 1644 1645 else 1646 -- Before we issue an ambiguity complaint, check for 1647 -- the case of a subprogram call where at least one 1648 -- of the arguments is Any_Type, and if so, suppress 1649 -- the message, since it is a cascaded error. 1650 1651 if Nkind (N) = N_Function_Call 1652 or else Nkind (N) = N_Procedure_Call_Statement 1653 then 1654 declare 1655 A : Node_Id := First_Actual (N); 1656 E : Node_Id; 1657 1658 begin 1659 while Present (A) loop 1660 E := A; 1661 1662 if Nkind (E) = N_Parameter_Association then 1663 E := Explicit_Actual_Parameter (E); 1664 end if; 1665 1666 if Etype (E) = Any_Type then 1667 if Debug_Flag_V then 1668 Write_Str ("Any_Type in call"); 1669 Write_Eol; 1670 end if; 1671 1672 exit Interp_Loop; 1673 end if; 1674 1675 Next_Actual (A); 1676 end loop; 1677 end; 1678 1679 elsif Nkind (N) in N_Binary_Op 1680 and then (Etype (Left_Opnd (N)) = Any_Type 1681 or else Etype (Right_Opnd (N)) = Any_Type) 1682 then 1683 exit Interp_Loop; 1684 1685 elsif Nkind (N) in N_Unary_Op 1686 and then Etype (Right_Opnd (N)) = Any_Type 1687 then 1688 exit Interp_Loop; 1689 end if; 1690 1691 -- Not that special case, so issue message using the 1692 -- flag Ambiguous to control printing of the header 1693 -- message only at the start of an ambiguous set. 1694 1695 if not Ambiguous then 1696 Error_Msg_NE 1697 ("ambiguous expression (cannot resolve&)!", 1698 N, It.Nam); 1699 1700 Error_Msg_N 1701 ("possible interpretation#!", N); 1702 Ambiguous := True; 1703 end if; 1704 1705 Error_Msg_Sloc := Sloc (It.Nam); 1706 1707 -- By default, the error message refers to the candidate 1708 -- interpretation. But if it is a predefined operator, 1709 -- it is implicitly declared at the declaration of 1710 -- the type of the operand. Recover the sloc of that 1711 -- declaration for the error message. 1712 1713 if Nkind (N) in N_Op 1714 and then Scope (It.Nam) = Standard_Standard 1715 and then not Is_Overloaded (Right_Opnd (N)) 1716 and then Scope (Base_Type (Etype (Right_Opnd (N)))) 1717 /= Standard_Standard 1718 then 1719 Err_Type := First_Subtype (Etype (Right_Opnd (N))); 1720 1721 if Comes_From_Source (Err_Type) 1722 and then Present (Parent (Err_Type)) 1723 then 1724 Error_Msg_Sloc := Sloc (Parent (Err_Type)); 1725 end if; 1726 1727 elsif Nkind (N) in N_Binary_Op 1728 and then Scope (It.Nam) = Standard_Standard 1729 and then not Is_Overloaded (Left_Opnd (N)) 1730 and then Scope (Base_Type (Etype (Left_Opnd (N)))) 1731 /= Standard_Standard 1732 then 1733 Err_Type := First_Subtype (Etype (Left_Opnd (N))); 1734 1735 if Comes_From_Source (Err_Type) 1736 and then Present (Parent (Err_Type)) 1737 then 1738 Error_Msg_Sloc := Sloc (Parent (Err_Type)); 1739 end if; 1740 else 1741 Err_Type := Empty; 1742 end if; 1743 1744 if Nkind (N) in N_Op 1745 and then Scope (It.Nam) = Standard_Standard 1746 and then Present (Err_Type) 1747 then 1748 Error_Msg_N 1749 ("possible interpretation (predefined)#!", N); 1750 else 1751 Error_Msg_N ("possible interpretation#!", N); 1752 end if; 1753 1754 end if; 1755 end if; 1756 1757 -- We have a matching interpretation, Expr_Type is the 1758 -- type from this interpretation, and Seen is the entity. 1759 1760 -- For an operator, just set the entity name. The type will 1761 -- be set by the specific operator resolution routine. 1762 1763 if Nkind (N) in N_Op then 1764 Set_Entity (N, Seen); 1765 Generate_Reference (Seen, N); 1766 1767 elsif Nkind (N) = N_Character_Literal then 1768 Set_Etype (N, Expr_Type); 1769 1770 -- For an explicit dereference, attribute reference, range, 1771 -- short-circuit form (which is not an operator node), 1772 -- or a call with a name that is an explicit dereference, 1773 -- there is nothing to be done at this point. 1774 1775 elsif Nkind (N) = N_Explicit_Dereference 1776 or else Nkind (N) = N_Attribute_Reference 1777 or else Nkind (N) = N_And_Then 1778 or else Nkind (N) = N_Indexed_Component 1779 or else Nkind (N) = N_Or_Else 1780 or else Nkind (N) = N_Range 1781 or else Nkind (N) = N_Selected_Component 1782 or else Nkind (N) = N_Slice 1783 or else Nkind (Name (N)) = N_Explicit_Dereference 1784 then 1785 null; 1786 1787 -- For procedure or function calls, set the type of the 1788 -- name, and also the entity pointer for the prefix 1789 1790 elsif (Nkind (N) = N_Procedure_Call_Statement 1791 or else Nkind (N) = N_Function_Call) 1792 and then (Is_Entity_Name (Name (N)) 1793 or else Nkind (Name (N)) = N_Operator_Symbol) 1794 then 1795 Set_Etype (Name (N), Expr_Type); 1796 Set_Entity (Name (N), Seen); 1797 Generate_Reference (Seen, Name (N)); 1798 1799 elsif Nkind (N) = N_Function_Call 1800 and then Nkind (Name (N)) = N_Selected_Component 1801 then 1802 Set_Etype (Name (N), Expr_Type); 1803 Set_Entity (Selector_Name (Name (N)), Seen); 1804 Generate_Reference (Seen, Selector_Name (Name (N))); 1805 1806 -- For all other cases, just set the type of the Name 1807 1808 else 1809 Set_Etype (Name (N), Expr_Type); 1810 end if; 1811 1812 end if; 1813 1814 -- Move to next interpretation 1815 1816 exit Interp_Loop when not Present (It.Typ); 1817 1818 Get_Next_Interp (I, It); 1819 end loop Interp_Loop; 1820 end if; 1821 1822 -- At this stage Found indicates whether or not an acceptable 1823 -- interpretation exists. If not, then we have an error, except 1824 -- that if the context is Any_Type as a result of some other error, 1825 -- then we suppress the error report. 1826 1827 if not Found then 1828 if Typ /= Any_Type then 1829 1830 -- If type we are looking for is Void, then this is the 1831 -- procedure call case, and the error is simply that what 1832 -- we gave is not a procedure name (we think of procedure 1833 -- calls as expressions with types internally, but the user 1834 -- doesn't think of them this way!) 1835 1836 if Typ = Standard_Void_Type then 1837 1838 -- Special case message if function used as a procedure 1839 1840 if Nkind (N) = N_Procedure_Call_Statement 1841 and then Is_Entity_Name (Name (N)) 1842 and then Ekind (Entity (Name (N))) = E_Function 1843 then 1844 Error_Msg_NE 1845 ("cannot use function & in a procedure call", 1846 Name (N), Entity (Name (N))); 1847 1848 -- Otherwise give general message (not clear what cases 1849 -- this covers, but no harm in providing for them!) 1850 1851 else 1852 Error_Msg_N ("expect procedure name in procedure call", N); 1853 end if; 1854 1855 Found := True; 1856 1857 -- Otherwise we do have a subexpression with the wrong type 1858 1859 -- Check for the case of an allocator which uses an access 1860 -- type instead of the designated type. This is a common 1861 -- error and we specialize the message, posting an error 1862 -- on the operand of the allocator, complaining that we 1863 -- expected the designated type of the allocator. 1864 1865 elsif Nkind (N) = N_Allocator 1866 and then Ekind (Typ) in Access_Kind 1867 and then Ekind (Etype (N)) in Access_Kind 1868 and then Designated_Type (Etype (N)) = Typ 1869 then 1870 Wrong_Type (Expression (N), Designated_Type (Typ)); 1871 Found := True; 1872 1873 -- Check for view mismatch on Null in instances, for 1874 -- which the view-swapping mechanism has no identifier. 1875 1876 elsif (In_Instance or else In_Inlined_Body) 1877 and then (Nkind (N) = N_Null) 1878 and then Is_Private_Type (Typ) 1879 and then Is_Access_Type (Full_View (Typ)) 1880 then 1881 Resolve (N, Full_View (Typ)); 1882 Set_Etype (N, Typ); 1883 return; 1884 1885 -- Check for an aggregate. Sometimes we can get bogus 1886 -- aggregates from misuse of parentheses, and we are 1887 -- about to complain about the aggregate without even 1888 -- looking inside it. 1889 1890 -- Instead, if we have an aggregate of type Any_Composite, 1891 -- then analyze and resolve the component fields, and then 1892 -- only issue another message if we get no errors doing 1893 -- this (otherwise assume that the errors in the aggregate 1894 -- caused the problem). 1895 1896 elsif Nkind (N) = N_Aggregate 1897 and then Etype (N) = Any_Composite 1898 then 1899 -- Disable expansion in any case. If there is a type mismatch 1900 -- it may be fatal to try to expand the aggregate. The flag 1901 -- would otherwise be set to false when the error is posted. 1902 1903 Expander_Active := False; 1904 1905 declare 1906 procedure Check_Aggr (Aggr : Node_Id); 1907 -- Check one aggregate, and set Found to True if we 1908 -- have a definite error in any of its elements 1909 1910 procedure Check_Elmt (Aelmt : Node_Id); 1911 -- Check one element of aggregate and set Found to 1912 -- True if we definitely have an error in the element. 1913 1914 procedure Check_Aggr (Aggr : Node_Id) is 1915 Elmt : Node_Id; 1916 1917 begin 1918 if Present (Expressions (Aggr)) then 1919 Elmt := First (Expressions (Aggr)); 1920 while Present (Elmt) loop 1921 Check_Elmt (Elmt); 1922 Next (Elmt); 1923 end loop; 1924 end if; 1925 1926 if Present (Component_Associations (Aggr)) then 1927 Elmt := First (Component_Associations (Aggr)); 1928 while Present (Elmt) loop 1929 Check_Elmt (Expression (Elmt)); 1930 Next (Elmt); 1931 end loop; 1932 end if; 1933 end Check_Aggr; 1934 1935 ---------------- 1936 -- Check_Elmt -- 1937 ---------------- 1938 1939 procedure Check_Elmt (Aelmt : Node_Id) is 1940 begin 1941 -- If we have a nested aggregate, go inside it (to 1942 -- attempt a naked analyze-resolve of the aggregate 1943 -- can cause undesirable cascaded errors). Do not 1944 -- resolve expression if it needs a type from context, 1945 -- as for integer * fixed expression. 1946 1947 if Nkind (Aelmt) = N_Aggregate then 1948 Check_Aggr (Aelmt); 1949 1950 else 1951 Analyze (Aelmt); 1952 1953 if not Is_Overloaded (Aelmt) 1954 and then Etype (Aelmt) /= Any_Fixed 1955 then 1956 Resolve (Aelmt); 1957 end if; 1958 1959 if Etype (Aelmt) = Any_Type then 1960 Found := True; 1961 end if; 1962 end if; 1963 end Check_Elmt; 1964 1965 begin 1966 Check_Aggr (N); 1967 end; 1968 end if; 1969 1970 -- If an error message was issued already, Found got reset 1971 -- to True, so if it is still False, issue the standard 1972 -- Wrong_Type message. 1973 1974 if not Found then 1975 if Is_Overloaded (N) 1976 and then Nkind (N) = N_Function_Call 1977 then 1978 declare 1979 Subp_Name : Node_Id; 1980 begin 1981 if Is_Entity_Name (Name (N)) then 1982 Subp_Name := Name (N); 1983 1984 elsif Nkind (Name (N)) = N_Selected_Component then 1985 1986 -- Protected operation: retrieve operation name. 1987 1988 Subp_Name := Selector_Name (Name (N)); 1989 else 1990 raise Program_Error; 1991 end if; 1992 1993 Error_Msg_Node_2 := Typ; 1994 Error_Msg_NE ("no visible interpretation of&" & 1995 " matches expected type&", N, Subp_Name); 1996 end; 1997 1998 if All_Errors_Mode then 1999 declare 2000 Index : Interp_Index; 2001 It : Interp; 2002 2003 begin 2004 Error_Msg_N ("\possible interpretations:", N); 2005 Get_First_Interp (Name (N), Index, It); 2006 2007 while Present (It.Nam) loop 2008 2009 Error_Msg_Sloc := Sloc (It.Nam); 2010 Error_Msg_Node_2 := It.Typ; 2011 Error_Msg_NE ("\& declared#, type&", 2012 N, It.Nam); 2013 2014 Get_Next_Interp (Index, It); 2015 end loop; 2016 end; 2017 else 2018 Error_Msg_N ("\use -gnatf for details", N); 2019 end if; 2020 else 2021 Wrong_Type (N, Typ); 2022 end if; 2023 end if; 2024 end if; 2025 2026 Resolution_Failed; 2027 return; 2028 2029 -- Test if we have more than one interpretation for the context 2030 2031 elsif Ambiguous then 2032 Resolution_Failed; 2033 return; 2034 2035 -- Here we have an acceptable interpretation for the context 2036 2037 else 2038 -- A user-defined operator is tranformed into a function call at 2039 -- this point, so that further processing knows that operators are 2040 -- really operators (i.e. are predefined operators). User-defined 2041 -- operators that are intrinsic are just renamings of the predefined 2042 -- ones, and need not be turned into calls either, but if they rename 2043 -- a different operator, we must transform the node accordingly. 2044 -- Instantiations of Unchecked_Conversion are intrinsic but are 2045 -- treated as functions, even if given an operator designator. 2046 2047 if Nkind (N) in N_Op 2048 and then Present (Entity (N)) 2049 and then Ekind (Entity (N)) /= E_Operator 2050 then 2051 2052 if not Is_Predefined_Op (Entity (N)) then 2053 Rewrite_Operator_As_Call (N, Entity (N)); 2054 2055 elsif Present (Alias (Entity (N))) then 2056 Rewrite_Renamed_Operator (N, Alias (Entity (N))); 2057 end if; 2058 end if; 2059 2060 -- Propagate type information and normalize tree for various 2061 -- predefined operations. If the context only imposes a class of 2062 -- types, rather than a specific type, propagate the actual type 2063 -- downward. 2064 2065 if Typ = Any_Integer 2066 or else Typ = Any_Boolean 2067 or else Typ = Any_Modular 2068 or else Typ = Any_Real 2069 or else Typ = Any_Discrete 2070 then 2071 Ctx_Type := Expr_Type; 2072 2073 -- Any_Fixed is legal in a real context only if a specific 2074 -- fixed point type is imposed. If Norman Cohen can be 2075 -- confused by this, it deserves a separate message. 2076 2077 if Typ = Any_Real 2078 and then Expr_Type = Any_Fixed 2079 then 2080 Error_Msg_N ("Illegal context for mixed mode operation", N); 2081 Set_Etype (N, Universal_Real); 2082 Ctx_Type := Universal_Real; 2083 end if; 2084 end if; 2085 2086 case N_Subexpr'(Nkind (N)) is 2087 2088 when N_Aggregate => Resolve_Aggregate (N, Ctx_Type); 2089 2090 when N_Allocator => Resolve_Allocator (N, Ctx_Type); 2091 2092 when N_And_Then | N_Or_Else 2093 => Resolve_Short_Circuit (N, Ctx_Type); 2094 2095 when N_Attribute_Reference 2096 => Resolve_Attribute (N, Ctx_Type); 2097 2098 when N_Character_Literal 2099 => Resolve_Character_Literal (N, Ctx_Type); 2100 2101 when N_Conditional_Expression 2102 => Resolve_Conditional_Expression (N, Ctx_Type); 2103 2104 when N_Expanded_Name 2105 => Resolve_Entity_Name (N, Ctx_Type); 2106 2107 when N_Extension_Aggregate 2108 => Resolve_Extension_Aggregate (N, Ctx_Type); 2109 2110 when N_Explicit_Dereference 2111 => Resolve_Explicit_Dereference (N, Ctx_Type); 2112 2113 when N_Function_Call 2114 => Resolve_Call (N, Ctx_Type); 2115 2116 when N_Identifier 2117 => Resolve_Entity_Name (N, Ctx_Type); 2118 2119 when N_In | N_Not_In 2120 => Resolve_Membership_Op (N, Ctx_Type); 2121 2122 when N_Indexed_Component 2123 => Resolve_Indexed_Component (N, Ctx_Type); 2124 2125 when N_Integer_Literal 2126 => Resolve_Integer_Literal (N, Ctx_Type); 2127 2128 when N_Null => Resolve_Null (N, Ctx_Type); 2129 2130 when N_Op_And | N_Op_Or | N_Op_Xor 2131 => Resolve_Logical_Op (N, Ctx_Type); 2132 2133 when N_Op_Eq | N_Op_Ne 2134 => Resolve_Equality_Op (N, Ctx_Type); 2135 2136 when N_Op_Lt | N_Op_Le | N_Op_Gt | N_Op_Ge 2137 => Resolve_Comparison_Op (N, Ctx_Type); 2138 2139 when N_Op_Not => Resolve_Op_Not (N, Ctx_Type); 2140 2141 when N_Op_Add | N_Op_Subtract | N_Op_Multiply | 2142 N_Op_Divide | N_Op_Mod | N_Op_Rem 2143 2144 => Resolve_Arithmetic_Op (N, Ctx_Type); 2145 2146 when N_Op_Concat => Resolve_Op_Concat (N, Ctx_Type); 2147 2148 when N_Op_Expon => Resolve_Op_Expon (N, Ctx_Type); 2149 2150 when N_Op_Plus | N_Op_Minus | N_Op_Abs 2151 => Resolve_Unary_Op (N, Ctx_Type); 2152 2153 when N_Op_Shift => Resolve_Shift (N, Ctx_Type); 2154 2155 when N_Procedure_Call_Statement 2156 => Resolve_Call (N, Ctx_Type); 2157 2158 when N_Operator_Symbol 2159 => Resolve_Operator_Symbol (N, Ctx_Type); 2160 2161 when N_Qualified_Expression 2162 => Resolve_Qualified_Expression (N, Ctx_Type); 2163 2164 when N_Raise_xxx_Error 2165 => Set_Etype (N, Ctx_Type); 2166 2167 when N_Range => Resolve_Range (N, Ctx_Type); 2168 2169 when N_Real_Literal 2170 => Resolve_Real_Literal (N, Ctx_Type); 2171 2172 when N_Reference => Resolve_Reference (N, Ctx_Type); 2173 2174 when N_Selected_Component 2175 => Resolve_Selected_Component (N, Ctx_Type); 2176 2177 when N_Slice => Resolve_Slice (N, Ctx_Type); 2178 2179 when N_String_Literal 2180 => Resolve_String_Literal (N, Ctx_Type); 2181 2182 when N_Subprogram_Info 2183 => Resolve_Subprogram_Info (N, Ctx_Type); 2184 2185 when N_Type_Conversion 2186 => Resolve_Type_Conversion (N, Ctx_Type); 2187 2188 when N_Unchecked_Expression => 2189 Resolve_Unchecked_Expression (N, Ctx_Type); 2190 2191 when N_Unchecked_Type_Conversion => 2192 Resolve_Unchecked_Type_Conversion (N, Ctx_Type); 2193 2194 end case; 2195 2196 -- If the subexpression was replaced by a non-subexpression, then 2197 -- all we do is to expand it. The only legitimate case we know of 2198 -- is converting procedure call statement to entry call statements, 2199 -- but there may be others, so we are making this test general. 2200 2201 if Nkind (N) not in N_Subexpr then 2202 Debug_A_Exit ("resolving ", N, " (done)"); 2203 Expand (N); 2204 return; 2205 end if; 2206 2207 -- The expression is definitely NOT overloaded at this point, so 2208 -- we reset the Is_Overloaded flag to avoid any confusion when 2209 -- reanalyzing the node. 2210 2211 Set_Is_Overloaded (N, False); 2212 2213 -- Freeze expression type, entity if it is a name, and designated 2214 -- type if it is an allocator (RM 13.14(10,11,13)). 2215 2216 -- Now that the resolution of the type of the node is complete, 2217 -- and we did not detect an error, we can expand this node. We 2218 -- skip the expand call if we are in a default expression, see 2219 -- section "Handling of Default Expressions" in Sem spec. 2220 2221 Debug_A_Exit ("resolving ", N, " (done)"); 2222 2223 -- We unconditionally freeze the expression, even if we are in 2224 -- default expression mode (the Freeze_Expression routine tests 2225 -- this flag and only freezes static types if it is set). 2226 2227 Freeze_Expression (N); 2228 2229 -- Now we can do the expansion 2230 2231 Expand (N); 2232 end if; 2233 end Resolve; 2234 2235 ------------- 2236 -- Resolve -- 2237 ------------- 2238 2239 -- Version with check(s) suppressed 2240 2241 procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is 2242 begin 2243 if Suppress = All_Checks then 2244 declare 2245 Svg : constant Suppress_Array := Scope_Suppress; 2246 2247 begin 2248 Scope_Suppress := (others => True); 2249 Resolve (N, Typ); 2250 Scope_Suppress := Svg; 2251 end; 2252 2253 else 2254 declare 2255 Svg : constant Boolean := Scope_Suppress (Suppress); 2256 2257 begin 2258 Scope_Suppress (Suppress) := True; 2259 Resolve (N, Typ); 2260 Scope_Suppress (Suppress) := Svg; 2261 end; 2262 end if; 2263 end Resolve; 2264 2265 ------------- 2266 -- Resolve -- 2267 ------------- 2268 2269 -- Version with implicit type 2270 2271 procedure Resolve (N : Node_Id) is 2272 begin 2273 Resolve (N, Etype (N)); 2274 end Resolve; 2275 2276 --------------------- 2277 -- Resolve_Actuals -- 2278 --------------------- 2279 2280 procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id) is 2281 Loc : constant Source_Ptr := Sloc (N); 2282 A : Node_Id; 2283 F : Entity_Id; 2284 A_Typ : Entity_Id; 2285 F_Typ : Entity_Id; 2286 Prev : Node_Id := Empty; 2287 2288 procedure Insert_Default; 2289 -- If the actual is missing in a call, insert in the actuals list 2290 -- an instance of the default expression. The insertion is always 2291 -- a named association. 2292 2293 function Same_Ancestor (T1, T2 : Entity_Id) return Boolean; 2294 -- Check whether T1 and T2, or their full views, are derived from a 2295 -- common type. Used to enforce the restrictions on array conversions 2296 -- of AI95-00246. 2297 2298 -------------------- 2299 -- Insert_Default -- 2300 -------------------- 2301 2302 procedure Insert_Default is 2303 Actval : Node_Id; 2304 Assoc : Node_Id; 2305 2306 begin 2307 -- Missing argument in call, nothing to insert 2308 2309 if No (Default_Value (F)) then 2310 return; 2311 2312 else 2313 -- Note that we do a full New_Copy_Tree, so that any associated 2314 -- Itypes are properly copied. This may not be needed any more, 2315 -- but it does no harm as a safety measure! Defaults of a generic 2316 -- formal may be out of bounds of the corresponding actual (see 2317 -- cc1311b) and an additional check may be required. 2318 2319 Actval := New_Copy_Tree (Default_Value (F), 2320 New_Scope => Current_Scope, New_Sloc => Loc); 2321 2322 if Is_Concurrent_Type (Scope (Nam)) 2323 and then Has_Discriminants (Scope (Nam)) 2324 then 2325 Replace_Actual_Discriminants (N, Actval); 2326 end if; 2327 2328 if Is_Overloadable (Nam) 2329 and then Present (Alias (Nam)) 2330 then 2331 if Base_Type (Etype (F)) /= Base_Type (Etype (Actval)) 2332 and then not Is_Tagged_Type (Etype (F)) 2333 then 2334 -- If default is a real literal, do not introduce a 2335 -- conversion whose effect may depend on the run-time 2336 -- size of universal real. 2337 2338 if Nkind (Actval) = N_Real_Literal then 2339 Set_Etype (Actval, Base_Type (Etype (F))); 2340 else 2341 Actval := Unchecked_Convert_To (Etype (F), Actval); 2342 end if; 2343 end if; 2344 2345 if Is_Scalar_Type (Etype (F)) then 2346 Enable_Range_Check (Actval); 2347 end if; 2348 2349 Set_Parent (Actval, N); 2350 2351 -- Resolve aggregates with their base type, to avoid scope 2352 -- anomalies: the subtype was first built in the suprogram 2353 -- declaration, and the current call may be nested. 2354 2355 if Nkind (Actval) = N_Aggregate 2356 and then Has_Discriminants (Etype (Actval)) 2357 then 2358 Analyze_And_Resolve (Actval, Base_Type (Etype (Actval))); 2359 else 2360 Analyze_And_Resolve (Actval, Etype (Actval)); 2361 end if; 2362 2363 else 2364 Set_Parent (Actval, N); 2365 2366 -- See note above concerning aggregates. 2367 2368 if Nkind (Actval) = N_Aggregate 2369 and then Has_Discriminants (Etype (Actval)) 2370 then 2371 Analyze_And_Resolve (Actval, Base_Type (Etype (Actval))); 2372 2373 -- Resolve entities with their own type, which may differ 2374 -- from the type of a reference in a generic context (the 2375 -- view swapping mechanism did not anticipate the re-analysis 2376 -- of default values in calls). 2377 2378 elsif Is_Entity_Name (Actval) then 2379 Analyze_And_Resolve (Actval, Etype (Entity (Actval))); 2380 2381 else 2382 Analyze_And_Resolve (Actval, Etype (Actval)); 2383 end if; 2384 end if; 2385 2386 -- If default is a tag indeterminate function call, propagate 2387 -- tag to obtain proper dispatching. 2388 2389 if Is_Controlling_Formal (F) 2390 and then Nkind (Default_Value (F)) = N_Function_Call 2391 then 2392 Set_Is_Controlling_Actual (Actval); 2393 end if; 2394 2395 end if; 2396 2397 -- If the default expression raises constraint error, then just 2398 -- silently replace it with an N_Raise_Constraint_Error node, 2399 -- since we already gave the warning on the subprogram spec. 2400 2401 if Raises_Constraint_Error (Actval) then 2402 Rewrite (Actval, 2403 Make_Raise_Constraint_Error (Loc, 2404 Reason => CE_Range_Check_Failed)); 2405 Set_Raises_Constraint_Error (Actval); 2406 Set_Etype (Actval, Etype (F)); 2407 end if; 2408 2409 Assoc := 2410 Make_Parameter_Association (Loc, 2411 Explicit_Actual_Parameter => Actval, 2412 Selector_Name => Make_Identifier (Loc, Chars (F))); 2413 2414 -- Case of insertion is first named actual 2415 2416 if No (Prev) or else 2417 Nkind (Parent (Prev)) /= N_Parameter_Association 2418 then 2419 Set_Next_Named_Actual (Assoc, First_Named_Actual (N)); 2420 Set_First_Named_Actual (N, Actval); 2421 2422 if No (Prev) then 2423 if not Present (Parameter_Associations (N)) then 2424 Set_Parameter_Associations (N, New_List (Assoc)); 2425 else 2426 Append (Assoc, Parameter_Associations (N)); 2427 end if; 2428 2429 else 2430 Insert_After (Prev, Assoc); 2431 end if; 2432 2433 -- Case of insertion is not first named actual 2434 2435 else 2436 Set_Next_Named_Actual 2437 (Assoc, Next_Named_Actual (Parent (Prev))); 2438 Set_Next_Named_Actual (Parent (Prev), Actval); 2439 Append (Assoc, Parameter_Associations (N)); 2440 end if; 2441 2442 Mark_Rewrite_Insertion (Assoc); 2443 Mark_Rewrite_Insertion (Actval); 2444 2445 Prev := Actval; 2446 end Insert_Default; 2447 2448 ------------------- 2449 -- Same_Ancestor -- 2450 ------------------- 2451 2452 function Same_Ancestor (T1, T2 : Entity_Id) return Boolean is 2453 FT1 : Entity_Id := T1; 2454 FT2 : Entity_Id := T2; 2455 2456 begin 2457 if Is_Private_Type (T1) 2458 and then Present (Full_View (T1)) 2459 then 2460 FT1 := Full_View (T1); 2461 end if; 2462 2463 if Is_Private_Type (T2) 2464 and then Present (Full_View (T2)) 2465 then 2466 FT2 := Full_View (T2); 2467 end if; 2468 2469 return Root_Type (Base_Type (FT1)) = Root_Type (Base_Type (FT2)); 2470 end Same_Ancestor; 2471 2472 -- Start of processing for Resolve_Actuals 2473 2474 begin 2475 A := First_Actual (N); 2476 F := First_Formal (Nam); 2477 2478 while Present (F) loop 2479 if No (A) and then Needs_No_Actuals (Nam) then 2480 null; 2481 2482 -- If we have an error in any actual or formal, indicated by 2483 -- a type of Any_Type, then abandon resolution attempt, and 2484 -- set result type to Any_Type. 2485 2486 elsif (Present (A) and then Etype (A) = Any_Type) 2487 or else Etype (F) = Any_Type 2488 then 2489 Set_Etype (N, Any_Type); 2490 return; 2491 end if; 2492 2493 if Present (A) 2494 and then (Nkind (Parent (A)) /= N_Parameter_Association 2495 or else 2496 Chars (Selector_Name (Parent (A))) = Chars (F)) 2497 then 2498 -- If the formal is Out or In_Out, do not resolve and expand the 2499 -- conversion, because it is subsequently expanded into explicit 2500 -- temporaries and assignments. However, the object of the 2501 -- conversion can be resolved. An exception is the case of 2502 -- a tagged type conversion with a class-wide actual. In that 2503 -- case we want the tag check to occur and no temporary will 2504 -- will be needed (no representation change can occur) and 2505 -- the parameter is passed by reference, so we go ahead and 2506 -- resolve the type conversion. 2507 2508 if Ekind (F) /= E_In_Parameter 2509 and then Nkind (A) = N_Type_Conversion 2510 and then not Is_Class_Wide_Type (Etype (Expression (A))) 2511 then 2512 if Ekind (F) = E_In_Out_Parameter 2513 and then Is_Array_Type (Etype (F)) 2514 then 2515 if Has_Aliased_Components (Etype (Expression (A))) 2516 /= Has_Aliased_Components (Etype (F)) 2517 then 2518 Error_Msg_N 2519 ("both component types in a view conversion must be" 2520 & " aliased, or neither", A); 2521 2522 elsif not Same_Ancestor (Etype (F), Etype (Expression (A))) 2523 and then 2524 (Is_By_Reference_Type (Etype (F)) 2525 or else Is_By_Reference_Type (Etype (Expression (A)))) 2526 then 2527 Error_Msg_N 2528 ("view conversion between unrelated by_reference " 2529 & "array types not allowed (\A\I-00246)?", A); 2530 end if; 2531 end if; 2532 2533 if Conversion_OK (A) 2534 or else Valid_Conversion (A, Etype (A), Expression (A)) 2535 then 2536 Resolve (Expression (A)); 2537 end if; 2538 2539 else 2540 if Nkind (A) = N_Type_Conversion 2541 and then Is_Array_Type (Etype (F)) 2542 and then not Same_Ancestor (Etype (F), Etype (Expression (A))) 2543 and then 2544 (Is_Limited_Type (Etype (F)) 2545 or else Is_Limited_Type (Etype (Expression (A)))) 2546 then 2547 Error_Msg_N 2548 ("Conversion between unrelated limited array types " 2549 & "not allowed (\A\I-00246)?", A); 2550 2551 -- Disable explanation (which produces additional errors) 2552 -- until AI is approved and warning becomes an error. 2553 2554 -- if Is_Limited_Type (Etype (F)) then 2555 -- Explain_Limited_Type (Etype (F), A); 2556 -- end if; 2557 2558 -- if Is_Limited_Type (Etype (Expression (A))) then 2559 -- Explain_Limited_Type (Etype (Expression (A)), A); 2560 -- end if; 2561 end if; 2562 2563 Resolve (A, Etype (F)); 2564 end if; 2565 2566 A_Typ := Etype (A); 2567 F_Typ := Etype (F); 2568 2569 -- Perform error checks for IN and IN OUT parameters 2570 2571 if Ekind (F) /= E_Out_Parameter then 2572 2573 -- Check unset reference. For scalar parameters, it is clearly 2574 -- wrong to pass an uninitialized value as either an IN or 2575 -- IN-OUT parameter. For composites, it is also clearly an 2576 -- error to pass a completely uninitialized value as an IN 2577 -- parameter, but the case of IN OUT is trickier. We prefer 2578 -- not to give a warning here. For example, suppose there is 2579 -- a routine that sets some component of a record to False. 2580 -- It is perfectly reasonable to make this IN-OUT and allow 2581 -- either initialized or uninitialized records to be passed 2582 -- in this case. 2583 2584 -- For partially initialized composite values, we also avoid 2585 -- warnings, since it is quite likely that we are passing a 2586 -- partially initialized value and only the initialized fields 2587 -- will in fact be read in the subprogram. 2588 2589 if Is_Scalar_Type (A_Typ) 2590 or else (Ekind (F) = E_In_Parameter 2591 and then not Is_Partially_Initialized_Type (A_Typ)) 2592 then 2593 Check_Unset_Reference (A); 2594 end if; 2595 2596 -- In Ada 83 we cannot pass an OUT parameter as an IN 2597 -- or IN OUT actual to a nested call, since this is a 2598 -- case of reading an out parameter, which is not allowed. 2599 2600 if Ada_83 2601 and then Is_Entity_Name (A) 2602 and then Ekind (Entity (A)) = E_Out_Parameter 2603 then 2604 Error_Msg_N ("(Ada 83) illegal reading of out parameter", A); 2605 end if; 2606 end if; 2607 2608 if Ekind (F) /= E_In_Parameter 2609 and then not Is_OK_Variable_For_Out_Formal (A) 2610 then 2611 Error_Msg_NE ("actual for& must be a variable", A, F); 2612 2613 if Is_Entity_Name (A) then 2614 Kill_Checks (Entity (A)); 2615 else 2616 Kill_All_Checks; 2617 end if; 2618 end if; 2619 2620 if Etype (A) = Any_Type then 2621 Set_Etype (N, Any_Type); 2622 return; 2623 end if; 2624 2625 -- Apply appropriate range checks for in, out, and in-out 2626 -- parameters. Out and in-out parameters also need a separate 2627 -- check, if there is a type conversion, to make sure the return 2628 -- value meets the constraints of the variable before the 2629 -- conversion. 2630 2631 -- Gigi looks at the check flag and uses the appropriate types. 2632 -- For now since one flag is used there is an optimization which 2633 -- might not be done in the In Out case since Gigi does not do 2634 -- any analysis. More thought required about this ??? 2635 2636 if Ekind (F) = E_In_Parameter 2637 or else Ekind (F) = E_In_Out_Parameter 2638 then 2639 if Is_Scalar_Type (Etype (A)) then 2640 Apply_Scalar_Range_Check (A, F_Typ); 2641 2642 elsif Is_Array_Type (Etype (A)) then 2643 Apply_Length_Check (A, F_Typ); 2644 2645 elsif Is_Record_Type (F_Typ) 2646 and then Has_Discriminants (F_Typ) 2647 and then Is_Constrained (F_Typ) 2648 and then (not Is_Derived_Type (F_Typ) 2649 or else Comes_From_Source (Nam)) 2650 then 2651 Apply_Discriminant_Check (A, F_Typ); 2652 2653 elsif Is_Access_Type (F_Typ) 2654 and then Is_Array_Type (Designated_Type (F_Typ)) 2655 and then Is_Constrained (Designated_Type (F_Typ)) 2656 then 2657 Apply_Length_Check (A, F_Typ); 2658 2659 elsif Is_Access_Type (F_Typ) 2660 and then Has_Discriminants (Designated_Type (F_Typ)) 2661 and then Is_Constrained (Designated_Type (F_Typ)) 2662 then 2663 Apply_Discriminant_Check (A, F_Typ); 2664 2665 else 2666 Apply_Range_Check (A, F_Typ); 2667 end if; 2668 end if; 2669 2670 if Ekind (F) = E_Out_Parameter 2671 or else Ekind (F) = E_In_Out_Parameter 2672 then 2673 if Nkind (A) = N_Type_Conversion then 2674 if Is_Scalar_Type (A_Typ) then 2675 Apply_Scalar_Range_Check 2676 (Expression (A), Etype (Expression (A)), A_Typ); 2677 else 2678 Apply_Range_Check 2679 (Expression (A), Etype (Expression (A)), A_Typ); 2680 end if; 2681 2682 else 2683 if Is_Scalar_Type (F_Typ) then 2684 Apply_Scalar_Range_Check (A, A_Typ, F_Typ); 2685 2686 elsif Is_Array_Type (F_Typ) 2687 and then Ekind (F) = E_Out_Parameter 2688 then 2689 Apply_Length_Check (A, F_Typ); 2690 2691 else 2692 Apply_Range_Check (A, A_Typ, F_Typ); 2693 end if; 2694 end if; 2695 end if; 2696 2697 -- An actual associated with an access parameter is implicitly 2698 -- converted to the anonymous access type of the formal and 2699 -- must satisfy the legality checks for access conversions. 2700 2701 if Ekind (F_Typ) = E_Anonymous_Access_Type then 2702 if not Valid_Conversion (A, F_Typ, A) then 2703 Error_Msg_N 2704 ("invalid implicit conversion for access parameter", A); 2705 end if; 2706 end if; 2707 2708 -- Check bad case of atomic/volatile argument (RM C.6(12)) 2709 2710 if Is_By_Reference_Type (Etype (F)) 2711 and then Comes_From_Source (N) 2712 then 2713 if Is_Atomic_Object (A) 2714 and then not Is_Atomic (Etype (F)) 2715 then 2716 Error_Msg_N 2717 ("cannot pass atomic argument to non-atomic formal", 2718 N); 2719 2720 elsif Is_Volatile_Object (A) 2721 and then not Is_Volatile (Etype (F)) 2722 then 2723 Error_Msg_N 2724 ("cannot pass volatile argument to non-volatile formal", 2725 N); 2726 end if; 2727 end if; 2728 2729 -- Check that subprograms don't have improper controlling 2730 -- arguments (RM 3.9.2 (9)) 2731 2732 if Is_Controlling_Formal (F) then 2733 Set_Is_Controlling_Actual (A); 2734 elsif Nkind (A) = N_Explicit_Dereference then 2735 Validate_Remote_Access_To_Class_Wide_Type (A); 2736 end if; 2737 2738 if (Is_Class_Wide_Type (A_Typ) or else Is_Dynamically_Tagged (A)) 2739 and then not Is_Class_Wide_Type (F_Typ) 2740 and then not Is_Controlling_Formal (F) 2741 then 2742 Error_Msg_N ("class-wide argument not allowed here!", A); 2743 2744 if Is_Subprogram (Nam) 2745 and then Comes_From_Source (Nam) 2746 then 2747 Error_Msg_Node_2 := F_Typ; 2748 Error_Msg_NE 2749 ("& is not a primitive operation of &!", A, Nam); 2750 end if; 2751 2752 elsif Is_Access_Type (A_Typ) 2753 and then Is_Access_Type (F_Typ) 2754 and then Ekind (F_Typ) /= E_Access_Subprogram_Type 2755 and then (Is_Class_Wide_Type (Designated_Type (A_Typ)) 2756 or else (Nkind (A) = N_Attribute_Reference 2757 and then 2758 Is_Class_Wide_Type (Etype (Prefix (A))))) 2759 and then not Is_Class_Wide_Type (Designated_Type (F_Typ)) 2760 and then not Is_Controlling_Formal (F) 2761 then 2762 Error_Msg_N 2763 ("access to class-wide argument not allowed here!", A); 2764 2765 if Is_Subprogram (Nam) 2766 and then Comes_From_Source (Nam) 2767 then 2768 Error_Msg_Node_2 := Designated_Type (F_Typ); 2769 Error_Msg_NE 2770 ("& is not a primitive operation of &!", A, Nam); 2771 end if; 2772 end if; 2773 2774 Eval_Actual (A); 2775 2776 -- If it is a named association, treat the selector_name as 2777 -- a proper identifier, and mark the corresponding entity. 2778 2779 if Nkind (Parent (A)) = N_Parameter_Association then 2780 Set_Entity (Selector_Name (Parent (A)), F); 2781 Generate_Reference (F, Selector_Name (Parent (A))); 2782 Set_Etype (Selector_Name (Parent (A)), F_Typ); 2783 Generate_Reference (F_Typ, N, ' '); 2784 end if; 2785 2786 Prev := A; 2787 2788 if Ekind (F) /= E_Out_Parameter then 2789 Check_Unset_Reference (A); 2790 end if; 2791 2792 Next_Actual (A); 2793 2794 -- Case where actual is not present 2795 2796 else 2797 Insert_Default; 2798 end if; 2799 2800 Next_Formal (F); 2801 end loop; 2802 end Resolve_Actuals; 2803 2804 ----------------------- 2805 -- Resolve_Allocator -- 2806 ----------------------- 2807 2808 procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id) is 2809 E : constant Node_Id := Expression (N); 2810 Subtyp : Entity_Id; 2811 Discrim : Entity_Id; 2812 Constr : Node_Id; 2813 Disc_Exp : Node_Id; 2814 2815 function In_Dispatching_Context return Boolean; 2816 -- If the allocator is an actual in a call, it is allowed to be 2817 -- class-wide when the context is not because it is a controlling 2818 -- actual. 2819 2820 ---------------------------- 2821 -- In_Dispatching_Context -- 2822 ---------------------------- 2823 2824 function In_Dispatching_Context return Boolean is 2825 Par : constant Node_Id := Parent (N); 2826 2827 begin 2828 return (Nkind (Par) = N_Function_Call 2829 or else Nkind (Par) = N_Procedure_Call_Statement) 2830 and then Is_Entity_Name (Name (Par)) 2831 and then Is_Dispatching_Operation (Entity (Name (Par))); 2832 end In_Dispatching_Context; 2833 2834 -- Start of processing for Resolve_Allocator 2835 2836 begin 2837 -- Replace general access with specific type 2838 2839 if Ekind (Etype (N)) = E_Allocator_Type then 2840 Set_Etype (N, Base_Type (Typ)); 2841 end if; 2842 2843 if Is_Abstract (Typ) then 2844 Error_Msg_N ("type of allocator cannot be abstract", N); 2845 end if; 2846 2847 -- For qualified expression, resolve the expression using the 2848 -- given subtype (nothing to do for type mark, subtype indication) 2849 2850 if Nkind (E) = N_Qualified_Expression then 2851 if Is_Class_Wide_Type (Etype (E)) 2852 and then not Is_Class_Wide_Type (Designated_Type (Typ)) 2853 and then not In_Dispatching_Context 2854 then 2855 Error_Msg_N 2856 ("class-wide allocator not allowed for this access type", N); 2857 end if; 2858 2859 Resolve (Expression (E), Etype (E)); 2860 Check_Unset_Reference (Expression (E)); 2861 2862 -- A qualified expression requires an exact match of the type, 2863 -- class-wide matching is not allowed. 2864 2865 if (Is_Class_Wide_Type (Etype (Expression (E))) 2866 or else Is_Class_Wide_Type (Etype (E))) 2867 and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E)) 2868 then 2869 Wrong_Type (Expression (E), Etype (E)); 2870 end if; 2871 2872 -- For a subtype mark or subtype indication, freeze the subtype 2873 2874 else 2875 Freeze_Expression (E); 2876 2877 if Is_Access_Constant (Typ) and then not No_Initialization (N) then 2878 Error_Msg_N 2879 ("initialization required for access-to-constant allocator", N); 2880 end if; 2881 2882 -- A special accessibility check is needed for allocators that 2883 -- constrain access discriminants. The level of the type of the 2884 -- expression used to contrain an access discriminant cannot be 2885 -- deeper than the type of the allocator (in constrast to access 2886 -- parameters, where the level of the actual can be arbitrary). 2887 -- We can't use Valid_Conversion to perform this check because 2888 -- in general the type of the allocator is unrelated to the type 2889 -- of the access discriminant. Note that specialized checks are 2890 -- needed for the cases of a constraint expression which is an 2891 -- access attribute or an access discriminant. 2892 2893 if Nkind (Original_Node (E)) = N_Subtype_Indication 2894 and then Ekind (Typ) /= E_Anonymous_Access_Type 2895 then 2896 Subtyp := Entity (Subtype_Mark (Original_Node (E))); 2897 2898 if Has_Discriminants (Subtyp) then 2899 Discrim := First_Discriminant (Base_Type (Subtyp)); 2900 Constr := First (Constraints (Constraint (Original_Node (E)))); 2901 2902 while Present (Discrim) and then Present (Constr) loop 2903 if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then 2904 if Nkind (Constr) = N_Discriminant_Association then 2905 Disc_Exp := Original_Node (Expression (Constr)); 2906 else 2907 Disc_Exp := Original_Node (Constr); 2908 end if; 2909 2910 if Type_Access_Level (Etype (Disc_Exp)) 2911 > Type_Access_Level (Typ) 2912 then 2913 Error_Msg_N 2914 ("operand type has deeper level than allocator type", 2915 Disc_Exp); 2916 2917 elsif Nkind (Disc_Exp) = N_Attribute_Reference 2918 and then Get_Attribute_Id (Attribute_Name (Disc_Exp)) 2919 = Attribute_Access 2920 and then Object_Access_Level (Prefix (Disc_Exp)) 2921 > Type_Access_Level (Typ) 2922 then 2923 Error_Msg_N 2924 ("prefix of attribute has deeper level than" 2925 & " allocator type", Disc_Exp); 2926 2927 -- When the operand is an access discriminant the check 2928 -- is against the level of the prefix object. 2929 2930 elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type 2931 and then Nkind (Disc_Exp) = N_Selected_Component 2932 and then Object_Access_Level (Prefix (Disc_Exp)) 2933 > Type_Access_Level (Typ) 2934 then 2935 Error_Msg_N 2936 ("access discriminant has deeper level than" 2937 & " allocator type", Disc_Exp); 2938 end if; 2939 end if; 2940 Next_Discriminant (Discrim); 2941 Next (Constr); 2942 end loop; 2943 end if; 2944 end if; 2945 end if; 2946 2947 -- Check for allocation from an empty storage pool 2948 2949 if No_Pool_Assigned (Typ) then 2950 declare 2951 Loc : constant Source_Ptr := Sloc (N); 2952 2953 begin 2954 Error_Msg_N ("?allocation from empty storage pool!", N); 2955 Error_Msg_N ("?Storage_Error will be raised at run time!", N); 2956 Insert_Action (N, 2957 Make_Raise_Storage_Error (Loc, 2958 Reason => SE_Empty_Storage_Pool)); 2959 end; 2960 end if; 2961 end Resolve_Allocator; 2962 2963 --------------------------- 2964 -- Resolve_Arithmetic_Op -- 2965 --------------------------- 2966 2967 -- Used for resolving all arithmetic operators except exponentiation 2968 2969 procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id) is 2970 L : constant Node_Id := Left_Opnd (N); 2971 R : constant Node_Id := Right_Opnd (N); 2972 TL : constant Entity_Id := Base_Type (Etype (L)); 2973 TR : constant Entity_Id := Base_Type (Etype (R)); 2974 T : Entity_Id; 2975 Rop : Node_Id; 2976 2977 B_Typ : constant Entity_Id := Base_Type (Typ); 2978 -- We do the resolution using the base type, because intermediate values 2979 -- in expressions always are of the base type, not a subtype of it. 2980 2981 function Is_Integer_Or_Universal (N : Node_Id) return Boolean; 2982 -- Return True iff given type is Integer or universal real/integer 2983 2984 procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id); 2985 -- Choose type of integer literal in fixed-point operation to conform 2986 -- to available fixed-point type. T is the type of the other operand, 2987 -- which is needed to determine the expected type of N. 2988 2989 procedure Set_Operand_Type (N : Node_Id); 2990 -- Set operand type to T if universal 2991 2992 ----------------------------- 2993 -- Is_Integer_Or_Universal -- 2994 ----------------------------- 2995 2996 function Is_Integer_Or_Universal (N : Node_Id) return Boolean is 2997 T : Entity_Id; 2998 Index : Interp_Index; 2999 It : Interp; 3000 3001 begin 3002 if not Is_Overloaded (N) then 3003 T := Etype (N); 3004 return Base_Type (T) = Base_Type (Standard_Integer) 3005 or else T = Universal_Integer 3006 or else T = Universal_Real; 3007 else 3008 Get_First_Interp (N, Index, It); 3009 3010 while Present (It.Typ) loop 3011 3012 if Base_Type (It.Typ) = Base_Type (Standard_Integer) 3013 or else It.Typ = Universal_Integer 3014 or else It.Typ = Universal_Real 3015 then 3016 return True; 3017 end if; 3018 3019 Get_Next_Interp (Index, It); 3020 end loop; 3021 end if; 3022 3023 return False; 3024 end Is_Integer_Or_Universal; 3025 3026 ---------------------------- 3027 -- Set_Mixed_Mode_Operand -- 3028 ---------------------------- 3029 3030 procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id) is 3031 Index : Interp_Index; 3032 It : Interp; 3033 3034 begin 3035 if Universal_Interpretation (N) = Universal_Integer then 3036 3037 -- A universal integer literal is resolved as standard integer 3038 -- except in the case of a fixed-point result, where we leave 3039 -- it as universal (to be handled by Exp_Fixd later on) 3040 3041 if Is_Fixed_Point_Type (T) then 3042 Resolve (N, Universal_Integer); 3043 else 3044 Resolve (N, Standard_Integer); 3045 end if; 3046 3047 elsif Universal_Interpretation (N) = Universal_Real 3048 and then (T = Base_Type (Standard_Integer) 3049 or else T = Universal_Integer 3050 or else T = Universal_Real) 3051 then 3052 -- A universal real can appear in a fixed-type context. We resolve 3053 -- the literal with that context, even though this might raise an 3054 -- exception prematurely (the other operand may be zero). 3055 3056 Resolve (N, B_Typ); 3057 3058 elsif Etype (N) = Base_Type (Standard_Integer) 3059 and then T = Universal_Real 3060 and then Is_Overloaded (N) 3061 then 3062 -- Integer arg in mixed-mode operation. Resolve with universal 3063 -- type, in case preference rule must be applied. 3064 3065 Resolve (N, Universal_Integer); 3066 3067 elsif Etype (N) = T 3068 and then B_Typ /= Universal_Fixed 3069 then 3070 -- Not a mixed-mode operation. Resolve with context. 3071 3072 Resolve (N, B_Typ); 3073 3074 elsif Etype (N) = Any_Fixed then 3075 3076 -- N may itself be a mixed-mode operation, so use context type. 3077 3078 Resolve (N, B_Typ); 3079 3080 elsif Is_Fixed_Point_Type (T) 3081 and then B_Typ = Universal_Fixed 3082 and then Is_Overloaded (N) 3083 then 3084 -- Must be (fixed * fixed) operation, operand must have one 3085 -- compatible interpretation. 3086 3087 Resolve (N, Any_Fixed); 3088 3089 elsif Is_Fixed_Point_Type (B_Typ) 3090 and then (T = Universal_Real 3091 or else Is_Fixed_Point_Type (T)) 3092 and then Is_Overloaded (N) 3093 then 3094 -- C * F(X) in a fixed context, where C is a real literal or a 3095 -- fixed-point expression. F must have either a fixed type 3096 -- interpretation or an integer interpretation, but not both. 3097 3098 Get_First_Interp (N, Index, It); 3099 3100 while Present (It.Typ) loop 3101 if Base_Type (It.Typ) = Base_Type (Standard_Integer) then 3102 3103 if Analyzed (N) then 3104 Error_Msg_N ("ambiguous operand in fixed operation", N); 3105 else 3106 Resolve (N, Standard_Integer); 3107 end if; 3108 3109 elsif Is_Fixed_Point_Type (It.Typ) then 3110 3111 if Analyzed (N) then 3112 Error_Msg_N ("ambiguous operand in fixed operation", N); 3113 else 3114 Resolve (N, It.Typ); 3115 end if; 3116 end if; 3117 3118 Get_Next_Interp (Index, It); 3119 end loop; 3120 3121 -- Reanalyze the literal with the fixed type of the context. 3122 3123 if N = L then 3124 Set_Analyzed (R, False); 3125 Resolve (R, B_Typ); 3126 else 3127 Set_Analyzed (L, False); 3128 Resolve (L, B_Typ); 3129 end if; 3130 3131 else 3132 Resolve (N); 3133 end if; 3134 end Set_Mixed_Mode_Operand; 3135 3136 ---------------------- 3137 -- Set_Operand_Type -- 3138 ---------------------- 3139 3140 procedure Set_Operand_Type (N : Node_Id) is 3141 begin 3142 if Etype (N) = Universal_Integer 3143 or else Etype (N) = Universal_Real 3144 then 3145 Set_Etype (N, T); 3146 end if; 3147 end Set_Operand_Type; 3148 3149 -- Start of processing for Resolve_Arithmetic_Op 3150 3151 begin 3152 if Comes_From_Source (N) 3153 and then Ekind (Entity (N)) = E_Function 3154 and then Is_Imported (Entity (N)) 3155 and then Is_Intrinsic_Subprogram (Entity (N)) 3156 then 3157 Resolve_Intrinsic_Operator (N, Typ); 3158 return; 3159 3160 -- Special-case for mixed-mode universal expressions or fixed point 3161 -- type operation: each argument is resolved separately. The same 3162 -- treatment is required if one of the operands of a fixed point 3163 -- operation is universal real, since in this case we don't do a 3164 -- conversion to a specific fixed-point type (instead the expander 3165 -- takes care of the case). 3166 3167 elsif (B_Typ = Universal_Integer 3168 or else B_Typ = Universal_Real) 3169 and then Present (Universal_Interpretation (L)) 3170 and then Present (Universal_Interpretation (R)) 3171 then 3172 Resolve (L, Universal_Interpretation (L)); 3173 Resolve (R, Universal_Interpretation (R)); 3174 Set_Etype (N, B_Typ); 3175 3176 elsif (B_Typ = Universal_Real 3177 or else Etype (N) = Universal_Fixed 3178 or else (Etype (N) = Any_Fixed 3179 and then Is_Fixed_Point_Type (B_Typ)) 3180 or else (Is_Fixed_Point_Type (B_Typ) 3181 and then (Is_Integer_Or_Universal (L) 3182 or else 3183 Is_Integer_Or_Universal (R)))) 3184 and then (Nkind (N) = N_Op_Multiply or else 3185 Nkind (N) = N_Op_Divide) 3186 then 3187 if TL = Universal_Integer or else TR = Universal_Integer then 3188 Check_For_Visible_Operator (N, B_Typ); 3189 end if; 3190 3191 -- If context is a fixed type and one operand is integer, the 3192 -- other is resolved with the type of the context. 3193 3194 if Is_Fixed_Point_Type (B_Typ) 3195 and then (Base_Type (TL) = Base_Type (Standard_Integer) 3196 or else TL = Universal_Integer) 3197 then 3198 Resolve (R, B_Typ); 3199 Resolve (L, TL); 3200 3201 elsif Is_Fixed_Point_Type (B_Typ) 3202 and then (Base_Type (TR) = Base_Type (Standard_Integer) 3203 or else TR = Universal_Integer) 3204 then 3205 Resolve (L, B_Typ); 3206 Resolve (R, TR); 3207 3208 else 3209 Set_Mixed_Mode_Operand (L, TR); 3210 Set_Mixed_Mode_Operand (R, TL); 3211 end if; 3212 3213 if Etype (N) = Universal_Fixed 3214 or else Etype (N) = Any_Fixed 3215 then 3216 if B_Typ = Universal_Fixed 3217 and then Nkind (Parent (N)) /= N_Type_Conversion 3218 and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion 3219 then 3220 Error_Msg_N 3221 ("type cannot be determined from context!", N); 3222 Error_Msg_N 3223 ("\explicit conversion to result type required", N); 3224 3225 Set_Etype (L, Any_Type); 3226 Set_Etype (R, Any_Type); 3227 3228 else 3229 if Ada_83 3230 and then Etype (N) = Universal_Fixed 3231 and then Nkind (Parent (N)) /= N_Type_Conversion 3232 and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion 3233 then 3234 Error_Msg_N 3235 ("(Ada 83) fixed-point operation " & 3236 "needs explicit conversion", 3237 N); 3238 end if; 3239 3240 Set_Etype (N, B_Typ); 3241 end if; 3242 3243 elsif Is_Fixed_Point_Type (B_Typ) 3244 and then (Is_Integer_Or_Universal (L) 3245 or else Nkind (L) = N_Real_Literal 3246 or else Nkind (R) = N_Real_Literal 3247 or else 3248 Is_Integer_Or_Universal (R)) 3249 then 3250 Set_Etype (N, B_Typ); 3251 3252 elsif Etype (N) = Any_Fixed then 3253 3254 -- If no previous errors, this is only possible if one operand 3255 -- is overloaded and the context is universal. Resolve as such. 3256 3257 Set_Etype (N, B_Typ); 3258 end if; 3259 3260 else 3261 if (TL = Universal_Integer or else TL = Universal_Real) 3262 and then (TR = Universal_Integer or else TR = Universal_Real) 3263 then 3264 Check_For_Visible_Operator (N, B_Typ); 3265 end if; 3266 3267 -- If the context is Universal_Fixed and the operands are also 3268 -- universal fixed, this is an error, unless there is only one 3269 -- applicable fixed_point type (usually duration). 3270 3271 if B_Typ = Universal_Fixed 3272 and then Etype (L) = Universal_Fixed 3273 then 3274 T := Unique_Fixed_Point_Type (N); 3275 3276 if T = Any_Type then 3277 Set_Etype (N, T); 3278 return; 3279 else 3280 Resolve (L, T); 3281 Resolve (R, T); 3282 end if; 3283 3284 else 3285 Resolve (L, B_Typ); 3286 Resolve (R, B_Typ); 3287 end if; 3288 3289 -- If one of the arguments was resolved to a non-universal type. 3290 -- label the result of the operation itself with the same type. 3291 -- Do the same for the universal argument, if any. 3292 3293 T := Intersect_Types (L, R); 3294 Set_Etype (N, Base_Type (T)); 3295 Set_Operand_Type (L); 3296 Set_Operand_Type (R); 3297 end if; 3298 3299 Generate_Operator_Reference (N, Typ); 3300 Eval_Arithmetic_Op (N); 3301 3302 -- Set overflow and division checking bit. Much cleverer code needed 3303 -- here eventually and perhaps the Resolve routines should be separated 3304 -- for the various arithmetic operations, since they will need 3305 -- different processing. ??? 3306 3307 if Nkind (N) in N_Op then 3308 if not Overflow_Checks_Suppressed (Etype (N)) then 3309 Enable_Overflow_Check (N); 3310 end if; 3311 3312 -- Give warning if explicit division by zero 3313 3314 if (Nkind (N) = N_Op_Divide 3315 or else Nkind (N) = N_Op_Rem 3316 or else Nkind (N) = N_Op_Mod) 3317 and then not Division_Checks_Suppressed (Etype (N)) 3318 then 3319 Rop := Right_Opnd (N); 3320 3321 if Compile_Time_Known_Value (Rop) 3322 and then ((Is_Integer_Type (Etype (Rop)) 3323 and then Expr_Value (Rop) = Uint_0) 3324 or else 3325 (Is_Real_Type (Etype (Rop)) 3326 and then Expr_Value_R (Rop) = Ureal_0)) 3327 then 3328 Apply_Compile_Time_Constraint_Error 3329 (N, "division by zero?", CE_Divide_By_Zero, 3330 Loc => Sloc (Right_Opnd (N))); 3331 3332 -- Otherwise just set the flag to check at run time 3333 3334 else 3335 Set_Do_Division_Check (N); 3336 end if; 3337 end if; 3338 end if; 3339 3340 Check_Unset_Reference (L); 3341 Check_Unset_Reference (R); 3342 end Resolve_Arithmetic_Op; 3343 3344 ------------------ 3345 -- Resolve_Call -- 3346 ------------------ 3347 3348 procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is 3349 Loc : constant Source_Ptr := Sloc (N); 3350 Subp : constant Node_Id := Name (N); 3351 Nam : Entity_Id; 3352 I : Interp_Index; 3353 It : Interp; 3354 Norm_OK : Boolean; 3355 Scop : Entity_Id; 3356 Decl : Node_Id; 3357 3358 begin 3359 -- The context imposes a unique interpretation with type Typ on 3360 -- a procedure or function call. Find the entity of the subprogram 3361 -- that yields the expected type, and propagate the corresponding 3362 -- formal constraints on the actuals. The caller has established 3363 -- that an interpretation exists, and emitted an error if not unique. 3364 3365 -- First deal with the case of a call to an access-to-subprogram, 3366 -- dereference made explicit in Analyze_Call. 3367 3368 if Ekind (Etype (Subp)) = E_Subprogram_Type then 3369 if not Is_Overloaded (Subp) then 3370 Nam := Etype (Subp); 3371 3372 else 3373 -- Find the interpretation whose type (a subprogram type) 3374 -- has a return type that is compatible with the context. 3375 -- Analysis of the node has established that one exists. 3376 3377 Get_First_Interp (Subp, I, It); 3378 Nam := Empty; 3379 3380 while Present (It.Typ) loop 3381 if Covers (Typ, Etype (It.Typ)) then 3382 Nam := It.Typ; 3383 exit; 3384 end if; 3385 3386 Get_Next_Interp (I, It); 3387 end loop; 3388 3389 if No (Nam) then 3390 raise Program_Error; 3391 end if; 3392 end if; 3393 3394 -- If the prefix is not an entity, then resolve it 3395 3396 if not Is_Entity_Name (Subp) then 3397 Resolve (Subp, Nam); 3398 end if; 3399 3400 -- For an indirect call, we always invalidate checks, since we 3401 -- do not know whether the subprogram is local or global. Yes 3402 -- we could do better here, e.g. by knowing that there are no 3403 -- local subprograms, but it does not seem worth the effort. 3404 -- Similarly, we kill al knowledge of current constant values. 3405 3406 Kill_Current_Values; 3407 3408 -- If this is a procedure call which is really an entry call, do 3409 -- the conversion of the procedure call to an entry call. Protected 3410 -- operations use the same circuitry because the name in the call 3411 -- can be an arbitrary expression with special resolution rules. 3412 3413 elsif Nkind (Subp) = N_Selected_Component 3414 or else Nkind (Subp) = N_Indexed_Component 3415 or else (Is_Entity_Name (Subp) 3416 and then Ekind (Entity (Subp)) = E_Entry) 3417 then 3418 Resolve_Entry_Call (N, Typ); 3419 Check_Elab_Call (N); 3420 3421 -- Kill checks and constant values, as above for indirect case 3422 -- Who knows what happens when another task is activated? 3423 3424 Kill_Current_Values; 3425 return; 3426 3427 -- Normal subprogram call with name established in Resolve 3428 3429 elsif not (Is_Type (Entity (Subp))) then 3430 Nam := Entity (Subp); 3431 Set_Entity_With_Style_Check (Subp, Nam); 3432 Generate_Reference (Nam, Subp); 3433 3434 -- Otherwise we must have the case of an overloaded call 3435 3436 else 3437 pragma Assert (Is_Overloaded (Subp)); 3438 Nam := Empty; -- We know that it will be assigned in loop below. 3439 3440 Get_First_Interp (Subp, I, It); 3441 3442 while Present (It.Typ) loop 3443 if Covers (Typ, It.Typ) then 3444 Nam := It.Nam; 3445 Set_Entity_With_Style_Check (Subp, Nam); 3446 Generate_Reference (Nam, Subp); 3447 exit; 3448 end if; 3449 3450 Get_Next_Interp (I, It); 3451 end loop; 3452 end if; 3453 3454 -- Check that a call to Current_Task does not occur in an entry body 3455 3456 if Is_RTE (Nam, RE_Current_Task) then 3457 declare 3458 P : Node_Id; 3459 3460 begin 3461 P := N; 3462 loop 3463 P := Parent (P); 3464 exit when No (P); 3465 3466 if Nkind (P) = N_Entry_Body then 3467 Error_Msg_NE 3468 ("& should not be used in entry body ('R'M C.7(17))", 3469 N, Nam); 3470 exit; 3471 end if; 3472 end loop; 3473 end; 3474 end if; 3475 3476 -- Cannot call thread body directly 3477 3478 if Is_Thread_Body (Nam) then 3479 Error_Msg_N ("cannot call thread body directly", N); 3480 end if; 3481 3482 -- If the subprogram is not global, then kill all checks. This is 3483 -- a bit conservative, since in many cases we could do better, but 3484 -- it is not worth the effort. Similarly, we kill constant values. 3485 -- However we do not need to do this for internal entities (unless 3486 -- they are inherited user-defined subprograms), since they are not 3487 -- in the business of molesting global values. 3488 3489 if not Is_Library_Level_Entity (Nam) 3490 and then (Comes_From_Source (Nam) 3491 or else (Present (Alias (Nam)) 3492 and then Comes_From_Source (Alias (Nam)))) 3493 then 3494 Kill_Current_Values; 3495 end if; 3496 3497 -- Check for call to obsolescent subprogram 3498 3499 if Warn_On_Obsolescent_Feature then 3500 Decl := Parent (Parent (Nam)); 3501 3502 if Nkind (Decl) = N_Subprogram_Declaration 3503 and then Is_List_Member (Decl) 3504 and then Nkind (Next (Decl)) = N_Pragma 3505 then 3506 declare 3507 P : constant Node_Id := Next (Decl); 3508 3509 begin 3510 if Chars (P) = Name_Obsolescent then 3511 Error_Msg_NE ("call to obsolescent subprogram&?", N, Nam); 3512 3513 if Pragma_Argument_Associations (P) /= No_List then 3514 Name_Buffer (1) := '|'; 3515 Name_Buffer (2) := '?'; 3516 Name_Len := 2; 3517 Add_String_To_Name_Buffer 3518 (Strval (Expression 3519 (First (Pragma_Argument_Associations (P))))); 3520 Error_Msg_N (Name_Buffer (1 .. Name_Len), N); 3521 end if; 3522 end if; 3523 end; 3524 end if; 3525 end if; 3526 3527 -- Check that a procedure call does not occur in the context 3528 -- of the entry call statement of a conditional or timed 3529 -- entry call. Note that the case of a call to a subprogram 3530 -- renaming of an entry will also be rejected. The test 3531 -- for N not being an N_Entry_Call_Statement is defensive, 3532 -- covering the possibility that the processing of entry 3533 -- calls might reach this point due to later modifications 3534 -- of the code above. 3535 3536 if Nkind (Parent (N)) = N_Entry_Call_Alternative 3537 and then Nkind (N) /= N_Entry_Call_Statement 3538 and then Entry_Call_Statement (Parent (N)) = N 3539 then 3540 Error_Msg_N ("entry call required in select statement", N); 3541 end if; 3542 3543 -- Check that this is not a call to a protected procedure or 3544 -- entry from within a protected function. 3545 3546 if Ekind (Current_Scope) = E_Function 3547 and then Ekind (Scope (Current_Scope)) = E_Protected_Type 3548 and then Ekind (Nam) /= E_Function 3549 and then Scope (Nam) = Scope (Current_Scope) 3550 then 3551 Error_Msg_N ("within protected function, protected " & 3552 "object is constant", N); 3553 Error_Msg_N ("\cannot call operation that may modify it", N); 3554 end if; 3555 3556 -- Freeze the subprogram name if not in default expression. Note 3557 -- that we freeze procedure calls as well as function calls. 3558 -- Procedure calls are not frozen according to the rules (RM 3559 -- 13.14(14)) because it is impossible to have a procedure call to 3560 -- a non-frozen procedure in pure Ada, but in the code that we 3561 -- generate in the expander, this rule needs extending because we 3562 -- can generate procedure calls that need freezing. 3563 3564 if Is_Entity_Name (Subp) and then not In_Default_Expression then 3565 Freeze_Expression (Subp); 3566 end if; 3567 3568 -- For a predefined operator, the type of the result is the type 3569 -- imposed by context, except for a predefined operation on universal 3570 -- fixed. Otherwise The type of the call is the type returned by the 3571 -- subprogram being called. 3572 3573 if Is_Predefined_Op (Nam) then 3574 if Etype (N) /= Universal_Fixed then 3575 Set_Etype (N, Typ); 3576 end if; 3577 3578 -- If the subprogram returns an array type, and the context 3579 -- requires the component type of that array type, the node is 3580 -- really an indexing of the parameterless call. Resolve as such. 3581 -- A pathological case occurs when the type of the component is 3582 -- an access to the array type. In this case the call is truly 3583 -- ambiguous. 3584 3585 elsif Needs_No_Actuals (Nam) 3586 and then 3587 ((Is_Array_Type (Etype (Nam)) 3588 and then Covers (Typ, Component_Type (Etype (Nam)))) 3589 or else (Is_Access_Type (Etype (Nam)) 3590 and then Is_Array_Type (Designated_Type (Etype (Nam))) 3591 and then 3592 Covers (Typ, 3593 Component_Type (Designated_Type (Etype (Nam)))))) 3594 then 3595 declare 3596 Index_Node : Node_Id; 3597 New_Subp : Node_Id; 3598 Ret_Type : constant Entity_Id := Etype (Nam); 3599 3600 begin 3601 if Is_Access_Type (Ret_Type) 3602 and then Ret_Type = Component_Type (Designated_Type (Ret_Type)) 3603 then 3604 Error_Msg_N 3605 ("cannot disambiguate function call and indexing", N); 3606 else 3607 New_Subp := Relocate_Node (Subp); 3608 Set_Entity (Subp, Nam); 3609 3610 if Component_Type (Ret_Type) /= Any_Type then 3611 Index_Node := 3612 Make_Indexed_Component (Loc, 3613 Prefix => 3614 Make_Function_Call (Loc, 3615 Name => New_Subp), 3616 Expressions => Parameter_Associations (N)); 3617 3618 -- Since we are correcting a node classification error made 3619 -- by the parser, we call Replace rather than Rewrite. 3620 3621 Replace (N, Index_Node); 3622 Set_Etype (Prefix (N), Ret_Type); 3623 Set_Etype (N, Typ); 3624 Resolve_Indexed_Component (N, Typ); 3625 Check_Elab_Call (Prefix (N)); 3626 end if; 3627 end if; 3628 3629 return; 3630 end; 3631 3632 else 3633 Set_Etype (N, Etype (Nam)); 3634 end if; 3635 3636 -- In the case where the call is to an overloaded subprogram, Analyze 3637 -- calls Normalize_Actuals once per overloaded subprogram. Therefore in 3638 -- such a case Normalize_Actuals needs to be called once more to order 3639 -- the actuals correctly. Otherwise the call will have the ordering 3640 -- given by the last overloaded subprogram whether this is the correct 3641 -- one being called or not. 3642 3643 if Is_Overloaded (Subp) then 3644 Normalize_Actuals (N, Nam, False, Norm_OK); 3645 pragma Assert (Norm_OK); 3646 end if; 3647 3648 -- In any case, call is fully resolved now. Reset Overload flag, to 3649 -- prevent subsequent overload resolution if node is analyzed again 3650 3651 Set_Is_Overloaded (Subp, False); 3652 Set_Is_Overloaded (N, False); 3653 3654 -- If we are calling the current subprogram from immediately within 3655 -- its body, then that is the case where we can sometimes detect 3656 -- cases of infinite recursion statically. Do not try this in case 3657 -- restriction No_Recursion is in effect anyway. 3658 3659 Scop := Current_Scope; 3660 3661 if Nam = Scop 3662 and then not Restrictions (No_Recursion) 3663 and then Check_Infinite_Recursion (N) 3664 then 3665 -- Here we detected and flagged an infinite recursion, so we do 3666 -- not need to test the case below for further warnings. 3667 3668 null; 3669 3670 -- If call is to immediately containing subprogram, then check for 3671 -- the case of a possible run-time detectable infinite recursion. 3672 3673 else 3674 while Scop /= Standard_Standard loop 3675 if Nam = Scop then 3676 -- Although in general recursion is not statically checkable, 3677 -- the case of calling an immediately containing subprogram 3678 -- is easy to catch. 3679 3680 Check_Restriction (No_Recursion, N); 3681 3682 -- If the recursive call is to a parameterless procedure, then 3683 -- even if we can't statically detect infinite recursion, this 3684 -- is pretty suspicious, and we output a warning. Furthermore, 3685 -- we will try later to detect some cases here at run time by 3686 -- expanding checking code (see Detect_Infinite_Recursion in 3687 -- package Exp_Ch6). 3688 -- If the recursive call is within a handler we do not emit a 3689 -- warning, because this is a common idiom: loop until input 3690 -- is correct, catch illegal input in handler and restart. 3691 3692 if No (First_Formal (Nam)) 3693 and then Etype (Nam) = Standard_Void_Type 3694 and then not Error_Posted (N) 3695 and then Nkind (Parent (N)) /= N_Exception_Handler 3696 then 3697 Set_Has_Recursive_Call (Nam); 3698 Error_Msg_N ("possible infinite recursion?", N); 3699 Error_Msg_N ("Storage_Error may be raised at run time?", N); 3700 end if; 3701 3702 exit; 3703 end if; 3704 3705 Scop := Scope (Scop); 3706 end loop; 3707 end if; 3708 3709 -- If subprogram name is a predefined operator, it was given in 3710 -- functional notation. Replace call node with operator node, so 3711 -- that actuals can be resolved appropriately. 3712 3713 if Is_Predefined_Op (Nam) or else Ekind (Nam) = E_Operator then 3714 Make_Call_Into_Operator (N, Typ, Entity (Name (N))); 3715 return; 3716 3717 elsif Present (Alias (Nam)) 3718 and then Is_Predefined_Op (Alias (Nam)) 3719 then 3720 Resolve_Actuals (N, Nam); 3721 Make_Call_Into_Operator (N, Typ, Alias (Nam)); 3722 return; 3723 end if; 3724 3725 -- Create a transient scope if the resulting type requires it 3726 3727 -- There are 3 notable exceptions: in init procs, the transient scope 3728 -- overhead is not needed and even incorrect due to the actual expansion 3729 -- of adjust calls; the second case is enumeration literal pseudo calls, 3730 -- the other case is intrinsic subprograms (Unchecked_Conversion and 3731 -- source information functions) that do not use the secondary stack 3732 -- even though the return type is unconstrained. 3733 3734 -- If this is an initialization call for a type whose initialization 3735 -- uses the secondary stack, we also need to create a transient scope 3736 -- for it, precisely because we will not do it within the init proc 3737 -- itself. 3738 3739 if Expander_Active 3740 and then Is_Type (Etype (Nam)) 3741 and then Requires_Transient_Scope (Etype (Nam)) 3742 and then Ekind (Nam) /= E_Enumeration_Literal 3743 and then not Within_Init_Proc 3744 and then not Is_Intrinsic_Subprogram (Nam) 3745 then 3746 Establish_Transient_Scope 3747 (N, Sec_Stack => not Functions_Return_By_DSP_On_Target); 3748 3749 -- If the call appears within the bounds of a loop, it will 3750 -- be rewritten and reanalyzed, nothing left to do here. 3751 3752 if Nkind (N) /= N_Function_Call then 3753 return; 3754 end if; 3755 3756 elsif Is_Init_Proc (Nam) 3757 and then not Within_Init_Proc 3758 then 3759 Check_Initialization_Call (N, Nam); 3760 end if; 3761 3762 -- A protected function cannot be called within the definition of the 3763 -- enclosing protected type. 3764 3765 if Is_Protected_Type (Scope (Nam)) 3766 and then In_Open_Scopes (Scope (Nam)) 3767 and then not Has_Completion (Scope (Nam)) 3768 then 3769 Error_Msg_NE 3770 ("& cannot be called before end of protected definition", N, Nam); 3771 end if; 3772 3773 -- Propagate interpretation to actuals, and add default expressions 3774 -- where needed. 3775 3776 if Present (First_Formal (Nam)) then 3777 Resolve_Actuals (N, Nam); 3778 3779 -- Overloaded literals are rewritten as function calls, for 3780 -- purpose of resolution. After resolution, we can replace 3781 -- the call with the literal itself. 3782 3783 elsif Ekind (Nam) = E_Enumeration_Literal then 3784 Copy_Node (Subp, N); 3785 Resolve_Entity_Name (N, Typ); 3786 3787 -- Avoid validation, since it is a static function call 3788 3789 return; 3790 end if; 3791 3792 -- If the subprogram is a primitive operation, check whether or not 3793 -- it is a correct dispatching call. 3794 3795 if Is_Overloadable (Nam) 3796 and then Is_Dispatching_Operation (Nam) 3797 then 3798 Check_Dispatching_Call (N); 3799 3800 elsif Is_Abstract (Nam) 3801 and then not In_Instance 3802 then 3803 Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam); 3804 end if; 3805 3806 if Is_Intrinsic_Subprogram (Nam) then 3807 Check_Intrinsic_Call (N); 3808 end if; 3809 3810 -- If we fall through we definitely have a non-static call 3811 3812 Check_Elab_Call (N); 3813 end Resolve_Call; 3814 3815 ------------------------------- 3816 -- Resolve_Character_Literal -- 3817 ------------------------------- 3818 3819 procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id) is 3820 B_Typ : constant Entity_Id := Base_Type (Typ); 3821 C : Entity_Id; 3822 3823 begin 3824 -- Verify that the character does belong to the type of the context 3825 3826 Set_Etype (N, B_Typ); 3827 Eval_Character_Literal (N); 3828 3829 -- Wide_Character literals must always be defined, since the set of 3830 -- wide character literals is complete, i.e. if a character literal 3831 -- is accepted by the parser, then it is OK for wide character. 3832 3833 if Root_Type (B_Typ) = Standard_Wide_Character then 3834 return; 3835 3836 -- Always accept character literal for type Any_Character, which 3837 -- occurs in error situations and in comparisons of literals, both 3838 -- of which should accept all literals. 3839 3840 elsif B_Typ = Any_Character then 3841 return; 3842 3843 -- For Standard.Character or a type derived from it, check that 3844 -- the literal is in range 3845 3846 elsif Root_Type (B_Typ) = Standard_Character then 3847 if In_Character_Range (Char_Literal_Value (N)) then 3848 return; 3849 end if; 3850 3851 -- If the entity is already set, this has already been resolved in 3852 -- a generic context, or comes from expansion. Nothing else to do. 3853 3854 elsif Present (Entity (N)) then 3855 return; 3856 3857 -- Otherwise we have a user defined character type, and we can use 3858 -- the standard visibility mechanisms to locate the referenced entity 3859 3860 else 3861 C := Current_Entity (N); 3862 3863 while Present (C) loop 3864 if Etype (C) = B_Typ then 3865 Set_Entity_With_Style_Check (N, C); 3866 Generate_Reference (C, N); 3867 return; 3868 end if; 3869 3870 C := Homonym (C); 3871 end loop; 3872 end if; 3873 3874 -- If we fall through, then the literal does not match any of the 3875 -- entries of the enumeration type. This isn't just a constraint 3876 -- error situation, it is an illegality (see RM 4.2). 3877 3878 Error_Msg_NE 3879 ("character not defined for }", N, First_Subtype (B_Typ)); 3880 end Resolve_Character_Literal; 3881 3882 --------------------------- 3883 -- Resolve_Comparison_Op -- 3884 --------------------------- 3885 3886 -- Context requires a boolean type, and plays no role in resolution. 3887 -- Processing identical to that for equality operators. The result 3888 -- type is the base type, which matters when pathological subtypes of 3889 -- booleans with limited ranges are used. 3890 3891 procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is 3892 L : constant Node_Id := Left_Opnd (N); 3893 R : constant Node_Id := Right_Opnd (N); 3894 T : Entity_Id; 3895 3896 begin 3897 Check_Direct_Boolean_Op (N); 3898 3899 -- If this is an intrinsic operation which is not predefined, use 3900 -- the types of its declared arguments to resolve the possibly 3901 -- overloaded operands. Otherwise the operands are unambiguous and 3902 -- specify the expected type. 3903 3904 if Scope (Entity (N)) /= Standard_Standard then 3905 T := Etype (First_Entity (Entity (N))); 3906 else 3907 T := Find_Unique_Type (L, R); 3908 3909 if T = Any_Fixed then 3910 T := Unique_Fixed_Point_Type (L); 3911 end if; 3912 end if; 3913 3914 Set_Etype (N, Base_Type (Typ)); 3915 Generate_Reference (T, N, ' '); 3916 3917 if T /= Any_Type then 3918 if T = Any_String 3919 or else T = Any_Composite 3920 or else T = Any_Character 3921 then 3922 if T = Any_Character then 3923 Ambiguous_Character (L); 3924 else 3925 Error_Msg_N ("ambiguous operands for comparison", N); 3926 end if; 3927 3928 Set_Etype (N, Any_Type); 3929 return; 3930 3931 else 3932 if Comes_From_Source (N) 3933 and then Has_Unchecked_Union (T) 3934 then 3935 Error_Msg_N 3936 ("cannot compare Unchecked_Union values", N); 3937 end if; 3938 3939 Resolve (L, T); 3940 Resolve (R, T); 3941 Check_Unset_Reference (L); 3942 Check_Unset_Reference (R); 3943 Generate_Operator_Reference (N, T); 3944 Eval_Relational_Op (N); 3945 end if; 3946 end if; 3947 end Resolve_Comparison_Op; 3948 3949 ------------------------------------ 3950 -- Resolve_Conditional_Expression -- 3951 ------------------------------------ 3952 3953 procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id) is 3954 Condition : constant Node_Id := First (Expressions (N)); 3955 Then_Expr : constant Node_Id := Next (Condition); 3956 Else_Expr : constant Node_Id := Next (Then_Expr); 3957 3958 begin 3959 Resolve (Condition, Standard_Boolean); 3960 Resolve (Then_Expr, Typ); 3961 Resolve (Else_Expr, Typ); 3962 3963 Set_Etype (N, Typ); 3964 Eval_Conditional_Expression (N); 3965 end Resolve_Conditional_Expression; 3966 3967 ----------------------------------------- 3968 -- Resolve_Discrete_Subtype_Indication -- 3969 ----------------------------------------- 3970 3971 procedure Resolve_Discrete_Subtype_Indication 3972 (N : Node_Id; 3973 Typ : Entity_Id) 3974 is 3975 R : Node_Id; 3976 S : Entity_Id; 3977 3978 begin 3979 Analyze (Subtype_Mark (N)); 3980 S := Entity (Subtype_Mark (N)); 3981 3982 if Nkind (Constraint (N)) /= N_Range_Constraint then 3983 Error_Msg_N ("expect range constraint for discrete type", N); 3984 Set_Etype (N, Any_Type); 3985 3986 else 3987 R := Range_Expression (Constraint (N)); 3988 3989 if R = Error then 3990 return; 3991 end if; 3992 3993 Analyze (R); 3994 3995 if Base_Type (S) /= Base_Type (Typ) then 3996 Error_Msg_NE 3997 ("expect subtype of }", N, First_Subtype (Typ)); 3998 3999 -- Rewrite the constraint as a range of Typ 4000 -- to allow compilation to proceed further. 4001 4002 Set_Etype (N, Typ); 4003 Rewrite (Low_Bound (R), 4004 Make_Attribute_Reference (Sloc (Low_Bound (R)), 4005 Prefix => New_Occurrence_Of (Typ, Sloc (R)), 4006 Attribute_Name => Name_First)); 4007 Rewrite (High_Bound (R), 4008 Make_Attribute_Reference (Sloc (High_Bound (R)), 4009 Prefix => New_Occurrence_Of (Typ, Sloc (R)), 4010 Attribute_Name => Name_First)); 4011 4012 else 4013 Resolve (R, Typ); 4014 Set_Etype (N, Etype (R)); 4015 4016 -- Additionally, we must check that the bounds are compatible 4017 -- with the given subtype, which might be different from the 4018 -- type of the context. 4019 4020 Apply_Range_Check (R, S); 4021 4022 -- ??? If the above check statically detects a Constraint_Error 4023 -- it replaces the offending bound(s) of the range R with a 4024 -- Constraint_Error node. When the itype which uses these bounds 4025 -- is frozen the resulting call to Duplicate_Subexpr generates 4026 -- a new temporary for the bounds. 4027 4028 -- Unfortunately there are other itypes that are also made depend 4029 -- on these bounds, so when Duplicate_Subexpr is called they get 4030 -- a forward reference to the newly created temporaries and Gigi 4031 -- aborts on such forward references. This is probably sign of a 4032 -- more fundamental problem somewhere else in either the order of 4033 -- itype freezing or the way certain itypes are constructed. 4034 4035 -- To get around this problem we call Remove_Side_Effects right 4036 -- away if either bounds of R are a Constraint_Error. 4037 4038 declare 4039 L : constant Node_Id := Low_Bound (R); 4040 H : constant Node_Id := High_Bound (R); 4041 4042 begin 4043 if Nkind (L) = N_Raise_Constraint_Error then 4044 Remove_Side_Effects (L); 4045 end if; 4046 4047 if Nkind (H) = N_Raise_Constraint_Error then 4048 Remove_Side_Effects (H); 4049 end if; 4050 end; 4051 4052 Check_Unset_Reference (Low_Bound (R)); 4053 Check_Unset_Reference (High_Bound (R)); 4054 end if; 4055 end if; 4056 end Resolve_Discrete_Subtype_Indication; 4057 4058 ------------------------- 4059 -- Resolve_Entity_Name -- 4060 ------------------------- 4061 4062 -- Used to resolve identifiers and expanded names 4063 4064 procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id) is 4065 E : constant Entity_Id := Entity (N); 4066 4067 begin 4068 -- If garbage from errors, set to Any_Type and return 4069 4070 if No (E) and then Total_Errors_Detected /= 0 then 4071 Set_Etype (N, Any_Type); 4072 return; 4073 end if; 4074 4075 -- Replace named numbers by corresponding literals. Note that this is 4076 -- the one case where Resolve_Entity_Name must reset the Etype, since 4077 -- it is currently marked as universal. 4078 4079 if Ekind (E) = E_Named_Integer then 4080 Set_Etype (N, Typ); 4081 Eval_Named_Integer (N); 4082 4083 elsif Ekind (E) = E_Named_Real then 4084 Set_Etype (N, Typ); 4085 Eval_Named_Real (N); 4086 4087 -- Allow use of subtype only if it is a concurrent type where we are 4088 -- currently inside the body. This will eventually be expanded 4089 -- into a call to Self (for tasks) or _object (for protected 4090 -- objects). Any other use of a subtype is invalid. 4091 4092 elsif Is_Type (E) then 4093 if Is_Concurrent_Type (E) 4094 and then In_Open_Scopes (E) 4095 then 4096 null; 4097 else 4098 Error_Msg_N 4099 ("Invalid use of subtype mark in expression or call", N); 4100 end if; 4101 4102 -- Check discriminant use if entity is discriminant in current scope, 4103 -- i.e. discriminant of record or concurrent type currently being 4104 -- analyzed. Uses in corresponding body are unrestricted. 4105 4106 elsif Ekind (E) = E_Discriminant 4107 and then Scope (E) = Current_Scope 4108 and then not Has_Completion (Current_Scope) 4109 then 4110 Check_Discriminant_Use (N); 4111 4112 -- A parameterless generic function cannot appear in a context that 4113 -- requires resolution. 4114 4115 elsif Ekind (E) = E_Generic_Function then 4116 Error_Msg_N ("illegal use of generic function", N); 4117 4118 elsif Ekind (E) = E_Out_Parameter 4119 and then Ada_83 4120 and then (Nkind (Parent (N)) in N_Op 4121 or else (Nkind (Parent (N)) = N_Assignment_Statement 4122 and then N = Expression (Parent (N))) 4123 or else Nkind (Parent (N)) = N_Explicit_Dereference) 4124 then 4125 Error_Msg_N ("(Ada 83) illegal reading of out parameter", N); 4126 4127 -- In all other cases, just do the possible static evaluation 4128 4129 else 4130 -- A deferred constant that appears in an expression must have 4131 -- a completion, unless it has been removed by in-place expansion 4132 -- of an aggregate. 4133 4134 if Ekind (E) = E_Constant 4135 and then Comes_From_Source (E) 4136 and then No (Constant_Value (E)) 4137 and then Is_Frozen (Etype (E)) 4138 and then not In_Default_Expression 4139 and then not Is_Imported (E) 4140 then 4141 4142 if No_Initialization (Parent (E)) 4143 or else (Present (Full_View (E)) 4144 and then No_Initialization (Parent (Full_View (E)))) 4145 then 4146 null; 4147 else 4148 Error_Msg_N ( 4149 "deferred constant is frozen before completion", N); 4150 end if; 4151 end if; 4152 4153 Eval_Entity_Name (N); 4154 end if; 4155 end Resolve_Entity_Name; 4156 4157 ------------------- 4158 -- Resolve_Entry -- 4159 ------------------- 4160 4161 procedure Resolve_Entry (Entry_Name : Node_Id) is 4162 Loc : constant Source_Ptr := Sloc (Entry_Name); 4163 Nam : Entity_Id; 4164 New_N : Node_Id; 4165 S : Entity_Id; 4166 Tsk : Entity_Id; 4167 E_Name : Node_Id; 4168 Index : Node_Id; 4169 4170 function Actual_Index_Type (E : Entity_Id) return Entity_Id; 4171 -- If the bounds of the entry family being called depend on task 4172 -- discriminants, build a new index subtype where a discriminant is 4173 -- replaced with the value of the discriminant of the target task. 4174 -- The target task is the prefix of the entry name in the call. 4175 4176 ----------------------- 4177 -- Actual_Index_Type -- 4178 ----------------------- 4179 4180 function Actual_Index_Type (E : Entity_Id) return Entity_Id is 4181 Typ : constant Entity_Id := Entry_Index_Type (E); 4182 Tsk : constant Entity_Id := Scope (E); 4183 Lo : constant Node_Id := Type_Low_Bound (Typ); 4184 Hi : constant Node_Id := Type_High_Bound (Typ); 4185 New_T : Entity_Id; 4186 4187 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; 4188 -- If the bound is given by a discriminant, replace with a reference 4189 -- to the discriminant of the same name in the target task. 4190 -- If the entry name is the target of a requeue statement and the 4191 -- entry is in the current protected object, the bound to be used 4192 -- is the discriminal of the object (see apply_range_checks for 4193 -- details of the transformation). 4194 4195 ----------------------------- 4196 -- Actual_Discriminant_Ref -- 4197 ----------------------------- 4198 4199 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is 4200 Typ : constant Entity_Id := Etype (Bound); 4201 Ref : Node_Id; 4202 4203 begin 4204 Remove_Side_Effects (Bound); 4205 4206 if not Is_Entity_Name (Bound) 4207 or else Ekind (Entity (Bound)) /= E_Discriminant 4208 then 4209 return Bound; 4210 4211 elsif Is_Protected_Type (Tsk) 4212 and then In_Open_Scopes (Tsk) 4213 and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement 4214 then 4215 return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); 4216 4217 else 4218 Ref := 4219 Make_Selected_Component (Loc, 4220 Prefix => New_Copy_Tree (Prefix (Prefix (Entry_Name))), 4221 Selector_Name => New_Occurrence_Of (Entity (Bound), Loc)); 4222 Analyze (Ref); 4223 Resolve (Ref, Typ); 4224 return Ref; 4225 end if; 4226 end Actual_Discriminant_Ref; 4227 4228 -- Start of processing for Actual_Index_Type 4229 4230 begin 4231 if not Has_Discriminants (Tsk) 4232 or else (not Is_Entity_Name (Lo) 4233 and then not Is_Entity_Name (Hi)) 4234 then 4235 return Entry_Index_Type (E); 4236 4237 else 4238 New_T := Create_Itype (Ekind (Typ), Parent (Entry_Name)); 4239 Set_Etype (New_T, Base_Type (Typ)); 4240 Set_Size_Info (New_T, Typ); 4241 Set_RM_Size (New_T, RM_Size (Typ)); 4242 Set_Scalar_Range (New_T, 4243 Make_Range (Sloc (Entry_Name), 4244 Low_Bound => Actual_Discriminant_Ref (Lo), 4245 High_Bound => Actual_Discriminant_Ref (Hi))); 4246 4247 return New_T; 4248 end if; 4249 end Actual_Index_Type; 4250 4251 -- Start of processing of Resolve_Entry 4252 4253 begin 4254 -- Find name of entry being called, and resolve prefix of name 4255 -- with its own type. The prefix can be overloaded, and the name 4256 -- and signature of the entry must be taken into account. 4257 4258 if Nkind (Entry_Name) = N_Indexed_Component then 4259 4260 -- Case of dealing with entry family within the current tasks 4261 4262 E_Name := Prefix (Entry_Name); 4263 4264 else 4265 E_Name := Entry_Name; 4266 end if; 4267 4268 if Is_Entity_Name (E_Name) then 4269 -- Entry call to an entry (or entry family) in the current task. 4270 -- This is legal even though the task will deadlock. Rewrite as 4271 -- call to current task. 4272 4273 -- This can also be a call to an entry in an enclosing task. 4274 -- If this is a single task, we have to retrieve its name, 4275 -- because the scope of the entry is the task type, not the 4276 -- object. If the enclosing task is a task type, the identity 4277 -- of the task is given by its own self variable. 4278 4279 -- Finally this can be a requeue on an entry of the same task 4280 -- or protected object. 4281 4282 S := Scope (Entity (E_Name)); 4283 4284 for J in reverse 0 .. Scope_Stack.Last loop 4285 4286 if Is_Task_Type (Scope_Stack.Table (J).Entity) 4287 and then not Comes_From_Source (S) 4288 then 4289 -- S is an enclosing task or protected object. The concurrent 4290 -- declaration has been converted into a type declaration, and 4291 -- the object itself has an object declaration that follows 4292 -- the type in the same declarative part. 4293 4294 Tsk := Next_Entity (S); 4295 4296 while Etype (Tsk) /= S loop 4297 Next_Entity (Tsk); 4298 end loop; 4299 4300 S := Tsk; 4301 exit; 4302 4303 elsif S = Scope_Stack.Table (J).Entity then 4304 4305 -- Call to current task. Will be transformed into call to Self 4306 4307 exit; 4308 4309 end if; 4310 end loop; 4311 4312 New_N := 4313 Make_Selected_Component (Loc, 4314 Prefix => New_Occurrence_Of (S, Loc), 4315 Selector_Name => 4316 New_Occurrence_Of (Entity (E_Name), Loc)); 4317 Rewrite (E_Name, New_N); 4318 Analyze (E_Name); 4319 4320 elsif Nkind (Entry_Name) = N_Selected_Component 4321 and then Is_Overloaded (Prefix (Entry_Name)) 4322 then 4323 -- Use the entry name (which must be unique at this point) to 4324 -- find the prefix that returns the corresponding task type or 4325 -- protected type. 4326 4327 declare 4328 Pref : constant Node_Id := Prefix (Entry_Name); 4329 Ent : constant Entity_Id := Entity (Selector_Name (Entry_Name)); 4330 I : Interp_Index; 4331 It : Interp; 4332 4333 begin 4334 Get_First_Interp (Pref, I, It); 4335 4336 while Present (It.Typ) loop 4337 4338 if Scope (Ent) = It.Typ then 4339 Set_Etype (Pref, It.Typ); 4340 exit; 4341 end if; 4342 4343 Get_Next_Interp (I, It); 4344 end loop; 4345 end; 4346 end if; 4347 4348 if Nkind (Entry_Name) = N_Selected_Component then 4349 Resolve (Prefix (Entry_Name)); 4350 4351 else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); 4352 Nam := Entity (Selector_Name (Prefix (Entry_Name))); 4353 Resolve (Prefix (Prefix (Entry_Name))); 4354 Index := First (Expressions (Entry_Name)); 4355 Resolve (Index, Entry_Index_Type (Nam)); 4356 4357 -- Up to this point the expression could have been the actual 4358 -- in a simple entry call, and be given by a named association. 4359 4360 if Nkind (Index) = N_Parameter_Association then 4361 Error_Msg_N ("expect expression for entry index", Index); 4362 else 4363 Apply_Range_Check (Index, Actual_Index_Type (Nam)); 4364 end if; 4365 end if; 4366 end Resolve_Entry; 4367 4368 ------------------------ 4369 -- Resolve_Entry_Call -- 4370 ------------------------ 4371 4372 procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id) is 4373 Entry_Name : constant Node_Id := Name (N); 4374 Loc : constant Source_Ptr := Sloc (Entry_Name); 4375 Actuals : List_Id; 4376 First_Named : Node_Id; 4377 Nam : Entity_Id; 4378 Norm_OK : Boolean; 4379 Obj : Node_Id; 4380 Was_Over : Boolean; 4381 4382 begin 4383 -- We kill all checks here, because it does not seem worth the 4384 -- effort to do anything better, an entry call is a big operation. 4385 4386 Kill_All_Checks; 4387 4388 -- Processing of the name is similar for entry calls and protected 4389 -- operation calls. Once the entity is determined, we can complete 4390 -- the resolution of the actuals. 4391 4392 -- The selector may be overloaded, in the case of a protected object 4393 -- with overloaded functions. The type of the context is used for 4394 -- resolution. 4395 4396 if Nkind (Entry_Name) = N_Selected_Component 4397 and then Is_Overloaded (Selector_Name (Entry_Name)) 4398 and then Typ /= Standard_Void_Type 4399 then 4400 declare 4401 I : Interp_Index; 4402 It : Interp; 4403 4404 begin 4405 Get_First_Interp (Selector_Name (Entry_Name), I, It); 4406 4407 while Present (It.Typ) loop 4408 4409 if Covers (Typ, It.Typ) then 4410 Set_Entity (Selector_Name (Entry_Name), It.Nam); 4411 Set_Etype (Entry_Name, It.Typ); 4412 4413 Generate_Reference (It.Typ, N, ' '); 4414 end if; 4415 4416 Get_Next_Interp (I, It); 4417 end loop; 4418 end; 4419 end if; 4420 4421 Resolve_Entry (Entry_Name); 4422 4423 if Nkind (Entry_Name) = N_Selected_Component then 4424 4425 -- Simple entry call. 4426 4427 Nam := Entity (Selector_Name (Entry_Name)); 4428 Obj := Prefix (Entry_Name); 4429 Was_Over := Is_Overloaded (Selector_Name (Entry_Name)); 4430 4431 else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); 4432 4433 -- Call to member of entry family. 4434 4435 Nam := Entity (Selector_Name (Prefix (Entry_Name))); 4436 Obj := Prefix (Prefix (Entry_Name)); 4437 Was_Over := Is_Overloaded (Selector_Name (Prefix (Entry_Name))); 4438 end if; 4439 4440 -- We cannot in general check the maximum depth of protected entry 4441 -- calls at compile time. But we can tell that any protected entry 4442 -- call at all violates a specified nesting depth of zero. 4443 4444 if Is_Protected_Type (Scope (Nam)) then 4445 Check_Restriction (Max_Entry_Queue_Depth, N); 4446 end if; 4447 4448 -- Use context type to disambiguate a protected function that can be 4449 -- called without actuals and that returns an array type, and where 4450 -- the argument list may be an indexing of the returned value. 4451 4452 if Ekind (Nam) = E_Function 4453 and then Needs_No_Actuals (Nam) 4454 and then Present (Parameter_Associations (N)) 4455 and then 4456 ((Is_Array_Type (Etype (Nam)) 4457 and then Covers (Typ, Component_Type (Etype (Nam)))) 4458 4459 or else (Is_Access_Type (Etype (Nam)) 4460 and then Is_Array_Type (Designated_Type (Etype (Nam))) 4461 and then Covers (Typ, 4462 Component_Type (Designated_Type (Etype (Nam)))))) 4463 then 4464 declare 4465 Index_Node : Node_Id; 4466 4467 begin 4468 Index_Node := 4469 Make_Indexed_Component (Loc, 4470 Prefix => 4471 Make_Function_Call (Loc, 4472 Name => Relocate_Node (Entry_Name)), 4473 Expressions => Parameter_Associations (N)); 4474 4475 -- Since we are correcting a node classification error made by 4476 -- the parser, we call Replace rather than Rewrite. 4477 4478 Replace (N, Index_Node); 4479 Set_Etype (Prefix (N), Etype (Nam)); 4480 Set_Etype (N, Typ); 4481 Resolve_Indexed_Component (N, Typ); 4482 return; 4483 end; 4484 end if; 4485 4486 -- The operation name may have been overloaded. Order the actuals 4487 -- according to the formals of the resolved entity, and set the 4488 -- return type to that of the operation. 4489 4490 if Was_Over then 4491 Normalize_Actuals (N, Nam, False, Norm_OK); 4492 pragma Assert (Norm_OK); 4493 Set_Etype (N, Etype (Nam)); 4494 end if; 4495 4496 Resolve_Actuals (N, Nam); 4497 Generate_Reference (Nam, Entry_Name); 4498 4499 if Ekind (Nam) = E_Entry 4500 or else Ekind (Nam) = E_Entry_Family 4501 then 4502 Check_Potentially_Blocking_Operation (N); 4503 end if; 4504 4505 -- Verify that a procedure call cannot masquerade as an entry 4506 -- call where an entry call is expected. 4507 4508 if Ekind (Nam) = E_Procedure then 4509 if Nkind (Parent (N)) = N_Entry_Call_Alternative 4510 and then N = Entry_Call_Statement (Parent (N)) 4511 then 4512 Error_Msg_N ("entry call required in select statement", N); 4513 4514 elsif Nkind (Parent (N)) = N_Triggering_Alternative 4515 and then N = Triggering_Statement (Parent (N)) 4516 then 4517 Error_Msg_N ("triggering statement cannot be procedure call", N); 4518 4519 elsif Ekind (Scope (Nam)) = E_Task_Type 4520 and then not In_Open_Scopes (Scope (Nam)) 4521 then 4522 Error_Msg_N ("Task has no entry with this name", Entry_Name); 4523 end if; 4524 end if; 4525 4526 -- After resolution, entry calls and protected procedure calls 4527 -- are changed into entry calls, for expansion. The structure 4528 -- of the node does not change, so it can safely be done in place. 4529 -- Protected function calls must keep their structure because they 4530 -- are subexpressions. 4531 4532 if Ekind (Nam) /= E_Function then 4533 4534 -- A protected operation that is not a function may modify the 4535 -- corresponding object, and cannot apply to a constant. 4536 -- If this is an internal call, the prefix is the type itself. 4537 4538 if Is_Protected_Type (Scope (Nam)) 4539 and then not Is_Variable (Obj) 4540 and then (not Is_Entity_Name (Obj) 4541 or else not Is_Type (Entity (Obj))) 4542 then 4543 Error_Msg_N 4544 ("prefix of protected procedure or entry call must be variable", 4545 Entry_Name); 4546 end if; 4547 4548 Actuals := Parameter_Associations (N); 4549 First_Named := First_Named_Actual (N); 4550 4551 Rewrite (N, 4552 Make_Entry_Call_Statement (Loc, 4553 Name => Entry_Name, 4554 Parameter_Associations => Actuals)); 4555 4556 Set_First_Named_Actual (N, First_Named); 4557 Set_Analyzed (N, True); 4558 4559 -- Protected functions can return on the secondary stack, in which 4560 -- case we must trigger the transient scope mechanism 4561 4562 elsif Expander_Active 4563 and then Requires_Transient_Scope (Etype (Nam)) 4564 then 4565 Establish_Transient_Scope (N, 4566 Sec_Stack => not Functions_Return_By_DSP_On_Target); 4567 end if; 4568 end Resolve_Entry_Call; 4569 4570 ------------------------- 4571 -- Resolve_Equality_Op -- 4572 ------------------------- 4573 4574 -- Both arguments must have the same type, and the boolean context 4575 -- does not participate in the resolution. The first pass verifies 4576 -- that the interpretation is not ambiguous, and the type of the left 4577 -- argument is correctly set, or is Any_Type in case of ambiguity. 4578 -- If both arguments are strings or aggregates, allocators, or Null, 4579 -- they are ambiguous even though they carry a single (universal) type. 4580 -- Diagnose this case here. 4581 4582 procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is 4583 L : constant Node_Id := Left_Opnd (N); 4584 R : constant Node_Id := Right_Opnd (N); 4585 T : Entity_Id := Find_Unique_Type (L, R); 4586 4587 function Find_Unique_Access_Type return Entity_Id; 4588 -- In the case of allocators, make a last-ditch attempt to find a single 4589 -- access type with the right designated type. This is semantically 4590 -- dubious, and of no interest to any real code, but c48008a makes it 4591 -- all worthwhile. 4592 4593 ----------------------------- 4594 -- Find_Unique_Access_Type -- 4595 ----------------------------- 4596 4597 function Find_Unique_Access_Type return Entity_Id is 4598 Acc : Entity_Id; 4599 E : Entity_Id; 4600 S : Entity_Id := Current_Scope; 4601 4602 begin 4603 if Ekind (Etype (R)) = E_Allocator_Type then 4604 Acc := Designated_Type (Etype (R)); 4605 4606 elsif Ekind (Etype (L)) = E_Allocator_Type then 4607 Acc := Designated_Type (Etype (L)); 4608 4609 else 4610 return Empty; 4611 end if; 4612 4613 while S /= Standard_Standard loop 4614 E := First_Entity (S); 4615 4616 while Present (E) loop 4617 4618 if Is_Type (E) 4619 and then Is_Access_Type (E) 4620 and then Ekind (E) /= E_Allocator_Type 4621 and then Designated_Type (E) = Base_Type (Acc) 4622 then 4623 return E; 4624 end if; 4625 4626 Next_Entity (E); 4627 end loop; 4628 4629 S := Scope (S); 4630 end loop; 4631 4632 return Empty; 4633 end Find_Unique_Access_Type; 4634 4635 -- Start of processing for Resolve_Equality_Op 4636 4637 begin 4638 Check_Direct_Boolean_Op (N); 4639 4640 Set_Etype (N, Base_Type (Typ)); 4641 Generate_Reference (T, N, ' '); 4642 4643 if T = Any_Fixed then 4644 T := Unique_Fixed_Point_Type (L); 4645 end if; 4646 4647 if T /= Any_Type then 4648 4649 if T = Any_String 4650 or else T = Any_Composite 4651 or else T = Any_Character 4652 then 4653 4654 if T = Any_Character then 4655 Ambiguous_Character (L); 4656 else 4657 Error_Msg_N ("ambiguous operands for equality", N); 4658 end if; 4659 4660 Set_Etype (N, Any_Type); 4661 return; 4662 4663 elsif T = Any_Access 4664 or else Ekind (T) = E_Allocator_Type 4665 then 4666 T := Find_Unique_Access_Type; 4667 4668 if No (T) then 4669 Error_Msg_N ("ambiguous operands for equality", N); 4670 Set_Etype (N, Any_Type); 4671 return; 4672 end if; 4673 end if; 4674 4675 if Comes_From_Source (N) 4676 and then Has_Unchecked_Union (T) 4677 then 4678 Error_Msg_N 4679 ("cannot compare Unchecked_Union values", N); 4680 end if; 4681 4682 Resolve (L, T); 4683 Resolve (R, T); 4684 4685 if Warn_On_Redundant_Constructs 4686 and then Comes_From_Source (N) 4687 and then Is_Entity_Name (R) 4688 and then Entity (R) = Standard_True 4689 and then Comes_From_Source (R) 4690 then 4691 Error_Msg_N ("comparison with True is redundant?", R); 4692 end if; 4693 4694 Check_Unset_Reference (L); 4695 Check_Unset_Reference (R); 4696 Generate_Operator_Reference (N, T); 4697 4698 -- If this is an inequality, it may be the implicit inequality 4699 -- created for a user-defined operation, in which case the corres- 4700 -- ponding equality operation is not intrinsic, and the operation 4701 -- cannot be constant-folded. Else fold. 4702 4703 if Nkind (N) = N_Op_Eq 4704 or else Comes_From_Source (Entity (N)) 4705 or else Ekind (Entity (N)) = E_Operator 4706 or else Is_Intrinsic_Subprogram 4707 (Corresponding_Equality (Entity (N))) 4708 then 4709 Eval_Relational_Op (N); 4710 elsif Nkind (N) = N_Op_Ne 4711 and then Is_Abstract (Entity (N)) 4712 then 4713 Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N)); 4714 end if; 4715 end if; 4716 end Resolve_Equality_Op; 4717 4718 ---------------------------------- 4719 -- Resolve_Explicit_Dereference -- 4720 ---------------------------------- 4721 4722 procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is 4723 P : constant Node_Id := Prefix (N); 4724 I : Interp_Index; 4725 It : Interp; 4726 4727 begin 4728 -- Now that we know the type, check that this is not a 4729 -- dereference of an uncompleted type. Note that this 4730 -- is not entirely correct, because dereferences of 4731 -- private types are legal in default expressions. 4732 -- This consideration also applies to similar checks 4733 -- for allocators, qualified expressions, and type 4734 -- conversions. ??? 4735 4736 Check_Fully_Declared (Typ, N); 4737 4738 if Is_Overloaded (P) then 4739 4740 -- Use the context type to select the prefix that has the 4741 -- correct designated type. 4742 4743 Get_First_Interp (P, I, It); 4744 while Present (It.Typ) loop 4745 exit when Is_Access_Type (It.Typ) 4746 and then Covers (Typ, Designated_Type (It.Typ)); 4747 4748 Get_Next_Interp (I, It); 4749 end loop; 4750 4751 Resolve (P, It.Typ); 4752 Set_Etype (N, Designated_Type (It.Typ)); 4753 4754 else 4755 Resolve (P); 4756 end if; 4757 4758 if Is_Access_Type (Etype (P)) then 4759 Apply_Access_Check (N); 4760 end if; 4761 4762 -- If the designated type is a packed unconstrained array type, 4763 -- and the explicit dereference is not in the context of an 4764 -- attribute reference, then we must compute and set the actual 4765 -- subtype, since it is needed by Gigi. The reason we exclude 4766 -- the attribute case is that this is handled fine by Gigi, and 4767 -- in fact we use such attributes to build the actual subtype. 4768 -- We also exclude generated code (which builds actual subtypes 4769 -- directly if they are needed). 4770 4771 if Is_Array_Type (Etype (N)) 4772 and then Is_Packed (Etype (N)) 4773 and then not Is_Constrained (Etype (N)) 4774 and then Nkind (Parent (N)) /= N_Attribute_Reference 4775 and then Comes_From_Source (N) 4776 then 4777 Set_Etype (N, Get_Actual_Subtype (N)); 4778 end if; 4779 4780 -- Note: there is no Eval processing required for an explicit 4781 -- deference, because the type is known to be an allocators, and 4782 -- allocator expressions can never be static. 4783 4784 end Resolve_Explicit_Dereference; 4785 4786 ------------------------------- 4787 -- Resolve_Indexed_Component -- 4788 ------------------------------- 4789 4790 procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id) is 4791 Name : constant Node_Id := Prefix (N); 4792 Expr : Node_Id; 4793 Array_Type : Entity_Id := Empty; -- to prevent junk warning 4794 Index : Node_Id; 4795 4796 begin 4797 if Is_Overloaded (Name) then 4798 4799 -- Use the context type to select the prefix that yields the 4800 -- correct component type. 4801 4802 declare 4803 I : Interp_Index; 4804 It : Interp; 4805 I1 : Interp_Index := 0; 4806 P : constant Node_Id := Prefix (N); 4807 Found : Boolean := False; 4808 4809 begin 4810 Get_First_Interp (P, I, It); 4811 4812 while Present (It.Typ) loop 4813 4814 if (Is_Array_Type (It.Typ) 4815 and then Covers (Typ, Component_Type (It.Typ))) 4816 or else (Is_Access_Type (It.Typ) 4817 and then Is_Array_Type (Designated_Type (It.Typ)) 4818 and then Covers 4819 (Typ, Component_Type (Designated_Type (It.Typ)))) 4820 then 4821 if Found then 4822 It := Disambiguate (P, I1, I, Any_Type); 4823 4824 if It = No_Interp then 4825 Error_Msg_N ("ambiguous prefix for indexing", N); 4826 Set_Etype (N, Typ); 4827 return; 4828 4829 else 4830 Found := True; 4831 Array_Type := It.Typ; 4832 I1 := I; 4833 end if; 4834 4835 else 4836 Found := True; 4837 Array_Type := It.Typ; 4838 I1 := I; 4839 end if; 4840 end if; 4841 4842 Get_Next_Interp (I, It); 4843 end loop; 4844 end; 4845 4846 else 4847 Array_Type := Etype (Name); 4848 end if; 4849 4850 Resolve (Name, Array_Type); 4851 Array_Type := Get_Actual_Subtype_If_Available (Name); 4852 4853 -- If prefix is access type, dereference to get real array type. 4854 -- Note: we do not apply an access check because the expander always 4855 -- introduces an explicit dereference, and the check will happen there. 4856 4857 if Is_Access_Type (Array_Type) then 4858 Array_Type := Designated_Type (Array_Type); 4859 end if; 4860 4861 -- If name was overloaded, set component type correctly now. 4862 4863 Set_Etype (N, Component_Type (Array_Type)); 4864 4865 Index := First_Index (Array_Type); 4866 Expr := First (Expressions (N)); 4867 4868 -- The prefix may have resolved to a string literal, in which case 4869 -- its etype has a special representation. This is only possible 4870 -- currently if the prefix is a static concatenation, written in 4871 -- functional notation. 4872 4873 if Ekind (Array_Type) = E_String_Literal_Subtype then 4874 Resolve (Expr, Standard_Positive); 4875 4876 else 4877 while Present (Index) and Present (Expr) loop 4878 Resolve (Expr, Etype (Index)); 4879 Check_Unset_Reference (Expr); 4880 4881 if Is_Scalar_Type (Etype (Expr)) then 4882 Apply_Scalar_Range_Check (Expr, Etype (Index)); 4883 else 4884 Apply_Range_Check (Expr, Get_Actual_Subtype (Index)); 4885 end if; 4886 4887 Next_Index (Index); 4888 Next (Expr); 4889 end loop; 4890 end if; 4891 4892 Eval_Indexed_Component (N); 4893 end Resolve_Indexed_Component; 4894 4895 ----------------------------- 4896 -- Resolve_Integer_Literal -- 4897 ----------------------------- 4898 4899 procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id) is 4900 begin 4901 Set_Etype (N, Typ); 4902 Eval_Integer_Literal (N); 4903 end Resolve_Integer_Literal; 4904 4905 --------------------------------- 4906 -- Resolve_Intrinsic_Operator -- 4907 --------------------------------- 4908 4909 procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is 4910 Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); 4911 Op : Entity_Id; 4912 Arg1 : Node_Id; 4913 Arg2 : Node_Id; 4914 4915 begin 4916 Op := Entity (N); 4917 4918 while Scope (Op) /= Standard_Standard loop 4919 Op := Homonym (Op); 4920 pragma Assert (Present (Op)); 4921 end loop; 4922 4923 Set_Entity (N, Op); 4924 4925 -- If the operand type is private, rewrite with suitable 4926 -- conversions on the operands and the result, to expose 4927 -- the proper underlying numeric type. 4928 4929 if Is_Private_Type (Typ) then 4930 Arg1 := Unchecked_Convert_To (Btyp, Left_Opnd (N)); 4931 4932 if Nkind (N) = N_Op_Expon then 4933 Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N)); 4934 else 4935 Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N)); 4936 end if; 4937 4938 Save_Interps (Left_Opnd (N), Expression (Arg1)); 4939 Save_Interps (Right_Opnd (N), Expression (Arg2)); 4940 4941 Set_Left_Opnd (N, Arg1); 4942 Set_Right_Opnd (N, Arg2); 4943 4944 Set_Etype (N, Btyp); 4945 Rewrite (N, Unchecked_Convert_To (Typ, N)); 4946 Resolve (N, Typ); 4947 4948 elsif Typ /= Etype (Left_Opnd (N)) 4949 or else Typ /= Etype (Right_Opnd (N)) 4950 then 4951 -- Add explicit conversion where needed, and save interpretations 4952 -- if operands are overloaded. 4953 4954 Arg1 := Convert_To (Typ, Left_Opnd (N)); 4955 Arg2 := Convert_To (Typ, Right_Opnd (N)); 4956 4957 if Nkind (Arg1) = N_Type_Conversion then 4958 Save_Interps (Left_Opnd (N), Expression (Arg1)); 4959 end if; 4960 4961 if Nkind (Arg2) = N_Type_Conversion then 4962 Save_Interps (Right_Opnd (N), Expression (Arg2)); 4963 end if; 4964 4965 Rewrite (Left_Opnd (N), Arg1); 4966 Rewrite (Right_Opnd (N), Arg2); 4967 Analyze (Arg1); 4968 Analyze (Arg2); 4969 Resolve_Arithmetic_Op (N, Typ); 4970 4971 else 4972 Resolve_Arithmetic_Op (N, Typ); 4973 end if; 4974 end Resolve_Intrinsic_Operator; 4975 4976 -------------------------------------- 4977 -- Resolve_Intrinsic_Unary_Operator -- 4978 -------------------------------------- 4979 4980 procedure Resolve_Intrinsic_Unary_Operator 4981 (N : Node_Id; 4982 Typ : Entity_Id) 4983 is 4984 Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); 4985 Op : Entity_Id; 4986 Arg2 : Node_Id; 4987 4988 begin 4989 Op := Entity (N); 4990 4991 while Scope (Op) /= Standard_Standard loop 4992 Op := Homonym (Op); 4993 pragma Assert (Present (Op)); 4994 end loop; 4995 4996 Set_Entity (N, Op); 4997 4998 if Is_Private_Type (Typ) then 4999 Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N)); 5000 Save_Interps (Right_Opnd (N), Expression (Arg2)); 5001 5002 Set_Right_Opnd (N, Arg2); 5003 5004 Set_Etype (N, Btyp); 5005 Rewrite (N, Unchecked_Convert_To (Typ, N)); 5006 Resolve (N, Typ); 5007 5008 else 5009 Resolve_Unary_Op (N, Typ); 5010 end if; 5011 end Resolve_Intrinsic_Unary_Operator; 5012 5013 ------------------------ 5014 -- Resolve_Logical_Op -- 5015 ------------------------ 5016 5017 procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is 5018 B_Typ : Entity_Id; 5019 5020 begin 5021 Check_Direct_Boolean_Op (N); 5022 5023 -- Predefined operations on scalar types yield the base type. On 5024 -- the other hand, logical operations on arrays yield the type of 5025 -- the arguments (and the context). 5026 5027 if Is_Array_Type (Typ) then 5028 B_Typ := Typ; 5029 else 5030 B_Typ := Base_Type (Typ); 5031 end if; 5032 5033 -- The following test is required because the operands of the operation 5034 -- may be literals, in which case the resulting type appears to be 5035 -- compatible with a signed integer type, when in fact it is compatible 5036 -- only with modular types. If the context itself is universal, the 5037 -- operation is illegal. 5038 5039 if not Valid_Boolean_Arg (Typ) then 5040 Error_Msg_N ("invalid context for logical operation", N); 5041 Set_Etype (N, Any_Type); 5042 return; 5043 5044 elsif Typ = Any_Modular then 5045 Error_Msg_N 5046 ("no modular type available in this context", N); 5047 Set_Etype (N, Any_Type); 5048 return; 5049 elsif Is_Modular_Integer_Type (Typ) 5050 and then Etype (Left_Opnd (N)) = Universal_Integer 5051 and then Etype (Right_Opnd (N)) = Universal_Integer 5052 then 5053 Check_For_Visible_Operator (N, B_Typ); 5054 end if; 5055 5056 Resolve (Left_Opnd (N), B_Typ); 5057 Resolve (Right_Opnd (N), B_Typ); 5058 5059 Check_Unset_Reference (Left_Opnd (N)); 5060 Check_Unset_Reference (Right_Opnd (N)); 5061 5062 Set_Etype (N, B_Typ); 5063 Generate_Operator_Reference (N, B_Typ); 5064 Eval_Logical_Op (N); 5065 end Resolve_Logical_Op; 5066 5067 --------------------------- 5068 -- Resolve_Membership_Op -- 5069 --------------------------- 5070 5071 -- The context can only be a boolean type, and does not determine 5072 -- the arguments. Arguments should be unambiguous, but the preference 5073 -- rule for universal types applies. 5074 5075 procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is 5076 pragma Warnings (Off, Typ); 5077 5078 L : constant Node_Id := Left_Opnd (N); 5079 R : constant Node_Id := Right_Opnd (N); 5080 T : Entity_Id; 5081 5082 begin 5083 if L = Error or else R = Error then 5084 return; 5085 end if; 5086 5087 if not Is_Overloaded (R) 5088 and then 5089 (Etype (R) = Universal_Integer or else 5090 Etype (R) = Universal_Real) 5091 and then Is_Overloaded (L) 5092 then 5093 T := Etype (R); 5094 else 5095 T := Intersect_Types (L, R); 5096 end if; 5097 5098 Resolve (L, T); 5099 Check_Unset_Reference (L); 5100 5101 if Nkind (R) = N_Range 5102 and then not Is_Scalar_Type (T) 5103 then 5104 Error_Msg_N ("scalar type required for range", R); 5105 end if; 5106 5107 if Is_Entity_Name (R) then 5108 Freeze_Expression (R); 5109 else 5110 Resolve (R, T); 5111 Check_Unset_Reference (R); 5112 end if; 5113 5114 Eval_Membership_Op (N); 5115 end Resolve_Membership_Op; 5116 5117 ------------------ 5118 -- Resolve_Null -- 5119 ------------------ 5120 5121 procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is 5122 begin 5123 -- For now allow circumvention of the restriction against 5124 -- anonymous null access values via a debug switch to allow 5125 -- for easier transition. 5126 5127 if not Debug_Flag_J 5128 and then Ekind (Typ) = E_Anonymous_Access_Type 5129 and then Comes_From_Source (N) 5130 then 5131 -- In the common case of a call which uses an explicitly null 5132 -- value for an access parameter, give specialized error msg 5133 5134 if Nkind (Parent (N)) = N_Procedure_Call_Statement 5135 or else 5136 Nkind (Parent (N)) = N_Function_Call 5137 then 5138 Error_Msg_N 5139 ("null is not allowed as argument for an access parameter", N); 5140 5141 -- Standard message for all other cases (are there any?) 5142 5143 else 5144 Error_Msg_N 5145 ("null cannot be of an anonymous access type", N); 5146 end if; 5147 end if; 5148 5149 -- In a distributed context, null for a remote access to subprogram 5150 -- may need to be replaced with a special record aggregate. In this 5151 -- case, return after having done the transformation. 5152 5153 if (Ekind (Typ) = E_Record_Type 5154 or else Is_Remote_Access_To_Subprogram_Type (Typ)) 5155 and then Remote_AST_Null_Value (N, Typ) 5156 then 5157 return; 5158 end if; 5159 5160 -- The null literal takes its type from the context. 5161 5162 Set_Etype (N, Typ); 5163 end Resolve_Null; 5164 5165 ----------------------- 5166 -- Resolve_Op_Concat -- 5167 ----------------------- 5168 5169 procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is 5170 Btyp : constant Entity_Id := Base_Type (Typ); 5171 Op1 : constant Node_Id := Left_Opnd (N); 5172 Op2 : constant Node_Id := Right_Opnd (N); 5173 5174 procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean); 5175 -- Internal procedure to resolve one operand of concatenation operator. 5176 -- The operand is either of the array type or of the component type. 5177 -- If the operand is an aggregate, and the component type is composite, 5178 -- this is ambiguous if component type has aggregates. 5179 5180 ------------------------------- 5181 -- Resolve_Concatenation_Arg -- 5182 ------------------------------- 5183 5184 procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean) is 5185 begin 5186 if In_Instance then 5187 if Is_Comp 5188 or else (not Is_Overloaded (Arg) 5189 and then Etype (Arg) /= Any_Composite 5190 and then Covers (Component_Type (Typ), Etype (Arg))) 5191 then 5192 Resolve (Arg, Component_Type (Typ)); 5193 else 5194 Resolve (Arg, Btyp); 5195 end if; 5196 5197 elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then 5198 5199 if Nkind (Arg) = N_Aggregate 5200 and then Is_Composite_Type (Component_Type (Typ)) 5201 then 5202 if Is_Private_Type (Component_Type (Typ)) then 5203 Resolve (Arg, Btyp); 5204 5205 else 5206 Error_Msg_N ("ambiguous aggregate must be qualified", Arg); 5207 Set_Etype (Arg, Any_Type); 5208 end if; 5209 5210 else 5211 if Is_Overloaded (Arg) 5212 and then Has_Compatible_Type (Arg, Typ) 5213 and then Etype (Arg) /= Any_Type 5214 then 5215 Error_Msg_N ("ambiguous operand for concatenation!", Arg); 5216 5217 declare 5218 I : Interp_Index; 5219 It : Interp; 5220 5221 begin 5222 Get_First_Interp (Arg, I, It); 5223 5224 while Present (It.Nam) loop 5225 5226 if Base_Type (Etype (It.Nam)) = Base_Type (Typ) 5227 or else Base_Type (Etype (It.Nam)) = 5228 Base_Type (Component_Type (Typ)) 5229 then 5230 Error_Msg_Sloc := Sloc (It.Nam); 5231 Error_Msg_N ("\possible interpretation#", Arg); 5232 end if; 5233 5234 Get_Next_Interp (I, It); 5235 end loop; 5236 end; 5237 end if; 5238 5239 Resolve (Arg, Component_Type (Typ)); 5240 5241 if Nkind (Arg) = N_String_Literal then 5242 Set_Etype (Arg, Component_Type (Typ)); 5243 end if; 5244 5245 if Arg = Left_Opnd (N) then 5246 Set_Is_Component_Left_Opnd (N); 5247 else 5248 Set_Is_Component_Right_Opnd (N); 5249 end if; 5250 end if; 5251 5252 else 5253 Resolve (Arg, Btyp); 5254 end if; 5255 5256 Check_Unset_Reference (Arg); 5257 end Resolve_Concatenation_Arg; 5258 5259 -- Start of processing for Resolve_Op_Concat 5260 5261 begin 5262 Set_Etype (N, Btyp); 5263 5264 if Is_Limited_Composite (Btyp) then 5265 Error_Msg_N ("concatenation not available for limited array", N); 5266 Explain_Limited_Type (Btyp, N); 5267 end if; 5268 5269 -- If the operands are themselves concatenations, resolve them as 5270 -- such directly. This removes several layers of recursion and allows 5271 -- GNAT to handle larger multiple concatenations. 5272 5273 if Nkind (Op1) = N_Op_Concat 5274 and then not Is_Array_Type (Component_Type (Typ)) 5275 and then Entity (Op1) = Entity (N) 5276 then 5277 Resolve_Op_Concat (Op1, Typ); 5278 else 5279 Resolve_Concatenation_Arg 5280 (Op1, Is_Component_Left_Opnd (N)); 5281 end if; 5282 5283 if Nkind (Op2) = N_Op_Concat 5284 and then not Is_Array_Type (Component_Type (Typ)) 5285 and then Entity (Op2) = Entity (N) 5286 then 5287 Resolve_Op_Concat (Op2, Typ); 5288 else 5289 Resolve_Concatenation_Arg 5290 (Op2, Is_Component_Right_Opnd (N)); 5291 end if; 5292 5293 Generate_Operator_Reference (N, Typ); 5294 5295 if Is_String_Type (Typ) then 5296 Eval_Concatenation (N); 5297 end if; 5298 5299 -- If this is not a static concatenation, but the result is a 5300 -- string type (and not an array of strings) insure that static 5301 -- string operands have their subtypes properly constructed. 5302 5303 if Nkind (N) /= N_String_Literal 5304 and then Is_Character_Type (Component_Type (Typ)) 5305 then 5306 Set_String_Literal_Subtype (Op1, Typ); 5307 Set_String_Literal_Subtype (Op2, Typ); 5308 end if; 5309 end Resolve_Op_Concat; 5310 5311 ---------------------- 5312 -- Resolve_Op_Expon -- 5313 ---------------------- 5314 5315 procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id) is 5316 B_Typ : constant Entity_Id := Base_Type (Typ); 5317 5318 begin 5319 -- Catch attempts to do fixed-point exponentation with universal 5320 -- operands, which is a case where the illegality is not caught 5321 -- during normal operator analysis. 5322 5323 if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then 5324 Error_Msg_N ("exponentiation not available for fixed point", N); 5325 return; 5326 end if; 5327 5328 if Comes_From_Source (N) 5329 and then Ekind (Entity (N)) = E_Function 5330 and then Is_Imported (Entity (N)) 5331 and then Is_Intrinsic_Subprogram (Entity (N)) 5332 then 5333 Resolve_Intrinsic_Operator (N, Typ); 5334 return; 5335 end if; 5336 5337 if Etype (Left_Opnd (N)) = Universal_Integer 5338 or else Etype (Left_Opnd (N)) = Universal_Real 5339 then 5340 Check_For_Visible_Operator (N, B_Typ); 5341 end if; 5342 5343 -- We do the resolution using the base type, because intermediate values 5344 -- in expressions always are of the base type, not a subtype of it. 5345 5346 Resolve (Left_Opnd (N), B_Typ); 5347 Resolve (Right_Opnd (N), Standard_Integer); 5348 5349 Check_Unset_Reference (Left_Opnd (N)); 5350 Check_Unset_Reference (Right_Opnd (N)); 5351 5352 Set_Etype (N, B_Typ); 5353 Generate_Operator_Reference (N, B_Typ); 5354 Eval_Op_Expon (N); 5355 5356 -- Set overflow checking bit. Much cleverer code needed here eventually 5357 -- and perhaps the Resolve routines should be separated for the various 5358 -- arithmetic operations, since they will need different processing. ??? 5359 5360 if Nkind (N) in N_Op then 5361 if not Overflow_Checks_Suppressed (Etype (N)) then 5362 Enable_Overflow_Check (N); 5363 end if; 5364 end if; 5365 end Resolve_Op_Expon; 5366 5367 -------------------- 5368 -- Resolve_Op_Not -- 5369 -------------------- 5370 5371 procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id) is 5372 B_Typ : Entity_Id; 5373 5374 function Parent_Is_Boolean return Boolean; 5375 -- This function determines if the parent node is a boolean operator 5376 -- or operation (comparison op, membership test, or short circuit form) 5377 -- and the not in question is the left operand of this operation. 5378 -- Note that if the not is in parens, then false is returned. 5379 5380 function Parent_Is_Boolean return Boolean is 5381 begin 5382 if Paren_Count (N) /= 0 then 5383 return False; 5384 5385 else 5386 case Nkind (Parent (N)) is 5387 when N_Op_And | 5388 N_Op_Eq | 5389 N_Op_Ge | 5390 N_Op_Gt | 5391 N_Op_Le | 5392 N_Op_Lt | 5393 N_Op_Ne | 5394 N_Op_Or | 5395 N_Op_Xor | 5396 N_In | 5397 N_Not_In | 5398 N_And_Then | 5399 N_Or_Else => 5400 5401 return Left_Opnd (Parent (N)) = N; 5402 5403 when others => 5404 return False; 5405 end case; 5406 end if; 5407 end Parent_Is_Boolean; 5408 5409 -- Start of processing for Resolve_Op_Not 5410 5411 begin 5412 -- Predefined operations on scalar types yield the base type. On 5413 -- the other hand, logical operations on arrays yield the type of 5414 -- the arguments (and the context). 5415 5416 if Is_Array_Type (Typ) then 5417 B_Typ := Typ; 5418 else 5419 B_Typ := Base_Type (Typ); 5420 end if; 5421 5422 if not Valid_Boolean_Arg (Typ) then 5423 Error_Msg_N ("invalid operand type for operator&", N); 5424 Set_Etype (N, Any_Type); 5425 return; 5426 5427 elsif Typ = Universal_Integer or else Typ = Any_Modular then 5428 if Parent_Is_Boolean then 5429 Error_Msg_N 5430 ("operand of not must be enclosed in parentheses", 5431 Right_Opnd (N)); 5432 else 5433 Error_Msg_N 5434 ("no modular type available in this context", N); 5435 end if; 5436 5437 Set_Etype (N, Any_Type); 5438 return; 5439 5440 else 5441 if not Is_Boolean_Type (Typ) 5442 and then Parent_Is_Boolean 5443 then 5444 Error_Msg_N ("?not expression should be parenthesized here", N); 5445 end if; 5446 5447 Resolve (Right_Opnd (N), B_Typ); 5448 Check_Unset_Reference (Right_Opnd (N)); 5449 Set_Etype (N, B_Typ); 5450 Generate_Operator_Reference (N, B_Typ); 5451 Eval_Op_Not (N); 5452 end if; 5453 end Resolve_Op_Not; 5454 5455 ----------------------------- 5456 -- Resolve_Operator_Symbol -- 5457 ----------------------------- 5458 5459 -- Nothing to be done, all resolved already 5460 5461 procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id) is 5462 pragma Warnings (Off, N); 5463 pragma Warnings (Off, Typ); 5464 5465 begin 5466 null; 5467 end Resolve_Operator_Symbol; 5468 5469 ---------------------------------- 5470 -- Resolve_Qualified_Expression -- 5471 ---------------------------------- 5472 5473 procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id) is 5474 pragma Warnings (Off, Typ); 5475 5476 Target_Typ : constant Entity_Id := Entity (Subtype_Mark (N)); 5477 Expr : constant Node_Id := Expression (N); 5478 5479 begin 5480 Resolve (Expr, Target_Typ); 5481 5482 -- A qualified expression requires an exact match of the type, 5483 -- class-wide matching is not allowed. 5484 5485 if Is_Class_Wide_Type (Target_Typ) 5486 and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ) 5487 then 5488 Wrong_Type (Expr, Target_Typ); 5489 end if; 5490 5491 -- If the target type is unconstrained, then we reset the type of 5492 -- the result from the type of the expression. For other cases, the 5493 -- actual subtype of the expression is the target type. 5494 5495 if Is_Composite_Type (Target_Typ) 5496 and then not Is_Constrained (Target_Typ) 5497 then 5498 Set_Etype (N, Etype (Expr)); 5499 end if; 5500 5501 Eval_Qualified_Expression (N); 5502 end Resolve_Qualified_Expression; 5503 5504 ------------------- 5505 -- Resolve_Range -- 5506 ------------------- 5507 5508 procedure Resolve_Range (N : Node_Id; Typ : Entity_Id) is 5509 L : constant Node_Id := Low_Bound (N); 5510 H : constant Node_Id := High_Bound (N); 5511 5512 begin 5513 Set_Etype (N, Typ); 5514 Resolve (L, Typ); 5515 Resolve (H, Typ); 5516 5517 Check_Unset_Reference (L); 5518 Check_Unset_Reference (H); 5519 5520 -- We have to check the bounds for being within the base range as 5521 -- required for a non-static context. Normally this is automatic 5522 -- and done as part of evaluating expressions, but the N_Range 5523 -- node is an exception, since in GNAT we consider this node to 5524 -- be a subexpression, even though in Ada it is not. The circuit 5525 -- in Sem_Eval could check for this, but that would put the test 5526 -- on the main evaluation path for expressions. 5527 5528 Check_Non_Static_Context (L); 5529 Check_Non_Static_Context (H); 5530 5531 -- If bounds are static, constant-fold them, so size computations 5532 -- are identical between front-end and back-end. Do not perform this 5533 -- transformation while analyzing generic units, as type information 5534 -- would then be lost when reanalyzing the constant node in the 5535 -- instance. 5536 5537 if Is_Discrete_Type (Typ) and then Expander_Active then 5538 if Is_OK_Static_Expression (L) then 5539 Fold_Uint (L, Expr_Value (L), Is_Static_Expression (L)); 5540 end if; 5541 5542 if Is_OK_Static_Expression (H) then 5543 Fold_Uint (H, Expr_Value (H), Is_Static_Expression (H)); 5544 end if; 5545 end if; 5546 end Resolve_Range; 5547 5548 -------------------------- 5549 -- Resolve_Real_Literal -- 5550 -------------------------- 5551 5552 procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id) is 5553 Actual_Typ : constant Entity_Id := Etype (N); 5554 5555 begin 5556 -- Special processing for fixed-point literals to make sure that the 5557 -- value is an exact multiple of small where this is required. We 5558 -- skip this for the universal real case, and also for generic types. 5559 5560 if Is_Fixed_Point_Type (Typ) 5561 and then Typ /= Universal_Fixed 5562 and then Typ /= Any_Fixed 5563 and then not Is_Generic_Type (Typ) 5564 then 5565 declare 5566 Val : constant Ureal := Realval (N); 5567 Cintr : constant Ureal := Val / Small_Value (Typ); 5568 Cint : constant Uint := UR_Trunc (Cintr); 5569 Den : constant Uint := Norm_Den (Cintr); 5570 Stat : Boolean; 5571 5572 begin 5573 -- Case of literal is not an exact multiple of the Small 5574 5575 if Den /= 1 then 5576 5577 -- For a source program literal for a decimal fixed-point 5578 -- type, this is statically illegal (RM 4.9(36)). 5579 5580 if Is_Decimal_Fixed_Point_Type (Typ) 5581 and then Actual_Typ = Universal_Real 5582 and then Comes_From_Source (N) 5583 then 5584 Error_Msg_N ("value has extraneous low order digits", N); 5585 end if; 5586 5587 -- Replace literal by a value that is the exact representation 5588 -- of a value of the type, i.e. a multiple of the small value, 5589 -- by truncation, since Machine_Rounds is false for all GNAT 5590 -- fixed-point types (RM 4.9(38)). 5591 5592 Stat := Is_Static_Expression (N); 5593 Rewrite (N, 5594 Make_Real_Literal (Sloc (N), 5595 Realval => Small_Value (Typ) * Cint)); 5596 5597 Set_Is_Static_Expression (N, Stat); 5598 end if; 5599 5600 -- In all cases, set the corresponding integer field 5601 5602 Set_Corresponding_Integer_Value (N, Cint); 5603 end; 5604 end if; 5605 5606 -- Now replace the actual type by the expected type as usual 5607 5608 Set_Etype (N, Typ); 5609 Eval_Real_Literal (N); 5610 end Resolve_Real_Literal; 5611 5612 ----------------------- 5613 -- Resolve_Reference -- 5614 ----------------------- 5615 5616 procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id) is 5617 P : constant Node_Id := Prefix (N); 5618 5619 begin 5620 -- Replace general access with specific type 5621 5622 if Ekind (Etype (N)) = E_Allocator_Type then 5623 Set_Etype (N, Base_Type (Typ)); 5624 end if; 5625 5626 Resolve (P, Designated_Type (Etype (N))); 5627 5628 -- If we are taking the reference of a volatile entity, then treat 5629 -- it as a potential modification of this entity. This is much too 5630 -- conservative, but is necessary because remove side effects can 5631 -- result in transformations of normal assignments into reference 5632 -- sequences that otherwise fail to notice the modification. 5633 5634 if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then 5635 Note_Possible_Modification (P); 5636 end if; 5637 end Resolve_Reference; 5638 5639 -------------------------------- 5640 -- Resolve_Selected_Component -- 5641 -------------------------------- 5642 5643 procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is 5644 Comp : Entity_Id; 5645 Comp1 : Entity_Id := Empty; -- prevent junk warning 5646 P : constant Node_Id := Prefix (N); 5647 S : constant Node_Id := Selector_Name (N); 5648 T : Entity_Id := Etype (P); 5649 I : Interp_Index; 5650 I1 : Interp_Index := 0; -- prevent junk warning 5651 It : Interp; 5652 It1 : Interp; 5653 Found : Boolean; 5654 5655 function Init_Component return Boolean; 5656 -- Check whether this is the initialization of a component within an 5657 -- init proc (by assignment or call to another init proc). If true, 5658 -- there is no need for a discriminant check. 5659 5660 -------------------- 5661 -- Init_Component -- 5662 -------------------- 5663 5664 function Init_Component return Boolean is 5665 begin 5666 return Inside_Init_Proc 5667 and then Nkind (Prefix (N)) = N_Identifier 5668 and then Chars (Prefix (N)) = Name_uInit 5669 and then Nkind (Parent (Parent (N))) = N_Case_Statement_Alternative; 5670 end Init_Component; 5671 5672 -- Start of processing for Resolve_Selected_Component 5673 5674 begin 5675 if Is_Overloaded (P) then 5676 5677 -- Use the context type to select the prefix that has a selector 5678 -- of the correct name and type. 5679 5680 Found := False; 5681 Get_First_Interp (P, I, It); 5682 5683 Search : while Present (It.Typ) loop 5684 if Is_Access_Type (It.Typ) then 5685 T := Designated_Type (It.Typ); 5686 else 5687 T := It.Typ; 5688 end if; 5689 5690 if Is_Record_Type (T) then 5691 Comp := First_Entity (T); 5692 5693 while Present (Comp) loop 5694 5695 if Chars (Comp) = Chars (S) 5696 and then Covers (Etype (Comp), Typ) 5697 then 5698 if not Found then 5699 Found := True; 5700 I1 := I; 5701 It1 := It; 5702 Comp1 := Comp; 5703 5704 else 5705 It := Disambiguate (P, I1, I, Any_Type); 5706 5707 if It = No_Interp then 5708 Error_Msg_N 5709 ("ambiguous prefix for selected component", N); 5710 Set_Etype (N, Typ); 5711 return; 5712 5713 else 5714 It1 := It; 5715 5716 if Scope (Comp1) /= It1.Typ then 5717 5718 -- Resolution chooses the new interpretation. 5719 -- Find the component with the right name. 5720 5721 Comp1 := First_Entity (It1.Typ); 5722 5723 while Present (Comp1) 5724 and then Chars (Comp1) /= Chars (S) 5725 loop 5726 Comp1 := Next_Entity (Comp1); 5727 end loop; 5728 end if; 5729 5730 exit Search; 5731 end if; 5732 end if; 5733 end if; 5734 5735 Comp := Next_Entity (Comp); 5736 end loop; 5737 5738 end if; 5739 5740 Get_Next_Interp (I, It); 5741 end loop Search; 5742 5743 Resolve (P, It1.Typ); 5744 Set_Etype (N, Typ); 5745 Set_Entity (S, Comp1); 5746 5747 else 5748 -- Resolve prefix with its type 5749 5750 Resolve (P, T); 5751 end if; 5752 5753 -- Deal with access type case 5754 5755 if Is_Access_Type (Etype (P)) then 5756 Apply_Access_Check (N); 5757 T := Designated_Type (Etype (P)); 5758 else 5759 T := Etype (P); 5760 end if; 5761 5762 if Has_Discriminants (T) 5763 and then (Ekind (Entity (S)) = E_Component 5764 or else 5765 Ekind (Entity (S)) = E_Discriminant) 5766 and then Present (Original_Record_Component (Entity (S))) 5767 and then Ekind (Original_Record_Component (Entity (S))) = E_Component 5768 and then Present (Discriminant_Checking_Func 5769 (Original_Record_Component (Entity (S)))) 5770 and then not Discriminant_Checks_Suppressed (T) 5771 and then not Init_Component 5772 then 5773 Set_Do_Discriminant_Check (N); 5774 end if; 5775 5776 if Ekind (Entity (S)) = E_Void then 5777 Error_Msg_N ("premature use of component", S); 5778 end if; 5779 5780 -- If the prefix is a record conversion, this may be a renamed 5781 -- discriminant whose bounds differ from those of the original 5782 -- one, so we must ensure that a range check is performed. 5783 5784 if Nkind (P) = N_Type_Conversion 5785 and then Ekind (Entity (S)) = E_Discriminant 5786 and then Is_Discrete_Type (Typ) 5787 then 5788 Set_Etype (N, Base_Type (Typ)); 5789 end if; 5790 5791 -- Note: No Eval processing is required, because the prefix is of a 5792 -- record type, or protected type, and neither can possibly be static. 5793 5794 end Resolve_Selected_Component; 5795 5796 ------------------- 5797 -- Resolve_Shift -- 5798 ------------------- 5799 5800 procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id) is 5801 B_Typ : constant Entity_Id := Base_Type (Typ); 5802 L : constant Node_Id := Left_Opnd (N); 5803 R : constant Node_Id := Right_Opnd (N); 5804 5805 begin 5806 -- We do the resolution using the base type, because intermediate values 5807 -- in expressions always are of the base type, not a subtype of it. 5808 5809 Resolve (L, B_Typ); 5810 Resolve (R, Standard_Natural); 5811 5812 Check_Unset_Reference (L); 5813 Check_Unset_Reference (R); 5814 5815 Set_Etype (N, B_Typ); 5816 Generate_Operator_Reference (N, B_Typ); 5817 Eval_Shift (N); 5818 end Resolve_Shift; 5819 5820 --------------------------- 5821 -- Resolve_Short_Circuit -- 5822 --------------------------- 5823 5824 procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id) is 5825 B_Typ : constant Entity_Id := Base_Type (Typ); 5826 L : constant Node_Id := Left_Opnd (N); 5827 R : constant Node_Id := Right_Opnd (N); 5828 5829 begin 5830 Resolve (L, B_Typ); 5831 Resolve (R, B_Typ); 5832 5833 Check_Unset_Reference (L); 5834 Check_Unset_Reference (R); 5835 5836 Set_Etype (N, B_Typ); 5837 Eval_Short_Circuit (N); 5838 end Resolve_Short_Circuit; 5839 5840 ------------------- 5841 -- Resolve_Slice -- 5842 ------------------- 5843 5844 procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id) is 5845 Name : constant Node_Id := Prefix (N); 5846 Drange : constant Node_Id := Discrete_Range (N); 5847 Array_Type : Entity_Id := Empty; 5848 Index : Node_Id; 5849 5850 begin 5851 if Is_Overloaded (Name) then 5852 5853 -- Use the context type to select the prefix that yields the 5854 -- correct array type. 5855 5856 declare 5857 I : Interp_Index; 5858 I1 : Interp_Index := 0; 5859 It : Interp; 5860 P : constant Node_Id := Prefix (N); 5861 Found : Boolean := False; 5862 5863 begin 5864 Get_First_Interp (P, I, It); 5865 5866 while Present (It.Typ) loop 5867 5868 if (Is_Array_Type (It.Typ) 5869 and then Covers (Typ, It.Typ)) 5870 or else (Is_Access_Type (It.Typ) 5871 and then Is_Array_Type (Designated_Type (It.Typ)) 5872 and then Covers (Typ, Designated_Type (It.Typ))) 5873 then 5874 if Found then 5875 It := Disambiguate (P, I1, I, Any_Type); 5876 5877 if It = No_Interp then 5878 Error_Msg_N ("ambiguous prefix for slicing", N); 5879 Set_Etype (N, Typ); 5880 return; 5881 else 5882 Found := True; 5883 Array_Type := It.Typ; 5884 I1 := I; 5885 end if; 5886 else 5887 Found := True; 5888 Array_Type := It.Typ; 5889 I1 := I; 5890 end if; 5891 end if; 5892 5893 Get_Next_Interp (I, It); 5894 end loop; 5895 end; 5896 5897 else 5898 Array_Type := Etype (Name); 5899 end if; 5900 5901 Resolve (Name, Array_Type); 5902 5903 if Is_Access_Type (Array_Type) then 5904 Apply_Access_Check (N); 5905 Array_Type := Designated_Type (Array_Type); 5906 5907 elsif Is_Entity_Name (Name) 5908 or else (Nkind (Name) = N_Function_Call 5909 and then not Is_Constrained (Etype (Name))) 5910 then 5911 Array_Type := Get_Actual_Subtype (Name); 5912 end if; 5913 5914 -- If name was overloaded, set slice type correctly now 5915 5916 Set_Etype (N, Array_Type); 5917 5918 -- If the range is specified by a subtype mark, no resolution 5919 -- is necessary. 5920 5921 if not Is_Entity_Name (Drange) then 5922 Index := First_Index (Array_Type); 5923 Resolve (Drange, Base_Type (Etype (Index))); 5924 5925 if Nkind (Drange) = N_Range then 5926 Apply_Range_Check (Drange, Etype (Index)); 5927 end if; 5928 end if; 5929 5930 Set_Slice_Subtype (N); 5931 Eval_Slice (N); 5932 end Resolve_Slice; 5933 5934 ---------------------------- 5935 -- Resolve_String_Literal -- 5936 ---------------------------- 5937 5938 procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id) is 5939 C_Typ : constant Entity_Id := Component_Type (Typ); 5940 R_Typ : constant Entity_Id := Root_Type (C_Typ); 5941 Loc : constant Source_Ptr := Sloc (N); 5942 Str : constant String_Id := Strval (N); 5943 Strlen : constant Nat := String_Length (Str); 5944 Subtype_Id : Entity_Id; 5945 Need_Check : Boolean; 5946 5947 begin 5948 -- For a string appearing in a concatenation, defer creation of the 5949 -- string_literal_subtype until the end of the resolution of the 5950 -- concatenation, because the literal may be constant-folded away. 5951 -- This is a useful optimization for long concatenation expressions. 5952 5953 -- If the string is an aggregate built for a single character (which 5954 -- happens in a non-static context) or a is null string to which special 5955 -- checks may apply, we build the subtype. Wide strings must also get 5956 -- a string subtype if they come from a one character aggregate. Strings 5957 -- generated by attributes might be static, but it is often hard to 5958 -- determine whether the enclosing context is static, so we generate 5959 -- subtypes for them as well, thus losing some rarer optimizations ??? 5960 -- Same for strings that come from a static conversion. 5961 5962 Need_Check := 5963 (Strlen = 0 and then Typ /= Standard_String) 5964 or else Nkind (Parent (N)) /= N_Op_Concat 5965 or else (N /= Left_Opnd (Parent (N)) 5966 and then N /= Right_Opnd (Parent (N))) 5967 or else (Typ = Standard_Wide_String 5968 and then Nkind (Original_Node (N)) /= N_String_Literal); 5969 5970 -- If the resolving type is itself a string literal subtype, we 5971 -- can just reuse it, since there is no point in creating another. 5972 5973 if Ekind (Typ) = E_String_Literal_Subtype then 5974 Subtype_Id := Typ; 5975 5976 elsif Nkind (Parent (N)) = N_Op_Concat 5977 and then not Need_Check 5978 and then Nkind (Original_Node (N)) /= N_Character_Literal 5979 and then Nkind (Original_Node (N)) /= N_Attribute_Reference 5980 and then Nkind (Original_Node (N)) /= N_Qualified_Expression 5981 and then Nkind (Original_Node (N)) /= N_Type_Conversion 5982 then 5983 Subtype_Id := Typ; 5984 5985 -- Otherwise we must create a string literal subtype. Note that the 5986 -- whole idea of string literal subtypes is simply to avoid the need 5987 -- for building a full fledged array subtype for each literal. 5988 else 5989 Set_String_Literal_Subtype (N, Typ); 5990 Subtype_Id := Etype (N); 5991 end if; 5992 5993 if Nkind (Parent (N)) /= N_Op_Concat 5994 or else Need_Check 5995 then 5996 Set_Etype (N, Subtype_Id); 5997 Eval_String_Literal (N); 5998 end if; 5999 6000 if Is_Limited_Composite (Typ) 6001 or else Is_Private_Composite (Typ) 6002 then 6003 Error_Msg_N ("string literal not available for private array", N); 6004 Set_Etype (N, Any_Type); 6005 return; 6006 end if; 6007 6008 -- The validity of a null string has been checked in the 6009 -- call to Eval_String_Literal. 6010 6011 if Strlen = 0 then 6012 return; 6013 6014 -- Always accept string literal with component type Any_Character, 6015 -- which occurs in error situations and in comparisons of literals, 6016 -- both of which should accept all literals. 6017 6018 elsif R_Typ = Any_Character then 6019 return; 6020 6021 -- If the type is bit-packed, then we always tranform the string 6022 -- literal into a full fledged aggregate. 6023 6024 elsif Is_Bit_Packed_Array (Typ) then 6025 null; 6026 6027 -- Deal with cases of Wide_String and String 6028 6029 else 6030 -- For Standard.Wide_String, or any other type whose component 6031 -- type is Standard.Wide_Character, we know that all the 6032 -- characters in the string must be acceptable, since the parser 6033 -- accepted the characters as valid character literals. 6034 6035 if R_Typ = Standard_Wide_Character then 6036 null; 6037 6038 -- For the case of Standard.String, or any other type whose 6039 -- component type is Standard.Character, we must make sure that 6040 -- there are no wide characters in the string, i.e. that it is 6041 -- entirely composed of characters in range of type String. 6042 6043 -- If the string literal is the result of a static concatenation, 6044 -- the test has already been performed on the components, and need 6045 -- not be repeated. 6046 6047 elsif R_Typ = Standard_Character 6048 and then Nkind (Original_Node (N)) /= N_Op_Concat 6049 then 6050 for J in 1 .. Strlen loop 6051 if not In_Character_Range (Get_String_Char (Str, J)) then 6052 6053 -- If we are out of range, post error. This is one of the 6054 -- very few places that we place the flag in the middle of 6055 -- a token, right under the offending wide character. 6056 6057 Error_Msg 6058 ("literal out of range of type Character", 6059 Source_Ptr (Int (Loc) + J)); 6060 return; 6061 end if; 6062 end loop; 6063 6064 -- If the root type is not a standard character, then we will convert 6065 -- the string into an aggregate and will let the aggregate code do 6066 -- the checking. 6067 6068 else 6069 null; 6070 6071 end if; 6072 6073 -- See if the component type of the array corresponding to the 6074 -- string has compile time known bounds. If yes we can directly 6075 -- check whether the evaluation of the string will raise constraint 6076 -- error. Otherwise we need to transform the string literal into 6077 -- the corresponding character aggregate and let the aggregate 6078 -- code do the checking. 6079 6080 if R_Typ = Standard_Wide_Character 6081 or else R_Typ = Standard_Character 6082 then 6083 -- Check for the case of full range, where we are definitely OK 6084 6085 if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then 6086 return; 6087 end if; 6088 6089 -- Here the range is not the complete base type range, so check 6090 6091 declare 6092 Comp_Typ_Lo : constant Node_Id := 6093 Type_Low_Bound (Component_Type (Typ)); 6094 Comp_Typ_Hi : constant Node_Id := 6095 Type_High_Bound (Component_Type (Typ)); 6096 6097 Char_Val : Uint; 6098 6099 begin 6100 if Compile_Time_Known_Value (Comp_Typ_Lo) 6101 and then Compile_Time_Known_Value (Comp_Typ_Hi) 6102 then 6103 for J in 1 .. Strlen loop 6104 Char_Val := UI_From_Int (Int (Get_String_Char (Str, J))); 6105 6106 if Char_Val < Expr_Value (Comp_Typ_Lo) 6107 or else Char_Val > Expr_Value (Comp_Typ_Hi) 6108 then 6109 Apply_Compile_Time_Constraint_Error 6110 (N, "character out of range?", CE_Range_Check_Failed, 6111 Loc => Source_Ptr (Int (Loc) + J)); 6112 end if; 6113 end loop; 6114 6115 return; 6116 end if; 6117 end; 6118 end if; 6119 end if; 6120 6121 -- If we got here we meed to transform the string literal into the 6122 -- equivalent qualified positional array aggregate. This is rather 6123 -- heavy artillery for this situation, but it is hard work to avoid. 6124 6125 declare 6126 Lits : constant List_Id := New_List; 6127 P : Source_Ptr := Loc + 1; 6128 C : Char_Code; 6129 6130 begin 6131 -- Build the character literals, we give them source locations 6132 -- that correspond to the string positions, which is a bit tricky 6133 -- given the possible presence of wide character escape sequences. 6134 6135 for J in 1 .. Strlen loop 6136 C := Get_String_Char (Str, J); 6137 Set_Character_Literal_Name (C); 6138 6139 Append_To (Lits, 6140 Make_Character_Literal (P, Name_Find, C)); 6141 6142 if In_Character_Range (C) then 6143 P := P + 1; 6144 6145 -- Should we have a call to Skip_Wide here ??? 6146 -- ??? else 6147 -- Skip_Wide (P); 6148 6149 end if; 6150 end loop; 6151 6152 Rewrite (N, 6153 Make_Qualified_Expression (Loc, 6154 Subtype_Mark => New_Reference_To (Typ, Loc), 6155 Expression => 6156 Make_Aggregate (Loc, Expressions => Lits))); 6157 6158 Analyze_And_Resolve (N, Typ); 6159 end; 6160 end Resolve_String_Literal; 6161 6162 ----------------------------- 6163 -- Resolve_Subprogram_Info -- 6164 ----------------------------- 6165 6166 procedure Resolve_Subprogram_Info (N : Node_Id; Typ : Entity_Id) is 6167 begin 6168 Set_Etype (N, Typ); 6169 end Resolve_Subprogram_Info; 6170 6171 ----------------------------- 6172 -- Resolve_Type_Conversion -- 6173 ----------------------------- 6174 6175 procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is 6176 Target_Type : constant Entity_Id := Etype (N); 6177 Conv_OK : constant Boolean := Conversion_OK (N); 6178 Operand : Node_Id; 6179 Opnd_Type : Entity_Id; 6180 Rop : Node_Id; 6181 Orig_N : Node_Id; 6182 Orig_T : Node_Id; 6183 6184 begin 6185 Operand := Expression (N); 6186 6187 if not Conv_OK 6188 and then not Valid_Conversion (N, Target_Type, Operand) 6189 then 6190 return; 6191 end if; 6192 6193 if Etype (Operand) = Any_Fixed then 6194 6195 -- Mixed-mode operation involving a literal. Context must be a fixed 6196 -- type which is applied to the literal subsequently. 6197 6198 if Is_Fixed_Point_Type (Typ) then 6199 Set_Etype (Operand, Universal_Real); 6200 6201 elsif Is_Numeric_Type (Typ) 6202 and then (Nkind (Operand) = N_Op_Multiply 6203 or else Nkind (Operand) = N_Op_Divide) 6204 and then (Etype (Right_Opnd (Operand)) = Universal_Real 6205 or else Etype (Left_Opnd (Operand)) = Universal_Real) 6206 then 6207 if Unique_Fixed_Point_Type (N) = Any_Type then 6208 return; -- expression is ambiguous. 6209 else 6210 Set_Etype (Operand, Standard_Duration); 6211 end if; 6212 6213 if Etype (Right_Opnd (Operand)) = Universal_Real then 6214 Rop := New_Copy_Tree (Right_Opnd (Operand)); 6215 else 6216 Rop := New_Copy_Tree (Left_Opnd (Operand)); 6217 end if; 6218 6219 Resolve (Rop, Standard_Long_Long_Float); 6220 6221 if Realval (Rop) /= Ureal_0 6222 and then abs (Realval (Rop)) < Delta_Value (Standard_Duration) 6223 then 6224 Error_Msg_N ("universal real operand can only be interpreted?", 6225 Rop); 6226 Error_Msg_N ("\as Duration, and will lose precision?", Rop); 6227 end if; 6228 6229 elsif Is_Numeric_Type (Typ) 6230 and then Nkind (Operand) in N_Op 6231 and then Unique_Fixed_Point_Type (N) /= Any_Type 6232 then 6233 Set_Etype (Operand, Standard_Duration); 6234 6235 else 6236 Error_Msg_N ("invalid context for mixed mode operation", N); 6237 Set_Etype (Operand, Any_Type); 6238 return; 6239 end if; 6240 end if; 6241 6242 Opnd_Type := Etype (Operand); 6243 Resolve (Operand); 6244 6245 -- Note: we do the Eval_Type_Conversion call before applying the 6246 -- required checks for a subtype conversion. This is important, 6247 -- since both are prepared under certain circumstances to change 6248 -- the type conversion to a constraint error node, but in the case 6249 -- of Eval_Type_Conversion this may reflect an illegality in the 6250 -- static case, and we would miss the illegality (getting only a 6251 -- warning message), if we applied the type conversion checks first. 6252 6253 Eval_Type_Conversion (N); 6254 6255 -- If after evaluation, we still have a type conversion, then we 6256 -- may need to apply checks required for a subtype conversion. 6257 6258 -- Skip these type conversion checks if universal fixed operands 6259 -- operands involved, since range checks are handled separately for 6260 -- these cases (in the appropriate Expand routines in unit Exp_Fixd). 6261 6262 if Nkind (N) = N_Type_Conversion 6263 and then not Is_Generic_Type (Root_Type (Target_Type)) 6264 and then Target_Type /= Universal_Fixed 6265 and then Opnd_Type /= Universal_Fixed 6266 then 6267 Apply_Type_Conversion_Checks (N); 6268 end if; 6269 6270 -- Issue warning for conversion of simple object to its own type 6271 -- We have to test the original nodes, since they may have been 6272 -- rewritten by various optimizations. 6273 6274 Orig_N := Original_Node (N); 6275 6276 if Warn_On_Redundant_Constructs 6277 and then Comes_From_Source (Orig_N) 6278 and then Nkind (Orig_N) = N_Type_Conversion 6279 then 6280 Orig_N := Original_Node (Expression (Orig_N)); 6281 Orig_T := Target_Type; 6282 6283 -- If the node is part of a larger expression, the Target_Type 6284 -- may not be the original type of the node if the context is a 6285 -- condition. Recover original type to see if conversion is needed. 6286 6287 if Is_Boolean_Type (Orig_T) 6288 and then Nkind (Parent (N)) in N_Op 6289 then 6290 Orig_T := Etype (Parent (N)); 6291 end if; 6292 6293 if Is_Entity_Name (Orig_N) 6294 and then Etype (Entity (Orig_N)) = Orig_T 6295 then 6296 Error_Msg_NE 6297 ("?useless conversion, & has this type", N, Entity (Orig_N)); 6298 end if; 6299 end if; 6300 end Resolve_Type_Conversion; 6301 6302 ---------------------- 6303 -- Resolve_Unary_Op -- 6304 ---------------------- 6305 6306 procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is 6307 B_Typ : constant Entity_Id := Base_Type (Typ); 6308 R : constant Node_Id := Right_Opnd (N); 6309 OK : Boolean; 6310 Lo : Uint; 6311 Hi : Uint; 6312 6313 begin 6314 -- Generate warning for expressions like abs (x mod 2) 6315 6316 if Warn_On_Redundant_Constructs 6317 and then Nkind (N) = N_Op_Abs 6318 then 6319 Determine_Range (Right_Opnd (N), OK, Lo, Hi); 6320 6321 if OK and then Hi >= Lo and then Lo >= 0 then 6322 Error_Msg_N 6323 ("?abs applied to known non-negative value has no effect", N); 6324 end if; 6325 end if; 6326 6327 -- Generate warning for expressions like -5 mod 3 6328 6329 if Paren_Count (N) = 0 6330 and then Nkind (N) = N_Op_Minus 6331 and then Nkind (Right_Opnd (N)) = N_Op_Mod 6332 and then Comes_From_Source (N) 6333 then 6334 Error_Msg_N 6335 ("?unary minus expression should be parenthesized here", N); 6336 end if; 6337 6338 if Comes_From_Source (N) 6339 and then Ekind (Entity (N)) = E_Function 6340 and then Is_Imported (Entity (N)) 6341 and then Is_Intrinsic_Subprogram (Entity (N)) 6342 then 6343 Resolve_Intrinsic_Unary_Operator (N, Typ); 6344 return; 6345 end if; 6346 6347 if Etype (R) = Universal_Integer 6348 or else Etype (R) = Universal_Real 6349 then 6350 Check_For_Visible_Operator (N, B_Typ); 6351 end if; 6352 6353 Set_Etype (N, B_Typ); 6354 Resolve (R, B_Typ); 6355 6356 Check_Unset_Reference (R); 6357 Generate_Operator_Reference (N, B_Typ); 6358 Eval_Unary_Op (N); 6359 6360 -- Set overflow checking bit. Much cleverer code needed here eventually 6361 -- and perhaps the Resolve routines should be separated for the various 6362 -- arithmetic operations, since they will need different processing ??? 6363 6364 if Nkind (N) in N_Op then 6365 if not Overflow_Checks_Suppressed (Etype (N)) then 6366 Enable_Overflow_Check (N); 6367 end if; 6368 end if; 6369 end Resolve_Unary_Op; 6370 6371 ---------------------------------- 6372 -- Resolve_Unchecked_Expression -- 6373 ---------------------------------- 6374 6375 procedure Resolve_Unchecked_Expression 6376 (N : Node_Id; 6377 Typ : Entity_Id) 6378 is 6379 begin 6380 Resolve (Expression (N), Typ, Suppress => All_Checks); 6381 Set_Etype (N, Typ); 6382 end Resolve_Unchecked_Expression; 6383 6384 --------------------------------------- 6385 -- Resolve_Unchecked_Type_Conversion -- 6386 --------------------------------------- 6387 6388 procedure Resolve_Unchecked_Type_Conversion 6389 (N : Node_Id; 6390 Typ : Entity_Id) 6391 is 6392 pragma Warnings (Off, Typ); 6393 6394 Operand : constant Node_Id := Expression (N); 6395 Opnd_Type : constant Entity_Id := Etype (Operand); 6396 6397 begin 6398 -- Resolve operand using its own type. 6399 6400 Resolve (Operand, Opnd_Type); 6401 Eval_Unchecked_Conversion (N); 6402 6403 end Resolve_Unchecked_Type_Conversion; 6404 6405 ------------------------------ 6406 -- Rewrite_Operator_As_Call -- 6407 ------------------------------ 6408 6409 procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is 6410 Loc : constant Source_Ptr := Sloc (N); 6411 Actuals : constant List_Id := New_List; 6412 New_N : Node_Id; 6413 6414 begin 6415 if Nkind (N) in N_Binary_Op then 6416 Append (Left_Opnd (N), Actuals); 6417 end if; 6418 6419 Append (Right_Opnd (N), Actuals); 6420 6421 New_N := 6422 Make_Function_Call (Sloc => Loc, 6423 Name => New_Occurrence_Of (Nam, Loc), 6424 Parameter_Associations => Actuals); 6425 6426 Preserve_Comes_From_Source (New_N, N); 6427 Preserve_Comes_From_Source (Name (New_N), N); 6428 Rewrite (N, New_N); 6429 Set_Etype (N, Etype (Nam)); 6430 end Rewrite_Operator_As_Call; 6431 6432 ------------------------------ 6433 -- Rewrite_Renamed_Operator -- 6434 ------------------------------ 6435 6436 procedure Rewrite_Renamed_Operator (N : Node_Id; Op : Entity_Id) is 6437 Nam : constant Name_Id := Chars (Op); 6438 Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op; 6439 Op_Node : Node_Id; 6440 6441 begin 6442 -- Rewrite the operator node using the real operator, not its 6443 -- renaming. Exclude user-defined intrinsic operations, which 6444 -- are treated separately. 6445 6446 if Ekind (Op) /= E_Function then 6447 Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N)); 6448 Set_Chars (Op_Node, Nam); 6449 Set_Etype (Op_Node, Etype (N)); 6450 Set_Entity (Op_Node, Op); 6451 Set_Right_Opnd (Op_Node, Right_Opnd (N)); 6452 6453 -- Indicate that both the original entity and its renaming 6454 -- are referenced at this point. 6455 6456 Generate_Reference (Entity (N), N); 6457 Generate_Reference (Op, N); 6458 6459 if Is_Binary then 6460 Set_Left_Opnd (Op_Node, Left_Opnd (N)); 6461 end if; 6462 6463 Rewrite (N, Op_Node); 6464 end if; 6465 end Rewrite_Renamed_Operator; 6466 6467 ----------------------- 6468 -- Set_Slice_Subtype -- 6469 ----------------------- 6470 6471 -- Build an implicit subtype declaration to represent the type delivered 6472 -- by the slice. This is an abbreviated version of an array subtype. We 6473 -- define an index subtype for the slice, using either the subtype name 6474 -- or the discrete range of the slice. To be consistent with index usage 6475 -- elsewhere, we create a list header to hold the single index. This list 6476 -- is not otherwise attached to the syntax tree. 6477 6478 procedure Set_Slice_Subtype (N : Node_Id) is 6479 Loc : constant Source_Ptr := Sloc (N); 6480 Index_List : constant List_Id := New_List; 6481 Index : Node_Id; 6482 Index_Subtype : Entity_Id; 6483 Index_Type : Entity_Id; 6484 Slice_Subtype : Entity_Id; 6485 Drange : constant Node_Id := Discrete_Range (N); 6486 6487 begin 6488 if Is_Entity_Name (Drange) then 6489 Index_Subtype := Entity (Drange); 6490 6491 else 6492 -- We force the evaluation of a range. This is definitely needed in 6493 -- the renamed case, and seems safer to do unconditionally. Note in 6494 -- any case that since we will create and insert an Itype referring 6495 -- to this range, we must make sure any side effect removal actions 6496 -- are inserted before the Itype definition. 6497 6498 if Nkind (Drange) = N_Range then 6499 Force_Evaluation (Low_Bound (Drange)); 6500 Force_Evaluation (High_Bound (Drange)); 6501 end if; 6502 6503 Index_Type := Base_Type (Etype (Drange)); 6504 6505 Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N); 6506 6507 Set_Scalar_Range (Index_Subtype, Drange); 6508 Set_Etype (Index_Subtype, Index_Type); 6509 Set_Size_Info (Index_Subtype, Index_Type); 6510 Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); 6511 end if; 6512 6513 Slice_Subtype := Create_Itype (E_Array_Subtype, N); 6514 6515 Index := New_Occurrence_Of (Index_Subtype, Loc); 6516 Set_Etype (Index, Index_Subtype); 6517 Append (Index, Index_List); 6518 6519 Set_First_Index (Slice_Subtype, Index); 6520 Set_Etype (Slice_Subtype, Base_Type (Etype (N))); 6521 Set_Is_Constrained (Slice_Subtype, True); 6522 Init_Size_Align (Slice_Subtype); 6523 6524 Check_Compile_Time_Size (Slice_Subtype); 6525 6526 -- The Etype of the existing Slice node is reset to this slice 6527 -- subtype. Its bounds are obtained from its first index. 6528 6529 Set_Etype (N, Slice_Subtype); 6530 6531 -- In the packed case, this must be immediately frozen 6532 6533 -- Couldn't we always freeze here??? and if we did, then the above 6534 -- call to Check_Compile_Time_Size could be eliminated, which would 6535 -- be nice, because then that routine could be made private to Freeze. 6536 6537 if Is_Packed (Slice_Subtype) and not In_Default_Expression then 6538 Freeze_Itype (Slice_Subtype, N); 6539 end if; 6540 6541 end Set_Slice_Subtype; 6542 6543 -------------------------------- 6544 -- Set_String_Literal_Subtype -- 6545 -------------------------------- 6546 6547 procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is 6548 Subtype_Id : Entity_Id; 6549 6550 begin 6551 if Nkind (N) /= N_String_Literal then 6552 return; 6553 else 6554 Subtype_Id := Create_Itype (E_String_Literal_Subtype, N); 6555 end if; 6556 6557 Set_String_Literal_Length (Subtype_Id, UI_From_Int 6558 (String_Length (Strval (N)))); 6559 Set_Etype (Subtype_Id, Base_Type (Typ)); 6560 Set_Is_Constrained (Subtype_Id); 6561 6562 -- The low bound is set from the low bound of the corresponding 6563 -- index type. Note that we do not store the high bound in the 6564 -- string literal subtype, but it can be deduced if necssary 6565 -- from the length and the low bound. 6566 6567 Set_String_Literal_Low_Bound 6568 (Subtype_Id, Type_Low_Bound (Etype (First_Index (Typ)))); 6569 6570 Set_Etype (N, Subtype_Id); 6571 end Set_String_Literal_Subtype; 6572 6573 ----------------------------- 6574 -- Unique_Fixed_Point_Type -- 6575 ----------------------------- 6576 6577 function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id is 6578 T1 : Entity_Id := Empty; 6579 T2 : Entity_Id; 6580 Item : Node_Id; 6581 Scop : Entity_Id; 6582 6583 procedure Fixed_Point_Error; 6584 -- If true ambiguity, give details. 6585 6586 procedure Fixed_Point_Error is 6587 begin 6588 Error_Msg_N ("ambiguous universal_fixed_expression", N); 6589 Error_Msg_NE ("\possible interpretation as}", N, T1); 6590 Error_Msg_NE ("\possible interpretation as}", N, T2); 6591 end Fixed_Point_Error; 6592 6593 begin 6594 -- The operations on Duration are visible, so Duration is always a 6595 -- possible interpretation. 6596 6597 T1 := Standard_Duration; 6598 6599 -- Look for fixed-point types in enclosing scopes. 6600 6601 Scop := Current_Scope; 6602 while Scop /= Standard_Standard loop 6603 T2 := First_Entity (Scop); 6604 6605 while Present (T2) loop 6606 if Is_Fixed_Point_Type (T2) 6607 and then Current_Entity (T2) = T2 6608 and then Scope (Base_Type (T2)) = Scop 6609 then 6610 if Present (T1) then 6611 Fixed_Point_Error; 6612 return Any_Type; 6613 else 6614 T1 := T2; 6615 end if; 6616 end if; 6617 6618 Next_Entity (T2); 6619 end loop; 6620 6621 Scop := Scope (Scop); 6622 end loop; 6623 6624 -- Look for visible fixed type declarations in the context. 6625 6626 Item := First (Context_Items (Cunit (Current_Sem_Unit))); 6627 6628 while Present (Item) loop 6629 if Nkind (Item) = N_With_Clause then 6630 Scop := Entity (Name (Item)); 6631 T2 := First_Entity (Scop); 6632 6633 while Present (T2) loop 6634 if Is_Fixed_Point_Type (T2) 6635 and then Scope (Base_Type (T2)) = Scop 6636 and then (Is_Potentially_Use_Visible (T2) 6637 or else In_Use (T2)) 6638 then 6639 if Present (T1) then 6640 Fixed_Point_Error; 6641 return Any_Type; 6642 else 6643 T1 := T2; 6644 end if; 6645 end if; 6646 6647 Next_Entity (T2); 6648 end loop; 6649 end if; 6650 6651 Next (Item); 6652 end loop; 6653 6654 if Nkind (N) = N_Real_Literal then 6655 Error_Msg_NE ("real literal interpreted as }?", N, T1); 6656 6657 else 6658 Error_Msg_NE ("universal_fixed expression interpreted as }?", N, T1); 6659 end if; 6660 6661 return T1; 6662 end Unique_Fixed_Point_Type; 6663 6664 ---------------------- 6665 -- Valid_Conversion -- 6666 ---------------------- 6667 6668 function Valid_Conversion 6669 (N : Node_Id; 6670 Target : Entity_Id; 6671 Operand : Node_Id) 6672 return Boolean 6673 is 6674 Target_Type : constant Entity_Id := Base_Type (Target); 6675 Opnd_Type : Entity_Id := Etype (Operand); 6676 6677 function Conversion_Check 6678 (Valid : Boolean; 6679 Msg : String) 6680 return Boolean; 6681 -- Little routine to post Msg if Valid is False, returns Valid value 6682 6683 function Valid_Tagged_Conversion 6684 (Target_Type : Entity_Id; 6685 Opnd_Type : Entity_Id) 6686 return Boolean; 6687 -- Specifically test for validity of tagged conversions 6688 6689 ---------------------- 6690 -- Conversion_Check -- 6691 ---------------------- 6692 6693 function Conversion_Check 6694 (Valid : Boolean; 6695 Msg : String) 6696 return Boolean 6697 is 6698 begin 6699 if not Valid then 6700 Error_Msg_N (Msg, Operand); 6701 end if; 6702 6703 return Valid; 6704 end Conversion_Check; 6705 6706 ----------------------------- 6707 -- Valid_Tagged_Conversion -- 6708 ----------------------------- 6709 6710 function Valid_Tagged_Conversion 6711 (Target_Type : Entity_Id; 6712 Opnd_Type : Entity_Id) 6713 return Boolean 6714 is 6715 begin 6716 -- Upward conversions are allowed (RM 4.6(22)). 6717 6718 if Covers (Target_Type, Opnd_Type) 6719 or else Is_Ancestor (Target_Type, Opnd_Type) 6720 then 6721 return True; 6722 6723 -- Downward conversion are allowed if the operand is 6724 -- is class-wide (RM 4.6(23)). 6725 6726 elsif Is_Class_Wide_Type (Opnd_Type) 6727 and then Covers (Opnd_Type, Target_Type) 6728 then 6729 return True; 6730 6731 elsif Covers (Opnd_Type, Target_Type) 6732 or else Is_Ancestor (Opnd_Type, Target_Type) 6733 then 6734 return 6735 Conversion_Check (False, 6736 "downward conversion of tagged objects not allowed"); 6737 else 6738 Error_Msg_NE 6739 ("invalid tagged conversion, not compatible with}", 6740 N, First_Subtype (Opnd_Type)); 6741 return False; 6742 end if; 6743 end Valid_Tagged_Conversion; 6744 6745 -- Start of processing for Valid_Conversion 6746 6747 begin 6748 Check_Parameterless_Call (Operand); 6749 6750 if Is_Overloaded (Operand) then 6751 declare 6752 I : Interp_Index; 6753 I1 : Interp_Index; 6754 It : Interp; 6755 It1 : Interp; 6756 N1 : Entity_Id; 6757 6758 begin 6759 -- Remove procedure calls, which syntactically cannot appear 6760 -- in this context, but which cannot be removed by type checking, 6761 -- because the context does not impose a type. 6762 6763 Get_First_Interp (Operand, I, It); 6764 6765 while Present (It.Typ) loop 6766 6767 if It.Typ = Standard_Void_Type then 6768 Remove_Interp (I); 6769 end if; 6770 6771 Get_Next_Interp (I, It); 6772 end loop; 6773 6774 Get_First_Interp (Operand, I, It); 6775 I1 := I; 6776 It1 := It; 6777 6778 if No (It.Typ) then 6779 Error_Msg_N ("illegal operand in conversion", Operand); 6780 return False; 6781 end if; 6782 6783 Get_Next_Interp (I, It); 6784 6785 if Present (It.Typ) then 6786 N1 := It1.Nam; 6787 It1 := Disambiguate (Operand, I1, I, Any_Type); 6788 6789 if It1 = No_Interp then 6790 Error_Msg_N ("ambiguous operand in conversion", Operand); 6791 6792 Error_Msg_Sloc := Sloc (It.Nam); 6793 Error_Msg_N ("possible interpretation#!", Operand); 6794 6795 Error_Msg_Sloc := Sloc (N1); 6796 Error_Msg_N ("possible interpretation#!", Operand); 6797 6798 return False; 6799 end if; 6800 end if; 6801 6802 Set_Etype (Operand, It1.Typ); 6803 Opnd_Type := It1.Typ; 6804 end; 6805 end if; 6806 6807 if Chars (Current_Scope) = Name_Unchecked_Conversion then 6808 6809 -- This check is dubious, what if there were a user defined 6810 -- scope whose name was Unchecked_Conversion ??? 6811 6812 return True; 6813 6814 elsif Is_Numeric_Type (Target_Type) then 6815 if Opnd_Type = Universal_Fixed then 6816 return True; 6817 else 6818 return Conversion_Check (Is_Numeric_Type (Opnd_Type), 6819 "illegal operand for numeric conversion"); 6820 end if; 6821 6822 elsif Is_Array_Type (Target_Type) then 6823 if not Is_Array_Type (Opnd_Type) 6824 or else Opnd_Type = Any_Composite 6825 or else Opnd_Type = Any_String 6826 then 6827 Error_Msg_N 6828 ("illegal operand for array conversion", Operand); 6829 return False; 6830 6831 elsif Number_Dimensions (Target_Type) /= 6832 Number_Dimensions (Opnd_Type) 6833 then 6834 Error_Msg_N 6835 ("incompatible number of dimensions for conversion", Operand); 6836 return False; 6837 6838 else 6839 declare 6840 Target_Index : Node_Id := First_Index (Target_Type); 6841 Opnd_Index : Node_Id := First_Index (Opnd_Type); 6842 6843 Target_Index_Type : Entity_Id; 6844 Opnd_Index_Type : Entity_Id; 6845 6846 Target_Comp_Type : constant Entity_Id := 6847 Component_Type (Target_Type); 6848 Opnd_Comp_Type : constant Entity_Id := 6849 Component_Type (Opnd_Type); 6850 6851 begin 6852 while Present (Target_Index) and then Present (Opnd_Index) loop 6853 Target_Index_Type := Etype (Target_Index); 6854 Opnd_Index_Type := Etype (Opnd_Index); 6855 6856 if not (Is_Integer_Type (Target_Index_Type) 6857 and then Is_Integer_Type (Opnd_Index_Type)) 6858 and then (Root_Type (Target_Index_Type) 6859 /= Root_Type (Opnd_Index_Type)) 6860 then 6861 Error_Msg_N 6862 ("incompatible index types for array conversion", 6863 Operand); 6864 return False; 6865 end if; 6866 6867 Next_Index (Target_Index); 6868 Next_Index (Opnd_Index); 6869 end loop; 6870 6871 if Base_Type (Target_Comp_Type) /= 6872 Base_Type (Opnd_Comp_Type) 6873 then 6874 Error_Msg_N 6875 ("incompatible component types for array conversion", 6876 Operand); 6877 return False; 6878 6879 elsif 6880 Is_Constrained (Target_Comp_Type) 6881 /= Is_Constrained (Opnd_Comp_Type) 6882 or else not Subtypes_Statically_Match 6883 (Target_Comp_Type, Opnd_Comp_Type) 6884 then 6885 Error_Msg_N 6886 ("component subtypes must statically match", Operand); 6887 return False; 6888 6889 end if; 6890 end; 6891 end if; 6892 6893 return True; 6894 6895 elsif (Ekind (Target_Type) = E_General_Access_Type 6896 or else Ekind (Target_Type) = E_Anonymous_Access_Type) 6897 and then 6898 Conversion_Check 6899 (Is_Access_Type (Opnd_Type) 6900 and then Ekind (Opnd_Type) /= 6901 E_Access_Subprogram_Type 6902 and then Ekind (Opnd_Type) /= 6903 E_Access_Protected_Subprogram_Type, 6904 "must be an access-to-object type") 6905 then 6906 if Is_Access_Constant (Opnd_Type) 6907 and then not Is_Access_Constant (Target_Type) 6908 then 6909 Error_Msg_N 6910 ("access-to-constant operand type not allowed", Operand); 6911 return False; 6912 end if; 6913 6914 -- Check the static accessibility rule of 4.6(17). Note that 6915 -- the check is not enforced when within an instance body, since 6916 -- the RM requires such cases to be caught at run time. 6917 6918 if Ekind (Target_Type) /= E_Anonymous_Access_Type then 6919 if Type_Access_Level (Opnd_Type) 6920 > Type_Access_Level (Target_Type) 6921 then 6922 -- In an instance, this is a run-time check, but one we 6923 -- know will fail, so generate an appropriate warning. 6924 -- The raise will be generated by Expand_N_Type_Conversion. 6925 6926 if In_Instance_Body then 6927 Error_Msg_N 6928 ("?cannot convert local pointer to non-local access type", 6929 Operand); 6930 Error_Msg_N 6931 ("?Program_Error will be raised at run time", Operand); 6932 6933 else 6934 Error_Msg_N 6935 ("cannot convert local pointer to non-local access type", 6936 Operand); 6937 return False; 6938 end if; 6939 6940 elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type then 6941 6942 -- When the operand is a selected access discriminant 6943 -- the check needs to be made against the level of the 6944 -- object denoted by the prefix of the selected name. 6945 -- (Object_Access_Level handles checking the prefix 6946 -- of the operand for this case.) 6947 6948 if Nkind (Operand) = N_Selected_Component 6949 and then Object_Access_Level (Operand) 6950 > Type_Access_Level (Target_Type) 6951 then 6952 -- In an instance, this is a run-time check, but one we 6953 -- know will fail, so generate an appropriate warning. 6954 -- The raise will be generated by Expand_N_Type_Conversion. 6955 6956 if In_Instance_Body then 6957 Error_Msg_N 6958 ("?cannot convert access discriminant to non-local" & 6959 " access type", Operand); 6960 Error_Msg_N 6961 ("?Program_Error will be raised at run time", Operand); 6962 6963 else 6964 Error_Msg_N 6965 ("cannot convert access discriminant to non-local" & 6966 " access type", Operand); 6967 return False; 6968 end if; 6969 end if; 6970 6971 -- The case of a reference to an access discriminant 6972 -- from within a type declaration (which will appear 6973 -- as a discriminal) is always illegal because the 6974 -- level of the discriminant is considered to be 6975 -- deeper than any (namable) access type. 6976 6977 if Is_Entity_Name (Operand) 6978 and then (Ekind (Entity (Operand)) = E_In_Parameter 6979 or else Ekind (Entity (Operand)) = E_Constant) 6980 and then Present (Discriminal_Link (Entity (Operand))) 6981 then 6982 Error_Msg_N 6983 ("discriminant has deeper accessibility level than target", 6984 Operand); 6985 return False; 6986 end if; 6987 end if; 6988 end if; 6989 6990 declare 6991 Target : constant Entity_Id := Designated_Type (Target_Type); 6992 Opnd : constant Entity_Id := Designated_Type (Opnd_Type); 6993 6994 begin 6995 if Is_Tagged_Type (Target) then 6996 return Valid_Tagged_Conversion (Target, Opnd); 6997 6998 else 6999 if Base_Type (Target) /= Base_Type (Opnd) then 7000 Error_Msg_NE 7001 ("target designated type not compatible with }", 7002 N, Base_Type (Opnd)); 7003 return False; 7004 7005 elsif not Subtypes_Statically_Match (Target, Opnd) 7006 and then (not Has_Discriminants (Target) 7007 or else Is_Constrained (Target)) 7008 then 7009 Error_Msg_NE 7010 ("target designated subtype not compatible with }", 7011 N, Opnd); 7012 return False; 7013 7014 else 7015 return True; 7016 end if; 7017 end if; 7018 end; 7019 7020 elsif Ekind (Target_Type) = E_Access_Subprogram_Type 7021 and then Conversion_Check 7022 (Ekind (Base_Type (Opnd_Type)) = E_Access_Subprogram_Type, 7023 "illegal operand for access subprogram conversion") 7024 then 7025 -- Check that the designated types are subtype conformant 7026 7027 if not Subtype_Conformant (Designated_Type (Opnd_Type), 7028 Designated_Type (Target_Type)) 7029 then 7030 Error_Msg_N 7031 ("operand type is not subtype conformant with target type", 7032 Operand); 7033 end if; 7034 7035 -- Check the static accessibility rule of 4.6(20) 7036 7037 if Type_Access_Level (Opnd_Type) > 7038 Type_Access_Level (Target_Type) 7039 then 7040 Error_Msg_N 7041 ("operand type has deeper accessibility level than target", 7042 Operand); 7043 7044 -- Check that if the operand type is declared in a generic body, 7045 -- then the target type must be declared within that same body 7046 -- (enforces last sentence of 4.6(20)). 7047 7048 elsif Present (Enclosing_Generic_Body (Opnd_Type)) then 7049 declare 7050 O_Gen : constant Node_Id := 7051 Enclosing_Generic_Body (Opnd_Type); 7052 7053 T_Gen : Node_Id := 7054 Enclosing_Generic_Body (Target_Type); 7055 7056 begin 7057 while Present (T_Gen) and then T_Gen /= O_Gen loop 7058 T_Gen := Enclosing_Generic_Body (T_Gen); 7059 end loop; 7060 7061 if T_Gen /= O_Gen then 7062 Error_Msg_N 7063 ("target type must be declared in same generic body" 7064 & " as operand type", N); 7065 end if; 7066 end; 7067 end if; 7068 7069 return True; 7070 7071 elsif Is_Remote_Access_To_Subprogram_Type (Target_Type) 7072 and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type) 7073 then 7074 -- It is valid to convert from one RAS type to another provided 7075 -- that their specification statically match. 7076 7077 Check_Subtype_Conformant 7078 (New_Id => 7079 Designated_Type (Corresponding_Remote_Type (Target_Type)), 7080 Old_Id => 7081 Designated_Type (Corresponding_Remote_Type (Opnd_Type)), 7082 Err_Loc => 7083 N); 7084 return True; 7085 7086 elsif Is_Tagged_Type (Target_Type) then 7087 return Valid_Tagged_Conversion (Target_Type, Opnd_Type); 7088 7089 -- Types derived from the same root type are convertible. 7090 7091 elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then 7092 return True; 7093 7094 -- In an instance, there may be inconsistent views of the same 7095 -- type, or types derived from the same type. 7096 7097 elsif In_Instance 7098 and then Underlying_Type (Target_Type) = Underlying_Type (Opnd_Type) 7099 then 7100 return True; 7101 7102 -- Special check for common access type error case 7103 7104 elsif Ekind (Target_Type) = E_Access_Type 7105 and then Is_Access_Type (Opnd_Type) 7106 then 7107 Error_Msg_N ("target type must be general access type!", N); 7108 Error_Msg_NE ("add ALL to }!", N, Target_Type); 7109 7110 return False; 7111 7112 else 7113 Error_Msg_NE ("invalid conversion, not compatible with }", 7114 N, Opnd_Type); 7115 7116 return False; 7117 end if; 7118 end Valid_Conversion; 7119 7120end Sem_Res; 7121