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-2013, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Checks; use Checks; 28with Debug; use Debug; 29with Debug_A; use Debug_A; 30with Einfo; use Einfo; 31with Errout; use Errout; 32with Expander; use Expander; 33with Exp_Disp; use Exp_Disp; 34with Exp_Ch6; use Exp_Ch6; 35with Exp_Ch7; use Exp_Ch7; 36with Exp_Tss; use Exp_Tss; 37with Exp_Util; use Exp_Util; 38with Fname; use Fname; 39with Freeze; use Freeze; 40with Itypes; use Itypes; 41with Lib; use Lib; 42with Lib.Xref; use Lib.Xref; 43with Namet; use Namet; 44with Nmake; use Nmake; 45with Nlists; use Nlists; 46with Opt; use Opt; 47with Output; use Output; 48with Restrict; use Restrict; 49with Rident; use Rident; 50with Rtsfind; use Rtsfind; 51with Sem; use Sem; 52with Sem_Aux; use Sem_Aux; 53with Sem_Aggr; use Sem_Aggr; 54with Sem_Attr; use Sem_Attr; 55with Sem_Cat; use Sem_Cat; 56with Sem_Ch4; use Sem_Ch4; 57with Sem_Ch6; use Sem_Ch6; 58with Sem_Ch8; use Sem_Ch8; 59with Sem_Ch13; use Sem_Ch13; 60with Sem_Dim; use Sem_Dim; 61with Sem_Disp; use Sem_Disp; 62with Sem_Dist; use Sem_Dist; 63with Sem_Elim; use Sem_Elim; 64with Sem_Elab; use Sem_Elab; 65with Sem_Eval; use Sem_Eval; 66with Sem_Intr; use Sem_Intr; 67with Sem_Util; use Sem_Util; 68with Targparm; use Targparm; 69with Sem_Type; use Sem_Type; 70with Sem_Warn; use Sem_Warn; 71with Sinfo; use Sinfo; 72with Sinfo.CN; use Sinfo.CN; 73with Snames; use Snames; 74with Stand; use Stand; 75with Stringt; use Stringt; 76with Style; use Style; 77with Tbuild; use Tbuild; 78with Uintp; use Uintp; 79with Urealp; use Urealp; 80 81package body Sem_Res is 82 83 ----------------------- 84 -- Local Subprograms -- 85 ----------------------- 86 87 -- Second pass (top-down) type checking and overload resolution procedures 88 -- Typ is the type required by context. These procedures propagate the type 89 -- information recursively to the descendants of N. If the node is not 90 -- overloaded, its Etype is established in the first pass. If overloaded, 91 -- the Resolve routines set the correct type. For arith. operators, the 92 -- Etype is the base type of the context. 93 94 -- Note that Resolve_Attribute is separated off in Sem_Attr 95 96 function Bad_Unordered_Enumeration_Reference 97 (N : Node_Id; 98 T : Entity_Id) return Boolean; 99 -- Node N contains a potentially dubious reference to type T, either an 100 -- explicit comparison, or an explicit range. This function returns True 101 -- if the type T is an enumeration type for which No pragma Order has been 102 -- given, and the reference N is not in the same extended source unit as 103 -- the declaration of T. 104 105 procedure Check_Discriminant_Use (N : Node_Id); 106 -- Enforce the restrictions on the use of discriminants when constraining 107 -- a component of a discriminated type (record or concurrent type). 108 109 procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id); 110 -- Given a node for an operator associated with type T, check that 111 -- the operator is visible. Operators all of whose operands are 112 -- universal must be checked for visibility during resolution 113 -- because their type is not determinable based on their operands. 114 115 procedure Check_Fully_Declared_Prefix 116 (Typ : Entity_Id; 117 Pref : Node_Id); 118 -- Check that the type of the prefix of a dereference is not incomplete 119 120 function Check_Infinite_Recursion (N : Node_Id) return Boolean; 121 -- Given a call node, N, which is known to occur immediately within the 122 -- subprogram being called, determines whether it is a detectable case of 123 -- an infinite recursion, and if so, outputs appropriate messages. Returns 124 -- True if an infinite recursion is detected, and False otherwise. 125 126 procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id); 127 -- If the type of the object being initialized uses the secondary stack 128 -- directly or indirectly, create a transient scope for the call to the 129 -- init proc. This is because we do not create transient scopes for the 130 -- initialization of individual components within the init proc itself. 131 -- Could be optimized away perhaps? 132 133 procedure Check_No_Direct_Boolean_Operators (N : Node_Id); 134 -- N is the node for a logical operator. If the operator is predefined, and 135 -- the root type of the operands is Standard.Boolean, then a check is made 136 -- for restriction No_Direct_Boolean_Operators. This procedure also handles 137 -- the style check for Style_Check_Boolean_And_Or. 138 139 function Is_Definite_Access_Type (E : Entity_Id) return Boolean; 140 -- Determine whether E is an access type declared by an access declaration, 141 -- and not an (anonymous) allocator type. 142 143 function Is_Predefined_Op (Nam : Entity_Id) return Boolean; 144 -- Utility to check whether the entity for an operator is a predefined 145 -- operator, in which case the expression is left as an operator in the 146 -- tree (else it is rewritten into a call). An instance of an intrinsic 147 -- conversion operation may be given an operator name, but is not treated 148 -- like an operator. Note that an operator that is an imported back-end 149 -- builtin has convention Intrinsic, but is expected to be rewritten into 150 -- a call, so such an operator is not treated as predefined by this 151 -- predicate. 152 153 procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id); 154 -- If a default expression in entry call N depends on the discriminants 155 -- of the task, it must be replaced with a reference to the discriminant 156 -- of the task being called. 157 158 procedure Resolve_Op_Concat_Arg 159 (N : Node_Id; 160 Arg : Node_Id; 161 Typ : Entity_Id; 162 Is_Comp : Boolean); 163 -- Internal procedure for Resolve_Op_Concat to resolve one operand of 164 -- concatenation operator. The operand is either of the array type or of 165 -- the component type. If the operand is an aggregate, and the component 166 -- type is composite, this is ambiguous if component type has aggregates. 167 168 procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id); 169 -- Does the first part of the work of Resolve_Op_Concat 170 171 procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id); 172 -- Does the "rest" of the work of Resolve_Op_Concat, after the left operand 173 -- has been resolved. See Resolve_Op_Concat for details. 174 175 procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id); 176 procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id); 177 procedure Resolve_Call (N : Node_Id; Typ : Entity_Id); 178 procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id); 179 procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id); 180 procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id); 181 procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id); 182 procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id); 183 procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id); 184 procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id); 185 procedure Resolve_If_Expression (N : Node_Id; Typ : Entity_Id); 186 procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id); 187 procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id); 188 procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id); 189 procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id); 190 procedure Resolve_Null (N : Node_Id; Typ : Entity_Id); 191 procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id); 192 procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id); 193 procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id); 194 procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id); 195 procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id); 196 procedure Resolve_Range (N : Node_Id; Typ : Entity_Id); 197 procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id); 198 procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id); 199 procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id); 200 procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id); 201 procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id); 202 procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id); 203 procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id); 204 procedure Resolve_Subprogram_Info (N : Node_Id; Typ : Entity_Id); 205 procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id); 206 procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id); 207 procedure Resolve_Unchecked_Expression (N : Node_Id; Typ : Entity_Id); 208 procedure Resolve_Unchecked_Type_Conversion (N : Node_Id; Typ : Entity_Id); 209 210 function Operator_Kind 211 (Op_Name : Name_Id; 212 Is_Binary : Boolean) return Node_Kind; 213 -- Utility to map the name of an operator into the corresponding Node. Used 214 -- by other node rewriting procedures. 215 216 procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id); 217 -- Resolve actuals of call, and add default expressions for missing ones. 218 -- N is the Node_Id for the subprogram call, and Nam is the entity of the 219 -- called subprogram. 220 221 procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id); 222 -- Called from Resolve_Call, when the prefix denotes an entry or element 223 -- of entry family. Actuals are resolved as for subprograms, and the node 224 -- is rebuilt as an entry call. Also called for protected operations. Typ 225 -- is the context type, which is used when the operation is a protected 226 -- function with no arguments, and the return value is indexed. 227 228 procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id); 229 -- A call to a user-defined intrinsic operator is rewritten as a call to 230 -- the corresponding predefined operator, with suitable conversions. Note 231 -- that this applies only for intrinsic operators that denote predefined 232 -- operators, not ones that are intrinsic imports of back-end builtins. 233 234 procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id); 235 -- Ditto, for unary operators (arithmetic ones and "not" on signed 236 -- integer types for VMS). 237 238 procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id); 239 -- If an operator node resolves to a call to a user-defined operator, 240 -- rewrite the node as a function call. 241 242 procedure Make_Call_Into_Operator 243 (N : Node_Id; 244 Typ : Entity_Id; 245 Op_Id : Entity_Id); 246 -- Inverse transformation: if an operator is given in functional notation, 247 -- then after resolving the node, transform into an operator node, so 248 -- that operands are resolved properly. Recall that predefined operators 249 -- do not have a full signature and special resolution rules apply. 250 251 procedure Rewrite_Renamed_Operator 252 (N : Node_Id; 253 Op : Entity_Id; 254 Typ : Entity_Id); 255 -- An operator can rename another, e.g. in an instantiation. In that 256 -- case, the proper operator node must be constructed and resolved. 257 258 procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id); 259 -- The String_Literal_Subtype is built for all strings that are not 260 -- operands of a static concatenation operation. If the argument is 261 -- not a N_String_Literal node, then the call has no effect. 262 263 procedure Set_Slice_Subtype (N : Node_Id); 264 -- Build subtype of array type, with the range specified by the slice 265 266 procedure Simplify_Type_Conversion (N : Node_Id); 267 -- Called after N has been resolved and evaluated, but before range checks 268 -- have been applied. Currently simplifies a combination of floating-point 269 -- to integer conversion and Truncation attribute. 270 271 function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id; 272 -- A universal_fixed expression in an universal context is unambiguous if 273 -- there is only one applicable fixed point type. Determining whether there 274 -- is only one requires a search over all visible entities, and happens 275 -- only in very pathological cases (see 6115-006). 276 277 ------------------------- 278 -- Ambiguous_Character -- 279 ------------------------- 280 281 procedure Ambiguous_Character (C : Node_Id) is 282 E : Entity_Id; 283 284 begin 285 if Nkind (C) = N_Character_Literal then 286 Error_Msg_N ("ambiguous character literal", C); 287 288 -- First the ones in Standard 289 290 Error_Msg_N ("\\possible interpretation: Character!", C); 291 Error_Msg_N ("\\possible interpretation: Wide_Character!", C); 292 293 -- Include Wide_Wide_Character in Ada 2005 mode 294 295 if Ada_Version >= Ada_2005 then 296 Error_Msg_N ("\\possible interpretation: Wide_Wide_Character!", C); 297 end if; 298 299 -- Now any other types that match 300 301 E := Current_Entity (C); 302 while Present (E) loop 303 Error_Msg_NE ("\\possible interpretation:}!", C, Etype (E)); 304 E := Homonym (E); 305 end loop; 306 end if; 307 end Ambiguous_Character; 308 309 ------------------------- 310 -- Analyze_And_Resolve -- 311 ------------------------- 312 313 procedure Analyze_And_Resolve (N : Node_Id) is 314 begin 315 Analyze (N); 316 Resolve (N); 317 end Analyze_And_Resolve; 318 319 procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id) is 320 begin 321 Analyze (N); 322 Resolve (N, Typ); 323 end Analyze_And_Resolve; 324 325 -- Versions with check(s) suppressed 326 327 procedure Analyze_And_Resolve 328 (N : Node_Id; 329 Typ : Entity_Id; 330 Suppress : Check_Id) 331 is 332 Scop : constant Entity_Id := Current_Scope; 333 334 begin 335 if Suppress = All_Checks then 336 declare 337 Sva : constant Suppress_Array := Scope_Suppress.Suppress; 338 begin 339 Scope_Suppress.Suppress := (others => True); 340 Analyze_And_Resolve (N, Typ); 341 Scope_Suppress.Suppress := Sva; 342 end; 343 344 else 345 declare 346 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); 347 begin 348 Scope_Suppress.Suppress (Suppress) := True; 349 Analyze_And_Resolve (N, Typ); 350 Scope_Suppress.Suppress (Suppress) := Svg; 351 end; 352 end if; 353 354 if Current_Scope /= Scop 355 and then Scope_Is_Transient 356 then 357 -- This can only happen if a transient scope was created for an inner 358 -- expression, which will be removed upon completion of the analysis 359 -- of an enclosing construct. The transient scope must have the 360 -- suppress status of the enclosing environment, not of this Analyze 361 -- call. 362 363 Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress := 364 Scope_Suppress; 365 end if; 366 end Analyze_And_Resolve; 367 368 procedure Analyze_And_Resolve 369 (N : Node_Id; 370 Suppress : Check_Id) 371 is 372 Scop : constant Entity_Id := Current_Scope; 373 374 begin 375 if Suppress = All_Checks then 376 declare 377 Sva : constant Suppress_Array := Scope_Suppress.Suppress; 378 begin 379 Scope_Suppress.Suppress := (others => True); 380 Analyze_And_Resolve (N); 381 Scope_Suppress.Suppress := Sva; 382 end; 383 384 else 385 declare 386 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); 387 begin 388 Scope_Suppress.Suppress (Suppress) := True; 389 Analyze_And_Resolve (N); 390 Scope_Suppress.Suppress (Suppress) := Svg; 391 end; 392 end if; 393 394 if Current_Scope /= Scop and then Scope_Is_Transient then 395 Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress := 396 Scope_Suppress; 397 end if; 398 end Analyze_And_Resolve; 399 400 ---------------------------------------- 401 -- Bad_Unordered_Enumeration_Reference -- 402 ---------------------------------------- 403 404 function Bad_Unordered_Enumeration_Reference 405 (N : Node_Id; 406 T : Entity_Id) return Boolean 407 is 408 begin 409 return Is_Enumeration_Type (T) 410 and then Comes_From_Source (N) 411 and then Warn_On_Unordered_Enumeration_Type 412 and then not Has_Pragma_Ordered (T) 413 and then not In_Same_Extended_Unit (N, T); 414 end Bad_Unordered_Enumeration_Reference; 415 416 ---------------------------- 417 -- Check_Discriminant_Use -- 418 ---------------------------- 419 420 procedure Check_Discriminant_Use (N : Node_Id) is 421 PN : constant Node_Id := Parent (N); 422 Disc : constant Entity_Id := Entity (N); 423 P : Node_Id; 424 D : Node_Id; 425 426 begin 427 -- Any use in a spec-expression is legal 428 429 if In_Spec_Expression then 430 null; 431 432 elsif Nkind (PN) = N_Range then 433 434 -- Discriminant cannot be used to constrain a scalar type 435 436 P := Parent (PN); 437 438 if Nkind (P) = N_Range_Constraint 439 and then Nkind (Parent (P)) = N_Subtype_Indication 440 and then Nkind (Parent (Parent (P))) = N_Component_Definition 441 then 442 Error_Msg_N ("discriminant cannot constrain scalar type", N); 443 444 elsif Nkind (P) = N_Index_Or_Discriminant_Constraint then 445 446 -- The following check catches the unusual case where a 447 -- discriminant appears within an index constraint that is part of 448 -- a larger expression within a constraint on a component, e.g. "C 449 -- : Int range 1 .. F (new A(1 .. D))". For now we only check case 450 -- of record components, and note that a similar check should also 451 -- apply in the case of discriminant constraints below. ??? 452 453 -- Note that the check for N_Subtype_Declaration below is to 454 -- detect the valid use of discriminants in the constraints of a 455 -- subtype declaration when this subtype declaration appears 456 -- inside the scope of a record type (which is syntactically 457 -- illegal, but which may be created as part of derived type 458 -- processing for records). See Sem_Ch3.Build_Derived_Record_Type 459 -- for more info. 460 461 if Ekind (Current_Scope) = E_Record_Type 462 and then Scope (Disc) = Current_Scope 463 and then not 464 (Nkind (Parent (P)) = N_Subtype_Indication 465 and then 466 Nkind_In (Parent (Parent (P)), N_Component_Definition, 467 N_Subtype_Declaration) 468 and then Paren_Count (N) = 0) 469 then 470 Error_Msg_N 471 ("discriminant must appear alone in component constraint", N); 472 return; 473 end if; 474 475 -- Detect a common error: 476 477 -- type R (D : Positive := 100) is record 478 -- Name : String (1 .. D); 479 -- end record; 480 481 -- The default value causes an object of type R to be allocated 482 -- with room for Positive'Last characters. The RM does not mandate 483 -- the allocation of the maximum size, but that is what GNAT does 484 -- so we should warn the programmer that there is a problem. 485 486 Check_Large : declare 487 SI : Node_Id; 488 T : Entity_Id; 489 TB : Node_Id; 490 CB : Entity_Id; 491 492 function Large_Storage_Type (T : Entity_Id) return Boolean; 493 -- Return True if type T has a large enough range that any 494 -- array whose index type covered the whole range of the type 495 -- would likely raise Storage_Error. 496 497 ------------------------ 498 -- Large_Storage_Type -- 499 ------------------------ 500 501 function Large_Storage_Type (T : Entity_Id) return Boolean is 502 begin 503 -- The type is considered large if its bounds are known at 504 -- compile time and if it requires at least as many bits as 505 -- a Positive to store the possible values. 506 507 return Compile_Time_Known_Value (Type_Low_Bound (T)) 508 and then Compile_Time_Known_Value (Type_High_Bound (T)) 509 and then 510 Minimum_Size (T, Biased => True) >= 511 RM_Size (Standard_Positive); 512 end Large_Storage_Type; 513 514 -- Start of processing for Check_Large 515 516 begin 517 -- Check that the Disc has a large range 518 519 if not Large_Storage_Type (Etype (Disc)) then 520 goto No_Danger; 521 end if; 522 523 -- If the enclosing type is limited, we allocate only the 524 -- default value, not the maximum, and there is no need for 525 -- a warning. 526 527 if Is_Limited_Type (Scope (Disc)) then 528 goto No_Danger; 529 end if; 530 531 -- Check that it is the high bound 532 533 if N /= High_Bound (PN) 534 or else No (Discriminant_Default_Value (Disc)) 535 then 536 goto No_Danger; 537 end if; 538 539 -- Check the array allows a large range at this bound. First 540 -- find the array 541 542 SI := Parent (P); 543 544 if Nkind (SI) /= N_Subtype_Indication then 545 goto No_Danger; 546 end if; 547 548 T := Entity (Subtype_Mark (SI)); 549 550 if not Is_Array_Type (T) then 551 goto No_Danger; 552 end if; 553 554 -- Next, find the dimension 555 556 TB := First_Index (T); 557 CB := First (Constraints (P)); 558 while True 559 and then Present (TB) 560 and then Present (CB) 561 and then CB /= PN 562 loop 563 Next_Index (TB); 564 Next (CB); 565 end loop; 566 567 if CB /= PN then 568 goto No_Danger; 569 end if; 570 571 -- Now, check the dimension has a large range 572 573 if not Large_Storage_Type (Etype (TB)) then 574 goto No_Danger; 575 end if; 576 577 -- Warn about the danger 578 579 Error_Msg_N 580 ("??creation of & object may raise Storage_Error!", 581 Scope (Disc)); 582 583 <<No_Danger>> 584 null; 585 586 end Check_Large; 587 end if; 588 589 -- Legal case is in index or discriminant constraint 590 591 elsif Nkind_In (PN, N_Index_Or_Discriminant_Constraint, 592 N_Discriminant_Association) 593 then 594 if Paren_Count (N) > 0 then 595 Error_Msg_N 596 ("discriminant in constraint must appear alone", N); 597 598 elsif Nkind (N) = N_Expanded_Name 599 and then Comes_From_Source (N) 600 then 601 Error_Msg_N 602 ("discriminant must appear alone as a direct name", N); 603 end if; 604 605 return; 606 607 -- Otherwise, context is an expression. It should not be within (i.e. a 608 -- subexpression of) a constraint for a component. 609 610 else 611 D := PN; 612 P := Parent (PN); 613 while not Nkind_In (P, N_Component_Declaration, 614 N_Subtype_Indication, 615 N_Entry_Declaration) 616 loop 617 D := P; 618 P := Parent (P); 619 exit when No (P); 620 end loop; 621 622 -- If the discriminant is used in an expression that is a bound of a 623 -- scalar type, an Itype is created and the bounds are attached to 624 -- its range, not to the original subtype indication. Such use is of 625 -- course a double fault. 626 627 if (Nkind (P) = N_Subtype_Indication 628 and then Nkind_In (Parent (P), N_Component_Definition, 629 N_Derived_Type_Definition) 630 and then D = Constraint (P)) 631 632 -- The constraint itself may be given by a subtype indication, 633 -- rather than by a more common discrete range. 634 635 or else (Nkind (P) = N_Subtype_Indication 636 and then 637 Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint) 638 or else Nkind (P) = N_Entry_Declaration 639 or else Nkind (D) = N_Defining_Identifier 640 then 641 Error_Msg_N 642 ("discriminant in constraint must appear alone", N); 643 end if; 644 end if; 645 end Check_Discriminant_Use; 646 647 -------------------------------- 648 -- Check_For_Visible_Operator -- 649 -------------------------------- 650 651 procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is 652 begin 653 if Is_Invisible_Operator (N, T) then 654 Error_Msg_NE -- CODEFIX 655 ("operator for} is not directly visible!", N, First_Subtype (T)); 656 Error_Msg_N -- CODEFIX 657 ("use clause would make operation legal!", N); 658 end if; 659 end Check_For_Visible_Operator; 660 661 ---------------------------------- 662 -- Check_Fully_Declared_Prefix -- 663 ---------------------------------- 664 665 procedure Check_Fully_Declared_Prefix 666 (Typ : Entity_Id; 667 Pref : Node_Id) 668 is 669 begin 670 -- Check that the designated type of the prefix of a dereference is 671 -- not an incomplete type. This cannot be done unconditionally, because 672 -- dereferences of private types are legal in default expressions. This 673 -- case is taken care of in Check_Fully_Declared, called below. There 674 -- are also 2005 cases where it is legal for the prefix to be unfrozen. 675 676 -- This consideration also applies to similar checks for allocators, 677 -- qualified expressions, and type conversions. 678 679 -- An additional exception concerns other per-object expressions that 680 -- are not directly related to component declarations, in particular 681 -- representation pragmas for tasks. These will be per-object 682 -- expressions if they depend on discriminants or some global entity. 683 -- If the task has access discriminants, the designated type may be 684 -- incomplete at the point the expression is resolved. This resolution 685 -- takes place within the body of the initialization procedure, where 686 -- the discriminant is replaced by its discriminal. 687 688 if Is_Entity_Name (Pref) 689 and then Ekind (Entity (Pref)) = E_In_Parameter 690 then 691 null; 692 693 -- Ada 2005 (AI-326): Tagged incomplete types allowed. The wrong usages 694 -- are handled by Analyze_Access_Attribute, Analyze_Assignment, 695 -- Analyze_Object_Renaming, and Freeze_Entity. 696 697 elsif Ada_Version >= Ada_2005 698 and then Is_Entity_Name (Pref) 699 and then Is_Access_Type (Etype (Pref)) 700 and then Ekind (Directly_Designated_Type (Etype (Pref))) = 701 E_Incomplete_Type 702 and then Is_Tagged_Type (Directly_Designated_Type (Etype (Pref))) 703 then 704 null; 705 else 706 Check_Fully_Declared (Typ, Parent (Pref)); 707 end if; 708 end Check_Fully_Declared_Prefix; 709 710 ------------------------------ 711 -- Check_Infinite_Recursion -- 712 ------------------------------ 713 714 function Check_Infinite_Recursion (N : Node_Id) return Boolean is 715 P : Node_Id; 716 C : Node_Id; 717 718 function Same_Argument_List return Boolean; 719 -- Check whether list of actuals is identical to list of formals of 720 -- called function (which is also the enclosing scope). 721 722 ------------------------ 723 -- Same_Argument_List -- 724 ------------------------ 725 726 function Same_Argument_List return Boolean is 727 A : Node_Id; 728 F : Entity_Id; 729 Subp : Entity_Id; 730 731 begin 732 if not Is_Entity_Name (Name (N)) then 733 return False; 734 else 735 Subp := Entity (Name (N)); 736 end if; 737 738 F := First_Formal (Subp); 739 A := First_Actual (N); 740 while Present (F) and then Present (A) loop 741 if not Is_Entity_Name (A) 742 or else Entity (A) /= F 743 then 744 return False; 745 end if; 746 747 Next_Actual (A); 748 Next_Formal (F); 749 end loop; 750 751 return True; 752 end Same_Argument_List; 753 754 -- Start of processing for Check_Infinite_Recursion 755 756 begin 757 -- Special case, if this is a procedure call and is a call to the 758 -- current procedure with the same argument list, then this is for 759 -- sure an infinite recursion and we insert a call to raise SE. 760 761 if Is_List_Member (N) 762 and then List_Length (List_Containing (N)) = 1 763 and then Same_Argument_List 764 then 765 declare 766 P : constant Node_Id := Parent (N); 767 begin 768 if Nkind (P) = N_Handled_Sequence_Of_Statements 769 and then Nkind (Parent (P)) = N_Subprogram_Body 770 and then Is_Empty_List (Declarations (Parent (P))) 771 then 772 Error_Msg_N ("!??infinite recursion", N); 773 Error_Msg_N ("\!??Storage_Error will be raised at run time", N); 774 Insert_Action (N, 775 Make_Raise_Storage_Error (Sloc (N), 776 Reason => SE_Infinite_Recursion)); 777 return True; 778 end if; 779 end; 780 end if; 781 782 -- If not that special case, search up tree, quitting if we reach a 783 -- construct (e.g. a conditional) that tells us that this is not a 784 -- case for an infinite recursion warning. 785 786 C := N; 787 loop 788 P := Parent (C); 789 790 -- If no parent, then we were not inside a subprogram, this can for 791 -- example happen when processing certain pragmas in a spec. Just 792 -- return False in this case. 793 794 if No (P) then 795 return False; 796 end if; 797 798 -- Done if we get to subprogram body, this is definitely an infinite 799 -- recursion case if we did not find anything to stop us. 800 801 exit when Nkind (P) = N_Subprogram_Body; 802 803 -- If appearing in conditional, result is false 804 805 if Nkind_In (P, N_Or_Else, 806 N_And_Then, 807 N_Case_Expression, 808 N_Case_Statement, 809 N_If_Expression, 810 N_If_Statement) 811 then 812 return False; 813 814 elsif Nkind (P) = N_Handled_Sequence_Of_Statements 815 and then C /= First (Statements (P)) 816 then 817 -- If the call is the expression of a return statement and the 818 -- actuals are identical to the formals, it's worth a warning. 819 -- However, we skip this if there is an immediately preceding 820 -- raise statement, since the call is never executed. 821 822 -- Furthermore, this corresponds to a common idiom: 823 824 -- function F (L : Thing) return Boolean is 825 -- begin 826 -- raise Program_Error; 827 -- return F (L); 828 -- end F; 829 830 -- for generating a stub function 831 832 if Nkind (Parent (N)) = N_Simple_Return_Statement 833 and then Same_Argument_List 834 then 835 exit when not Is_List_Member (Parent (N)); 836 837 -- OK, return statement is in a statement list, look for raise 838 839 declare 840 Nod : Node_Id; 841 842 begin 843 -- Skip past N_Freeze_Entity nodes generated by expansion 844 845 Nod := Prev (Parent (N)); 846 while Present (Nod) 847 and then Nkind (Nod) = N_Freeze_Entity 848 loop 849 Prev (Nod); 850 end loop; 851 852 -- If no raise statement, give warning. We look at the 853 -- original node, because in the case of "raise ... with 854 -- ...", the node has been transformed into a call. 855 856 exit when Nkind (Original_Node (Nod)) /= N_Raise_Statement 857 and then 858 (Nkind (Nod) not in N_Raise_xxx_Error 859 or else Present (Condition (Nod))); 860 end; 861 end if; 862 863 return False; 864 865 else 866 C := P; 867 end if; 868 end loop; 869 870 Error_Msg_N ("!??possible infinite recursion", N); 871 Error_Msg_N ("\!??Storage_Error may be raised at run time", N); 872 873 return True; 874 end Check_Infinite_Recursion; 875 876 ------------------------------- 877 -- Check_Initialization_Call -- 878 ------------------------------- 879 880 procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is 881 Typ : constant Entity_Id := Etype (First_Formal (Nam)); 882 883 function Uses_SS (T : Entity_Id) return Boolean; 884 -- Check whether the creation of an object of the type will involve 885 -- use of the secondary stack. If T is a record type, this is true 886 -- if the expression for some component uses the secondary stack, e.g. 887 -- through a call to a function that returns an unconstrained value. 888 -- False if T is controlled, because cleanups occur elsewhere. 889 890 ------------- 891 -- Uses_SS -- 892 ------------- 893 894 function Uses_SS (T : Entity_Id) return Boolean is 895 Comp : Entity_Id; 896 Expr : Node_Id; 897 Full_Type : Entity_Id := Underlying_Type (T); 898 899 begin 900 -- Normally we want to use the underlying type, but if it's not set 901 -- then continue with T. 902 903 if not Present (Full_Type) then 904 Full_Type := T; 905 end if; 906 907 if Is_Controlled (Full_Type) then 908 return False; 909 910 elsif Is_Array_Type (Full_Type) then 911 return Uses_SS (Component_Type (Full_Type)); 912 913 elsif Is_Record_Type (Full_Type) then 914 Comp := First_Component (Full_Type); 915 while Present (Comp) loop 916 if Ekind (Comp) = E_Component 917 and then Nkind (Parent (Comp)) = N_Component_Declaration 918 then 919 -- The expression for a dynamic component may be rewritten 920 -- as a dereference, so retrieve original node. 921 922 Expr := Original_Node (Expression (Parent (Comp))); 923 924 -- Return True if the expression is a call to a function 925 -- (including an attribute function such as Image, or a 926 -- user-defined operator) with a result that requires a 927 -- transient scope. 928 929 if (Nkind (Expr) = N_Function_Call 930 or else Nkind (Expr) in N_Op 931 or else (Nkind (Expr) = N_Attribute_Reference 932 and then Present (Expressions (Expr)))) 933 and then Requires_Transient_Scope (Etype (Expr)) 934 then 935 return True; 936 937 elsif Uses_SS (Etype (Comp)) then 938 return True; 939 end if; 940 end if; 941 942 Next_Component (Comp); 943 end loop; 944 945 return False; 946 947 else 948 return False; 949 end if; 950 end Uses_SS; 951 952 -- Start of processing for Check_Initialization_Call 953 954 begin 955 -- Establish a transient scope if the type needs it 956 957 if Uses_SS (Typ) then 958 Establish_Transient_Scope (First_Actual (N), Sec_Stack => True); 959 end if; 960 end Check_Initialization_Call; 961 962 --------------------------------------- 963 -- Check_No_Direct_Boolean_Operators -- 964 --------------------------------------- 965 966 procedure Check_No_Direct_Boolean_Operators (N : Node_Id) is 967 begin 968 if Scope (Entity (N)) = Standard_Standard 969 and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean 970 then 971 -- Restriction only applies to original source code 972 973 if Comes_From_Source (N) then 974 Check_Restriction (No_Direct_Boolean_Operators, N); 975 end if; 976 end if; 977 978 if Style_Check then 979 Check_Boolean_Operator (N); 980 end if; 981 end Check_No_Direct_Boolean_Operators; 982 983 ------------------------------ 984 -- Check_Parameterless_Call -- 985 ------------------------------ 986 987 procedure Check_Parameterless_Call (N : Node_Id) is 988 Nam : Node_Id; 989 990 function Prefix_Is_Access_Subp return Boolean; 991 -- If the prefix is of an access_to_subprogram type, the node must be 992 -- rewritten as a call. Ditto if the prefix is overloaded and all its 993 -- interpretations are access to subprograms. 994 995 --------------------------- 996 -- Prefix_Is_Access_Subp -- 997 --------------------------- 998 999 function Prefix_Is_Access_Subp return Boolean is 1000 I : Interp_Index; 1001 It : Interp; 1002 1003 begin 1004 -- If the context is an attribute reference that can apply to 1005 -- functions, this is never a parameterless call (RM 4.1.4(6)). 1006 1007 if Nkind (Parent (N)) = N_Attribute_Reference 1008 and then (Attribute_Name (Parent (N)) = Name_Address or else 1009 Attribute_Name (Parent (N)) = Name_Code_Address or else 1010 Attribute_Name (Parent (N)) = Name_Access) 1011 then 1012 return False; 1013 end if; 1014 1015 if not Is_Overloaded (N) then 1016 return 1017 Ekind (Etype (N)) = E_Subprogram_Type 1018 and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type; 1019 else 1020 Get_First_Interp (N, I, It); 1021 while Present (It.Typ) loop 1022 if Ekind (It.Typ) /= E_Subprogram_Type 1023 or else Base_Type (Etype (It.Typ)) = Standard_Void_Type 1024 then 1025 return False; 1026 end if; 1027 1028 Get_Next_Interp (I, It); 1029 end loop; 1030 1031 return True; 1032 end if; 1033 end Prefix_Is_Access_Subp; 1034 1035 -- Start of processing for Check_Parameterless_Call 1036 1037 begin 1038 -- Defend against junk stuff if errors already detected 1039 1040 if Total_Errors_Detected /= 0 then 1041 if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then 1042 return; 1043 elsif Nkind (N) in N_Has_Chars 1044 and then Chars (N) in Error_Name_Or_No_Name 1045 then 1046 return; 1047 end if; 1048 1049 Require_Entity (N); 1050 end if; 1051 1052 -- If the context expects a value, and the name is a procedure, this is 1053 -- most likely a missing 'Access. Don't try to resolve the parameterless 1054 -- call, error will be caught when the outer call is analyzed. 1055 1056 if Is_Entity_Name (N) 1057 and then Ekind (Entity (N)) = E_Procedure 1058 and then not Is_Overloaded (N) 1059 and then 1060 Nkind_In (Parent (N), N_Parameter_Association, 1061 N_Function_Call, 1062 N_Procedure_Call_Statement) 1063 then 1064 return; 1065 end if; 1066 1067 -- Rewrite as call if overloadable entity that is (or could be, in the 1068 -- overloaded case) a function call. If we know for sure that the entity 1069 -- is an enumeration literal, we do not rewrite it. 1070 1071 -- If the entity is the name of an operator, it cannot be a call because 1072 -- operators cannot have default parameters. In this case, this must be 1073 -- a string whose contents coincide with an operator name. Set the kind 1074 -- of the node appropriately. 1075 1076 if (Is_Entity_Name (N) 1077 and then Nkind (N) /= N_Operator_Symbol 1078 and then Is_Overloadable (Entity (N)) 1079 and then (Ekind (Entity (N)) /= E_Enumeration_Literal 1080 or else Is_Overloaded (N))) 1081 1082 -- Rewrite as call if it is an explicit dereference of an expression of 1083 -- a subprogram access type, and the subprogram type is not that of a 1084 -- procedure or entry. 1085 1086 or else 1087 (Nkind (N) = N_Explicit_Dereference and then Prefix_Is_Access_Subp) 1088 1089 -- Rewrite as call if it is a selected component which is a function, 1090 -- this is the case of a call to a protected function (which may be 1091 -- overloaded with other protected operations). 1092 1093 or else 1094 (Nkind (N) = N_Selected_Component 1095 and then (Ekind (Entity (Selector_Name (N))) = E_Function 1096 or else 1097 (Ekind_In (Entity (Selector_Name (N)), E_Entry, 1098 E_Procedure) 1099 and then Is_Overloaded (Selector_Name (N))))) 1100 1101 -- If one of the above three conditions is met, rewrite as call. Apply 1102 -- the rewriting only once. 1103 1104 then 1105 if Nkind (Parent (N)) /= N_Function_Call 1106 or else N /= Name (Parent (N)) 1107 then 1108 1109 -- This may be a prefixed call that was not fully analyzed, e.g. 1110 -- an actual in an instance. 1111 1112 if Ada_Version >= Ada_2005 1113 and then Nkind (N) = N_Selected_Component 1114 and then Is_Dispatching_Operation (Entity (Selector_Name (N))) 1115 then 1116 Analyze_Selected_Component (N); 1117 1118 if Nkind (N) /= N_Selected_Component then 1119 return; 1120 end if; 1121 end if; 1122 1123 Nam := New_Copy (N); 1124 1125 -- If overloaded, overload set belongs to new copy 1126 1127 Save_Interps (N, Nam); 1128 1129 -- Change node to parameterless function call (note that the 1130 -- Parameter_Associations associations field is left set to Empty, 1131 -- its normal default value since there are no parameters) 1132 1133 Change_Node (N, N_Function_Call); 1134 Set_Name (N, Nam); 1135 Set_Sloc (N, Sloc (Nam)); 1136 Analyze_Call (N); 1137 end if; 1138 1139 elsif Nkind (N) = N_Parameter_Association then 1140 Check_Parameterless_Call (Explicit_Actual_Parameter (N)); 1141 1142 elsif Nkind (N) = N_Operator_Symbol then 1143 Change_Operator_Symbol_To_String_Literal (N); 1144 Set_Is_Overloaded (N, False); 1145 Set_Etype (N, Any_String); 1146 end if; 1147 end Check_Parameterless_Call; 1148 1149 ----------------------------- 1150 -- Is_Definite_Access_Type -- 1151 ----------------------------- 1152 1153 function Is_Definite_Access_Type (E : Entity_Id) return Boolean is 1154 Btyp : constant Entity_Id := Base_Type (E); 1155 begin 1156 return Ekind (Btyp) = E_Access_Type 1157 or else (Ekind (Btyp) = E_Access_Subprogram_Type 1158 and then Comes_From_Source (Btyp)); 1159 end Is_Definite_Access_Type; 1160 1161 ---------------------- 1162 -- Is_Predefined_Op -- 1163 ---------------------- 1164 1165 function Is_Predefined_Op (Nam : Entity_Id) return Boolean is 1166 begin 1167 -- Predefined operators are intrinsic subprograms 1168 1169 if not Is_Intrinsic_Subprogram (Nam) then 1170 return False; 1171 end if; 1172 1173 -- A call to a back-end builtin is never a predefined operator 1174 1175 if Is_Imported (Nam) and then Present (Interface_Name (Nam)) then 1176 return False; 1177 end if; 1178 1179 return not Is_Generic_Instance (Nam) 1180 and then Chars (Nam) in Any_Operator_Name 1181 and then (No (Alias (Nam)) or else Is_Predefined_Op (Alias (Nam))); 1182 end Is_Predefined_Op; 1183 1184 ----------------------------- 1185 -- Make_Call_Into_Operator -- 1186 ----------------------------- 1187 1188 procedure Make_Call_Into_Operator 1189 (N : Node_Id; 1190 Typ : Entity_Id; 1191 Op_Id : Entity_Id) 1192 is 1193 Op_Name : constant Name_Id := Chars (Op_Id); 1194 Act1 : Node_Id := First_Actual (N); 1195 Act2 : Node_Id := Next_Actual (Act1); 1196 Error : Boolean := False; 1197 Func : constant Entity_Id := Entity (Name (N)); 1198 Is_Binary : constant Boolean := Present (Act2); 1199 Op_Node : Node_Id; 1200 Opnd_Type : Entity_Id; 1201 Orig_Type : Entity_Id := Empty; 1202 Pack : Entity_Id; 1203 1204 type Kind_Test is access function (E : Entity_Id) return Boolean; 1205 1206 function Operand_Type_In_Scope (S : Entity_Id) return Boolean; 1207 -- If the operand is not universal, and the operator is given by an 1208 -- expanded name, verify that the operand has an interpretation with a 1209 -- type defined in the given scope of the operator. 1210 1211 function Type_In_P (Test : Kind_Test) return Entity_Id; 1212 -- Find a type of the given class in package Pack that contains the 1213 -- operator. 1214 1215 --------------------------- 1216 -- Operand_Type_In_Scope -- 1217 --------------------------- 1218 1219 function Operand_Type_In_Scope (S : Entity_Id) return Boolean is 1220 Nod : constant Node_Id := Right_Opnd (Op_Node); 1221 I : Interp_Index; 1222 It : Interp; 1223 1224 begin 1225 if not Is_Overloaded (Nod) then 1226 return Scope (Base_Type (Etype (Nod))) = S; 1227 1228 else 1229 Get_First_Interp (Nod, I, It); 1230 while Present (It.Typ) loop 1231 if Scope (Base_Type (It.Typ)) = S then 1232 return True; 1233 end if; 1234 1235 Get_Next_Interp (I, It); 1236 end loop; 1237 1238 return False; 1239 end if; 1240 end Operand_Type_In_Scope; 1241 1242 --------------- 1243 -- Type_In_P -- 1244 --------------- 1245 1246 function Type_In_P (Test : Kind_Test) return Entity_Id is 1247 E : Entity_Id; 1248 1249 function In_Decl return Boolean; 1250 -- Verify that node is not part of the type declaration for the 1251 -- candidate type, which would otherwise be invisible. 1252 1253 ------------- 1254 -- In_Decl -- 1255 ------------- 1256 1257 function In_Decl return Boolean is 1258 Decl_Node : constant Node_Id := Parent (E); 1259 N2 : Node_Id; 1260 1261 begin 1262 N2 := N; 1263 1264 if Etype (E) = Any_Type then 1265 return True; 1266 1267 elsif No (Decl_Node) then 1268 return False; 1269 1270 else 1271 while Present (N2) 1272 and then Nkind (N2) /= N_Compilation_Unit 1273 loop 1274 if N2 = Decl_Node then 1275 return True; 1276 else 1277 N2 := Parent (N2); 1278 end if; 1279 end loop; 1280 1281 return False; 1282 end if; 1283 end In_Decl; 1284 1285 -- Start of processing for Type_In_P 1286 1287 begin 1288 -- If the context type is declared in the prefix package, this is the 1289 -- desired base type. 1290 1291 if Scope (Base_Type (Typ)) = Pack and then Test (Typ) then 1292 return Base_Type (Typ); 1293 1294 else 1295 E := First_Entity (Pack); 1296 while Present (E) loop 1297 if Test (E) 1298 and then not In_Decl 1299 then 1300 return E; 1301 end if; 1302 1303 Next_Entity (E); 1304 end loop; 1305 1306 return Empty; 1307 end if; 1308 end Type_In_P; 1309 1310 -- Start of processing for Make_Call_Into_Operator 1311 1312 begin 1313 Op_Node := New_Node (Operator_Kind (Op_Name, Is_Binary), Sloc (N)); 1314 1315 -- Binary operator 1316 1317 if Is_Binary then 1318 Set_Left_Opnd (Op_Node, Relocate_Node (Act1)); 1319 Set_Right_Opnd (Op_Node, Relocate_Node (Act2)); 1320 Save_Interps (Act1, Left_Opnd (Op_Node)); 1321 Save_Interps (Act2, Right_Opnd (Op_Node)); 1322 Act1 := Left_Opnd (Op_Node); 1323 Act2 := Right_Opnd (Op_Node); 1324 1325 -- Unary operator 1326 1327 else 1328 Set_Right_Opnd (Op_Node, Relocate_Node (Act1)); 1329 Save_Interps (Act1, Right_Opnd (Op_Node)); 1330 Act1 := Right_Opnd (Op_Node); 1331 end if; 1332 1333 -- If the operator is denoted by an expanded name, and the prefix is 1334 -- not Standard, but the operator is a predefined one whose scope is 1335 -- Standard, then this is an implicit_operator, inserted as an 1336 -- interpretation by the procedure of the same name. This procedure 1337 -- overestimates the presence of implicit operators, because it does 1338 -- not examine the type of the operands. Verify now that the operand 1339 -- type appears in the given scope. If right operand is universal, 1340 -- check the other operand. In the case of concatenation, either 1341 -- argument can be the component type, so check the type of the result. 1342 -- If both arguments are literals, look for a type of the right kind 1343 -- defined in the given scope. This elaborate nonsense is brought to 1344 -- you courtesy of b33302a. The type itself must be frozen, so we must 1345 -- find the type of the proper class in the given scope. 1346 1347 -- A final wrinkle is the multiplication operator for fixed point types, 1348 -- which is defined in Standard only, and not in the scope of the 1349 -- fixed point type itself. 1350 1351 if Nkind (Name (N)) = N_Expanded_Name then 1352 Pack := Entity (Prefix (Name (N))); 1353 1354 -- If this is a package renaming, get renamed entity, which will be 1355 -- the scope of the operands if operaton is type-correct. 1356 1357 if Present (Renamed_Entity (Pack)) then 1358 Pack := Renamed_Entity (Pack); 1359 end if; 1360 1361 -- If the entity being called is defined in the given package, it is 1362 -- a renaming of a predefined operator, and known to be legal. 1363 1364 if Scope (Entity (Name (N))) = Pack 1365 and then Pack /= Standard_Standard 1366 then 1367 null; 1368 1369 -- Visibility does not need to be checked in an instance: if the 1370 -- operator was not visible in the generic it has been diagnosed 1371 -- already, else there is an implicit copy of it in the instance. 1372 1373 elsif In_Instance then 1374 null; 1375 1376 elsif (Op_Name = Name_Op_Multiply or else Op_Name = Name_Op_Divide) 1377 and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node))) 1378 and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node))) 1379 then 1380 if Pack /= Standard_Standard then 1381 Error := True; 1382 end if; 1383 1384 -- Ada 2005 AI-420: Predefined equality on Universal_Access is 1385 -- available. 1386 1387 elsif Ada_Version >= Ada_2005 1388 and then (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne) 1389 and then Ekind (Etype (Act1)) = E_Anonymous_Access_Type 1390 then 1391 null; 1392 1393 else 1394 Opnd_Type := Base_Type (Etype (Right_Opnd (Op_Node))); 1395 1396 if Op_Name = Name_Op_Concat then 1397 Opnd_Type := Base_Type (Typ); 1398 1399 elsif (Scope (Opnd_Type) = Standard_Standard 1400 and then Is_Binary) 1401 or else (Nkind (Right_Opnd (Op_Node)) = N_Attribute_Reference 1402 and then Is_Binary 1403 and then not Comes_From_Source (Opnd_Type)) 1404 then 1405 Opnd_Type := Base_Type (Etype (Left_Opnd (Op_Node))); 1406 end if; 1407 1408 if Scope (Opnd_Type) = Standard_Standard then 1409 1410 -- Verify that the scope contains a type that corresponds to 1411 -- the given literal. Optimize the case where Pack is Standard. 1412 1413 if Pack /= Standard_Standard then 1414 1415 if Opnd_Type = Universal_Integer then 1416 Orig_Type := Type_In_P (Is_Integer_Type'Access); 1417 1418 elsif Opnd_Type = Universal_Real then 1419 Orig_Type := Type_In_P (Is_Real_Type'Access); 1420 1421 elsif Opnd_Type = Any_String then 1422 Orig_Type := Type_In_P (Is_String_Type'Access); 1423 1424 elsif Opnd_Type = Any_Access then 1425 Orig_Type := Type_In_P (Is_Definite_Access_Type'Access); 1426 1427 elsif Opnd_Type = Any_Composite then 1428 Orig_Type := Type_In_P (Is_Composite_Type'Access); 1429 1430 if Present (Orig_Type) then 1431 if Has_Private_Component (Orig_Type) then 1432 Orig_Type := Empty; 1433 else 1434 Set_Etype (Act1, Orig_Type); 1435 1436 if Is_Binary then 1437 Set_Etype (Act2, Orig_Type); 1438 end if; 1439 end if; 1440 end if; 1441 1442 else 1443 Orig_Type := Empty; 1444 end if; 1445 1446 Error := No (Orig_Type); 1447 end if; 1448 1449 elsif Ekind (Opnd_Type) = E_Allocator_Type 1450 and then No (Type_In_P (Is_Definite_Access_Type'Access)) 1451 then 1452 Error := True; 1453 1454 -- If the type is defined elsewhere, and the operator is not 1455 -- defined in the given scope (by a renaming declaration, e.g.) 1456 -- then this is an error as well. If an extension of System is 1457 -- present, and the type may be defined there, Pack must be 1458 -- System itself. 1459 1460 elsif Scope (Opnd_Type) /= Pack 1461 and then Scope (Op_Id) /= Pack 1462 and then (No (System_Aux_Id) 1463 or else Scope (Opnd_Type) /= System_Aux_Id 1464 or else Pack /= Scope (System_Aux_Id)) 1465 then 1466 if not Is_Overloaded (Right_Opnd (Op_Node)) then 1467 Error := True; 1468 else 1469 Error := not Operand_Type_In_Scope (Pack); 1470 end if; 1471 1472 elsif Pack = Standard_Standard 1473 and then not Operand_Type_In_Scope (Standard_Standard) 1474 then 1475 Error := True; 1476 end if; 1477 end if; 1478 1479 if Error then 1480 Error_Msg_Node_2 := Pack; 1481 Error_Msg_NE 1482 ("& not declared in&", N, Selector_Name (Name (N))); 1483 Set_Etype (N, Any_Type); 1484 return; 1485 1486 -- Detect a mismatch between the context type and the result type 1487 -- in the named package, which is otherwise not detected if the 1488 -- operands are universal. Check is only needed if source entity is 1489 -- an operator, not a function that renames an operator. 1490 1491 elsif Nkind (Parent (N)) /= N_Type_Conversion 1492 and then Ekind (Entity (Name (N))) = E_Operator 1493 and then Is_Numeric_Type (Typ) 1494 and then not Is_Universal_Numeric_Type (Typ) 1495 and then Scope (Base_Type (Typ)) /= Pack 1496 and then not In_Instance 1497 then 1498 if Is_Fixed_Point_Type (Typ) 1499 and then (Op_Name = Name_Op_Multiply 1500 or else 1501 Op_Name = Name_Op_Divide) 1502 then 1503 -- Already checked above 1504 1505 null; 1506 1507 -- Operator may be defined in an extension of System 1508 1509 elsif Present (System_Aux_Id) 1510 and then Scope (Opnd_Type) = System_Aux_Id 1511 then 1512 null; 1513 1514 else 1515 -- Could we use Wrong_Type here??? (this would require setting 1516 -- Etype (N) to the actual type found where Typ was expected). 1517 1518 Error_Msg_NE ("expect }", N, Typ); 1519 end if; 1520 end if; 1521 end if; 1522 1523 Set_Chars (Op_Node, Op_Name); 1524 1525 if not Is_Private_Type (Etype (N)) then 1526 Set_Etype (Op_Node, Base_Type (Etype (N))); 1527 else 1528 Set_Etype (Op_Node, Etype (N)); 1529 end if; 1530 1531 -- If this is a call to a function that renames a predefined equality, 1532 -- the renaming declaration provides a type that must be used to 1533 -- resolve the operands. This must be done now because resolution of 1534 -- the equality node will not resolve any remaining ambiguity, and it 1535 -- assumes that the first operand is not overloaded. 1536 1537 if (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne) 1538 and then Ekind (Func) = E_Function 1539 and then Is_Overloaded (Act1) 1540 then 1541 Resolve (Act1, Base_Type (Etype (First_Formal (Func)))); 1542 Resolve (Act2, Base_Type (Etype (First_Formal (Func)))); 1543 end if; 1544 1545 Set_Entity (Op_Node, Op_Id); 1546 Generate_Reference (Op_Id, N, ' '); 1547 1548 -- Do rewrite setting Comes_From_Source on the result if the original 1549 -- call came from source. Although it is not strictly the case that the 1550 -- operator as such comes from the source, logically it corresponds 1551 -- exactly to the function call in the source, so it should be marked 1552 -- this way (e.g. to make sure that validity checks work fine). 1553 1554 declare 1555 CS : constant Boolean := Comes_From_Source (N); 1556 begin 1557 Rewrite (N, Op_Node); 1558 Set_Comes_From_Source (N, CS); 1559 end; 1560 1561 -- If this is an arithmetic operator and the result type is private, 1562 -- the operands and the result must be wrapped in conversion to 1563 -- expose the underlying numeric type and expand the proper checks, 1564 -- e.g. on division. 1565 1566 if Is_Private_Type (Typ) then 1567 case Nkind (N) is 1568 when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide | 1569 N_Op_Expon | N_Op_Mod | N_Op_Rem => 1570 Resolve_Intrinsic_Operator (N, Typ); 1571 1572 when N_Op_Plus | N_Op_Minus | N_Op_Abs => 1573 Resolve_Intrinsic_Unary_Operator (N, Typ); 1574 1575 when others => 1576 Resolve (N, Typ); 1577 end case; 1578 else 1579 Resolve (N, Typ); 1580 end if; 1581 end Make_Call_Into_Operator; 1582 1583 ------------------- 1584 -- Operator_Kind -- 1585 ------------------- 1586 1587 function Operator_Kind 1588 (Op_Name : Name_Id; 1589 Is_Binary : Boolean) return Node_Kind 1590 is 1591 Kind : Node_Kind; 1592 1593 begin 1594 -- Use CASE statement or array??? 1595 1596 if Is_Binary then 1597 if Op_Name = Name_Op_And then 1598 Kind := N_Op_And; 1599 elsif Op_Name = Name_Op_Or then 1600 Kind := N_Op_Or; 1601 elsif Op_Name = Name_Op_Xor then 1602 Kind := N_Op_Xor; 1603 elsif Op_Name = Name_Op_Eq then 1604 Kind := N_Op_Eq; 1605 elsif Op_Name = Name_Op_Ne then 1606 Kind := N_Op_Ne; 1607 elsif Op_Name = Name_Op_Lt then 1608 Kind := N_Op_Lt; 1609 elsif Op_Name = Name_Op_Le then 1610 Kind := N_Op_Le; 1611 elsif Op_Name = Name_Op_Gt then 1612 Kind := N_Op_Gt; 1613 elsif Op_Name = Name_Op_Ge then 1614 Kind := N_Op_Ge; 1615 elsif Op_Name = Name_Op_Add then 1616 Kind := N_Op_Add; 1617 elsif Op_Name = Name_Op_Subtract then 1618 Kind := N_Op_Subtract; 1619 elsif Op_Name = Name_Op_Concat then 1620 Kind := N_Op_Concat; 1621 elsif Op_Name = Name_Op_Multiply then 1622 Kind := N_Op_Multiply; 1623 elsif Op_Name = Name_Op_Divide then 1624 Kind := N_Op_Divide; 1625 elsif Op_Name = Name_Op_Mod then 1626 Kind := N_Op_Mod; 1627 elsif Op_Name = Name_Op_Rem then 1628 Kind := N_Op_Rem; 1629 elsif Op_Name = Name_Op_Expon then 1630 Kind := N_Op_Expon; 1631 else 1632 raise Program_Error; 1633 end if; 1634 1635 -- Unary operators 1636 1637 else 1638 if Op_Name = Name_Op_Add then 1639 Kind := N_Op_Plus; 1640 elsif Op_Name = Name_Op_Subtract then 1641 Kind := N_Op_Minus; 1642 elsif Op_Name = Name_Op_Abs then 1643 Kind := N_Op_Abs; 1644 elsif Op_Name = Name_Op_Not then 1645 Kind := N_Op_Not; 1646 else 1647 raise Program_Error; 1648 end if; 1649 end if; 1650 1651 return Kind; 1652 end Operator_Kind; 1653 1654 ---------------------------- 1655 -- Preanalyze_And_Resolve -- 1656 ---------------------------- 1657 1658 procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id) is 1659 Save_Full_Analysis : constant Boolean := Full_Analysis; 1660 1661 begin 1662 Full_Analysis := False; 1663 Expander_Mode_Save_And_Set (False); 1664 1665 -- Normally, we suppress all checks for this preanalysis. There is no 1666 -- point in processing them now, since they will be applied properly 1667 -- and in the proper location when the default expressions reanalyzed 1668 -- and reexpanded later on. We will also have more information at that 1669 -- point for possible suppression of individual checks. 1670 1671 -- However, in Alfa mode, most expansion is suppressed, and this 1672 -- later reanalysis and reexpansion may not occur. Alfa mode does 1673 -- require the setting of checking flags for proof purposes, so we 1674 -- do the Alfa preanalysis without suppressing checks. 1675 1676 -- This special handling for Alfa mode is required for example in the 1677 -- case of Ada 2012 constructs such as quantified expressions, which are 1678 -- expanded in two separate steps. 1679 1680 if Alfa_Mode then 1681 Analyze_And_Resolve (N, T); 1682 else 1683 Analyze_And_Resolve (N, T, Suppress => All_Checks); 1684 end if; 1685 1686 Expander_Mode_Restore; 1687 Full_Analysis := Save_Full_Analysis; 1688 end Preanalyze_And_Resolve; 1689 1690 -- Version without context type 1691 1692 procedure Preanalyze_And_Resolve (N : Node_Id) is 1693 Save_Full_Analysis : constant Boolean := Full_Analysis; 1694 1695 begin 1696 Full_Analysis := False; 1697 Expander_Mode_Save_And_Set (False); 1698 1699 Analyze (N); 1700 Resolve (N, Etype (N), Suppress => All_Checks); 1701 1702 Expander_Mode_Restore; 1703 Full_Analysis := Save_Full_Analysis; 1704 end Preanalyze_And_Resolve; 1705 1706 ---------------------------------- 1707 -- Replace_Actual_Discriminants -- 1708 ---------------------------------- 1709 1710 procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id) is 1711 Loc : constant Source_Ptr := Sloc (N); 1712 Tsk : Node_Id := Empty; 1713 1714 function Process_Discr (Nod : Node_Id) return Traverse_Result; 1715 -- Comment needed??? 1716 1717 ------------------- 1718 -- Process_Discr -- 1719 ------------------- 1720 1721 function Process_Discr (Nod : Node_Id) return Traverse_Result is 1722 Ent : Entity_Id; 1723 1724 begin 1725 if Nkind (Nod) = N_Identifier then 1726 Ent := Entity (Nod); 1727 1728 if Present (Ent) 1729 and then Ekind (Ent) = E_Discriminant 1730 then 1731 Rewrite (Nod, 1732 Make_Selected_Component (Loc, 1733 Prefix => New_Copy_Tree (Tsk, New_Sloc => Loc), 1734 Selector_Name => Make_Identifier (Loc, Chars (Ent)))); 1735 1736 Set_Etype (Nod, Etype (Ent)); 1737 end if; 1738 1739 end if; 1740 1741 return OK; 1742 end Process_Discr; 1743 1744 procedure Replace_Discrs is new Traverse_Proc (Process_Discr); 1745 1746 -- Start of processing for Replace_Actual_Discriminants 1747 1748 begin 1749 if not Full_Expander_Active then 1750 return; 1751 end if; 1752 1753 if Nkind (Name (N)) = N_Selected_Component then 1754 Tsk := Prefix (Name (N)); 1755 1756 elsif Nkind (Name (N)) = N_Indexed_Component then 1757 Tsk := Prefix (Prefix (Name (N))); 1758 end if; 1759 1760 if No (Tsk) then 1761 return; 1762 else 1763 Replace_Discrs (Default); 1764 end if; 1765 end Replace_Actual_Discriminants; 1766 1767 ------------- 1768 -- Resolve -- 1769 ------------- 1770 1771 procedure Resolve (N : Node_Id; Typ : Entity_Id) is 1772 Ambiguous : Boolean := False; 1773 Ctx_Type : Entity_Id := Typ; 1774 Expr_Type : Entity_Id := Empty; -- prevent junk warning 1775 Err_Type : Entity_Id := Empty; 1776 Found : Boolean := False; 1777 From_Lib : Boolean; 1778 I : Interp_Index; 1779 I1 : Interp_Index := 0; -- prevent junk warning 1780 It : Interp; 1781 It1 : Interp; 1782 Seen : Entity_Id := Empty; -- prevent junk warning 1783 1784 function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean; 1785 -- Determine whether a node comes from a predefined library unit or 1786 -- Standard. 1787 1788 procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id); 1789 -- Try and fix up a literal so that it matches its expected type. New 1790 -- literals are manufactured if necessary to avoid cascaded errors. 1791 1792 function Proper_Current_Scope return Entity_Id; 1793 -- Return the current scope. Skip loop scopes created for the purpose of 1794 -- quantified expression analysis since those do not appear in the tree. 1795 1796 procedure Report_Ambiguous_Argument; 1797 -- Additional diagnostics when an ambiguous call has an ambiguous 1798 -- argument (typically a controlling actual). 1799 1800 procedure Resolution_Failed; 1801 -- Called when attempt at resolving current expression fails 1802 1803 ------------------------------------ 1804 -- Comes_From_Predefined_Lib_Unit -- 1805 ------------------------------------- 1806 1807 function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean is 1808 begin 1809 return 1810 Sloc (Nod) = Standard_Location 1811 or else Is_Predefined_File_Name 1812 (Unit_File_Name (Get_Source_Unit (Sloc (Nod)))); 1813 end Comes_From_Predefined_Lib_Unit; 1814 1815 -------------------- 1816 -- Patch_Up_Value -- 1817 -------------------- 1818 1819 procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id) is 1820 begin 1821 if Nkind (N) = N_Integer_Literal and then Is_Real_Type (Typ) then 1822 Rewrite (N, 1823 Make_Real_Literal (Sloc (N), 1824 Realval => UR_From_Uint (Intval (N)))); 1825 Set_Etype (N, Universal_Real); 1826 Set_Is_Static_Expression (N); 1827 1828 elsif Nkind (N) = N_Real_Literal and then Is_Integer_Type (Typ) then 1829 Rewrite (N, 1830 Make_Integer_Literal (Sloc (N), 1831 Intval => UR_To_Uint (Realval (N)))); 1832 Set_Etype (N, Universal_Integer); 1833 Set_Is_Static_Expression (N); 1834 1835 elsif Nkind (N) = N_String_Literal 1836 and then Is_Character_Type (Typ) 1837 then 1838 Set_Character_Literal_Name (Char_Code (Character'Pos ('A'))); 1839 Rewrite (N, 1840 Make_Character_Literal (Sloc (N), 1841 Chars => Name_Find, 1842 Char_Literal_Value => 1843 UI_From_Int (Character'Pos ('A')))); 1844 Set_Etype (N, Any_Character); 1845 Set_Is_Static_Expression (N); 1846 1847 elsif Nkind (N) /= N_String_Literal and then Is_String_Type (Typ) then 1848 Rewrite (N, 1849 Make_String_Literal (Sloc (N), 1850 Strval => End_String)); 1851 1852 elsif Nkind (N) = N_Range then 1853 Patch_Up_Value (Low_Bound (N), Typ); 1854 Patch_Up_Value (High_Bound (N), Typ); 1855 end if; 1856 end Patch_Up_Value; 1857 1858 -------------------------- 1859 -- Proper_Current_Scope -- 1860 -------------------------- 1861 1862 function Proper_Current_Scope return Entity_Id is 1863 S : Entity_Id := Current_Scope; 1864 1865 begin 1866 while Present (S) loop 1867 1868 -- Skip a loop scope created for quantified expression analysis 1869 1870 if Ekind (S) = E_Loop 1871 and then Nkind (Parent (S)) = N_Quantified_Expression 1872 then 1873 S := Scope (S); 1874 else 1875 exit; 1876 end if; 1877 end loop; 1878 1879 return S; 1880 end Proper_Current_Scope; 1881 1882 ------------------------------- 1883 -- Report_Ambiguous_Argument -- 1884 ------------------------------- 1885 1886 procedure Report_Ambiguous_Argument is 1887 Arg : constant Node_Id := First (Parameter_Associations (N)); 1888 I : Interp_Index; 1889 It : Interp; 1890 1891 begin 1892 if Nkind (Arg) = N_Function_Call 1893 and then Is_Entity_Name (Name (Arg)) 1894 and then Is_Overloaded (Name (Arg)) 1895 then 1896 Error_Msg_NE ("ambiguous call to&", Arg, Name (Arg)); 1897 1898 -- Could use comments on what is going on here??? 1899 1900 Get_First_Interp (Name (Arg), I, It); 1901 while Present (It.Nam) loop 1902 Error_Msg_Sloc := Sloc (It.Nam); 1903 1904 if Nkind (Parent (It.Nam)) = N_Full_Type_Declaration then 1905 Error_Msg_N ("interpretation (inherited) #!", Arg); 1906 else 1907 Error_Msg_N ("interpretation #!", Arg); 1908 end if; 1909 1910 Get_Next_Interp (I, It); 1911 end loop; 1912 end if; 1913 end Report_Ambiguous_Argument; 1914 1915 ----------------------- 1916 -- Resolution_Failed -- 1917 ----------------------- 1918 1919 procedure Resolution_Failed is 1920 begin 1921 Patch_Up_Value (N, Typ); 1922 Set_Etype (N, Typ); 1923 Debug_A_Exit ("resolving ", N, " (done, resolution failed)"); 1924 Set_Is_Overloaded (N, False); 1925 1926 -- The caller will return without calling the expander, so we need 1927 -- to set the analyzed flag. Note that it is fine to set Analyzed 1928 -- to True even if we are in the middle of a shallow analysis, 1929 -- (see the spec of sem for more details) since this is an error 1930 -- situation anyway, and there is no point in repeating the 1931 -- analysis later (indeed it won't work to repeat it later, since 1932 -- we haven't got a clear resolution of which entity is being 1933 -- referenced.) 1934 1935 Set_Analyzed (N, True); 1936 return; 1937 end Resolution_Failed; 1938 1939 -- Start of processing for Resolve 1940 1941 begin 1942 if N = Error then 1943 return; 1944 end if; 1945 1946 -- Access attribute on remote subprogram cannot be used for a non-remote 1947 -- access-to-subprogram type. 1948 1949 if Nkind (N) = N_Attribute_Reference 1950 and then (Attribute_Name (N) = Name_Access or else 1951 Attribute_Name (N) = Name_Unrestricted_Access or else 1952 Attribute_Name (N) = Name_Unchecked_Access) 1953 and then Comes_From_Source (N) 1954 and then Is_Entity_Name (Prefix (N)) 1955 and then Is_Subprogram (Entity (Prefix (N))) 1956 and then Is_Remote_Call_Interface (Entity (Prefix (N))) 1957 and then not Is_Remote_Access_To_Subprogram_Type (Typ) 1958 then 1959 Error_Msg_N 1960 ("prefix must statically denote a non-remote subprogram", N); 1961 end if; 1962 1963 From_Lib := Comes_From_Predefined_Lib_Unit (N); 1964 1965 -- If the context is a Remote_Access_To_Subprogram, access attributes 1966 -- must be resolved with the corresponding fat pointer. There is no need 1967 -- to check for the attribute name since the return type of an 1968 -- attribute is never a remote type. 1969 1970 if Nkind (N) = N_Attribute_Reference 1971 and then Comes_From_Source (N) 1972 and then (Is_Remote_Call_Interface (Typ) or else Is_Remote_Types (Typ)) 1973 then 1974 declare 1975 Attr : constant Attribute_Id := 1976 Get_Attribute_Id (Attribute_Name (N)); 1977 Pref : constant Node_Id := Prefix (N); 1978 Decl : Node_Id; 1979 Spec : Node_Id; 1980 Is_Remote : Boolean := True; 1981 1982 begin 1983 -- Check that Typ is a remote access-to-subprogram type 1984 1985 if Is_Remote_Access_To_Subprogram_Type (Typ) then 1986 1987 -- Prefix (N) must statically denote a remote subprogram 1988 -- declared in a package specification. 1989 1990 if Attr = Attribute_Access or else 1991 Attr = Attribute_Unchecked_Access or else 1992 Attr = Attribute_Unrestricted_Access 1993 then 1994 Decl := Unit_Declaration_Node (Entity (Pref)); 1995 1996 if Nkind (Decl) = N_Subprogram_Body then 1997 Spec := Corresponding_Spec (Decl); 1998 1999 if not No (Spec) then 2000 Decl := Unit_Declaration_Node (Spec); 2001 end if; 2002 end if; 2003 2004 Spec := Parent (Decl); 2005 2006 if not Is_Entity_Name (Prefix (N)) 2007 or else Nkind (Spec) /= N_Package_Specification 2008 or else 2009 not Is_Remote_Call_Interface (Defining_Entity (Spec)) 2010 then 2011 Is_Remote := False; 2012 Error_Msg_N 2013 ("prefix must statically denote a remote subprogram ", 2014 N); 2015 end if; 2016 2017 -- If we are generating code in distributed mode, perform 2018 -- semantic checks against corresponding remote entities. 2019 2020 if Full_Expander_Active 2021 and then Get_PCS_Name /= Name_No_DSA 2022 then 2023 Check_Subtype_Conformant 2024 (New_Id => Entity (Prefix (N)), 2025 Old_Id => Designated_Type 2026 (Corresponding_Remote_Type (Typ)), 2027 Err_Loc => N); 2028 2029 if Is_Remote then 2030 Process_Remote_AST_Attribute (N, Typ); 2031 end if; 2032 end if; 2033 end if; 2034 end if; 2035 end; 2036 end if; 2037 2038 Debug_A_Entry ("resolving ", N); 2039 2040 if Debug_Flag_V then 2041 Write_Overloads (N); 2042 end if; 2043 2044 if Comes_From_Source (N) then 2045 if Is_Fixed_Point_Type (Typ) then 2046 Check_Restriction (No_Fixed_Point, N); 2047 2048 elsif Is_Floating_Point_Type (Typ) 2049 and then Typ /= Universal_Real 2050 and then Typ /= Any_Real 2051 then 2052 Check_Restriction (No_Floating_Point, N); 2053 end if; 2054 end if; 2055 2056 -- Return if already analyzed 2057 2058 if Analyzed (N) then 2059 Debug_A_Exit ("resolving ", N, " (done, already analyzed)"); 2060 Analyze_Dimension (N); 2061 return; 2062 2063 -- Return if type = Any_Type (previous error encountered) 2064 2065 elsif Etype (N) = Any_Type then 2066 Debug_A_Exit ("resolving ", N, " (done, Etype = Any_Type)"); 2067 return; 2068 end if; 2069 2070 Check_Parameterless_Call (N); 2071 2072 -- If not overloaded, then we know the type, and all that needs doing 2073 -- is to check that this type is compatible with the context. 2074 2075 if not Is_Overloaded (N) then 2076 Found := Covers (Typ, Etype (N)); 2077 Expr_Type := Etype (N); 2078 2079 -- In the overloaded case, we must select the interpretation that 2080 -- is compatible with the context (i.e. the type passed to Resolve) 2081 2082 else 2083 -- Loop through possible interpretations 2084 2085 Get_First_Interp (N, I, It); 2086 Interp_Loop : while Present (It.Typ) loop 2087 2088 if Debug_Flag_V then 2089 Write_Str ("Interp: "); 2090 Write_Interp (It); 2091 end if; 2092 2093 -- We are only interested in interpretations that are compatible 2094 -- with the expected type, any other interpretations are ignored. 2095 2096 if not Covers (Typ, It.Typ) then 2097 if Debug_Flag_V then 2098 Write_Str (" interpretation incompatible with context"); 2099 Write_Eol; 2100 end if; 2101 2102 else 2103 -- Skip the current interpretation if it is disabled by an 2104 -- abstract operator. This action is performed only when the 2105 -- type against which we are resolving is the same as the 2106 -- type of the interpretation. 2107 2108 if Ada_Version >= Ada_2005 2109 and then It.Typ = Typ 2110 and then Typ /= Universal_Integer 2111 and then Typ /= Universal_Real 2112 and then Present (It.Abstract_Op) 2113 then 2114 if Debug_Flag_V then 2115 Write_Line ("Skip."); 2116 end if; 2117 2118 goto Continue; 2119 end if; 2120 2121 -- First matching interpretation 2122 2123 if not Found then 2124 Found := True; 2125 I1 := I; 2126 Seen := It.Nam; 2127 Expr_Type := It.Typ; 2128 2129 -- Matching interpretation that is not the first, maybe an 2130 -- error, but there are some cases where preference rules are 2131 -- used to choose between the two possibilities. These and 2132 -- some more obscure cases are handled in Disambiguate. 2133 2134 else 2135 -- If the current statement is part of a predefined library 2136 -- unit, then all interpretations which come from user level 2137 -- packages should not be considered. 2138 2139 if From_Lib 2140 and then not Comes_From_Predefined_Lib_Unit (It.Nam) 2141 then 2142 goto Continue; 2143 end if; 2144 2145 Error_Msg_Sloc := Sloc (Seen); 2146 It1 := Disambiguate (N, I1, I, Typ); 2147 2148 -- Disambiguation has succeeded. Skip the remaining 2149 -- interpretations. 2150 2151 if It1 /= No_Interp then 2152 Seen := It1.Nam; 2153 Expr_Type := It1.Typ; 2154 2155 while Present (It.Typ) loop 2156 Get_Next_Interp (I, It); 2157 end loop; 2158 2159 else 2160 -- Before we issue an ambiguity complaint, check for 2161 -- the case of a subprogram call where at least one 2162 -- of the arguments is Any_Type, and if so, suppress 2163 -- the message, since it is a cascaded error. 2164 2165 if Nkind (N) in N_Subprogram_Call then 2166 declare 2167 A : Node_Id; 2168 E : Node_Id; 2169 2170 begin 2171 A := First_Actual (N); 2172 while Present (A) loop 2173 E := A; 2174 2175 if Nkind (E) = N_Parameter_Association then 2176 E := Explicit_Actual_Parameter (E); 2177 end if; 2178 2179 if Etype (E) = Any_Type then 2180 if Debug_Flag_V then 2181 Write_Str ("Any_Type in call"); 2182 Write_Eol; 2183 end if; 2184 2185 exit Interp_Loop; 2186 end if; 2187 2188 Next_Actual (A); 2189 end loop; 2190 end; 2191 2192 elsif Nkind (N) in N_Binary_Op 2193 and then (Etype (Left_Opnd (N)) = Any_Type 2194 or else Etype (Right_Opnd (N)) = Any_Type) 2195 then 2196 exit Interp_Loop; 2197 2198 elsif Nkind (N) in N_Unary_Op 2199 and then Etype (Right_Opnd (N)) = Any_Type 2200 then 2201 exit Interp_Loop; 2202 end if; 2203 2204 -- Not that special case, so issue message using the 2205 -- flag Ambiguous to control printing of the header 2206 -- message only at the start of an ambiguous set. 2207 2208 if not Ambiguous then 2209 if Nkind (N) = N_Function_Call 2210 and then Nkind (Name (N)) = N_Explicit_Dereference 2211 then 2212 Error_Msg_N 2213 ("ambiguous expression " 2214 & "(cannot resolve indirect call)!", N); 2215 else 2216 Error_Msg_NE -- CODEFIX 2217 ("ambiguous expression (cannot resolve&)!", 2218 N, It.Nam); 2219 end if; 2220 2221 Ambiguous := True; 2222 2223 if Nkind (Parent (Seen)) = N_Full_Type_Declaration then 2224 Error_Msg_N 2225 ("\\possible interpretation (inherited)#!", N); 2226 else 2227 Error_Msg_N -- CODEFIX 2228 ("\\possible interpretation#!", N); 2229 end if; 2230 2231 if Nkind (N) in N_Subprogram_Call 2232 and then Present (Parameter_Associations (N)) 2233 then 2234 Report_Ambiguous_Argument; 2235 end if; 2236 end if; 2237 2238 Error_Msg_Sloc := Sloc (It.Nam); 2239 2240 -- By default, the error message refers to the candidate 2241 -- interpretation. But if it is a predefined operator, it 2242 -- is implicitly declared at the declaration of the type 2243 -- of the operand. Recover the sloc of that declaration 2244 -- for the error message. 2245 2246 if Nkind (N) in N_Op 2247 and then Scope (It.Nam) = Standard_Standard 2248 and then not Is_Overloaded (Right_Opnd (N)) 2249 and then Scope (Base_Type (Etype (Right_Opnd (N)))) /= 2250 Standard_Standard 2251 then 2252 Err_Type := First_Subtype (Etype (Right_Opnd (N))); 2253 2254 if Comes_From_Source (Err_Type) 2255 and then Present (Parent (Err_Type)) 2256 then 2257 Error_Msg_Sloc := Sloc (Parent (Err_Type)); 2258 end if; 2259 2260 elsif Nkind (N) in N_Binary_Op 2261 and then Scope (It.Nam) = Standard_Standard 2262 and then not Is_Overloaded (Left_Opnd (N)) 2263 and then Scope (Base_Type (Etype (Left_Opnd (N)))) /= 2264 Standard_Standard 2265 then 2266 Err_Type := First_Subtype (Etype (Left_Opnd (N))); 2267 2268 if Comes_From_Source (Err_Type) 2269 and then Present (Parent (Err_Type)) 2270 then 2271 Error_Msg_Sloc := Sloc (Parent (Err_Type)); 2272 end if; 2273 2274 -- If this is an indirect call, use the subprogram_type 2275 -- in the message, to have a meaningful location. Also 2276 -- indicate if this is an inherited operation, created 2277 -- by a type declaration. 2278 2279 elsif Nkind (N) = N_Function_Call 2280 and then Nkind (Name (N)) = N_Explicit_Dereference 2281 and then Is_Type (It.Nam) 2282 then 2283 Err_Type := It.Nam; 2284 Error_Msg_Sloc := 2285 Sloc (Associated_Node_For_Itype (Err_Type)); 2286 else 2287 Err_Type := Empty; 2288 end if; 2289 2290 if Nkind (N) in N_Op 2291 and then Scope (It.Nam) = Standard_Standard 2292 and then Present (Err_Type) 2293 then 2294 -- Special-case the message for universal_fixed 2295 -- operators, which are not declared with the type 2296 -- of the operand, but appear forever in Standard. 2297 2298 if It.Typ = Universal_Fixed 2299 and then Scope (It.Nam) = Standard_Standard 2300 then 2301 Error_Msg_N 2302 ("\\possible interpretation as " & 2303 "universal_fixed operation " & 2304 "(RM 4.5.5 (19))", N); 2305 else 2306 Error_Msg_N 2307 ("\\possible interpretation (predefined)#!", N); 2308 end if; 2309 2310 elsif 2311 Nkind (Parent (It.Nam)) = N_Full_Type_Declaration 2312 then 2313 Error_Msg_N 2314 ("\\possible interpretation (inherited)#!", N); 2315 else 2316 Error_Msg_N -- CODEFIX 2317 ("\\possible interpretation#!", N); 2318 end if; 2319 2320 end if; 2321 end if; 2322 2323 -- We have a matching interpretation, Expr_Type is the type 2324 -- from this interpretation, and Seen is the entity. 2325 2326 -- For an operator, just set the entity name. The type will be 2327 -- set by the specific operator resolution routine. 2328 2329 if Nkind (N) in N_Op then 2330 Set_Entity (N, Seen); 2331 Generate_Reference (Seen, N); 2332 2333 elsif Nkind (N) = N_Case_Expression then 2334 Set_Etype (N, Expr_Type); 2335 2336 elsif Nkind (N) = N_Character_Literal then 2337 Set_Etype (N, Expr_Type); 2338 2339 elsif Nkind (N) = N_If_Expression then 2340 Set_Etype (N, Expr_Type); 2341 2342 -- AI05-0139-2: Expression is overloaded because type has 2343 -- implicit dereference. If type matches context, no implicit 2344 -- dereference is involved. 2345 2346 elsif Has_Implicit_Dereference (Expr_Type) then 2347 Set_Etype (N, Expr_Type); 2348 Set_Is_Overloaded (N, False); 2349 exit Interp_Loop; 2350 2351 elsif Is_Overloaded (N) 2352 and then Present (It.Nam) 2353 and then Ekind (It.Nam) = E_Discriminant 2354 and then Has_Implicit_Dereference (It.Nam) 2355 then 2356 Build_Explicit_Dereference (N, It.Nam); 2357 2358 -- For an explicit dereference, attribute reference, range, 2359 -- short-circuit form (which is not an operator node), or call 2360 -- with a name that is an explicit dereference, there is 2361 -- nothing to be done at this point. 2362 2363 elsif Nkind_In (N, N_Explicit_Dereference, 2364 N_Attribute_Reference, 2365 N_And_Then, 2366 N_Indexed_Component, 2367 N_Or_Else, 2368 N_Range, 2369 N_Selected_Component, 2370 N_Slice) 2371 or else Nkind (Name (N)) = N_Explicit_Dereference 2372 then 2373 null; 2374 2375 -- For procedure or function calls, set the type of the name, 2376 -- and also the entity pointer for the prefix. 2377 2378 elsif Nkind (N) in N_Subprogram_Call 2379 and then Is_Entity_Name (Name (N)) 2380 then 2381 Set_Etype (Name (N), Expr_Type); 2382 Set_Entity (Name (N), Seen); 2383 Generate_Reference (Seen, Name (N)); 2384 2385 elsif Nkind (N) = N_Function_Call 2386 and then Nkind (Name (N)) = N_Selected_Component 2387 then 2388 Set_Etype (Name (N), Expr_Type); 2389 Set_Entity (Selector_Name (Name (N)), Seen); 2390 Generate_Reference (Seen, Selector_Name (Name (N))); 2391 2392 -- For all other cases, just set the type of the Name 2393 2394 else 2395 Set_Etype (Name (N), Expr_Type); 2396 end if; 2397 2398 end if; 2399 2400 <<Continue>> 2401 2402 -- Move to next interpretation 2403 2404 exit Interp_Loop when No (It.Typ); 2405 2406 Get_Next_Interp (I, It); 2407 end loop Interp_Loop; 2408 end if; 2409 2410 -- At this stage Found indicates whether or not an acceptable 2411 -- interpretation exists. If not, then we have an error, except that if 2412 -- the context is Any_Type as a result of some other error, then we 2413 -- suppress the error report. 2414 2415 if not Found then 2416 if Typ /= Any_Type then 2417 2418 -- If type we are looking for is Void, then this is the procedure 2419 -- call case, and the error is simply that what we gave is not a 2420 -- procedure name (we think of procedure calls as expressions with 2421 -- types internally, but the user doesn't think of them this way!) 2422 2423 if Typ = Standard_Void_Type then 2424 2425 -- Special case message if function used as a procedure 2426 2427 if Nkind (N) = N_Procedure_Call_Statement 2428 and then Is_Entity_Name (Name (N)) 2429 and then Ekind (Entity (Name (N))) = E_Function 2430 then 2431 Error_Msg_NE 2432 ("cannot use function & in a procedure call", 2433 Name (N), Entity (Name (N))); 2434 2435 -- Otherwise give general message (not clear what cases this 2436 -- covers, but no harm in providing for them!) 2437 2438 else 2439 Error_Msg_N ("expect procedure name in procedure call", N); 2440 end if; 2441 2442 Found := True; 2443 2444 -- Otherwise we do have a subexpression with the wrong type 2445 2446 -- Check for the case of an allocator which uses an access type 2447 -- instead of the designated type. This is a common error and we 2448 -- specialize the message, posting an error on the operand of the 2449 -- allocator, complaining that we expected the designated type of 2450 -- the allocator. 2451 2452 elsif Nkind (N) = N_Allocator 2453 and then Ekind (Typ) in Access_Kind 2454 and then Ekind (Etype (N)) in Access_Kind 2455 and then Designated_Type (Etype (N)) = Typ 2456 then 2457 Wrong_Type (Expression (N), Designated_Type (Typ)); 2458 Found := True; 2459 2460 -- Check for view mismatch on Null in instances, for which the 2461 -- view-swapping mechanism has no identifier. 2462 2463 elsif (In_Instance or else In_Inlined_Body) 2464 and then (Nkind (N) = N_Null) 2465 and then Is_Private_Type (Typ) 2466 and then Is_Access_Type (Full_View (Typ)) 2467 then 2468 Resolve (N, Full_View (Typ)); 2469 Set_Etype (N, Typ); 2470 return; 2471 2472 -- Check for an aggregate. Sometimes we can get bogus aggregates 2473 -- from misuse of parentheses, and we are about to complain about 2474 -- the aggregate without even looking inside it. 2475 2476 -- Instead, if we have an aggregate of type Any_Composite, then 2477 -- analyze and resolve the component fields, and then only issue 2478 -- another message if we get no errors doing this (otherwise 2479 -- assume that the errors in the aggregate caused the problem). 2480 2481 elsif Nkind (N) = N_Aggregate 2482 and then Etype (N) = Any_Composite 2483 then 2484 -- Disable expansion in any case. If there is a type mismatch 2485 -- it may be fatal to try to expand the aggregate. The flag 2486 -- would otherwise be set to false when the error is posted. 2487 2488 Expander_Active := False; 2489 2490 declare 2491 procedure Check_Aggr (Aggr : Node_Id); 2492 -- Check one aggregate, and set Found to True if we have a 2493 -- definite error in any of its elements 2494 2495 procedure Check_Elmt (Aelmt : Node_Id); 2496 -- Check one element of aggregate and set Found to True if 2497 -- we definitely have an error in the element. 2498 2499 ---------------- 2500 -- Check_Aggr -- 2501 ---------------- 2502 2503 procedure Check_Aggr (Aggr : Node_Id) is 2504 Elmt : Node_Id; 2505 2506 begin 2507 if Present (Expressions (Aggr)) then 2508 Elmt := First (Expressions (Aggr)); 2509 while Present (Elmt) loop 2510 Check_Elmt (Elmt); 2511 Next (Elmt); 2512 end loop; 2513 end if; 2514 2515 if Present (Component_Associations (Aggr)) then 2516 Elmt := First (Component_Associations (Aggr)); 2517 while Present (Elmt) loop 2518 2519 -- If this is a default-initialized component, then 2520 -- there is nothing to check. The box will be 2521 -- replaced by the appropriate call during late 2522 -- expansion. 2523 2524 if not Box_Present (Elmt) then 2525 Check_Elmt (Expression (Elmt)); 2526 end if; 2527 2528 Next (Elmt); 2529 end loop; 2530 end if; 2531 end Check_Aggr; 2532 2533 ---------------- 2534 -- Check_Elmt -- 2535 ---------------- 2536 2537 procedure Check_Elmt (Aelmt : Node_Id) is 2538 begin 2539 -- If we have a nested aggregate, go inside it (to 2540 -- attempt a naked analyze-resolve of the aggregate can 2541 -- cause undesirable cascaded errors). Do not resolve 2542 -- expression if it needs a type from context, as for 2543 -- integer * fixed expression. 2544 2545 if Nkind (Aelmt) = N_Aggregate then 2546 Check_Aggr (Aelmt); 2547 2548 else 2549 Analyze (Aelmt); 2550 2551 if not Is_Overloaded (Aelmt) 2552 and then Etype (Aelmt) /= Any_Fixed 2553 then 2554 Resolve (Aelmt); 2555 end if; 2556 2557 if Etype (Aelmt) = Any_Type then 2558 Found := True; 2559 end if; 2560 end if; 2561 end Check_Elmt; 2562 2563 begin 2564 Check_Aggr (N); 2565 end; 2566 end if; 2567 2568 -- If an error message was issued already, Found got reset to 2569 -- True, so if it is still False, issue standard Wrong_Type msg. 2570 2571 if not Found then 2572 if Is_Overloaded (N) 2573 and then Nkind (N) = N_Function_Call 2574 then 2575 declare 2576 Subp_Name : Node_Id; 2577 begin 2578 if Is_Entity_Name (Name (N)) then 2579 Subp_Name := Name (N); 2580 2581 elsif Nkind (Name (N)) = N_Selected_Component then 2582 2583 -- Protected operation: retrieve operation name 2584 2585 Subp_Name := Selector_Name (Name (N)); 2586 2587 else 2588 raise Program_Error; 2589 end if; 2590 2591 Error_Msg_Node_2 := Typ; 2592 Error_Msg_NE ("no visible interpretation of&" & 2593 " matches expected type&", N, Subp_Name); 2594 end; 2595 2596 if All_Errors_Mode then 2597 declare 2598 Index : Interp_Index; 2599 It : Interp; 2600 2601 begin 2602 Error_Msg_N ("\\possible interpretations:", N); 2603 2604 Get_First_Interp (Name (N), Index, It); 2605 while Present (It.Nam) loop 2606 Error_Msg_Sloc := Sloc (It.Nam); 2607 Error_Msg_Node_2 := It.Nam; 2608 Error_Msg_NE 2609 ("\\ type& for & declared#", N, It.Typ); 2610 Get_Next_Interp (Index, It); 2611 end loop; 2612 end; 2613 2614 else 2615 Error_Msg_N ("\use -gnatf for details", N); 2616 end if; 2617 2618 else 2619 Wrong_Type (N, Typ); 2620 end if; 2621 end if; 2622 end if; 2623 2624 Resolution_Failed; 2625 return; 2626 2627 -- Test if we have more than one interpretation for the context 2628 2629 elsif Ambiguous then 2630 Resolution_Failed; 2631 return; 2632 2633 -- Only one intepretation 2634 2635 else 2636 -- In Ada 2005, if we have something like "X : T := 2 + 2;", where 2637 -- the "+" on T is abstract, and the operands are of universal type, 2638 -- the above code will have (incorrectly) resolved the "+" to the 2639 -- universal one in Standard. Therefore check for this case and give 2640 -- an error. We can't do this earlier, because it would cause legal 2641 -- cases to get errors (when some other type has an abstract "+"). 2642 2643 if Ada_Version >= Ada_2005 2644 and then Nkind (N) in N_Op 2645 and then Is_Overloaded (N) 2646 and then Is_Universal_Numeric_Type (Etype (Entity (N))) 2647 then 2648 Get_First_Interp (N, I, It); 2649 while Present (It.Typ) loop 2650 if Present (It.Abstract_Op) and then 2651 Etype (It.Abstract_Op) = Typ 2652 then 2653 Error_Msg_NE 2654 ("cannot call abstract subprogram &!", N, It.Abstract_Op); 2655 return; 2656 end if; 2657 2658 Get_Next_Interp (I, It); 2659 end loop; 2660 end if; 2661 2662 -- Here we have an acceptable interpretation for the context 2663 2664 -- Propagate type information and normalize tree for various 2665 -- predefined operations. If the context only imposes a class of 2666 -- types, rather than a specific type, propagate the actual type 2667 -- downward. 2668 2669 if Typ = Any_Integer or else 2670 Typ = Any_Boolean or else 2671 Typ = Any_Modular or else 2672 Typ = Any_Real or else 2673 Typ = Any_Discrete 2674 then 2675 Ctx_Type := Expr_Type; 2676 2677 -- Any_Fixed is legal in a real context only if a specific fixed- 2678 -- point type is imposed. If Norman Cohen can be confused by this, 2679 -- it deserves a separate message. 2680 2681 if Typ = Any_Real 2682 and then Expr_Type = Any_Fixed 2683 then 2684 Error_Msg_N ("illegal context for mixed mode operation", N); 2685 Set_Etype (N, Universal_Real); 2686 Ctx_Type := Universal_Real; 2687 end if; 2688 end if; 2689 2690 -- A user-defined operator is transformed into a function call at 2691 -- this point, so that further processing knows that operators are 2692 -- really operators (i.e. are predefined operators). User-defined 2693 -- operators that are intrinsic are just renamings of the predefined 2694 -- ones, and need not be turned into calls either, but if they rename 2695 -- a different operator, we must transform the node accordingly. 2696 -- Instantiations of Unchecked_Conversion are intrinsic but are 2697 -- treated as functions, even if given an operator designator. 2698 2699 if Nkind (N) in N_Op 2700 and then Present (Entity (N)) 2701 and then Ekind (Entity (N)) /= E_Operator 2702 then 2703 2704 if not Is_Predefined_Op (Entity (N)) then 2705 Rewrite_Operator_As_Call (N, Entity (N)); 2706 2707 elsif Present (Alias (Entity (N))) 2708 and then 2709 Nkind (Parent (Parent (Entity (N)))) = 2710 N_Subprogram_Renaming_Declaration 2711 then 2712 Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ); 2713 2714 -- If the node is rewritten, it will be fully resolved in 2715 -- Rewrite_Renamed_Operator. 2716 2717 if Analyzed (N) then 2718 return; 2719 end if; 2720 end if; 2721 end if; 2722 2723 case N_Subexpr'(Nkind (N)) is 2724 2725 when N_Aggregate => Resolve_Aggregate (N, Ctx_Type); 2726 2727 when N_Allocator => Resolve_Allocator (N, Ctx_Type); 2728 2729 when N_Short_Circuit 2730 => Resolve_Short_Circuit (N, Ctx_Type); 2731 2732 when N_Attribute_Reference 2733 => Resolve_Attribute (N, Ctx_Type); 2734 2735 when N_Case_Expression 2736 => Resolve_Case_Expression (N, Ctx_Type); 2737 2738 when N_Character_Literal 2739 => Resolve_Character_Literal (N, Ctx_Type); 2740 2741 when N_Expanded_Name 2742 => Resolve_Entity_Name (N, Ctx_Type); 2743 2744 when N_Explicit_Dereference 2745 => Resolve_Explicit_Dereference (N, Ctx_Type); 2746 2747 when N_Expression_With_Actions 2748 => Resolve_Expression_With_Actions (N, Ctx_Type); 2749 2750 when N_Extension_Aggregate 2751 => Resolve_Extension_Aggregate (N, Ctx_Type); 2752 2753 when N_Function_Call 2754 => Resolve_Call (N, Ctx_Type); 2755 2756 when N_Identifier 2757 => Resolve_Entity_Name (N, Ctx_Type); 2758 2759 when N_If_Expression 2760 => Resolve_If_Expression (N, Ctx_Type); 2761 2762 when N_Indexed_Component 2763 => Resolve_Indexed_Component (N, Ctx_Type); 2764 2765 when N_Integer_Literal 2766 => Resolve_Integer_Literal (N, Ctx_Type); 2767 2768 when N_Membership_Test 2769 => Resolve_Membership_Op (N, Ctx_Type); 2770 2771 when N_Null => Resolve_Null (N, Ctx_Type); 2772 2773 when N_Op_And | N_Op_Or | N_Op_Xor 2774 => Resolve_Logical_Op (N, Ctx_Type); 2775 2776 when N_Op_Eq | N_Op_Ne 2777 => Resolve_Equality_Op (N, Ctx_Type); 2778 2779 when N_Op_Lt | N_Op_Le | N_Op_Gt | N_Op_Ge 2780 => Resolve_Comparison_Op (N, Ctx_Type); 2781 2782 when N_Op_Not => Resolve_Op_Not (N, Ctx_Type); 2783 2784 when N_Op_Add | N_Op_Subtract | N_Op_Multiply | 2785 N_Op_Divide | N_Op_Mod | N_Op_Rem 2786 2787 => Resolve_Arithmetic_Op (N, Ctx_Type); 2788 2789 when N_Op_Concat => Resolve_Op_Concat (N, Ctx_Type); 2790 2791 when N_Op_Expon => Resolve_Op_Expon (N, Ctx_Type); 2792 2793 when N_Op_Plus | N_Op_Minus | N_Op_Abs 2794 => Resolve_Unary_Op (N, Ctx_Type); 2795 2796 when N_Op_Shift => Resolve_Shift (N, Ctx_Type); 2797 2798 when N_Procedure_Call_Statement 2799 => Resolve_Call (N, Ctx_Type); 2800 2801 when N_Operator_Symbol 2802 => Resolve_Operator_Symbol (N, Ctx_Type); 2803 2804 when N_Qualified_Expression 2805 => Resolve_Qualified_Expression (N, Ctx_Type); 2806 2807 when N_Quantified_Expression => null; 2808 2809 when N_Raise_xxx_Error 2810 => Set_Etype (N, Ctx_Type); 2811 2812 when N_Range => Resolve_Range (N, Ctx_Type); 2813 2814 when N_Real_Literal 2815 => Resolve_Real_Literal (N, Ctx_Type); 2816 2817 when N_Reference => Resolve_Reference (N, Ctx_Type); 2818 2819 when N_Selected_Component 2820 => Resolve_Selected_Component (N, Ctx_Type); 2821 2822 when N_Slice => Resolve_Slice (N, Ctx_Type); 2823 2824 when N_String_Literal 2825 => Resolve_String_Literal (N, Ctx_Type); 2826 2827 when N_Subprogram_Info 2828 => Resolve_Subprogram_Info (N, Ctx_Type); 2829 2830 when N_Type_Conversion 2831 => Resolve_Type_Conversion (N, Ctx_Type); 2832 2833 when N_Unchecked_Expression => 2834 Resolve_Unchecked_Expression (N, Ctx_Type); 2835 2836 when N_Unchecked_Type_Conversion => 2837 Resolve_Unchecked_Type_Conversion (N, Ctx_Type); 2838 end case; 2839 2840 -- Ada 2012 (AI05-0149): Apply an (implicit) conversion to an 2841 -- expression of an anonymous access type that occurs in the context 2842 -- of a named general access type, except when the expression is that 2843 -- of a membership test. This ensures proper legality checking in 2844 -- terms of allowed conversions (expressions that would be illegal to 2845 -- convert implicitly are allowed in membership tests). 2846 2847 if Ada_Version >= Ada_2012 2848 and then Ekind (Ctx_Type) = E_General_Access_Type 2849 and then Ekind (Etype (N)) = E_Anonymous_Access_Type 2850 and then Nkind (Parent (N)) not in N_Membership_Test 2851 then 2852 Rewrite (N, Convert_To (Ctx_Type, Relocate_Node (N))); 2853 Analyze_And_Resolve (N, Ctx_Type); 2854 end if; 2855 2856 -- If the subexpression was replaced by a non-subexpression, then 2857 -- all we do is to expand it. The only legitimate case we know of 2858 -- is converting procedure call statement to entry call statements, 2859 -- but there may be others, so we are making this test general. 2860 2861 if Nkind (N) not in N_Subexpr then 2862 Debug_A_Exit ("resolving ", N, " (done)"); 2863 Expand (N); 2864 return; 2865 end if; 2866 2867 -- The expression is definitely NOT overloaded at this point, so 2868 -- we reset the Is_Overloaded flag to avoid any confusion when 2869 -- reanalyzing the node. 2870 2871 Set_Is_Overloaded (N, False); 2872 2873 -- Freeze expression type, entity if it is a name, and designated 2874 -- type if it is an allocator (RM 13.14(10,11,13)). 2875 2876 -- Now that the resolution of the type of the node is complete, and 2877 -- we did not detect an error, we can expand this node. We skip the 2878 -- expand call if we are in a default expression, see section 2879 -- "Handling of Default Expressions" in Sem spec. 2880 2881 Debug_A_Exit ("resolving ", N, " (done)"); 2882 2883 -- We unconditionally freeze the expression, even if we are in 2884 -- default expression mode (the Freeze_Expression routine tests this 2885 -- flag and only freezes static types if it is set). 2886 2887 -- Ada 2012 (AI05-177): Expression functions do not freeze. Only 2888 -- their use (in an expanded call) freezes. 2889 2890 if Ekind (Proper_Current_Scope) /= E_Function 2891 or else Nkind (Original_Node (Unit_Declaration_Node 2892 (Proper_Current_Scope))) /= N_Expression_Function 2893 then 2894 Freeze_Expression (N); 2895 end if; 2896 2897 -- Now we can do the expansion 2898 2899 Expand (N); 2900 end if; 2901 end Resolve; 2902 2903 ------------- 2904 -- Resolve -- 2905 ------------- 2906 2907 -- Version with check(s) suppressed 2908 2909 procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is 2910 begin 2911 if Suppress = All_Checks then 2912 declare 2913 Sva : constant Suppress_Array := Scope_Suppress.Suppress; 2914 begin 2915 Scope_Suppress.Suppress := (others => True); 2916 Resolve (N, Typ); 2917 Scope_Suppress.Suppress := Sva; 2918 end; 2919 2920 else 2921 declare 2922 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); 2923 begin 2924 Scope_Suppress.Suppress (Suppress) := True; 2925 Resolve (N, Typ); 2926 Scope_Suppress.Suppress (Suppress) := Svg; 2927 end; 2928 end if; 2929 end Resolve; 2930 2931 ------------- 2932 -- Resolve -- 2933 ------------- 2934 2935 -- Version with implicit type 2936 2937 procedure Resolve (N : Node_Id) is 2938 begin 2939 Resolve (N, Etype (N)); 2940 end Resolve; 2941 2942 --------------------- 2943 -- Resolve_Actuals -- 2944 --------------------- 2945 2946 procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id) is 2947 Loc : constant Source_Ptr := Sloc (N); 2948 A : Node_Id; 2949 F : Entity_Id; 2950 A_Typ : Entity_Id; 2951 F_Typ : Entity_Id; 2952 Prev : Node_Id := Empty; 2953 Orig_A : Node_Id; 2954 2955 procedure Check_Argument_Order; 2956 -- Performs a check for the case where the actuals are all simple 2957 -- identifiers that correspond to the formal names, but in the wrong 2958 -- order, which is considered suspicious and cause for a warning. 2959 2960 procedure Check_Prefixed_Call; 2961 -- If the original node is an overloaded call in prefix notation, 2962 -- insert an 'Access or a dereference as needed over the first actual. 2963 -- Try_Object_Operation has already verified that there is a valid 2964 -- interpretation, but the form of the actual can only be determined 2965 -- once the primitive operation is identified. 2966 2967 procedure Insert_Default; 2968 -- If the actual is missing in a call, insert in the actuals list 2969 -- an instance of the default expression. The insertion is always 2970 -- a named association. 2971 2972 function Same_Ancestor (T1, T2 : Entity_Id) return Boolean; 2973 -- Check whether T1 and T2, or their full views, are derived from a 2974 -- common type. Used to enforce the restrictions on array conversions 2975 -- of AI95-00246. 2976 2977 function Static_Concatenation (N : Node_Id) return Boolean; 2978 -- Predicate to determine whether an actual that is a concatenation 2979 -- will be evaluated statically and does not need a transient scope. 2980 -- This must be determined before the actual is resolved and expanded 2981 -- because if needed the transient scope must be introduced earlier. 2982 2983 -------------------------- 2984 -- Check_Argument_Order -- 2985 -------------------------- 2986 2987 procedure Check_Argument_Order is 2988 begin 2989 -- Nothing to do if no parameters, or original node is neither a 2990 -- function call nor a procedure call statement (happens in the 2991 -- operator-transformed-to-function call case), or the call does 2992 -- not come from source, or this warning is off. 2993 2994 if not Warn_On_Parameter_Order 2995 or else No (Parameter_Associations (N)) 2996 or else Nkind (Original_Node (N)) not in N_Subprogram_Call 2997 or else not Comes_From_Source (N) 2998 then 2999 return; 3000 end if; 3001 3002 declare 3003 Nargs : constant Nat := List_Length (Parameter_Associations (N)); 3004 3005 begin 3006 -- Nothing to do if only one parameter 3007 3008 if Nargs < 2 then 3009 return; 3010 end if; 3011 3012 -- Here if at least two arguments 3013 3014 declare 3015 Actuals : array (1 .. Nargs) of Node_Id; 3016 Actual : Node_Id; 3017 Formal : Node_Id; 3018 3019 Wrong_Order : Boolean := False; 3020 -- Set True if an out of order case is found 3021 3022 begin 3023 -- Collect identifier names of actuals, fail if any actual is 3024 -- not a simple identifier, and record max length of name. 3025 3026 Actual := First (Parameter_Associations (N)); 3027 for J in Actuals'Range loop 3028 if Nkind (Actual) /= N_Identifier then 3029 return; 3030 else 3031 Actuals (J) := Actual; 3032 Next (Actual); 3033 end if; 3034 end loop; 3035 3036 -- If we got this far, all actuals are identifiers and the list 3037 -- of their names is stored in the Actuals array. 3038 3039 Formal := First_Formal (Nam); 3040 for J in Actuals'Range loop 3041 3042 -- If we ran out of formals, that's odd, probably an error 3043 -- which will be detected elsewhere, but abandon the search. 3044 3045 if No (Formal) then 3046 return; 3047 end if; 3048 3049 -- If name matches and is in order OK 3050 3051 if Chars (Formal) = Chars (Actuals (J)) then 3052 null; 3053 3054 else 3055 -- If no match, see if it is elsewhere in list and if so 3056 -- flag potential wrong order if type is compatible. 3057 3058 for K in Actuals'Range loop 3059 if Chars (Formal) = Chars (Actuals (K)) 3060 and then 3061 Has_Compatible_Type (Actuals (K), Etype (Formal)) 3062 then 3063 Wrong_Order := True; 3064 goto Continue; 3065 end if; 3066 end loop; 3067 3068 -- No match 3069 3070 return; 3071 end if; 3072 3073 <<Continue>> Next_Formal (Formal); 3074 end loop; 3075 3076 -- If Formals left over, also probably an error, skip warning 3077 3078 if Present (Formal) then 3079 return; 3080 end if; 3081 3082 -- Here we give the warning if something was out of order 3083 3084 if Wrong_Order then 3085 Error_Msg_N 3086 ("?P?actuals for this call may be in wrong order", N); 3087 end if; 3088 end; 3089 end; 3090 end Check_Argument_Order; 3091 3092 ------------------------- 3093 -- Check_Prefixed_Call -- 3094 ------------------------- 3095 3096 procedure Check_Prefixed_Call is 3097 Act : constant Node_Id := First_Actual (N); 3098 A_Type : constant Entity_Id := Etype (Act); 3099 F_Type : constant Entity_Id := Etype (First_Formal (Nam)); 3100 Orig : constant Node_Id := Original_Node (N); 3101 New_A : Node_Id; 3102 3103 begin 3104 -- Check whether the call is a prefixed call, with or without 3105 -- additional actuals. 3106 3107 if Nkind (Orig) = N_Selected_Component 3108 or else 3109 (Nkind (Orig) = N_Indexed_Component 3110 and then Nkind (Prefix (Orig)) = N_Selected_Component 3111 and then Is_Entity_Name (Prefix (Prefix (Orig))) 3112 and then Is_Entity_Name (Act) 3113 and then Chars (Act) = Chars (Prefix (Prefix (Orig)))) 3114 then 3115 if Is_Access_Type (A_Type) 3116 and then not Is_Access_Type (F_Type) 3117 then 3118 -- Introduce dereference on object in prefix 3119 3120 New_A := 3121 Make_Explicit_Dereference (Sloc (Act), 3122 Prefix => Relocate_Node (Act)); 3123 Rewrite (Act, New_A); 3124 Analyze (Act); 3125 3126 elsif Is_Access_Type (F_Type) 3127 and then not Is_Access_Type (A_Type) 3128 then 3129 -- Introduce an implicit 'Access in prefix 3130 3131 if not Is_Aliased_View (Act) then 3132 Error_Msg_NE 3133 ("object in prefixed call to& must be aliased" 3134 & " (RM-2005 4.3.1 (13))", 3135 Prefix (Act), Nam); 3136 end if; 3137 3138 Rewrite (Act, 3139 Make_Attribute_Reference (Loc, 3140 Attribute_Name => Name_Access, 3141 Prefix => Relocate_Node (Act))); 3142 end if; 3143 3144 Analyze (Act); 3145 end if; 3146 end Check_Prefixed_Call; 3147 3148 -------------------- 3149 -- Insert_Default -- 3150 -------------------- 3151 3152 procedure Insert_Default is 3153 Actval : Node_Id; 3154 Assoc : Node_Id; 3155 3156 begin 3157 -- Missing argument in call, nothing to insert 3158 3159 if No (Default_Value (F)) then 3160 return; 3161 3162 else 3163 -- Note that we do a full New_Copy_Tree, so that any associated 3164 -- Itypes are properly copied. This may not be needed any more, 3165 -- but it does no harm as a safety measure! Defaults of a generic 3166 -- formal may be out of bounds of the corresponding actual (see 3167 -- cc1311b) and an additional check may be required. 3168 3169 Actval := 3170 New_Copy_Tree 3171 (Default_Value (F), 3172 New_Scope => Current_Scope, 3173 New_Sloc => Loc); 3174 3175 if Is_Concurrent_Type (Scope (Nam)) 3176 and then Has_Discriminants (Scope (Nam)) 3177 then 3178 Replace_Actual_Discriminants (N, Actval); 3179 end if; 3180 3181 if Is_Overloadable (Nam) 3182 and then Present (Alias (Nam)) 3183 then 3184 if Base_Type (Etype (F)) /= Base_Type (Etype (Actval)) 3185 and then not Is_Tagged_Type (Etype (F)) 3186 then 3187 -- If default is a real literal, do not introduce a 3188 -- conversion whose effect may depend on the run-time 3189 -- size of universal real. 3190 3191 if Nkind (Actval) = N_Real_Literal then 3192 Set_Etype (Actval, Base_Type (Etype (F))); 3193 else 3194 Actval := Unchecked_Convert_To (Etype (F), Actval); 3195 end if; 3196 end if; 3197 3198 if Is_Scalar_Type (Etype (F)) then 3199 Enable_Range_Check (Actval); 3200 end if; 3201 3202 Set_Parent (Actval, N); 3203 3204 -- Resolve aggregates with their base type, to avoid scope 3205 -- anomalies: the subtype was first built in the subprogram 3206 -- declaration, and the current call may be nested. 3207 3208 if Nkind (Actval) = N_Aggregate then 3209 Analyze_And_Resolve (Actval, Etype (F)); 3210 else 3211 Analyze_And_Resolve (Actval, Etype (Actval)); 3212 end if; 3213 3214 else 3215 Set_Parent (Actval, N); 3216 3217 -- See note above concerning aggregates 3218 3219 if Nkind (Actval) = N_Aggregate 3220 and then Has_Discriminants (Etype (Actval)) 3221 then 3222 Analyze_And_Resolve (Actval, Base_Type (Etype (Actval))); 3223 3224 -- Resolve entities with their own type, which may differ from 3225 -- the type of a reference in a generic context (the view 3226 -- swapping mechanism did not anticipate the re-analysis of 3227 -- default values in calls). 3228 3229 elsif Is_Entity_Name (Actval) then 3230 Analyze_And_Resolve (Actval, Etype (Entity (Actval))); 3231 3232 else 3233 Analyze_And_Resolve (Actval, Etype (Actval)); 3234 end if; 3235 end if; 3236 3237 -- If default is a tag indeterminate function call, propagate tag 3238 -- to obtain proper dispatching. 3239 3240 if Is_Controlling_Formal (F) 3241 and then Nkind (Default_Value (F)) = N_Function_Call 3242 then 3243 Set_Is_Controlling_Actual (Actval); 3244 end if; 3245 3246 end if; 3247 3248 -- If the default expression raises constraint error, then just 3249 -- silently replace it with an N_Raise_Constraint_Error node, since 3250 -- we already gave the warning on the subprogram spec. If node is 3251 -- already a Raise_Constraint_Error leave as is, to prevent loops in 3252 -- the warnings removal machinery. 3253 3254 if Raises_Constraint_Error (Actval) 3255 and then Nkind (Actval) /= N_Raise_Constraint_Error 3256 then 3257 Rewrite (Actval, 3258 Make_Raise_Constraint_Error (Loc, 3259 Reason => CE_Range_Check_Failed)); 3260 Set_Raises_Constraint_Error (Actval); 3261 Set_Etype (Actval, Etype (F)); 3262 end if; 3263 3264 Assoc := 3265 Make_Parameter_Association (Loc, 3266 Explicit_Actual_Parameter => Actval, 3267 Selector_Name => Make_Identifier (Loc, Chars (F))); 3268 3269 -- Case of insertion is first named actual 3270 3271 if No (Prev) or else 3272 Nkind (Parent (Prev)) /= N_Parameter_Association 3273 then 3274 Set_Next_Named_Actual (Assoc, First_Named_Actual (N)); 3275 Set_First_Named_Actual (N, Actval); 3276 3277 if No (Prev) then 3278 if No (Parameter_Associations (N)) then 3279 Set_Parameter_Associations (N, New_List (Assoc)); 3280 else 3281 Append (Assoc, Parameter_Associations (N)); 3282 end if; 3283 3284 else 3285 Insert_After (Prev, Assoc); 3286 end if; 3287 3288 -- Case of insertion is not first named actual 3289 3290 else 3291 Set_Next_Named_Actual 3292 (Assoc, Next_Named_Actual (Parent (Prev))); 3293 Set_Next_Named_Actual (Parent (Prev), Actval); 3294 Append (Assoc, Parameter_Associations (N)); 3295 end if; 3296 3297 Mark_Rewrite_Insertion (Assoc); 3298 Mark_Rewrite_Insertion (Actval); 3299 3300 Prev := Actval; 3301 end Insert_Default; 3302 3303 ------------------- 3304 -- Same_Ancestor -- 3305 ------------------- 3306 3307 function Same_Ancestor (T1, T2 : Entity_Id) return Boolean is 3308 FT1 : Entity_Id := T1; 3309 FT2 : Entity_Id := T2; 3310 3311 begin 3312 if Is_Private_Type (T1) 3313 and then Present (Full_View (T1)) 3314 then 3315 FT1 := Full_View (T1); 3316 end if; 3317 3318 if Is_Private_Type (T2) 3319 and then Present (Full_View (T2)) 3320 then 3321 FT2 := Full_View (T2); 3322 end if; 3323 3324 return Root_Type (Base_Type (FT1)) = Root_Type (Base_Type (FT2)); 3325 end Same_Ancestor; 3326 3327 -------------------------- 3328 -- Static_Concatenation -- 3329 -------------------------- 3330 3331 function Static_Concatenation (N : Node_Id) return Boolean is 3332 begin 3333 case Nkind (N) is 3334 when N_String_Literal => 3335 return True; 3336 3337 when N_Op_Concat => 3338 3339 -- Concatenation is static when both operands are static and 3340 -- the concatenation operator is a predefined one. 3341 3342 return Scope (Entity (N)) = Standard_Standard 3343 and then 3344 Static_Concatenation (Left_Opnd (N)) 3345 and then 3346 Static_Concatenation (Right_Opnd (N)); 3347 3348 when others => 3349 if Is_Entity_Name (N) then 3350 declare 3351 Ent : constant Entity_Id := Entity (N); 3352 begin 3353 return Ekind (Ent) = E_Constant 3354 and then Present (Constant_Value (Ent)) 3355 and then 3356 Is_Static_Expression (Constant_Value (Ent)); 3357 end; 3358 3359 else 3360 return False; 3361 end if; 3362 end case; 3363 end Static_Concatenation; 3364 3365 -- Start of processing for Resolve_Actuals 3366 3367 begin 3368 Check_Argument_Order; 3369 Check_Function_Writable_Actuals (N); 3370 3371 if Present (First_Actual (N)) then 3372 Check_Prefixed_Call; 3373 end if; 3374 3375 A := First_Actual (N); 3376 F := First_Formal (Nam); 3377 while Present (F) loop 3378 if No (A) and then Needs_No_Actuals (Nam) then 3379 null; 3380 3381 -- If we have an error in any actual or formal, indicated by a type 3382 -- of Any_Type, then abandon resolution attempt, and set result type 3383 -- to Any_Type. 3384 3385 elsif (Present (A) and then Etype (A) = Any_Type) 3386 or else Etype (F) = Any_Type 3387 then 3388 Set_Etype (N, Any_Type); 3389 return; 3390 end if; 3391 3392 -- Case where actual is present 3393 3394 -- If the actual is an entity, generate a reference to it now. We 3395 -- do this before the actual is resolved, because a formal of some 3396 -- protected subprogram, or a task discriminant, will be rewritten 3397 -- during expansion, and the source entity reference may be lost. 3398 3399 if Present (A) 3400 and then Is_Entity_Name (A) 3401 and then Comes_From_Source (N) 3402 then 3403 Orig_A := Entity (A); 3404 3405 if Present (Orig_A) then 3406 if Is_Formal (Orig_A) 3407 and then Ekind (F) /= E_In_Parameter 3408 then 3409 Generate_Reference (Orig_A, A, 'm'); 3410 3411 elsif not Is_Overloaded (A) then 3412 if Ekind (F) /= E_Out_Parameter then 3413 Generate_Reference (Orig_A, A); 3414 3415 -- RM 6.4.1(12): For an out parameter that is passed by 3416 -- copy, the formal parameter object is created, and: 3417 3418 -- * For an access type, the formal parameter is initialized 3419 -- from the value of the actual, without checking that the 3420 -- value satisfies any constraint, any predicate, or any 3421 -- exclusion of the null value. 3422 3423 -- * For a scalar type that has the Default_Value aspect 3424 -- specified, the formal parameter is initialized from the 3425 -- value of the actual, without checking that the value 3426 -- satisfies any constraint or any predicate. 3427 -- I do not understand why this case is included??? this is 3428 -- not a case where an OUT parameter is treated as IN OUT. 3429 3430 -- * For a composite type with discriminants or that has 3431 -- implicit initial values for any subcomponents, the 3432 -- behavior is as for an in out parameter passed by copy. 3433 3434 -- Hence for these cases we generate the read reference now 3435 -- (the write reference will be generated later by 3436 -- Note_Possible_Modification). 3437 3438 elsif Is_By_Copy_Type (Etype (F)) 3439 and then 3440 (Is_Access_Type (Etype (F)) 3441 or else 3442 (Is_Scalar_Type (Etype (F)) 3443 and then 3444 Present (Default_Aspect_Value (Etype (F)))) 3445 or else 3446 (Is_Composite_Type (Etype (F)) 3447 and then (Has_Discriminants (Etype (F)) 3448 or else Is_Partially_Initialized_Type 3449 (Etype (F))))) 3450 then 3451 Generate_Reference (Orig_A, A); 3452 end if; 3453 end if; 3454 end if; 3455 end if; 3456 3457 if Present (A) 3458 and then (Nkind (Parent (A)) /= N_Parameter_Association 3459 or else Chars (Selector_Name (Parent (A))) = Chars (F)) 3460 then 3461 -- If style checking mode on, check match of formal name 3462 3463 if Style_Check then 3464 if Nkind (Parent (A)) = N_Parameter_Association then 3465 Check_Identifier (Selector_Name (Parent (A)), F); 3466 end if; 3467 end if; 3468 3469 -- If the formal is Out or In_Out, do not resolve and expand the 3470 -- conversion, because it is subsequently expanded into explicit 3471 -- temporaries and assignments. However, the object of the 3472 -- conversion can be resolved. An exception is the case of tagged 3473 -- type conversion with a class-wide actual. In that case we want 3474 -- the tag check to occur and no temporary will be needed (no 3475 -- representation change can occur) and the parameter is passed by 3476 -- reference, so we go ahead and resolve the type conversion. 3477 -- Another exception is the case of reference to component or 3478 -- subcomponent of a bit-packed array, in which case we want to 3479 -- defer expansion to the point the in and out assignments are 3480 -- performed. 3481 3482 if Ekind (F) /= E_In_Parameter 3483 and then Nkind (A) = N_Type_Conversion 3484 and then not Is_Class_Wide_Type (Etype (Expression (A))) 3485 then 3486 if Ekind (F) = E_In_Out_Parameter 3487 and then Is_Array_Type (Etype (F)) 3488 then 3489 -- In a view conversion, the conversion must be legal in 3490 -- both directions, and thus both component types must be 3491 -- aliased, or neither (4.6 (8)). 3492 3493 -- The extra rule in 4.6 (24.9.2) seems unduly restrictive: 3494 -- the privacy requirement should not apply to generic 3495 -- types, and should be checked in an instance. ARG query 3496 -- is in order ??? 3497 3498 if Has_Aliased_Components (Etype (Expression (A))) /= 3499 Has_Aliased_Components (Etype (F)) 3500 then 3501 Error_Msg_N 3502 ("both component types in a view conversion must be" 3503 & " aliased, or neither", A); 3504 3505 -- Comment here??? what set of cases??? 3506 3507 elsif 3508 not Same_Ancestor (Etype (F), Etype (Expression (A))) 3509 then 3510 -- Check view conv between unrelated by ref array types 3511 3512 if Is_By_Reference_Type (Etype (F)) 3513 or else Is_By_Reference_Type (Etype (Expression (A))) 3514 then 3515 Error_Msg_N 3516 ("view conversion between unrelated by reference " & 3517 "array types not allowed (\'A'I-00246)", A); 3518 3519 -- In Ada 2005 mode, check view conversion component 3520 -- type cannot be private, tagged, or volatile. Note 3521 -- that we only apply this to source conversions. The 3522 -- generated code can contain conversions which are 3523 -- not subject to this test, and we cannot extract the 3524 -- component type in such cases since it is not present. 3525 3526 elsif Comes_From_Source (A) 3527 and then Ada_Version >= Ada_2005 3528 then 3529 declare 3530 Comp_Type : constant Entity_Id := 3531 Component_Type 3532 (Etype (Expression (A))); 3533 begin 3534 if (Is_Private_Type (Comp_Type) 3535 and then not Is_Generic_Type (Comp_Type)) 3536 or else Is_Tagged_Type (Comp_Type) 3537 or else Is_Volatile (Comp_Type) 3538 then 3539 Error_Msg_N 3540 ("component type of a view conversion cannot" 3541 & " be private, tagged, or volatile" 3542 & " (RM 4.6 (24))", 3543 Expression (A)); 3544 end if; 3545 end; 3546 end if; 3547 end if; 3548 end if; 3549 3550 -- Resolve expression if conversion is all OK 3551 3552 if (Conversion_OK (A) 3553 or else Valid_Conversion (A, Etype (A), Expression (A))) 3554 and then not Is_Ref_To_Bit_Packed_Array (Expression (A)) 3555 then 3556 Resolve (Expression (A)); 3557 end if; 3558 3559 -- If the actual is a function call that returns a limited 3560 -- unconstrained object that needs finalization, create a 3561 -- transient scope for it, so that it can receive the proper 3562 -- finalization list. 3563 3564 elsif Nkind (A) = N_Function_Call 3565 and then Is_Limited_Record (Etype (F)) 3566 and then not Is_Constrained (Etype (F)) 3567 and then Full_Expander_Active 3568 and then (Is_Controlled (Etype (F)) or else Has_Task (Etype (F))) 3569 then 3570 Establish_Transient_Scope (A, False); 3571 Resolve (A, Etype (F)); 3572 3573 -- A small optimization: if one of the actuals is a concatenation 3574 -- create a block around a procedure call to recover stack space. 3575 -- This alleviates stack usage when several procedure calls in 3576 -- the same statement list use concatenation. We do not perform 3577 -- this wrapping for code statements, where the argument is a 3578 -- static string, and we want to preserve warnings involving 3579 -- sequences of such statements. 3580 3581 elsif Nkind (A) = N_Op_Concat 3582 and then Nkind (N) = N_Procedure_Call_Statement 3583 and then Full_Expander_Active 3584 and then 3585 not (Is_Intrinsic_Subprogram (Nam) 3586 and then Chars (Nam) = Name_Asm) 3587 and then not Static_Concatenation (A) 3588 then 3589 Establish_Transient_Scope (A, False); 3590 Resolve (A, Etype (F)); 3591 3592 else 3593 if Nkind (A) = N_Type_Conversion 3594 and then Is_Array_Type (Etype (F)) 3595 and then not Same_Ancestor (Etype (F), Etype (Expression (A))) 3596 and then 3597 (Is_Limited_Type (Etype (F)) 3598 or else Is_Limited_Type (Etype (Expression (A)))) 3599 then 3600 Error_Msg_N 3601 ("conversion between unrelated limited array types " & 3602 "not allowed (\A\I-00246)", A); 3603 3604 if Is_Limited_Type (Etype (F)) then 3605 Explain_Limited_Type (Etype (F), A); 3606 end if; 3607 3608 if Is_Limited_Type (Etype (Expression (A))) then 3609 Explain_Limited_Type (Etype (Expression (A)), A); 3610 end if; 3611 end if; 3612 3613 -- (Ada 2005: AI-251): If the actual is an allocator whose 3614 -- directly designated type is a class-wide interface, we build 3615 -- an anonymous access type to use it as the type of the 3616 -- allocator. Later, when the subprogram call is expanded, if 3617 -- the interface has a secondary dispatch table the expander 3618 -- will add a type conversion to force the correct displacement 3619 -- of the pointer. 3620 3621 if Nkind (A) = N_Allocator then 3622 declare 3623 DDT : constant Entity_Id := 3624 Directly_Designated_Type (Base_Type (Etype (F))); 3625 3626 New_Itype : Entity_Id; 3627 3628 begin 3629 if Is_Class_Wide_Type (DDT) 3630 and then Is_Interface (DDT) 3631 then 3632 New_Itype := Create_Itype (E_Anonymous_Access_Type, A); 3633 Set_Etype (New_Itype, Etype (A)); 3634 Set_Directly_Designated_Type (New_Itype, 3635 Directly_Designated_Type (Etype (A))); 3636 Set_Etype (A, New_Itype); 3637 end if; 3638 3639 -- Ada 2005, AI-162:If the actual is an allocator, the 3640 -- innermost enclosing statement is the master of the 3641 -- created object. This needs to be done with expansion 3642 -- enabled only, otherwise the transient scope will not 3643 -- be removed in the expansion of the wrapped construct. 3644 3645 if (Is_Controlled (DDT) or else Has_Task (DDT)) 3646 and then Full_Expander_Active 3647 then 3648 Establish_Transient_Scope (A, False); 3649 end if; 3650 end; 3651 end if; 3652 3653 -- (Ada 2005): The call may be to a primitive operation of 3654 -- a tagged synchronized type, declared outside of the type. 3655 -- In this case the controlling actual must be converted to 3656 -- its corresponding record type, which is the formal type. 3657 -- The actual may be a subtype, either because of a constraint 3658 -- or because it is a generic actual, so use base type to 3659 -- locate concurrent type. 3660 3661 F_Typ := Base_Type (Etype (F)); 3662 3663 if Is_Tagged_Type (F_Typ) 3664 and then (Is_Concurrent_Type (F_Typ) 3665 or else Is_Concurrent_Record_Type (F_Typ)) 3666 then 3667 -- If the actual is overloaded, look for an interpretation 3668 -- that has a synchronized type. 3669 3670 if not Is_Overloaded (A) then 3671 A_Typ := Base_Type (Etype (A)); 3672 3673 else 3674 declare 3675 Index : Interp_Index; 3676 It : Interp; 3677 3678 begin 3679 Get_First_Interp (A, Index, It); 3680 while Present (It.Typ) loop 3681 if Is_Concurrent_Type (It.Typ) 3682 or else Is_Concurrent_Record_Type (It.Typ) 3683 then 3684 A_Typ := Base_Type (It.Typ); 3685 exit; 3686 end if; 3687 3688 Get_Next_Interp (Index, It); 3689 end loop; 3690 end; 3691 end if; 3692 3693 declare 3694 Full_A_Typ : Entity_Id; 3695 3696 begin 3697 if Present (Full_View (A_Typ)) then 3698 Full_A_Typ := Base_Type (Full_View (A_Typ)); 3699 else 3700 Full_A_Typ := A_Typ; 3701 end if; 3702 3703 -- Tagged synchronized type (case 1): the actual is a 3704 -- concurrent type. 3705 3706 if Is_Concurrent_Type (A_Typ) 3707 and then Corresponding_Record_Type (A_Typ) = F_Typ 3708 then 3709 Rewrite (A, 3710 Unchecked_Convert_To 3711 (Corresponding_Record_Type (A_Typ), A)); 3712 Resolve (A, Etype (F)); 3713 3714 -- Tagged synchronized type (case 2): the formal is a 3715 -- concurrent type. 3716 3717 elsif Ekind (Full_A_Typ) = E_Record_Type 3718 and then Present 3719 (Corresponding_Concurrent_Type (Full_A_Typ)) 3720 and then Is_Concurrent_Type (F_Typ) 3721 and then Present (Corresponding_Record_Type (F_Typ)) 3722 and then Full_A_Typ = Corresponding_Record_Type (F_Typ) 3723 then 3724 Resolve (A, Corresponding_Record_Type (F_Typ)); 3725 3726 -- Common case 3727 3728 else 3729 Resolve (A, Etype (F)); 3730 end if; 3731 end; 3732 else 3733 3734 -- not a synchronized operation. 3735 3736 Resolve (A, Etype (F)); 3737 end if; 3738 end if; 3739 3740 A_Typ := Etype (A); 3741 F_Typ := Etype (F); 3742 3743 if Comes_From_Source (Original_Node (N)) 3744 and then Nkind_In (Original_Node (N), N_Function_Call, 3745 N_Procedure_Call_Statement) 3746 then 3747 -- In formal mode, check that actual parameters matching 3748 -- formals of tagged types are objects (or ancestor type 3749 -- conversions of objects), not general expressions. 3750 3751 if Is_Actual_Tagged_Parameter (A) then 3752 if Is_SPARK_Object_Reference (A) then 3753 null; 3754 3755 elsif Nkind (A) = N_Type_Conversion then 3756 declare 3757 Operand : constant Node_Id := Expression (A); 3758 Operand_Typ : constant Entity_Id := Etype (Operand); 3759 Target_Typ : constant Entity_Id := A_Typ; 3760 3761 begin 3762 if not Is_SPARK_Object_Reference (Operand) then 3763 Check_SPARK_Restriction 3764 ("object required", Operand); 3765 3766 -- In formal mode, the only view conversions are those 3767 -- involving ancestor conversion of an extended type. 3768 3769 elsif not 3770 (Is_Tagged_Type (Target_Typ) 3771 and then not Is_Class_Wide_Type (Target_Typ) 3772 and then Is_Tagged_Type (Operand_Typ) 3773 and then not Is_Class_Wide_Type (Operand_Typ) 3774 and then Is_Ancestor (Target_Typ, Operand_Typ)) 3775 then 3776 if Ekind_In 3777 (F, E_Out_Parameter, E_In_Out_Parameter) 3778 then 3779 Check_SPARK_Restriction 3780 ("ancestor conversion is the only permitted " 3781 & "view conversion", A); 3782 else 3783 Check_SPARK_Restriction 3784 ("ancestor conversion required", A); 3785 end if; 3786 3787 else 3788 null; 3789 end if; 3790 end; 3791 3792 else 3793 Check_SPARK_Restriction ("object required", A); 3794 end if; 3795 3796 -- In formal mode, the only view conversions are those 3797 -- involving ancestor conversion of an extended type. 3798 3799 elsif Nkind (A) = N_Type_Conversion 3800 and then Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) 3801 then 3802 Check_SPARK_Restriction 3803 ("ancestor conversion is the only permitted view " 3804 & "conversion", A); 3805 end if; 3806 end if; 3807 3808 -- has warnings suppressed, then we reset Never_Set_In_Source for 3809 -- the calling entity. The reason for this is to catch cases like 3810 -- GNAT.Spitbol.Patterns.Vstring_Var where the called subprogram 3811 -- uses trickery to modify an IN parameter. 3812 3813 if Ekind (F) = E_In_Parameter 3814 and then Is_Entity_Name (A) 3815 and then Present (Entity (A)) 3816 and then Ekind (Entity (A)) = E_Variable 3817 and then Has_Warnings_Off (F_Typ) 3818 then 3819 Set_Never_Set_In_Source (Entity (A), False); 3820 end if; 3821 3822 -- Perform error checks for IN and IN OUT parameters 3823 3824 if Ekind (F) /= E_Out_Parameter then 3825 3826 -- Check unset reference. For scalar parameters, it is clearly 3827 -- wrong to pass an uninitialized value as either an IN or 3828 -- IN-OUT parameter. For composites, it is also clearly an 3829 -- error to pass a completely uninitialized value as an IN 3830 -- parameter, but the case of IN OUT is trickier. We prefer 3831 -- not to give a warning here. For example, suppose there is 3832 -- a routine that sets some component of a record to False. 3833 -- It is perfectly reasonable to make this IN-OUT and allow 3834 -- either initialized or uninitialized records to be passed 3835 -- in this case. 3836 3837 -- For partially initialized composite values, we also avoid 3838 -- warnings, since it is quite likely that we are passing a 3839 -- partially initialized value and only the initialized fields 3840 -- will in fact be read in the subprogram. 3841 3842 if Is_Scalar_Type (A_Typ) 3843 or else (Ekind (F) = E_In_Parameter 3844 and then not Is_Partially_Initialized_Type (A_Typ)) 3845 then 3846 Check_Unset_Reference (A); 3847 end if; 3848 3849 -- In Ada 83 we cannot pass an OUT parameter as an IN or IN OUT 3850 -- actual to a nested call, since this is case of reading an 3851 -- out parameter, which is not allowed. 3852 3853 if Ada_Version = Ada_83 3854 and then Is_Entity_Name (A) 3855 and then Ekind (Entity (A)) = E_Out_Parameter 3856 then 3857 Error_Msg_N ("(Ada 83) illegal reading of out parameter", A); 3858 end if; 3859 end if; 3860 3861 -- Case of OUT or IN OUT parameter 3862 3863 if Ekind (F) /= E_In_Parameter then 3864 3865 -- For an Out parameter, check for useless assignment. Note 3866 -- that we can't set Last_Assignment this early, because we may 3867 -- kill current values in Resolve_Call, and that call would 3868 -- clobber the Last_Assignment field. 3869 3870 -- Note: call Warn_On_Useless_Assignment before doing the check 3871 -- below for Is_OK_Variable_For_Out_Formal so that the setting 3872 -- of Referenced_As_LHS/Referenced_As_Out_Formal properly 3873 -- reflects the last assignment, not this one! 3874 3875 if Ekind (F) = E_Out_Parameter then 3876 if Warn_On_Modified_As_Out_Parameter (F) 3877 and then Is_Entity_Name (A) 3878 and then Present (Entity (A)) 3879 and then Comes_From_Source (N) 3880 then 3881 Warn_On_Useless_Assignment (Entity (A), A); 3882 end if; 3883 end if; 3884 3885 -- Validate the form of the actual. Note that the call to 3886 -- Is_OK_Variable_For_Out_Formal generates the required 3887 -- reference in this case. 3888 3889 -- A call to an initialization procedure for an aggregate 3890 -- component may initialize a nested component of a constant 3891 -- designated object. In this context the object is variable. 3892 3893 if not Is_OK_Variable_For_Out_Formal (A) 3894 and then not Is_Init_Proc (Nam) 3895 then 3896 Error_Msg_NE ("actual for& must be a variable", A, F); 3897 end if; 3898 3899 -- What's the following about??? 3900 3901 if Is_Entity_Name (A) then 3902 Kill_Checks (Entity (A)); 3903 else 3904 Kill_All_Checks; 3905 end if; 3906 end if; 3907 3908 if Etype (A) = Any_Type then 3909 Set_Etype (N, Any_Type); 3910 return; 3911 end if; 3912 3913 -- Apply appropriate range checks for in, out, and in-out 3914 -- parameters. Out and in-out parameters also need a separate 3915 -- check, if there is a type conversion, to make sure the return 3916 -- value meets the constraints of the variable before the 3917 -- conversion. 3918 3919 -- Gigi looks at the check flag and uses the appropriate types. 3920 -- For now since one flag is used there is an optimization which 3921 -- might not be done in the In Out case since Gigi does not do 3922 -- any analysis. More thought required about this ??? 3923 3924 if Ekind_In (F, E_In_Parameter, E_In_Out_Parameter) then 3925 3926 -- Apply predicate checks, unless this is a call to the 3927 -- predicate check function itself, which would cause an 3928 -- infinite recursion. 3929 3930 if not (Ekind (Nam) = E_Function 3931 and then Has_Predicates (Nam)) 3932 then 3933 Apply_Predicate_Check (A, F_Typ); 3934 end if; 3935 3936 -- Apply required constraint checks 3937 3938 if Is_Scalar_Type (Etype (A)) then 3939 Apply_Scalar_Range_Check (A, F_Typ); 3940 3941 elsif Is_Array_Type (Etype (A)) then 3942 Apply_Length_Check (A, F_Typ); 3943 3944 elsif Is_Record_Type (F_Typ) 3945 and then Has_Discriminants (F_Typ) 3946 and then Is_Constrained (F_Typ) 3947 and then (not Is_Derived_Type (F_Typ) 3948 or else Comes_From_Source (Nam)) 3949 then 3950 Apply_Discriminant_Check (A, F_Typ); 3951 3952 elsif Is_Access_Type (F_Typ) 3953 and then Is_Array_Type (Designated_Type (F_Typ)) 3954 and then Is_Constrained (Designated_Type (F_Typ)) 3955 then 3956 Apply_Length_Check (A, F_Typ); 3957 3958 elsif Is_Access_Type (F_Typ) 3959 and then Has_Discriminants (Designated_Type (F_Typ)) 3960 and then Is_Constrained (Designated_Type (F_Typ)) 3961 then 3962 Apply_Discriminant_Check (A, F_Typ); 3963 3964 else 3965 Apply_Range_Check (A, F_Typ); 3966 end if; 3967 3968 -- Ada 2005 (AI-231): Note that the controlling parameter case 3969 -- already existed in Ada 95, which is partially checked 3970 -- elsewhere (see Checks), and we don't want the warning 3971 -- message to differ. 3972 3973 if Is_Access_Type (F_Typ) 3974 and then Can_Never_Be_Null (F_Typ) 3975 and then Known_Null (A) 3976 then 3977 if Is_Controlling_Formal (F) then 3978 Apply_Compile_Time_Constraint_Error 3979 (N => A, 3980 Msg => "null value not allowed here??", 3981 Reason => CE_Access_Check_Failed); 3982 3983 elsif Ada_Version >= Ada_2005 then 3984 Apply_Compile_Time_Constraint_Error 3985 (N => A, 3986 Msg => "(Ada 2005) null not allowed in " 3987 & "null-excluding formal??", 3988 Reason => CE_Null_Not_Allowed); 3989 end if; 3990 end if; 3991 end if; 3992 3993 if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) then 3994 if Nkind (A) = N_Type_Conversion then 3995 if Is_Scalar_Type (A_Typ) then 3996 Apply_Scalar_Range_Check 3997 (Expression (A), Etype (Expression (A)), A_Typ); 3998 else 3999 Apply_Range_Check 4000 (Expression (A), Etype (Expression (A)), A_Typ); 4001 end if; 4002 4003 else 4004 if Is_Scalar_Type (F_Typ) then 4005 Apply_Scalar_Range_Check (A, A_Typ, F_Typ); 4006 elsif Is_Array_Type (F_Typ) 4007 and then Ekind (F) = E_Out_Parameter 4008 then 4009 Apply_Length_Check (A, F_Typ); 4010 else 4011 Apply_Range_Check (A, A_Typ, F_Typ); 4012 end if; 4013 end if; 4014 end if; 4015 4016 -- An actual associated with an access parameter is implicitly 4017 -- converted to the anonymous access type of the formal and must 4018 -- satisfy the legality checks for access conversions. 4019 4020 if Ekind (F_Typ) = E_Anonymous_Access_Type then 4021 if not Valid_Conversion (A, F_Typ, A) then 4022 Error_Msg_N 4023 ("invalid implicit conversion for access parameter", A); 4024 end if; 4025 4026 -- If the actual is an access selected component of a variable, 4027 -- the call may modify its designated object. It is reasonable 4028 -- to treat this as a potential modification of the enclosing 4029 -- record, to prevent spurious warnings that it should be 4030 -- declared as a constant, because intuitively programmers 4031 -- regard the designated subcomponent as part of the record. 4032 4033 if Nkind (A) = N_Selected_Component 4034 and then Is_Entity_Name (Prefix (A)) 4035 and then not Is_Constant_Object (Entity (Prefix (A))) 4036 then 4037 Note_Possible_Modification (A, Sure => False); 4038 end if; 4039 end if; 4040 4041 -- Check bad case of atomic/volatile argument (RM C.6(12)) 4042 4043 if Is_By_Reference_Type (Etype (F)) 4044 and then Comes_From_Source (N) 4045 then 4046 if Is_Atomic_Object (A) 4047 and then not Is_Atomic (Etype (F)) 4048 then 4049 Error_Msg_NE 4050 ("cannot pass atomic argument to non-atomic formal&", 4051 A, F); 4052 4053 elsif Is_Volatile_Object (A) 4054 and then not Is_Volatile (Etype (F)) 4055 then 4056 Error_Msg_NE 4057 ("cannot pass volatile argument to non-volatile formal&", 4058 A, F); 4059 end if; 4060 end if; 4061 4062 -- Check that subprograms don't have improper controlling 4063 -- arguments (RM 3.9.2 (9)). 4064 4065 -- A primitive operation may have an access parameter of an 4066 -- incomplete tagged type, but a dispatching call is illegal 4067 -- if the type is still incomplete. 4068 4069 if Is_Controlling_Formal (F) then 4070 Set_Is_Controlling_Actual (A); 4071 4072 if Ekind (Etype (F)) = E_Anonymous_Access_Type then 4073 declare 4074 Desig : constant Entity_Id := Designated_Type (Etype (F)); 4075 begin 4076 if Ekind (Desig) = E_Incomplete_Type 4077 and then No (Full_View (Desig)) 4078 and then No (Non_Limited_View (Desig)) 4079 then 4080 Error_Msg_NE 4081 ("premature use of incomplete type& " & 4082 "in dispatching call", A, Desig); 4083 end if; 4084 end; 4085 end if; 4086 4087 elsif Nkind (A) = N_Explicit_Dereference then 4088 Validate_Remote_Access_To_Class_Wide_Type (A); 4089 end if; 4090 4091 if (Is_Class_Wide_Type (A_Typ) or else Is_Dynamically_Tagged (A)) 4092 and then not Is_Class_Wide_Type (F_Typ) 4093 and then not Is_Controlling_Formal (F) 4094 then 4095 Error_Msg_N ("class-wide argument not allowed here!", A); 4096 4097 if Is_Subprogram (Nam) 4098 and then Comes_From_Source (Nam) 4099 then 4100 Error_Msg_Node_2 := F_Typ; 4101 Error_Msg_NE 4102 ("& is not a dispatching operation of &!", A, Nam); 4103 end if; 4104 4105 -- Apply the checks described in 3.10.2(27): if the context is a 4106 -- specific access-to-object, the actual cannot be class-wide. 4107 -- Use base type to exclude access_to_subprogram cases. 4108 4109 elsif Is_Access_Type (A_Typ) 4110 and then Is_Access_Type (F_Typ) 4111 and then not Is_Access_Subprogram_Type (Base_Type (F_Typ)) 4112 and then (Is_Class_Wide_Type (Designated_Type (A_Typ)) 4113 or else (Nkind (A) = N_Attribute_Reference 4114 and then 4115 Is_Class_Wide_Type (Etype (Prefix (A))))) 4116 and then not Is_Class_Wide_Type (Designated_Type (F_Typ)) 4117 and then not Is_Controlling_Formal (F) 4118 4119 -- Disable these checks for call to imported C++ subprograms 4120 4121 and then not 4122 (Is_Entity_Name (Name (N)) 4123 and then Is_Imported (Entity (Name (N))) 4124 and then Convention (Entity (Name (N))) = Convention_CPP) 4125 then 4126 Error_Msg_N 4127 ("access to class-wide argument not allowed here!", A); 4128 4129 if Is_Subprogram (Nam) and then Comes_From_Source (Nam) then 4130 Error_Msg_Node_2 := Designated_Type (F_Typ); 4131 Error_Msg_NE 4132 ("& is not a dispatching operation of &!", A, Nam); 4133 end if; 4134 end if; 4135 4136 Eval_Actual (A); 4137 4138 -- If it is a named association, treat the selector_name as a 4139 -- proper identifier, and mark the corresponding entity. Ignore 4140 -- this reference in Alfa mode, as it refers to an entity not in 4141 -- scope at the point of reference, so the reference should be 4142 -- ignored for computing effects of subprograms. 4143 4144 if Nkind (Parent (A)) = N_Parameter_Association 4145 and then not Alfa_Mode 4146 then 4147 Set_Entity (Selector_Name (Parent (A)), F); 4148 Generate_Reference (F, Selector_Name (Parent (A))); 4149 Set_Etype (Selector_Name (Parent (A)), F_Typ); 4150 Generate_Reference (F_Typ, N, ' '); 4151 end if; 4152 4153 Prev := A; 4154 4155 if Ekind (F) /= E_Out_Parameter then 4156 Check_Unset_Reference (A); 4157 end if; 4158 4159 Next_Actual (A); 4160 4161 -- Case where actual is not present 4162 4163 else 4164 Insert_Default; 4165 end if; 4166 4167 Next_Formal (F); 4168 end loop; 4169 end Resolve_Actuals; 4170 4171 ----------------------- 4172 -- Resolve_Allocator -- 4173 ----------------------- 4174 4175 procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id) is 4176 Desig_T : constant Entity_Id := Designated_Type (Typ); 4177 E : constant Node_Id := Expression (N); 4178 Subtyp : Entity_Id; 4179 Discrim : Entity_Id; 4180 Constr : Node_Id; 4181 Aggr : Node_Id; 4182 Assoc : Node_Id := Empty; 4183 Disc_Exp : Node_Id; 4184 4185 procedure Check_Allocator_Discrim_Accessibility 4186 (Disc_Exp : Node_Id; 4187 Alloc_Typ : Entity_Id); 4188 -- Check that accessibility level associated with an access discriminant 4189 -- initialized in an allocator by the expression Disc_Exp is not deeper 4190 -- than the level of the allocator type Alloc_Typ. An error message is 4191 -- issued if this condition is violated. Specialized checks are done for 4192 -- the cases of a constraint expression which is an access attribute or 4193 -- an access discriminant. 4194 4195 function In_Dispatching_Context return Boolean; 4196 -- If the allocator is an actual in a call, it is allowed to be class- 4197 -- wide when the context is not because it is a controlling actual. 4198 4199 ------------------------------------------- 4200 -- Check_Allocator_Discrim_Accessibility -- 4201 ------------------------------------------- 4202 4203 procedure Check_Allocator_Discrim_Accessibility 4204 (Disc_Exp : Node_Id; 4205 Alloc_Typ : Entity_Id) 4206 is 4207 begin 4208 if Type_Access_Level (Etype (Disc_Exp)) > 4209 Deepest_Type_Access_Level (Alloc_Typ) 4210 then 4211 Error_Msg_N 4212 ("operand type has deeper level than allocator type", Disc_Exp); 4213 4214 -- When the expression is an Access attribute the level of the prefix 4215 -- object must not be deeper than that of the allocator's type. 4216 4217 elsif Nkind (Disc_Exp) = N_Attribute_Reference 4218 and then Get_Attribute_Id (Attribute_Name (Disc_Exp)) = 4219 Attribute_Access 4220 and then Object_Access_Level (Prefix (Disc_Exp)) > 4221 Deepest_Type_Access_Level (Alloc_Typ) 4222 then 4223 Error_Msg_N 4224 ("prefix of attribute has deeper level than allocator type", 4225 Disc_Exp); 4226 4227 -- When the expression is an access discriminant the check is against 4228 -- the level of the prefix object. 4229 4230 elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type 4231 and then Nkind (Disc_Exp) = N_Selected_Component 4232 and then Object_Access_Level (Prefix (Disc_Exp)) > 4233 Deepest_Type_Access_Level (Alloc_Typ) 4234 then 4235 Error_Msg_N 4236 ("access discriminant has deeper level than allocator type", 4237 Disc_Exp); 4238 4239 -- All other cases are legal 4240 4241 else 4242 null; 4243 end if; 4244 end Check_Allocator_Discrim_Accessibility; 4245 4246 ---------------------------- 4247 -- In_Dispatching_Context -- 4248 ---------------------------- 4249 4250 function In_Dispatching_Context return Boolean is 4251 Par : constant Node_Id := Parent (N); 4252 4253 begin 4254 return Nkind (Par) in N_Subprogram_Call 4255 and then Is_Entity_Name (Name (Par)) 4256 and then Is_Dispatching_Operation (Entity (Name (Par))); 4257 end In_Dispatching_Context; 4258 4259 -- Start of processing for Resolve_Allocator 4260 4261 begin 4262 -- Replace general access with specific type 4263 4264 if Ekind (Etype (N)) = E_Allocator_Type then 4265 Set_Etype (N, Base_Type (Typ)); 4266 end if; 4267 4268 if Is_Abstract_Type (Typ) then 4269 Error_Msg_N ("type of allocator cannot be abstract", N); 4270 end if; 4271 4272 -- For qualified expression, resolve the expression using the 4273 -- given subtype (nothing to do for type mark, subtype indication) 4274 4275 if Nkind (E) = N_Qualified_Expression then 4276 if Is_Class_Wide_Type (Etype (E)) 4277 and then not Is_Class_Wide_Type (Desig_T) 4278 and then not In_Dispatching_Context 4279 then 4280 Error_Msg_N 4281 ("class-wide allocator not allowed for this access type", N); 4282 end if; 4283 4284 Resolve (Expression (E), Etype (E)); 4285 Check_Unset_Reference (Expression (E)); 4286 4287 -- A qualified expression requires an exact match of the type, 4288 -- class-wide matching is not allowed. 4289 4290 if (Is_Class_Wide_Type (Etype (Expression (E))) 4291 or else Is_Class_Wide_Type (Etype (E))) 4292 and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E)) 4293 then 4294 Wrong_Type (Expression (E), Etype (E)); 4295 end if; 4296 4297 -- Calls to build-in-place functions are not currently supported in 4298 -- allocators for access types associated with a simple storage pool. 4299 -- Supporting such allocators may require passing additional implicit 4300 -- parameters to build-in-place functions (or a significant revision 4301 -- of the current b-i-p implementation to unify the handling for 4302 -- multiple kinds of storage pools). ??? 4303 4304 if Is_Immutably_Limited_Type (Desig_T) 4305 and then Nkind (Expression (E)) = N_Function_Call 4306 then 4307 declare 4308 Pool : constant Entity_Id := 4309 Associated_Storage_Pool (Root_Type (Typ)); 4310 begin 4311 if Present (Pool) 4312 and then 4313 Present (Get_Rep_Pragma 4314 (Etype (Pool), Name_Simple_Storage_Pool_Type)) 4315 then 4316 Error_Msg_N 4317 ("limited function calls not yet supported in simple " & 4318 "storage pool allocators", Expression (E)); 4319 end if; 4320 end; 4321 end if; 4322 4323 -- A special accessibility check is needed for allocators that 4324 -- constrain access discriminants. The level of the type of the 4325 -- expression used to constrain an access discriminant cannot be 4326 -- deeper than the type of the allocator (in contrast to access 4327 -- parameters, where the level of the actual can be arbitrary). 4328 4329 -- We can't use Valid_Conversion to perform this check because 4330 -- in general the type of the allocator is unrelated to the type 4331 -- of the access discriminant. 4332 4333 if Ekind (Typ) /= E_Anonymous_Access_Type 4334 or else Is_Local_Anonymous_Access (Typ) 4335 then 4336 Subtyp := Entity (Subtype_Mark (E)); 4337 4338 Aggr := Original_Node (Expression (E)); 4339 4340 if Has_Discriminants (Subtyp) 4341 and then Nkind_In (Aggr, N_Aggregate, N_Extension_Aggregate) 4342 then 4343 Discrim := First_Discriminant (Base_Type (Subtyp)); 4344 4345 -- Get the first component expression of the aggregate 4346 4347 if Present (Expressions (Aggr)) then 4348 Disc_Exp := First (Expressions (Aggr)); 4349 4350 elsif Present (Component_Associations (Aggr)) then 4351 Assoc := First (Component_Associations (Aggr)); 4352 4353 if Present (Assoc) then 4354 Disc_Exp := Expression (Assoc); 4355 else 4356 Disc_Exp := Empty; 4357 end if; 4358 4359 else 4360 Disc_Exp := Empty; 4361 end if; 4362 4363 while Present (Discrim) and then Present (Disc_Exp) loop 4364 if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then 4365 Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ); 4366 end if; 4367 4368 Next_Discriminant (Discrim); 4369 4370 if Present (Discrim) then 4371 if Present (Assoc) then 4372 Next (Assoc); 4373 Disc_Exp := Expression (Assoc); 4374 4375 elsif Present (Next (Disc_Exp)) then 4376 Next (Disc_Exp); 4377 4378 else 4379 Assoc := First (Component_Associations (Aggr)); 4380 4381 if Present (Assoc) then 4382 Disc_Exp := Expression (Assoc); 4383 else 4384 Disc_Exp := Empty; 4385 end if; 4386 end if; 4387 end if; 4388 end loop; 4389 end if; 4390 end if; 4391 4392 -- For a subtype mark or subtype indication, freeze the subtype 4393 4394 else 4395 Freeze_Expression (E); 4396 4397 if Is_Access_Constant (Typ) and then not No_Initialization (N) then 4398 Error_Msg_N 4399 ("initialization required for access-to-constant allocator", N); 4400 end if; 4401 4402 -- A special accessibility check is needed for allocators that 4403 -- constrain access discriminants. The level of the type of the 4404 -- expression used to constrain an access discriminant cannot be 4405 -- deeper than the type of the allocator (in contrast to access 4406 -- parameters, where the level of the actual can be arbitrary). 4407 -- We can't use Valid_Conversion to perform this check because 4408 -- in general the type of the allocator is unrelated to the type 4409 -- of the access discriminant. 4410 4411 if Nkind (Original_Node (E)) = N_Subtype_Indication 4412 and then (Ekind (Typ) /= E_Anonymous_Access_Type 4413 or else Is_Local_Anonymous_Access (Typ)) 4414 then 4415 Subtyp := Entity (Subtype_Mark (Original_Node (E))); 4416 4417 if Has_Discriminants (Subtyp) then 4418 Discrim := First_Discriminant (Base_Type (Subtyp)); 4419 Constr := First (Constraints (Constraint (Original_Node (E)))); 4420 while Present (Discrim) and then Present (Constr) loop 4421 if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then 4422 if Nkind (Constr) = N_Discriminant_Association then 4423 Disc_Exp := Original_Node (Expression (Constr)); 4424 else 4425 Disc_Exp := Original_Node (Constr); 4426 end if; 4427 4428 Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ); 4429 end if; 4430 4431 Next_Discriminant (Discrim); 4432 Next (Constr); 4433 end loop; 4434 end if; 4435 end if; 4436 end if; 4437 4438 -- Ada 2005 (AI-344): A class-wide allocator requires an accessibility 4439 -- check that the level of the type of the created object is not deeper 4440 -- than the level of the allocator's access type, since extensions can 4441 -- now occur at deeper levels than their ancestor types. This is a 4442 -- static accessibility level check; a run-time check is also needed in 4443 -- the case of an initialized allocator with a class-wide argument (see 4444 -- Expand_Allocator_Expression). 4445 4446 if Ada_Version >= Ada_2005 4447 and then Is_Class_Wide_Type (Desig_T) 4448 then 4449 declare 4450 Exp_Typ : Entity_Id; 4451 4452 begin 4453 if Nkind (E) = N_Qualified_Expression then 4454 Exp_Typ := Etype (E); 4455 elsif Nkind (E) = N_Subtype_Indication then 4456 Exp_Typ := Entity (Subtype_Mark (Original_Node (E))); 4457 else 4458 Exp_Typ := Entity (E); 4459 end if; 4460 4461 if Type_Access_Level (Exp_Typ) > 4462 Deepest_Type_Access_Level (Typ) 4463 then 4464 if In_Instance_Body then 4465 Error_Msg_N ("??type in allocator has deeper level than" & 4466 " designated class-wide type", E); 4467 Error_Msg_N ("\??Program_Error will be raised at run time", 4468 E); 4469 Rewrite (N, 4470 Make_Raise_Program_Error (Sloc (N), 4471 Reason => PE_Accessibility_Check_Failed)); 4472 Set_Etype (N, Typ); 4473 4474 -- Do not apply Ada 2005 accessibility checks on a class-wide 4475 -- allocator if the type given in the allocator is a formal 4476 -- type. A run-time check will be performed in the instance. 4477 4478 elsif not Is_Generic_Type (Exp_Typ) then 4479 Error_Msg_N ("type in allocator has deeper level than" & 4480 " designated class-wide type", E); 4481 end if; 4482 end if; 4483 end; 4484 end if; 4485 4486 -- Check for allocation from an empty storage pool 4487 4488 if No_Pool_Assigned (Typ) then 4489 Error_Msg_N ("allocation from empty storage pool!", N); 4490 4491 -- If the context is an unchecked conversion, as may happen within an 4492 -- inlined subprogram, the allocator is being resolved with its own 4493 -- anonymous type. In that case, if the target type has a specific 4494 -- storage pool, it must be inherited explicitly by the allocator type. 4495 4496 elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion 4497 and then No (Associated_Storage_Pool (Typ)) 4498 then 4499 Set_Associated_Storage_Pool 4500 (Typ, Associated_Storage_Pool (Etype (Parent (N)))); 4501 end if; 4502 4503 if Ekind (Etype (N)) = E_Anonymous_Access_Type then 4504 Check_Restriction (No_Anonymous_Allocators, N); 4505 end if; 4506 4507 -- Check that an allocator with task parts isn't for a nested access 4508 -- type when restriction No_Task_Hierarchy applies. 4509 4510 if not Is_Library_Level_Entity (Base_Type (Typ)) 4511 and then Has_Task (Base_Type (Desig_T)) 4512 then 4513 Check_Restriction (No_Task_Hierarchy, N); 4514 end if; 4515 4516 -- An erroneous allocator may be rewritten as a raise Program_Error 4517 -- statement. 4518 4519 if Nkind (N) = N_Allocator then 4520 4521 -- An anonymous access discriminant is the definition of a 4522 -- coextension. 4523 4524 if Ekind (Typ) = E_Anonymous_Access_Type 4525 and then Nkind (Associated_Node_For_Itype (Typ)) = 4526 N_Discriminant_Specification 4527 then 4528 declare 4529 Discr : constant Entity_Id := 4530 Defining_Identifier (Associated_Node_For_Itype (Typ)); 4531 4532 begin 4533 -- Ada 2012 AI05-0052: If the designated type of the allocator 4534 -- is limited, then the allocator shall not be used to define 4535 -- the value of an access discriminant unless the discriminated 4536 -- type is immutably limited. 4537 4538 if Ada_Version >= Ada_2012 4539 and then Is_Limited_Type (Desig_T) 4540 and then not Is_Immutably_Limited_Type (Scope (Discr)) 4541 then 4542 Error_Msg_N 4543 ("only immutably limited types can have anonymous " 4544 & "access discriminants designating a limited type", N); 4545 end if; 4546 end; 4547 4548 -- Avoid marking an allocator as a dynamic coextension if it is 4549 -- within a static construct. 4550 4551 if not Is_Static_Coextension (N) then 4552 Set_Is_Dynamic_Coextension (N); 4553 end if; 4554 4555 -- Cleanup for potential static coextensions 4556 4557 else 4558 Set_Is_Dynamic_Coextension (N, False); 4559 Set_Is_Static_Coextension (N, False); 4560 end if; 4561 end if; 4562 4563 -- Report a simple error: if the designated object is a local task, 4564 -- its body has not been seen yet, and its activation will fail an 4565 -- elaboration check. 4566 4567 if Is_Task_Type (Desig_T) 4568 and then Scope (Base_Type (Desig_T)) = Current_Scope 4569 and then Is_Compilation_Unit (Current_Scope) 4570 and then Ekind (Current_Scope) = E_Package 4571 and then not In_Package_Body (Current_Scope) 4572 then 4573 Error_Msg_N ("??cannot activate task before body seen", N); 4574 Error_Msg_N ("\??Program_Error will be raised at run time", N); 4575 end if; 4576 4577 -- Ada 2012 (AI05-0111-3): Detect an attempt to allocate a task or a 4578 -- type with a task component on a subpool. This action must raise 4579 -- Program_Error at runtime. 4580 4581 if Ada_Version >= Ada_2012 4582 and then Nkind (N) = N_Allocator 4583 and then Present (Subpool_Handle_Name (N)) 4584 and then Has_Task (Desig_T) 4585 then 4586 Error_Msg_N ("??cannot allocate task on subpool", N); 4587 Error_Msg_N ("\??Program_Error will be raised at run time", N); 4588 4589 Rewrite (N, 4590 Make_Raise_Program_Error (Sloc (N), 4591 Reason => PE_Explicit_Raise)); 4592 Set_Etype (N, Typ); 4593 end if; 4594 end Resolve_Allocator; 4595 4596 --------------------------- 4597 -- Resolve_Arithmetic_Op -- 4598 --------------------------- 4599 4600 -- Used for resolving all arithmetic operators except exponentiation 4601 4602 procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id) is 4603 L : constant Node_Id := Left_Opnd (N); 4604 R : constant Node_Id := Right_Opnd (N); 4605 TL : constant Entity_Id := Base_Type (Etype (L)); 4606 TR : constant Entity_Id := Base_Type (Etype (R)); 4607 T : Entity_Id; 4608 Rop : Node_Id; 4609 4610 B_Typ : constant Entity_Id := Base_Type (Typ); 4611 -- We do the resolution using the base type, because intermediate values 4612 -- in expressions always are of the base type, not a subtype of it. 4613 4614 function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean; 4615 -- Returns True if N is in a context that expects "any real type" 4616 4617 function Is_Integer_Or_Universal (N : Node_Id) return Boolean; 4618 -- Return True iff given type is Integer or universal real/integer 4619 4620 procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id); 4621 -- Choose type of integer literal in fixed-point operation to conform 4622 -- to available fixed-point type. T is the type of the other operand, 4623 -- which is needed to determine the expected type of N. 4624 4625 procedure Set_Operand_Type (N : Node_Id); 4626 -- Set operand type to T if universal 4627 4628 ------------------------------- 4629 -- Expected_Type_Is_Any_Real -- 4630 ------------------------------- 4631 4632 function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean is 4633 begin 4634 -- N is the expression after "delta" in a fixed_point_definition; 4635 -- see RM-3.5.9(6): 4636 4637 return Nkind_In (Parent (N), N_Ordinary_Fixed_Point_Definition, 4638 N_Decimal_Fixed_Point_Definition, 4639 4640 -- N is one of the bounds in a real_range_specification; 4641 -- see RM-3.5.7(5): 4642 4643 N_Real_Range_Specification, 4644 4645 -- N is the expression of a delta_constraint; 4646 -- see RM-J.3(3): 4647 4648 N_Delta_Constraint); 4649 end Expected_Type_Is_Any_Real; 4650 4651 ----------------------------- 4652 -- Is_Integer_Or_Universal -- 4653 ----------------------------- 4654 4655 function Is_Integer_Or_Universal (N : Node_Id) return Boolean is 4656 T : Entity_Id; 4657 Index : Interp_Index; 4658 It : Interp; 4659 4660 begin 4661 if not Is_Overloaded (N) then 4662 T := Etype (N); 4663 return Base_Type (T) = Base_Type (Standard_Integer) 4664 or else T = Universal_Integer 4665 or else T = Universal_Real; 4666 else 4667 Get_First_Interp (N, Index, It); 4668 while Present (It.Typ) loop 4669 if Base_Type (It.Typ) = Base_Type (Standard_Integer) 4670 or else It.Typ = Universal_Integer 4671 or else It.Typ = Universal_Real 4672 then 4673 return True; 4674 end if; 4675 4676 Get_Next_Interp (Index, It); 4677 end loop; 4678 end if; 4679 4680 return False; 4681 end Is_Integer_Or_Universal; 4682 4683 ---------------------------- 4684 -- Set_Mixed_Mode_Operand -- 4685 ---------------------------- 4686 4687 procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id) is 4688 Index : Interp_Index; 4689 It : Interp; 4690 4691 begin 4692 if Universal_Interpretation (N) = Universal_Integer then 4693 4694 -- A universal integer literal is resolved as standard integer 4695 -- except in the case of a fixed-point result, where we leave it 4696 -- as universal (to be handled by Exp_Fixd later on) 4697 4698 if Is_Fixed_Point_Type (T) then 4699 Resolve (N, Universal_Integer); 4700 else 4701 Resolve (N, Standard_Integer); 4702 end if; 4703 4704 elsif Universal_Interpretation (N) = Universal_Real 4705 and then (T = Base_Type (Standard_Integer) 4706 or else T = Universal_Integer 4707 or else T = Universal_Real) 4708 then 4709 -- A universal real can appear in a fixed-type context. We resolve 4710 -- the literal with that context, even though this might raise an 4711 -- exception prematurely (the other operand may be zero). 4712 4713 Resolve (N, B_Typ); 4714 4715 elsif Etype (N) = Base_Type (Standard_Integer) 4716 and then T = Universal_Real 4717 and then Is_Overloaded (N) 4718 then 4719 -- Integer arg in mixed-mode operation. Resolve with universal 4720 -- type, in case preference rule must be applied. 4721 4722 Resolve (N, Universal_Integer); 4723 4724 elsif Etype (N) = T 4725 and then B_Typ /= Universal_Fixed 4726 then 4727 -- Not a mixed-mode operation, resolve with context 4728 4729 Resolve (N, B_Typ); 4730 4731 elsif Etype (N) = Any_Fixed then 4732 4733 -- N may itself be a mixed-mode operation, so use context type 4734 4735 Resolve (N, B_Typ); 4736 4737 elsif Is_Fixed_Point_Type (T) 4738 and then B_Typ = Universal_Fixed 4739 and then Is_Overloaded (N) 4740 then 4741 -- Must be (fixed * fixed) operation, operand must have one 4742 -- compatible interpretation. 4743 4744 Resolve (N, Any_Fixed); 4745 4746 elsif Is_Fixed_Point_Type (B_Typ) 4747 and then (T = Universal_Real 4748 or else Is_Fixed_Point_Type (T)) 4749 and then Is_Overloaded (N) 4750 then 4751 -- C * F(X) in a fixed context, where C is a real literal or a 4752 -- fixed-point expression. F must have either a fixed type 4753 -- interpretation or an integer interpretation, but not both. 4754 4755 Get_First_Interp (N, Index, It); 4756 while Present (It.Typ) loop 4757 if Base_Type (It.Typ) = Base_Type (Standard_Integer) then 4758 if Analyzed (N) then 4759 Error_Msg_N ("ambiguous operand in fixed operation", N); 4760 else 4761 Resolve (N, Standard_Integer); 4762 end if; 4763 4764 elsif Is_Fixed_Point_Type (It.Typ) then 4765 if Analyzed (N) then 4766 Error_Msg_N ("ambiguous operand in fixed operation", N); 4767 else 4768 Resolve (N, It.Typ); 4769 end if; 4770 end if; 4771 4772 Get_Next_Interp (Index, It); 4773 end loop; 4774 4775 -- Reanalyze the literal with the fixed type of the context. If 4776 -- context is Universal_Fixed, we are within a conversion, leave 4777 -- the literal as a universal real because there is no usable 4778 -- fixed type, and the target of the conversion plays no role in 4779 -- the resolution. 4780 4781 declare 4782 Op2 : Node_Id; 4783 T2 : Entity_Id; 4784 4785 begin 4786 if N = L then 4787 Op2 := R; 4788 else 4789 Op2 := L; 4790 end if; 4791 4792 if B_Typ = Universal_Fixed 4793 and then Nkind (Op2) = N_Real_Literal 4794 then 4795 T2 := Universal_Real; 4796 else 4797 T2 := B_Typ; 4798 end if; 4799 4800 Set_Analyzed (Op2, False); 4801 Resolve (Op2, T2); 4802 end; 4803 4804 else 4805 Resolve (N); 4806 end if; 4807 end Set_Mixed_Mode_Operand; 4808 4809 ---------------------- 4810 -- Set_Operand_Type -- 4811 ---------------------- 4812 4813 procedure Set_Operand_Type (N : Node_Id) is 4814 begin 4815 if Etype (N) = Universal_Integer 4816 or else Etype (N) = Universal_Real 4817 then 4818 Set_Etype (N, T); 4819 end if; 4820 end Set_Operand_Type; 4821 4822 -- Start of processing for Resolve_Arithmetic_Op 4823 4824 begin 4825 if Comes_From_Source (N) 4826 and then Ekind (Entity (N)) = E_Function 4827 and then Is_Imported (Entity (N)) 4828 and then Is_Intrinsic_Subprogram (Entity (N)) 4829 then 4830 Resolve_Intrinsic_Operator (N, Typ); 4831 return; 4832 4833 -- Special-case for mixed-mode universal expressions or fixed point type 4834 -- operation: each argument is resolved separately. The same treatment 4835 -- is required if one of the operands of a fixed point operation is 4836 -- universal real, since in this case we don't do a conversion to a 4837 -- specific fixed-point type (instead the expander handles the case). 4838 4839 -- Set the type of the node to its universal interpretation because 4840 -- legality checks on an exponentiation operand need the context. 4841 4842 elsif (B_Typ = Universal_Integer or else B_Typ = Universal_Real) 4843 and then Present (Universal_Interpretation (L)) 4844 and then Present (Universal_Interpretation (R)) 4845 then 4846 Set_Etype (N, B_Typ); 4847 Resolve (L, Universal_Interpretation (L)); 4848 Resolve (R, Universal_Interpretation (R)); 4849 4850 elsif (B_Typ = Universal_Real 4851 or else Etype (N) = Universal_Fixed 4852 or else (Etype (N) = Any_Fixed 4853 and then Is_Fixed_Point_Type (B_Typ)) 4854 or else (Is_Fixed_Point_Type (B_Typ) 4855 and then (Is_Integer_Or_Universal (L) 4856 or else 4857 Is_Integer_Or_Universal (R)))) 4858 and then Nkind_In (N, N_Op_Multiply, N_Op_Divide) 4859 then 4860 if TL = Universal_Integer or else TR = Universal_Integer then 4861 Check_For_Visible_Operator (N, B_Typ); 4862 end if; 4863 4864 -- If context is a fixed type and one operand is integer, the other 4865 -- is resolved with the type of the context. 4866 4867 if Is_Fixed_Point_Type (B_Typ) 4868 and then (Base_Type (TL) = Base_Type (Standard_Integer) 4869 or else TL = Universal_Integer) 4870 then 4871 Resolve (R, B_Typ); 4872 Resolve (L, TL); 4873 4874 elsif Is_Fixed_Point_Type (B_Typ) 4875 and then (Base_Type (TR) = Base_Type (Standard_Integer) 4876 or else TR = Universal_Integer) 4877 then 4878 Resolve (L, B_Typ); 4879 Resolve (R, TR); 4880 4881 else 4882 Set_Mixed_Mode_Operand (L, TR); 4883 Set_Mixed_Mode_Operand (R, TL); 4884 end if; 4885 4886 -- Check the rule in RM05-4.5.5(19.1/2) disallowing universal_fixed 4887 -- multiplying operators from being used when the expected type is 4888 -- also universal_fixed. Note that B_Typ will be Universal_Fixed in 4889 -- some cases where the expected type is actually Any_Real; 4890 -- Expected_Type_Is_Any_Real takes care of that case. 4891 4892 if Etype (N) = Universal_Fixed 4893 or else Etype (N) = Any_Fixed 4894 then 4895 if B_Typ = Universal_Fixed 4896 and then not Expected_Type_Is_Any_Real (N) 4897 and then not Nkind_In (Parent (N), N_Type_Conversion, 4898 N_Unchecked_Type_Conversion) 4899 then 4900 Error_Msg_N ("type cannot be determined from context!", N); 4901 Error_Msg_N ("\explicit conversion to result type required", N); 4902 4903 Set_Etype (L, Any_Type); 4904 Set_Etype (R, Any_Type); 4905 4906 else 4907 if Ada_Version = Ada_83 4908 and then Etype (N) = Universal_Fixed 4909 and then not 4910 Nkind_In (Parent (N), N_Type_Conversion, 4911 N_Unchecked_Type_Conversion) 4912 then 4913 Error_Msg_N 4914 ("(Ada 83) fixed-point operation " 4915 & "needs explicit conversion", N); 4916 end if; 4917 4918 -- The expected type is "any real type" in contexts like 4919 4920 -- type T is delta <universal_fixed-expression> ... 4921 4922 -- in which case we need to set the type to Universal_Real 4923 -- so that static expression evaluation will work properly. 4924 4925 if Expected_Type_Is_Any_Real (N) then 4926 Set_Etype (N, Universal_Real); 4927 else 4928 Set_Etype (N, B_Typ); 4929 end if; 4930 end if; 4931 4932 elsif Is_Fixed_Point_Type (B_Typ) 4933 and then (Is_Integer_Or_Universal (L) 4934 or else Nkind (L) = N_Real_Literal 4935 or else Nkind (R) = N_Real_Literal 4936 or else Is_Integer_Or_Universal (R)) 4937 then 4938 Set_Etype (N, B_Typ); 4939 4940 elsif Etype (N) = Any_Fixed then 4941 4942 -- If no previous errors, this is only possible if one operand is 4943 -- overloaded and the context is universal. Resolve as such. 4944 4945 Set_Etype (N, B_Typ); 4946 end if; 4947 4948 else 4949 if (TL = Universal_Integer or else TL = Universal_Real) 4950 and then 4951 (TR = Universal_Integer or else TR = Universal_Real) 4952 then 4953 Check_For_Visible_Operator (N, B_Typ); 4954 end if; 4955 4956 -- If the context is Universal_Fixed and the operands are also 4957 -- universal fixed, this is an error, unless there is only one 4958 -- applicable fixed_point type (usually Duration). 4959 4960 if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then 4961 T := Unique_Fixed_Point_Type (N); 4962 4963 if T = Any_Type then 4964 Set_Etype (N, T); 4965 return; 4966 else 4967 Resolve (L, T); 4968 Resolve (R, T); 4969 end if; 4970 4971 else 4972 Resolve (L, B_Typ); 4973 Resolve (R, B_Typ); 4974 end if; 4975 4976 -- If one of the arguments was resolved to a non-universal type. 4977 -- label the result of the operation itself with the same type. 4978 -- Do the same for the universal argument, if any. 4979 4980 T := Intersect_Types (L, R); 4981 Set_Etype (N, Base_Type (T)); 4982 Set_Operand_Type (L); 4983 Set_Operand_Type (R); 4984 end if; 4985 4986 Generate_Operator_Reference (N, Typ); 4987 Analyze_Dimension (N); 4988 Eval_Arithmetic_Op (N); 4989 4990 -- In SPARK, a multiplication or division with operands of fixed point 4991 -- types shall be qualified or explicitly converted to identify the 4992 -- result type. 4993 4994 if (Is_Fixed_Point_Type (Etype (L)) 4995 or else Is_Fixed_Point_Type (Etype (R))) 4996 and then Nkind_In (N, N_Op_Multiply, N_Op_Divide) 4997 and then 4998 not Nkind_In (Parent (N), N_Qualified_Expression, N_Type_Conversion) 4999 then 5000 Check_SPARK_Restriction 5001 ("operation should be qualified or explicitly converted", N); 5002 end if; 5003 5004 -- Set overflow and division checking bit 5005 5006 if Nkind (N) in N_Op then 5007 if not Overflow_Checks_Suppressed (Etype (N)) then 5008 Enable_Overflow_Check (N); 5009 end if; 5010 5011 -- Give warning if explicit division by zero 5012 5013 if Nkind_In (N, N_Op_Divide, N_Op_Rem, N_Op_Mod) 5014 and then not Division_Checks_Suppressed (Etype (N)) 5015 then 5016 Rop := Right_Opnd (N); 5017 5018 if Compile_Time_Known_Value (Rop) 5019 and then ((Is_Integer_Type (Etype (Rop)) 5020 and then Expr_Value (Rop) = Uint_0) 5021 or else 5022 (Is_Real_Type (Etype (Rop)) 5023 and then Expr_Value_R (Rop) = Ureal_0)) 5024 then 5025 -- Specialize the warning message according to the operation. 5026 -- The following warnings are for the case 5027 5028 case Nkind (N) is 5029 when N_Op_Divide => 5030 5031 -- For division, we have two cases, for float division 5032 -- of an unconstrained float type, on a machine where 5033 -- Machine_Overflows is false, we don't get an exception 5034 -- at run-time, but rather an infinity or Nan. The Nan 5035 -- case is pretty obscure, so just warn about infinities. 5036 5037 if Is_Floating_Point_Type (Typ) 5038 and then not Is_Constrained (Typ) 5039 and then not Machine_Overflows_On_Target 5040 then 5041 Error_Msg_N 5042 ("float division by zero, " & 5043 "may generate '+'/'- infinity??", Right_Opnd (N)); 5044 5045 -- For all other cases, we get a Constraint_Error 5046 5047 else 5048 Apply_Compile_Time_Constraint_Error 5049 (N, "division by zero??", CE_Divide_By_Zero, 5050 Loc => Sloc (Right_Opnd (N))); 5051 end if; 5052 5053 when N_Op_Rem => 5054 Apply_Compile_Time_Constraint_Error 5055 (N, "rem with zero divisor??", CE_Divide_By_Zero, 5056 Loc => Sloc (Right_Opnd (N))); 5057 5058 when N_Op_Mod => 5059 Apply_Compile_Time_Constraint_Error 5060 (N, "mod with zero divisor??", CE_Divide_By_Zero, 5061 Loc => Sloc (Right_Opnd (N))); 5062 5063 -- Division by zero can only happen with division, rem, 5064 -- and mod operations. 5065 5066 when others => 5067 raise Program_Error; 5068 end case; 5069 5070 -- Otherwise just set the flag to check at run time 5071 5072 else 5073 Activate_Division_Check (N); 5074 end if; 5075 end if; 5076 5077 -- If Restriction No_Implicit_Conditionals is active, then it is 5078 -- violated if either operand can be negative for mod, or for rem 5079 -- if both operands can be negative. 5080 5081 if Restriction_Check_Required (No_Implicit_Conditionals) 5082 and then Nkind_In (N, N_Op_Rem, N_Op_Mod) 5083 then 5084 declare 5085 Lo : Uint; 5086 Hi : Uint; 5087 OK : Boolean; 5088 5089 LNeg : Boolean; 5090 RNeg : Boolean; 5091 -- Set if corresponding operand might be negative 5092 5093 begin 5094 Determine_Range 5095 (Left_Opnd (N), OK, Lo, Hi, Assume_Valid => True); 5096 LNeg := (not OK) or else Lo < 0; 5097 5098 Determine_Range 5099 (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True); 5100 RNeg := (not OK) or else Lo < 0; 5101 5102 -- Check if we will be generating conditionals. There are two 5103 -- cases where that can happen, first for REM, the only case 5104 -- is largest negative integer mod -1, where the division can 5105 -- overflow, but we still have to give the right result. The 5106 -- front end generates a test for this annoying case. Here we 5107 -- just test if both operands can be negative (that's what the 5108 -- expander does, so we match its logic here). 5109 5110 -- The second case is mod where either operand can be negative. 5111 -- In this case, the back end has to generate additional tests. 5112 5113 if (Nkind (N) = N_Op_Rem and then (LNeg and RNeg)) 5114 or else 5115 (Nkind (N) = N_Op_Mod and then (LNeg or RNeg)) 5116 then 5117 Check_Restriction (No_Implicit_Conditionals, N); 5118 end if; 5119 end; 5120 end if; 5121 end if; 5122 5123 Check_Unset_Reference (L); 5124 Check_Unset_Reference (R); 5125 Check_Function_Writable_Actuals (N); 5126 end Resolve_Arithmetic_Op; 5127 5128 ------------------ 5129 -- Resolve_Call -- 5130 ------------------ 5131 5132 procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is 5133 Loc : constant Source_Ptr := Sloc (N); 5134 Subp : constant Node_Id := Name (N); 5135 Nam : Entity_Id; 5136 I : Interp_Index; 5137 It : Interp; 5138 Norm_OK : Boolean; 5139 Scop : Entity_Id; 5140 Rtype : Entity_Id; 5141 5142 function Same_Or_Aliased_Subprograms 5143 (S : Entity_Id; 5144 E : Entity_Id) return Boolean; 5145 -- Returns True if the subprogram entity S is the same as E or else 5146 -- S is an alias of E. 5147 5148 --------------------------------- 5149 -- Same_Or_Aliased_Subprograms -- 5150 --------------------------------- 5151 5152 function Same_Or_Aliased_Subprograms 5153 (S : Entity_Id; 5154 E : Entity_Id) return Boolean 5155 is 5156 Subp_Alias : constant Entity_Id := Alias (S); 5157 begin 5158 return S = E 5159 or else (Present (Subp_Alias) and then Subp_Alias = E); 5160 end Same_Or_Aliased_Subprograms; 5161 5162 -- Start of processing for Resolve_Call 5163 5164 begin 5165 -- The context imposes a unique interpretation with type Typ on a 5166 -- procedure or function call. Find the entity of the subprogram that 5167 -- yields the expected type, and propagate the corresponding formal 5168 -- constraints on the actuals. The caller has established that an 5169 -- interpretation exists, and emitted an error if not unique. 5170 5171 -- First deal with the case of a call to an access-to-subprogram, 5172 -- dereference made explicit in Analyze_Call. 5173 5174 if Ekind (Etype (Subp)) = E_Subprogram_Type then 5175 if not Is_Overloaded (Subp) then 5176 Nam := Etype (Subp); 5177 5178 else 5179 -- Find the interpretation whose type (a subprogram type) has a 5180 -- return type that is compatible with the context. Analysis of 5181 -- the node has established that one exists. 5182 5183 Nam := Empty; 5184 5185 Get_First_Interp (Subp, I, It); 5186 while Present (It.Typ) loop 5187 if Covers (Typ, Etype (It.Typ)) then 5188 Nam := It.Typ; 5189 exit; 5190 end if; 5191 5192 Get_Next_Interp (I, It); 5193 end loop; 5194 5195 if No (Nam) then 5196 raise Program_Error; 5197 end if; 5198 end if; 5199 5200 -- If the prefix is not an entity, then resolve it 5201 5202 if not Is_Entity_Name (Subp) then 5203 Resolve (Subp, Nam); 5204 end if; 5205 5206 -- For an indirect call, we always invalidate checks, since we do not 5207 -- know whether the subprogram is local or global. Yes we could do 5208 -- better here, e.g. by knowing that there are no local subprograms, 5209 -- but it does not seem worth the effort. Similarly, we kill all 5210 -- knowledge of current constant values. 5211 5212 Kill_Current_Values; 5213 5214 -- If this is a procedure call which is really an entry call, do 5215 -- the conversion of the procedure call to an entry call. Protected 5216 -- operations use the same circuitry because the name in the call 5217 -- can be an arbitrary expression with special resolution rules. 5218 5219 elsif Nkind_In (Subp, N_Selected_Component, N_Indexed_Component) 5220 or else (Is_Entity_Name (Subp) 5221 and then Ekind (Entity (Subp)) = E_Entry) 5222 then 5223 Resolve_Entry_Call (N, Typ); 5224 Check_Elab_Call (N); 5225 5226 -- Kill checks and constant values, as above for indirect case 5227 -- Who knows what happens when another task is activated? 5228 5229 Kill_Current_Values; 5230 return; 5231 5232 -- Normal subprogram call with name established in Resolve 5233 5234 elsif not (Is_Type (Entity (Subp))) then 5235 Nam := Entity (Subp); 5236 Set_Entity_With_Style_Check (Subp, Nam); 5237 5238 -- Otherwise we must have the case of an overloaded call 5239 5240 else 5241 pragma Assert (Is_Overloaded (Subp)); 5242 5243 -- Initialize Nam to prevent warning (we know it will be assigned 5244 -- in the loop below, but the compiler does not know that). 5245 5246 Nam := Empty; 5247 5248 Get_First_Interp (Subp, I, It); 5249 while Present (It.Typ) loop 5250 if Covers (Typ, It.Typ) then 5251 Nam := It.Nam; 5252 Set_Entity_With_Style_Check (Subp, Nam); 5253 exit; 5254 end if; 5255 5256 Get_Next_Interp (I, It); 5257 end loop; 5258 end if; 5259 5260 if Is_Access_Subprogram_Type (Base_Type (Etype (Nam))) 5261 and then not Is_Access_Subprogram_Type (Base_Type (Typ)) 5262 and then Nkind (Subp) /= N_Explicit_Dereference 5263 and then Present (Parameter_Associations (N)) 5264 then 5265 -- The prefix is a parameterless function call that returns an access 5266 -- to subprogram. If parameters are present in the current call, add 5267 -- add an explicit dereference. We use the base type here because 5268 -- within an instance these may be subtypes. 5269 5270 -- The dereference is added either in Analyze_Call or here. Should 5271 -- be consolidated ??? 5272 5273 Set_Is_Overloaded (Subp, False); 5274 Set_Etype (Subp, Etype (Nam)); 5275 Insert_Explicit_Dereference (Subp); 5276 Nam := Designated_Type (Etype (Nam)); 5277 Resolve (Subp, Nam); 5278 end if; 5279 5280 -- Check that a call to Current_Task does not occur in an entry body 5281 5282 if Is_RTE (Nam, RE_Current_Task) then 5283 declare 5284 P : Node_Id; 5285 5286 begin 5287 P := N; 5288 loop 5289 P := Parent (P); 5290 5291 -- Exclude calls that occur within the default of a formal 5292 -- parameter of the entry, since those are evaluated outside 5293 -- of the body. 5294 5295 exit when No (P) or else Nkind (P) = N_Parameter_Specification; 5296 5297 if Nkind (P) = N_Entry_Body 5298 or else (Nkind (P) = N_Subprogram_Body 5299 and then Is_Entry_Barrier_Function (P)) 5300 then 5301 Rtype := Etype (N); 5302 Error_Msg_NE 5303 ("??& should not be used in entry body (RM C.7(17))", 5304 N, Nam); 5305 Error_Msg_NE 5306 ("\Program_Error will be raised at run time??", N, Nam); 5307 Rewrite (N, 5308 Make_Raise_Program_Error (Loc, 5309 Reason => PE_Current_Task_In_Entry_Body)); 5310 Set_Etype (N, Rtype); 5311 return; 5312 end if; 5313 end loop; 5314 end; 5315 end if; 5316 5317 -- Check that a procedure call does not occur in the context of the 5318 -- entry call statement of a conditional or timed entry call. Note that 5319 -- the case of a call to a subprogram renaming of an entry will also be 5320 -- rejected. The test for N not being an N_Entry_Call_Statement is 5321 -- defensive, covering the possibility that the processing of entry 5322 -- calls might reach this point due to later modifications of the code 5323 -- above. 5324 5325 if Nkind (Parent (N)) = N_Entry_Call_Alternative 5326 and then Nkind (N) /= N_Entry_Call_Statement 5327 and then Entry_Call_Statement (Parent (N)) = N 5328 then 5329 if Ada_Version < Ada_2005 then 5330 Error_Msg_N ("entry call required in select statement", N); 5331 5332 -- Ada 2005 (AI-345): If a procedure_call_statement is used 5333 -- for a procedure_or_entry_call, the procedure_name or 5334 -- procedure_prefix of the procedure_call_statement shall denote 5335 -- an entry renamed by a procedure, or (a view of) a primitive 5336 -- subprogram of a limited interface whose first parameter is 5337 -- a controlling parameter. 5338 5339 elsif Nkind (N) = N_Procedure_Call_Statement 5340 and then not Is_Renamed_Entry (Nam) 5341 and then not Is_Controlling_Limited_Procedure (Nam) 5342 then 5343 Error_Msg_N 5344 ("entry call or dispatching primitive of interface required", N); 5345 end if; 5346 end if; 5347 5348 -- Check that this is not a call to a protected procedure or entry from 5349 -- within a protected function. 5350 5351 Check_Internal_Protected_Use (N, Nam); 5352 5353 -- Freeze the subprogram name if not in a spec-expression. Note that we 5354 -- freeze procedure calls as well as function calls. Procedure calls are 5355 -- not frozen according to the rules (RM 13.14(14)) because it is 5356 -- impossible to have a procedure call to a non-frozen procedure in pure 5357 -- Ada, but in the code that we generate in the expander, this rule 5358 -- needs extending because we can generate procedure calls that need 5359 -- freezing. 5360 5361 -- In Ada 2012, expression functions may be called within pre/post 5362 -- conditions of subsequent functions or expression functions. Such 5363 -- calls do not freeze when they appear within generated bodies, which 5364 -- would place the freeze node in the wrong scope. An expression 5365 -- function is frozen in the usual fashion, by the appearance of a real 5366 -- body, or at the end of a declarative part. 5367 5368 if Is_Entity_Name (Subp) and then not In_Spec_Expression 5369 and then 5370 (not Is_Expression_Function (Entity (Subp)) 5371 or else Scope (Entity (Subp)) = Current_Scope) 5372 then 5373 Freeze_Expression (Subp); 5374 end if; 5375 5376 -- For a predefined operator, the type of the result is the type imposed 5377 -- by context, except for a predefined operation on universal fixed. 5378 -- Otherwise The type of the call is the type returned by the subprogram 5379 -- being called. 5380 5381 if Is_Predefined_Op (Nam) then 5382 if Etype (N) /= Universal_Fixed then 5383 Set_Etype (N, Typ); 5384 end if; 5385 5386 -- If the subprogram returns an array type, and the context requires the 5387 -- component type of that array type, the node is really an indexing of 5388 -- the parameterless call. Resolve as such. A pathological case occurs 5389 -- when the type of the component is an access to the array type. In 5390 -- this case the call is truly ambiguous. 5391 5392 elsif (Needs_No_Actuals (Nam) or else Needs_One_Actual (Nam)) 5393 and then 5394 ((Is_Array_Type (Etype (Nam)) 5395 and then Covers (Typ, Component_Type (Etype (Nam)))) 5396 or else (Is_Access_Type (Etype (Nam)) 5397 and then Is_Array_Type (Designated_Type (Etype (Nam))) 5398 and then 5399 Covers 5400 (Typ, 5401 Component_Type (Designated_Type (Etype (Nam)))))) 5402 then 5403 declare 5404 Index_Node : Node_Id; 5405 New_Subp : Node_Id; 5406 Ret_Type : constant Entity_Id := Etype (Nam); 5407 5408 begin 5409 if Is_Access_Type (Ret_Type) 5410 and then Ret_Type = Component_Type (Designated_Type (Ret_Type)) 5411 then 5412 Error_Msg_N 5413 ("cannot disambiguate function call and indexing", N); 5414 else 5415 New_Subp := Relocate_Node (Subp); 5416 Set_Entity (Subp, Nam); 5417 5418 if (Is_Array_Type (Ret_Type) 5419 and then Component_Type (Ret_Type) /= Any_Type) 5420 or else 5421 (Is_Access_Type (Ret_Type) 5422 and then 5423 Component_Type (Designated_Type (Ret_Type)) /= Any_Type) 5424 then 5425 if Needs_No_Actuals (Nam) then 5426 5427 -- Indexed call to a parameterless function 5428 5429 Index_Node := 5430 Make_Indexed_Component (Loc, 5431 Prefix => 5432 Make_Function_Call (Loc, 5433 Name => New_Subp), 5434 Expressions => Parameter_Associations (N)); 5435 else 5436 -- An Ada 2005 prefixed call to a primitive operation 5437 -- whose first parameter is the prefix. This prefix was 5438 -- prepended to the parameter list, which is actually a 5439 -- list of indexes. Remove the prefix in order to build 5440 -- the proper indexed component. 5441 5442 Index_Node := 5443 Make_Indexed_Component (Loc, 5444 Prefix => 5445 Make_Function_Call (Loc, 5446 Name => New_Subp, 5447 Parameter_Associations => 5448 New_List 5449 (Remove_Head (Parameter_Associations (N)))), 5450 Expressions => Parameter_Associations (N)); 5451 end if; 5452 5453 -- Preserve the parenthesis count of the node 5454 5455 Set_Paren_Count (Index_Node, Paren_Count (N)); 5456 5457 -- Since we are correcting a node classification error made 5458 -- by the parser, we call Replace rather than Rewrite. 5459 5460 Replace (N, Index_Node); 5461 5462 Set_Etype (Prefix (N), Ret_Type); 5463 Set_Etype (N, Typ); 5464 Resolve_Indexed_Component (N, Typ); 5465 Check_Elab_Call (Prefix (N)); 5466 end if; 5467 end if; 5468 5469 return; 5470 end; 5471 5472 else 5473 Set_Etype (N, Etype (Nam)); 5474 end if; 5475 5476 -- In the case where the call is to an overloaded subprogram, Analyze 5477 -- calls Normalize_Actuals once per overloaded subprogram. Therefore in 5478 -- such a case Normalize_Actuals needs to be called once more to order 5479 -- the actuals correctly. Otherwise the call will have the ordering 5480 -- given by the last overloaded subprogram whether this is the correct 5481 -- one being called or not. 5482 5483 if Is_Overloaded (Subp) then 5484 Normalize_Actuals (N, Nam, False, Norm_OK); 5485 pragma Assert (Norm_OK); 5486 end if; 5487 5488 -- In any case, call is fully resolved now. Reset Overload flag, to 5489 -- prevent subsequent overload resolution if node is analyzed again 5490 5491 Set_Is_Overloaded (Subp, False); 5492 Set_Is_Overloaded (N, False); 5493 5494 -- If we are calling the current subprogram from immediately within its 5495 -- body, then that is the case where we can sometimes detect cases of 5496 -- infinite recursion statically. Do not try this in case restriction 5497 -- No_Recursion is in effect anyway, and do it only for source calls. 5498 5499 if Comes_From_Source (N) then 5500 Scop := Current_Scope; 5501 5502 -- Issue warning for possible infinite recursion in the absence 5503 -- of the No_Recursion restriction. 5504 5505 if Same_Or_Aliased_Subprograms (Nam, Scop) 5506 and then not Restriction_Active (No_Recursion) 5507 and then Check_Infinite_Recursion (N) 5508 then 5509 -- Here we detected and flagged an infinite recursion, so we do 5510 -- not need to test the case below for further warnings. Also we 5511 -- are all done if we now have a raise SE node. 5512 5513 if Nkind (N) = N_Raise_Storage_Error then 5514 return; 5515 end if; 5516 5517 -- If call is to immediately containing subprogram, then check for 5518 -- the case of a possible run-time detectable infinite recursion. 5519 5520 else 5521 Scope_Loop : while Scop /= Standard_Standard loop 5522 if Same_Or_Aliased_Subprograms (Nam, Scop) then 5523 5524 -- Although in general case, recursion is not statically 5525 -- checkable, the case of calling an immediately containing 5526 -- subprogram is easy to catch. 5527 5528 Check_Restriction (No_Recursion, N); 5529 5530 -- If the recursive call is to a parameterless subprogram, 5531 -- then even if we can't statically detect infinite 5532 -- recursion, this is pretty suspicious, and we output a 5533 -- warning. Furthermore, we will try later to detect some 5534 -- cases here at run time by expanding checking code (see 5535 -- Detect_Infinite_Recursion in package Exp_Ch6). 5536 5537 -- If the recursive call is within a handler, do not emit a 5538 -- warning, because this is a common idiom: loop until input 5539 -- is correct, catch illegal input in handler and restart. 5540 5541 if No (First_Formal (Nam)) 5542 and then Etype (Nam) = Standard_Void_Type 5543 and then not Error_Posted (N) 5544 and then Nkind (Parent (N)) /= N_Exception_Handler 5545 then 5546 -- For the case of a procedure call. We give the message 5547 -- only if the call is the first statement in a sequence 5548 -- of statements, or if all previous statements are 5549 -- simple assignments. This is simply a heuristic to 5550 -- decrease false positives, without losing too many good 5551 -- warnings. The idea is that these previous statements 5552 -- may affect global variables the procedure depends on. 5553 -- We also exclude raise statements, that may arise from 5554 -- constraint checks and are probably unrelated to the 5555 -- intended control flow. 5556 5557 if Nkind (N) = N_Procedure_Call_Statement 5558 and then Is_List_Member (N) 5559 then 5560 declare 5561 P : Node_Id; 5562 begin 5563 P := Prev (N); 5564 while Present (P) loop 5565 if not Nkind_In (P, 5566 N_Assignment_Statement, 5567 N_Raise_Constraint_Error) 5568 then 5569 exit Scope_Loop; 5570 end if; 5571 5572 Prev (P); 5573 end loop; 5574 end; 5575 end if; 5576 5577 -- Do not give warning if we are in a conditional context 5578 5579 declare 5580 K : constant Node_Kind := Nkind (Parent (N)); 5581 begin 5582 if (K = N_Loop_Statement 5583 and then Present (Iteration_Scheme (Parent (N)))) 5584 or else K = N_If_Statement 5585 or else K = N_Elsif_Part 5586 or else K = N_Case_Statement_Alternative 5587 then 5588 exit Scope_Loop; 5589 end if; 5590 end; 5591 5592 -- Here warning is to be issued 5593 5594 Set_Has_Recursive_Call (Nam); 5595 Error_Msg_N 5596 ("??possible infinite recursion!", N); 5597 Error_Msg_N 5598 ("\??Storage_Error may be raised at run time!", N); 5599 end if; 5600 5601 exit Scope_Loop; 5602 end if; 5603 5604 Scop := Scope (Scop); 5605 end loop Scope_Loop; 5606 end if; 5607 end if; 5608 5609 -- Check obsolescent reference to Ada.Characters.Handling subprogram 5610 5611 Check_Obsolescent_2005_Entity (Nam, Subp); 5612 5613 -- If subprogram name is a predefined operator, it was given in 5614 -- functional notation. Replace call node with operator node, so 5615 -- that actuals can be resolved appropriately. 5616 5617 if Is_Predefined_Op (Nam) or else Ekind (Nam) = E_Operator then 5618 Make_Call_Into_Operator (N, Typ, Entity (Name (N))); 5619 return; 5620 5621 elsif Present (Alias (Nam)) 5622 and then Is_Predefined_Op (Alias (Nam)) 5623 then 5624 Resolve_Actuals (N, Nam); 5625 Make_Call_Into_Operator (N, Typ, Alias (Nam)); 5626 return; 5627 end if; 5628 5629 -- Create a transient scope if the resulting type requires it 5630 5631 -- There are several notable exceptions: 5632 5633 -- a) In init procs, the transient scope overhead is not needed, and is 5634 -- even incorrect when the call is a nested initialization call for a 5635 -- component whose expansion may generate adjust calls. However, if the 5636 -- call is some other procedure call within an initialization procedure 5637 -- (for example a call to Create_Task in the init_proc of the task 5638 -- run-time record) a transient scope must be created around this call. 5639 5640 -- b) Enumeration literal pseudo-calls need no transient scope 5641 5642 -- c) Intrinsic subprograms (Unchecked_Conversion and source info 5643 -- functions) do not use the secondary stack even though the return 5644 -- type may be unconstrained. 5645 5646 -- d) Calls to a build-in-place function, since such functions may 5647 -- allocate their result directly in a target object, and cases where 5648 -- the result does get allocated in the secondary stack are checked for 5649 -- within the specialized Exp_Ch6 procedures for expanding those 5650 -- build-in-place calls. 5651 5652 -- e) If the subprogram is marked Inline_Always, then even if it returns 5653 -- an unconstrained type the call does not require use of the secondary 5654 -- stack. However, inlining will only take place if the body to inline 5655 -- is already present. It may not be available if e.g. the subprogram is 5656 -- declared in a child instance. 5657 5658 -- If this is an initialization call for a type whose construction 5659 -- uses the secondary stack, and it is not a nested call to initialize 5660 -- a component, we do need to create a transient scope for it. We 5661 -- check for this by traversing the type in Check_Initialization_Call. 5662 5663 if Is_Inlined (Nam) 5664 and then Has_Pragma_Inline_Always (Nam) 5665 and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration 5666 and then Present (Body_To_Inline (Unit_Declaration_Node (Nam))) 5667 and then not Debug_Flag_Dot_K 5668 then 5669 null; 5670 5671 elsif Is_Inlined (Nam) 5672 and then Has_Pragma_Inline (Nam) 5673 and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration 5674 and then Present (Body_To_Inline (Unit_Declaration_Node (Nam))) 5675 and then Debug_Flag_Dot_K 5676 then 5677 null; 5678 5679 elsif Ekind (Nam) = E_Enumeration_Literal 5680 or else Is_Build_In_Place_Function (Nam) 5681 or else Is_Intrinsic_Subprogram (Nam) 5682 then 5683 null; 5684 5685 elsif Full_Expander_Active 5686 and then Is_Type (Etype (Nam)) 5687 and then Requires_Transient_Scope (Etype (Nam)) 5688 and then 5689 (not Within_Init_Proc 5690 or else 5691 (not Is_Init_Proc (Nam) and then Ekind (Nam) /= E_Function)) 5692 then 5693 Establish_Transient_Scope (N, Sec_Stack => True); 5694 5695 -- If the call appears within the bounds of a loop, it will 5696 -- be rewritten and reanalyzed, nothing left to do here. 5697 5698 if Nkind (N) /= N_Function_Call then 5699 return; 5700 end if; 5701 5702 elsif Is_Init_Proc (Nam) 5703 and then not Within_Init_Proc 5704 then 5705 Check_Initialization_Call (N, Nam); 5706 end if; 5707 5708 -- A protected function cannot be called within the definition of the 5709 -- enclosing protected type. 5710 5711 if Is_Protected_Type (Scope (Nam)) 5712 and then In_Open_Scopes (Scope (Nam)) 5713 and then not Has_Completion (Scope (Nam)) 5714 then 5715 Error_Msg_NE 5716 ("& cannot be called before end of protected definition", N, Nam); 5717 end if; 5718 5719 -- Propagate interpretation to actuals, and add default expressions 5720 -- where needed. 5721 5722 if Present (First_Formal (Nam)) then 5723 Resolve_Actuals (N, Nam); 5724 5725 -- Overloaded literals are rewritten as function calls, for purpose of 5726 -- resolution. After resolution, we can replace the call with the 5727 -- literal itself. 5728 5729 elsif Ekind (Nam) = E_Enumeration_Literal then 5730 Copy_Node (Subp, N); 5731 Resolve_Entity_Name (N, Typ); 5732 5733 -- Avoid validation, since it is a static function call 5734 5735 Generate_Reference (Nam, Subp); 5736 return; 5737 end if; 5738 5739 -- If the subprogram is not global, then kill all saved values and 5740 -- checks. This is a bit conservative, since in many cases we could do 5741 -- better, but it is not worth the effort. Similarly, we kill constant 5742 -- values. However we do not need to do this for internal entities 5743 -- (unless they are inherited user-defined subprograms), since they 5744 -- are not in the business of molesting local values. 5745 5746 -- If the flag Suppress_Value_Tracking_On_Calls is set, then we also 5747 -- kill all checks and values for calls to global subprograms. This 5748 -- takes care of the case where an access to a local subprogram is 5749 -- taken, and could be passed directly or indirectly and then called 5750 -- from almost any context. 5751 5752 -- Note: we do not do this step till after resolving the actuals. That 5753 -- way we still take advantage of the current value information while 5754 -- scanning the actuals. 5755 5756 -- We suppress killing values if we are processing the nodes associated 5757 -- with N_Freeze_Entity nodes. Otherwise the declaration of a tagged 5758 -- type kills all the values as part of analyzing the code that 5759 -- initializes the dispatch tables. 5760 5761 if Inside_Freezing_Actions = 0 5762 and then (not Is_Library_Level_Entity (Nam) 5763 or else Suppress_Value_Tracking_On_Call 5764 (Nearest_Dynamic_Scope (Current_Scope))) 5765 and then (Comes_From_Source (Nam) 5766 or else (Present (Alias (Nam)) 5767 and then Comes_From_Source (Alias (Nam)))) 5768 then 5769 Kill_Current_Values; 5770 end if; 5771 5772 -- If we are warning about unread OUT parameters, this is the place to 5773 -- set Last_Assignment for OUT and IN OUT parameters. We have to do this 5774 -- after the above call to Kill_Current_Values (since that call clears 5775 -- the Last_Assignment field of all local variables). 5776 5777 if (Warn_On_Modified_Unread or Warn_On_All_Unread_Out_Parameters) 5778 and then Comes_From_Source (N) 5779 and then In_Extended_Main_Source_Unit (N) 5780 then 5781 declare 5782 F : Entity_Id; 5783 A : Node_Id; 5784 5785 begin 5786 F := First_Formal (Nam); 5787 A := First_Actual (N); 5788 while Present (F) and then Present (A) loop 5789 if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) 5790 and then Warn_On_Modified_As_Out_Parameter (F) 5791 and then Is_Entity_Name (A) 5792 and then Present (Entity (A)) 5793 and then Comes_From_Source (N) 5794 and then Safe_To_Capture_Value (N, Entity (A)) 5795 then 5796 Set_Last_Assignment (Entity (A), A); 5797 end if; 5798 5799 Next_Formal (F); 5800 Next_Actual (A); 5801 end loop; 5802 end; 5803 end if; 5804 5805 -- If the subprogram is a primitive operation, check whether or not 5806 -- it is a correct dispatching call. 5807 5808 if Is_Overloadable (Nam) 5809 and then Is_Dispatching_Operation (Nam) 5810 then 5811 Check_Dispatching_Call (N); 5812 5813 elsif Ekind (Nam) /= E_Subprogram_Type 5814 and then Is_Abstract_Subprogram (Nam) 5815 and then not In_Instance 5816 then 5817 Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam); 5818 end if; 5819 5820 -- If this is a dispatching call, generate the appropriate reference, 5821 -- for better source navigation in GPS. 5822 5823 if Is_Overloadable (Nam) 5824 and then Present (Controlling_Argument (N)) 5825 then 5826 Generate_Reference (Nam, Subp, 'R'); 5827 5828 -- Normal case, not a dispatching call: generate a call reference 5829 5830 else 5831 Generate_Reference (Nam, Subp, 's'); 5832 end if; 5833 5834 if Is_Intrinsic_Subprogram (Nam) then 5835 Check_Intrinsic_Call (N); 5836 end if; 5837 5838 -- Check for violation of restriction No_Specific_Termination_Handlers 5839 -- and warn on a potentially blocking call to Abort_Task. 5840 5841 if Restriction_Check_Required (No_Specific_Termination_Handlers) 5842 and then (Is_RTE (Nam, RE_Set_Specific_Handler) 5843 or else 5844 Is_RTE (Nam, RE_Specific_Handler)) 5845 then 5846 Check_Restriction (No_Specific_Termination_Handlers, N); 5847 5848 elsif Is_RTE (Nam, RE_Abort_Task) then 5849 Check_Potentially_Blocking_Operation (N); 5850 end if; 5851 5852 -- A call to Ada.Real_Time.Timing_Events.Set_Handler to set a relative 5853 -- timing event violates restriction No_Relative_Delay (AI-0211). We 5854 -- need to check the second argument to determine whether it is an 5855 -- absolute or relative timing event. 5856 5857 if Restriction_Check_Required (No_Relative_Delay) 5858 and then Is_RTE (Nam, RE_Set_Handler) 5859 and then Is_RTE (Etype (Next_Actual (First_Actual (N))), RE_Time_Span) 5860 then 5861 Check_Restriction (No_Relative_Delay, N); 5862 end if; 5863 5864 -- Issue an error for a call to an eliminated subprogram. This routine 5865 -- will not perform the check if the call appears within a default 5866 -- expression. 5867 5868 Check_For_Eliminated_Subprogram (Subp, Nam); 5869 5870 -- In formal mode, the primitive operations of a tagged type or type 5871 -- extension do not include functions that return the tagged type. 5872 5873 -- Commented out as the call to Is_Inherited_Operation_For_Type may 5874 -- cause an error because the type entity of the parent node of 5875 -- Entity (Name (N) may not be set. ??? 5876 -- So why not just add a guard ??? 5877 5878-- if Nkind (N) = N_Function_Call 5879-- and then Is_Tagged_Type (Etype (N)) 5880-- and then Is_Entity_Name (Name (N)) 5881-- and then Is_Inherited_Operation_For_Type 5882-- (Entity (Name (N)), Etype (N)) 5883-- then 5884-- Check_SPARK_Restriction ("function not inherited", N); 5885-- end if; 5886 5887 -- Implement rule in 12.5.1 (23.3/2): In an instance, if the actual is 5888 -- class-wide and the call dispatches on result in a context that does 5889 -- not provide a tag, the call raises Program_Error. 5890 5891 if Nkind (N) = N_Function_Call 5892 and then In_Instance 5893 and then Is_Generic_Actual_Type (Typ) 5894 and then Is_Class_Wide_Type (Typ) 5895 and then Has_Controlling_Result (Nam) 5896 and then Nkind (Parent (N)) = N_Object_Declaration 5897 then 5898 -- Verify that none of the formals are controlling 5899 5900 declare 5901 Call_OK : Boolean := False; 5902 F : Entity_Id; 5903 5904 begin 5905 F := First_Formal (Nam); 5906 while Present (F) loop 5907 if Is_Controlling_Formal (F) then 5908 Call_OK := True; 5909 exit; 5910 end if; 5911 5912 Next_Formal (F); 5913 end loop; 5914 5915 if not Call_OK then 5916 Error_Msg_N ("!?? cannot determine tag of result", N); 5917 Error_Msg_N ("!?? Program_Error will be raised", N); 5918 Insert_Action (N, 5919 Make_Raise_Program_Error (Sloc (N), 5920 Reason => PE_Explicit_Raise)); 5921 end if; 5922 end; 5923 end if; 5924 5925 -- Check the dimensions of the actuals in the call. For function calls, 5926 -- propagate the dimensions from the returned type to N. 5927 5928 Analyze_Dimension_Call (N, Nam); 5929 5930 -- All done, evaluate call and deal with elaboration issues 5931 5932 Eval_Call (N); 5933 Check_Elab_Call (N); 5934 Warn_On_Overlapping_Actuals (Nam, N); 5935 end Resolve_Call; 5936 5937 ----------------------------- 5938 -- Resolve_Case_Expression -- 5939 ----------------------------- 5940 5941 procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id) is 5942 Alt : Node_Id; 5943 5944 begin 5945 Alt := First (Alternatives (N)); 5946 while Present (Alt) loop 5947 Resolve (Expression (Alt), Typ); 5948 Next (Alt); 5949 end loop; 5950 5951 Set_Etype (N, Typ); 5952 Eval_Case_Expression (N); 5953 end Resolve_Case_Expression; 5954 5955 ------------------------------- 5956 -- Resolve_Character_Literal -- 5957 ------------------------------- 5958 5959 procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id) is 5960 B_Typ : constant Entity_Id := Base_Type (Typ); 5961 C : Entity_Id; 5962 5963 begin 5964 -- Verify that the character does belong to the type of the context 5965 5966 Set_Etype (N, B_Typ); 5967 Eval_Character_Literal (N); 5968 5969 -- Wide_Wide_Character literals must always be defined, since the set 5970 -- of wide wide character literals is complete, i.e. if a character 5971 -- literal is accepted by the parser, then it is OK for wide wide 5972 -- character (out of range character literals are rejected). 5973 5974 if Root_Type (B_Typ) = Standard_Wide_Wide_Character then 5975 return; 5976 5977 -- Always accept character literal for type Any_Character, which 5978 -- occurs in error situations and in comparisons of literals, both 5979 -- of which should accept all literals. 5980 5981 elsif B_Typ = Any_Character then 5982 return; 5983 5984 -- For Standard.Character or a type derived from it, check that the 5985 -- literal is in range. 5986 5987 elsif Root_Type (B_Typ) = Standard_Character then 5988 if In_Character_Range (UI_To_CC (Char_Literal_Value (N))) then 5989 return; 5990 end if; 5991 5992 -- For Standard.Wide_Character or a type derived from it, check that the 5993 -- literal is in range. 5994 5995 elsif Root_Type (B_Typ) = Standard_Wide_Character then 5996 if In_Wide_Character_Range (UI_To_CC (Char_Literal_Value (N))) then 5997 return; 5998 end if; 5999 6000 -- For Standard.Wide_Wide_Character or a type derived from it, we 6001 -- know the literal is in range, since the parser checked! 6002 6003 elsif Root_Type (B_Typ) = Standard_Wide_Wide_Character then 6004 return; 6005 6006 -- If the entity is already set, this has already been resolved in a 6007 -- generic context, or comes from expansion. Nothing else to do. 6008 6009 elsif Present (Entity (N)) then 6010 return; 6011 6012 -- Otherwise we have a user defined character type, and we can use the 6013 -- standard visibility mechanisms to locate the referenced entity. 6014 6015 else 6016 C := Current_Entity (N); 6017 while Present (C) loop 6018 if Etype (C) = B_Typ then 6019 Set_Entity_With_Style_Check (N, C); 6020 Generate_Reference (C, N); 6021 return; 6022 end if; 6023 6024 C := Homonym (C); 6025 end loop; 6026 end if; 6027 6028 -- If we fall through, then the literal does not match any of the 6029 -- entries of the enumeration type. This isn't just a constraint error 6030 -- situation, it is an illegality (see RM 4.2). 6031 6032 Error_Msg_NE 6033 ("character not defined for }", N, First_Subtype (B_Typ)); 6034 end Resolve_Character_Literal; 6035 6036 --------------------------- 6037 -- Resolve_Comparison_Op -- 6038 --------------------------- 6039 6040 -- Context requires a boolean type, and plays no role in resolution. 6041 -- Processing identical to that for equality operators. The result type is 6042 -- the base type, which matters when pathological subtypes of booleans with 6043 -- limited ranges are used. 6044 6045 procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is 6046 L : constant Node_Id := Left_Opnd (N); 6047 R : constant Node_Id := Right_Opnd (N); 6048 T : Entity_Id; 6049 6050 begin 6051 -- If this is an intrinsic operation which is not predefined, use the 6052 -- types of its declared arguments to resolve the possibly overloaded 6053 -- operands. Otherwise the operands are unambiguous and specify the 6054 -- expected type. 6055 6056 if Scope (Entity (N)) /= Standard_Standard then 6057 T := Etype (First_Entity (Entity (N))); 6058 6059 else 6060 T := Find_Unique_Type (L, R); 6061 6062 if T = Any_Fixed then 6063 T := Unique_Fixed_Point_Type (L); 6064 end if; 6065 end if; 6066 6067 Set_Etype (N, Base_Type (Typ)); 6068 Generate_Reference (T, N, ' '); 6069 6070 -- Skip remaining processing if already set to Any_Type 6071 6072 if T = Any_Type then 6073 return; 6074 end if; 6075 6076 -- Deal with other error cases 6077 6078 if T = Any_String or else 6079 T = Any_Composite or else 6080 T = Any_Character 6081 then 6082 if T = Any_Character then 6083 Ambiguous_Character (L); 6084 else 6085 Error_Msg_N ("ambiguous operands for comparison", N); 6086 end if; 6087 6088 Set_Etype (N, Any_Type); 6089 return; 6090 end if; 6091 6092 -- Resolve the operands if types OK 6093 6094 Resolve (L, T); 6095 Resolve (R, T); 6096 Check_Unset_Reference (L); 6097 Check_Unset_Reference (R); 6098 Generate_Operator_Reference (N, T); 6099 Check_Low_Bound_Tested (N); 6100 6101 -- In SPARK, ordering operators <, <=, >, >= are not defined for Boolean 6102 -- types or array types except String. 6103 6104 if Is_Boolean_Type (T) then 6105 Check_SPARK_Restriction 6106 ("comparison is not defined on Boolean type", N); 6107 6108 elsif Is_Array_Type (T) 6109 and then Base_Type (T) /= Standard_String 6110 then 6111 Check_SPARK_Restriction 6112 ("comparison is not defined on array types other than String", N); 6113 end if; 6114 6115 -- Check comparison on unordered enumeration 6116 6117 if Bad_Unordered_Enumeration_Reference (N, Etype (L)) then 6118 Error_Msg_N ("comparison on unordered enumeration type?U?", N); 6119 end if; 6120 6121 -- Evaluate the relation (note we do this after the above check since 6122 -- this Eval call may change N to True/False. 6123 6124 Analyze_Dimension (N); 6125 Eval_Relational_Op (N); 6126 end Resolve_Comparison_Op; 6127 6128 ----------------------------------------- 6129 -- Resolve_Discrete_Subtype_Indication -- 6130 ----------------------------------------- 6131 6132 procedure Resolve_Discrete_Subtype_Indication 6133 (N : Node_Id; 6134 Typ : Entity_Id) 6135 is 6136 R : Node_Id; 6137 S : Entity_Id; 6138 6139 begin 6140 Analyze (Subtype_Mark (N)); 6141 S := Entity (Subtype_Mark (N)); 6142 6143 if Nkind (Constraint (N)) /= N_Range_Constraint then 6144 Error_Msg_N ("expect range constraint for discrete type", N); 6145 Set_Etype (N, Any_Type); 6146 6147 else 6148 R := Range_Expression (Constraint (N)); 6149 6150 if R = Error then 6151 return; 6152 end if; 6153 6154 Analyze (R); 6155 6156 if Base_Type (S) /= Base_Type (Typ) then 6157 Error_Msg_NE 6158 ("expect subtype of }", N, First_Subtype (Typ)); 6159 6160 -- Rewrite the constraint as a range of Typ 6161 -- to allow compilation to proceed further. 6162 6163 Set_Etype (N, Typ); 6164 Rewrite (Low_Bound (R), 6165 Make_Attribute_Reference (Sloc (Low_Bound (R)), 6166 Prefix => New_Occurrence_Of (Typ, Sloc (R)), 6167 Attribute_Name => Name_First)); 6168 Rewrite (High_Bound (R), 6169 Make_Attribute_Reference (Sloc (High_Bound (R)), 6170 Prefix => New_Occurrence_Of (Typ, Sloc (R)), 6171 Attribute_Name => Name_First)); 6172 6173 else 6174 Resolve (R, Typ); 6175 Set_Etype (N, Etype (R)); 6176 6177 -- Additionally, we must check that the bounds are compatible 6178 -- with the given subtype, which might be different from the 6179 -- type of the context. 6180 6181 Apply_Range_Check (R, S); 6182 6183 -- ??? If the above check statically detects a Constraint_Error 6184 -- it replaces the offending bound(s) of the range R with a 6185 -- Constraint_Error node. When the itype which uses these bounds 6186 -- is frozen the resulting call to Duplicate_Subexpr generates 6187 -- a new temporary for the bounds. 6188 6189 -- Unfortunately there are other itypes that are also made depend 6190 -- on these bounds, so when Duplicate_Subexpr is called they get 6191 -- a forward reference to the newly created temporaries and Gigi 6192 -- aborts on such forward references. This is probably sign of a 6193 -- more fundamental problem somewhere else in either the order of 6194 -- itype freezing or the way certain itypes are constructed. 6195 6196 -- To get around this problem we call Remove_Side_Effects right 6197 -- away if either bounds of R are a Constraint_Error. 6198 6199 declare 6200 L : constant Node_Id := Low_Bound (R); 6201 H : constant Node_Id := High_Bound (R); 6202 6203 begin 6204 if Nkind (L) = N_Raise_Constraint_Error then 6205 Remove_Side_Effects (L); 6206 end if; 6207 6208 if Nkind (H) = N_Raise_Constraint_Error then 6209 Remove_Side_Effects (H); 6210 end if; 6211 end; 6212 6213 Check_Unset_Reference (Low_Bound (R)); 6214 Check_Unset_Reference (High_Bound (R)); 6215 end if; 6216 end if; 6217 end Resolve_Discrete_Subtype_Indication; 6218 6219 ------------------------- 6220 -- Resolve_Entity_Name -- 6221 ------------------------- 6222 6223 -- Used to resolve identifiers and expanded names 6224 6225 procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id) is 6226 E : constant Entity_Id := Entity (N); 6227 6228 begin 6229 -- If garbage from errors, set to Any_Type and return 6230 6231 if No (E) and then Total_Errors_Detected /= 0 then 6232 Set_Etype (N, Any_Type); 6233 return; 6234 end if; 6235 6236 -- Replace named numbers by corresponding literals. Note that this is 6237 -- the one case where Resolve_Entity_Name must reset the Etype, since 6238 -- it is currently marked as universal. 6239 6240 if Ekind (E) = E_Named_Integer then 6241 Set_Etype (N, Typ); 6242 Eval_Named_Integer (N); 6243 6244 elsif Ekind (E) = E_Named_Real then 6245 Set_Etype (N, Typ); 6246 Eval_Named_Real (N); 6247 6248 -- For enumeration literals, we need to make sure that a proper style 6249 -- check is done, since such literals are overloaded, and thus we did 6250 -- not do a style check during the first phase of analysis. 6251 6252 elsif Ekind (E) = E_Enumeration_Literal then 6253 Set_Entity_With_Style_Check (N, E); 6254 Eval_Entity_Name (N); 6255 6256 -- Case of subtype name appearing as an operand in expression 6257 6258 elsif Is_Type (E) then 6259 6260 -- Allow use of subtype if it is a concurrent type where we are 6261 -- currently inside the body. This will eventually be expanded into a 6262 -- call to Self (for tasks) or _object (for protected objects). Any 6263 -- other use of a subtype is invalid. 6264 6265 if Is_Concurrent_Type (E) 6266 and then In_Open_Scopes (E) 6267 then 6268 null; 6269 6270 -- Any other use is an error 6271 6272 else 6273 Error_Msg_N 6274 ("invalid use of subtype mark in expression or call", N); 6275 end if; 6276 6277 -- Check discriminant use if entity is discriminant in current scope, 6278 -- i.e. discriminant of record or concurrent type currently being 6279 -- analyzed. Uses in corresponding body are unrestricted. 6280 6281 elsif Ekind (E) = E_Discriminant 6282 and then Scope (E) = Current_Scope 6283 and then not Has_Completion (Current_Scope) 6284 then 6285 Check_Discriminant_Use (N); 6286 6287 -- A parameterless generic function cannot appear in a context that 6288 -- requires resolution. 6289 6290 elsif Ekind (E) = E_Generic_Function then 6291 Error_Msg_N ("illegal use of generic function", N); 6292 6293 elsif Ekind (E) = E_Out_Parameter 6294 and then Ada_Version = Ada_83 6295 and then (Nkind (Parent (N)) in N_Op 6296 or else (Nkind (Parent (N)) = N_Assignment_Statement 6297 and then N = Expression (Parent (N))) 6298 or else Nkind (Parent (N)) = N_Explicit_Dereference) 6299 then 6300 Error_Msg_N ("(Ada 83) illegal reading of out parameter", N); 6301 6302 -- In all other cases, just do the possible static evaluation 6303 6304 else 6305 -- A deferred constant that appears in an expression must have a 6306 -- completion, unless it has been removed by in-place expansion of 6307 -- an aggregate. 6308 6309 if Ekind (E) = E_Constant 6310 and then Comes_From_Source (E) 6311 and then No (Constant_Value (E)) 6312 and then Is_Frozen (Etype (E)) 6313 and then not In_Spec_Expression 6314 and then not Is_Imported (E) 6315 then 6316 if No_Initialization (Parent (E)) 6317 or else (Present (Full_View (E)) 6318 and then No_Initialization (Parent (Full_View (E)))) 6319 then 6320 null; 6321 else 6322 Error_Msg_N ( 6323 "deferred constant is frozen before completion", N); 6324 end if; 6325 end if; 6326 6327 Eval_Entity_Name (N); 6328 end if; 6329 end Resolve_Entity_Name; 6330 6331 ------------------- 6332 -- Resolve_Entry -- 6333 ------------------- 6334 6335 procedure Resolve_Entry (Entry_Name : Node_Id) is 6336 Loc : constant Source_Ptr := Sloc (Entry_Name); 6337 Nam : Entity_Id; 6338 New_N : Node_Id; 6339 S : Entity_Id; 6340 Tsk : Entity_Id; 6341 E_Name : Node_Id; 6342 Index : Node_Id; 6343 6344 function Actual_Index_Type (E : Entity_Id) return Entity_Id; 6345 -- If the bounds of the entry family being called depend on task 6346 -- discriminants, build a new index subtype where a discriminant is 6347 -- replaced with the value of the discriminant of the target task. 6348 -- The target task is the prefix of the entry name in the call. 6349 6350 ----------------------- 6351 -- Actual_Index_Type -- 6352 ----------------------- 6353 6354 function Actual_Index_Type (E : Entity_Id) return Entity_Id is 6355 Typ : constant Entity_Id := Entry_Index_Type (E); 6356 Tsk : constant Entity_Id := Scope (E); 6357 Lo : constant Node_Id := Type_Low_Bound (Typ); 6358 Hi : constant Node_Id := Type_High_Bound (Typ); 6359 New_T : Entity_Id; 6360 6361 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; 6362 -- If the bound is given by a discriminant, replace with a reference 6363 -- to the discriminant of the same name in the target task. If the 6364 -- entry name is the target of a requeue statement and the entry is 6365 -- in the current protected object, the bound to be used is the 6366 -- discriminal of the object (see Apply_Range_Checks for details of 6367 -- the transformation). 6368 6369 ----------------------------- 6370 -- Actual_Discriminant_Ref -- 6371 ----------------------------- 6372 6373 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is 6374 Typ : constant Entity_Id := Etype (Bound); 6375 Ref : Node_Id; 6376 6377 begin 6378 Remove_Side_Effects (Bound); 6379 6380 if not Is_Entity_Name (Bound) 6381 or else Ekind (Entity (Bound)) /= E_Discriminant 6382 then 6383 return Bound; 6384 6385 elsif Is_Protected_Type (Tsk) 6386 and then In_Open_Scopes (Tsk) 6387 and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement 6388 then 6389 -- Note: here Bound denotes a discriminant of the corresponding 6390 -- record type tskV, whose discriminal is a formal of the 6391 -- init-proc tskVIP. What we want is the body discriminal, 6392 -- which is associated to the discriminant of the original 6393 -- concurrent type tsk. 6394 6395 return New_Occurrence_Of 6396 (Find_Body_Discriminal (Entity (Bound)), Loc); 6397 6398 else 6399 Ref := 6400 Make_Selected_Component (Loc, 6401 Prefix => New_Copy_Tree (Prefix (Prefix (Entry_Name))), 6402 Selector_Name => New_Occurrence_Of (Entity (Bound), Loc)); 6403 Analyze (Ref); 6404 Resolve (Ref, Typ); 6405 return Ref; 6406 end if; 6407 end Actual_Discriminant_Ref; 6408 6409 -- Start of processing for Actual_Index_Type 6410 6411 begin 6412 if not Has_Discriminants (Tsk) 6413 or else (not Is_Entity_Name (Lo) and then not Is_Entity_Name (Hi)) 6414 then 6415 return Entry_Index_Type (E); 6416 6417 else 6418 New_T := Create_Itype (Ekind (Typ), Parent (Entry_Name)); 6419 Set_Etype (New_T, Base_Type (Typ)); 6420 Set_Size_Info (New_T, Typ); 6421 Set_RM_Size (New_T, RM_Size (Typ)); 6422 Set_Scalar_Range (New_T, 6423 Make_Range (Sloc (Entry_Name), 6424 Low_Bound => Actual_Discriminant_Ref (Lo), 6425 High_Bound => Actual_Discriminant_Ref (Hi))); 6426 6427 return New_T; 6428 end if; 6429 end Actual_Index_Type; 6430 6431 -- Start of processing of Resolve_Entry 6432 6433 begin 6434 -- Find name of entry being called, and resolve prefix of name with its 6435 -- own type. The prefix can be overloaded, and the name and signature of 6436 -- the entry must be taken into account. 6437 6438 if Nkind (Entry_Name) = N_Indexed_Component then 6439 6440 -- Case of dealing with entry family within the current tasks 6441 6442 E_Name := Prefix (Entry_Name); 6443 6444 else 6445 E_Name := Entry_Name; 6446 end if; 6447 6448 if Is_Entity_Name (E_Name) then 6449 6450 -- Entry call to an entry (or entry family) in the current task. This 6451 -- is legal even though the task will deadlock. Rewrite as call to 6452 -- current task. 6453 6454 -- This can also be a call to an entry in an enclosing task. If this 6455 -- is a single task, we have to retrieve its name, because the scope 6456 -- of the entry is the task type, not the object. If the enclosing 6457 -- task is a task type, the identity of the task is given by its own 6458 -- self variable. 6459 6460 -- Finally this can be a requeue on an entry of the same task or 6461 -- protected object. 6462 6463 S := Scope (Entity (E_Name)); 6464 6465 for J in reverse 0 .. Scope_Stack.Last loop 6466 if Is_Task_Type (Scope_Stack.Table (J).Entity) 6467 and then not Comes_From_Source (S) 6468 then 6469 -- S is an enclosing task or protected object. The concurrent 6470 -- declaration has been converted into a type declaration, and 6471 -- the object itself has an object declaration that follows 6472 -- the type in the same declarative part. 6473 6474 Tsk := Next_Entity (S); 6475 while Etype (Tsk) /= S loop 6476 Next_Entity (Tsk); 6477 end loop; 6478 6479 S := Tsk; 6480 exit; 6481 6482 elsif S = Scope_Stack.Table (J).Entity then 6483 6484 -- Call to current task. Will be transformed into call to Self 6485 6486 exit; 6487 6488 end if; 6489 end loop; 6490 6491 New_N := 6492 Make_Selected_Component (Loc, 6493 Prefix => New_Occurrence_Of (S, Loc), 6494 Selector_Name => 6495 New_Occurrence_Of (Entity (E_Name), Loc)); 6496 Rewrite (E_Name, New_N); 6497 Analyze (E_Name); 6498 6499 elsif Nkind (Entry_Name) = N_Selected_Component 6500 and then Is_Overloaded (Prefix (Entry_Name)) 6501 then 6502 -- Use the entry name (which must be unique at this point) to find 6503 -- the prefix that returns the corresponding task/protected type. 6504 6505 declare 6506 Pref : constant Node_Id := Prefix (Entry_Name); 6507 Ent : constant Entity_Id := Entity (Selector_Name (Entry_Name)); 6508 I : Interp_Index; 6509 It : Interp; 6510 6511 begin 6512 Get_First_Interp (Pref, I, It); 6513 while Present (It.Typ) loop 6514 if Scope (Ent) = It.Typ then 6515 Set_Etype (Pref, It.Typ); 6516 exit; 6517 end if; 6518 6519 Get_Next_Interp (I, It); 6520 end loop; 6521 end; 6522 end if; 6523 6524 if Nkind (Entry_Name) = N_Selected_Component then 6525 Resolve (Prefix (Entry_Name)); 6526 6527 else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); 6528 Nam := Entity (Selector_Name (Prefix (Entry_Name))); 6529 Resolve (Prefix (Prefix (Entry_Name))); 6530 Index := First (Expressions (Entry_Name)); 6531 Resolve (Index, Entry_Index_Type (Nam)); 6532 6533 -- Up to this point the expression could have been the actual in a 6534 -- simple entry call, and be given by a named association. 6535 6536 if Nkind (Index) = N_Parameter_Association then 6537 Error_Msg_N ("expect expression for entry index", Index); 6538 else 6539 Apply_Range_Check (Index, Actual_Index_Type (Nam)); 6540 end if; 6541 end if; 6542 end Resolve_Entry; 6543 6544 ------------------------ 6545 -- Resolve_Entry_Call -- 6546 ------------------------ 6547 6548 procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id) is 6549 Entry_Name : constant Node_Id := Name (N); 6550 Loc : constant Source_Ptr := Sloc (Entry_Name); 6551 Actuals : List_Id; 6552 First_Named : Node_Id; 6553 Nam : Entity_Id; 6554 Norm_OK : Boolean; 6555 Obj : Node_Id; 6556 Was_Over : Boolean; 6557 6558 begin 6559 -- We kill all checks here, because it does not seem worth the effort to 6560 -- do anything better, an entry call is a big operation. 6561 6562 Kill_All_Checks; 6563 6564 -- Processing of the name is similar for entry calls and protected 6565 -- operation calls. Once the entity is determined, we can complete 6566 -- the resolution of the actuals. 6567 6568 -- The selector may be overloaded, in the case of a protected object 6569 -- with overloaded functions. The type of the context is used for 6570 -- resolution. 6571 6572 if Nkind (Entry_Name) = N_Selected_Component 6573 and then Is_Overloaded (Selector_Name (Entry_Name)) 6574 and then Typ /= Standard_Void_Type 6575 then 6576 declare 6577 I : Interp_Index; 6578 It : Interp; 6579 6580 begin 6581 Get_First_Interp (Selector_Name (Entry_Name), I, It); 6582 while Present (It.Typ) loop 6583 if Covers (Typ, It.Typ) then 6584 Set_Entity (Selector_Name (Entry_Name), It.Nam); 6585 Set_Etype (Entry_Name, It.Typ); 6586 6587 Generate_Reference (It.Typ, N, ' '); 6588 end if; 6589 6590 Get_Next_Interp (I, It); 6591 end loop; 6592 end; 6593 end if; 6594 6595 Resolve_Entry (Entry_Name); 6596 6597 if Nkind (Entry_Name) = N_Selected_Component then 6598 6599 -- Simple entry call 6600 6601 Nam := Entity (Selector_Name (Entry_Name)); 6602 Obj := Prefix (Entry_Name); 6603 Was_Over := Is_Overloaded (Selector_Name (Entry_Name)); 6604 6605 else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); 6606 6607 -- Call to member of entry family 6608 6609 Nam := Entity (Selector_Name (Prefix (Entry_Name))); 6610 Obj := Prefix (Prefix (Entry_Name)); 6611 Was_Over := Is_Overloaded (Selector_Name (Prefix (Entry_Name))); 6612 end if; 6613 6614 -- We cannot in general check the maximum depth of protected entry calls 6615 -- at compile time. But we can tell that any protected entry call at all 6616 -- violates a specified nesting depth of zero. 6617 6618 if Is_Protected_Type (Scope (Nam)) then 6619 Check_Restriction (Max_Entry_Queue_Length, N); 6620 end if; 6621 6622 -- Use context type to disambiguate a protected function that can be 6623 -- called without actuals and that returns an array type, and where the 6624 -- argument list may be an indexing of the returned value. 6625 6626 if Ekind (Nam) = E_Function 6627 and then Needs_No_Actuals (Nam) 6628 and then Present (Parameter_Associations (N)) 6629 and then 6630 ((Is_Array_Type (Etype (Nam)) 6631 and then Covers (Typ, Component_Type (Etype (Nam)))) 6632 6633 or else (Is_Access_Type (Etype (Nam)) 6634 and then Is_Array_Type (Designated_Type (Etype (Nam))) 6635 and then 6636 Covers 6637 (Typ, 6638 Component_Type (Designated_Type (Etype (Nam)))))) 6639 then 6640 declare 6641 Index_Node : Node_Id; 6642 6643 begin 6644 Index_Node := 6645 Make_Indexed_Component (Loc, 6646 Prefix => 6647 Make_Function_Call (Loc, Name => Relocate_Node (Entry_Name)), 6648 Expressions => Parameter_Associations (N)); 6649 6650 -- Since we are correcting a node classification error made by the 6651 -- parser, we call Replace rather than Rewrite. 6652 6653 Replace (N, Index_Node); 6654 Set_Etype (Prefix (N), Etype (Nam)); 6655 Set_Etype (N, Typ); 6656 Resolve_Indexed_Component (N, Typ); 6657 return; 6658 end; 6659 end if; 6660 6661 if Ekind_In (Nam, E_Entry, E_Entry_Family) 6662 and then Present (PPC_Wrapper (Nam)) 6663 and then Current_Scope /= PPC_Wrapper (Nam) 6664 then 6665 -- Rewrite as call to the precondition wrapper, adding the task 6666 -- object to the list of actuals. If the call is to a member of an 6667 -- entry family, include the index as well. 6668 6669 declare 6670 New_Call : Node_Id; 6671 New_Actuals : List_Id; 6672 6673 begin 6674 New_Actuals := New_List (Obj); 6675 6676 if Nkind (Entry_Name) = N_Indexed_Component then 6677 Append_To (New_Actuals, 6678 New_Copy_Tree (First (Expressions (Entry_Name)))); 6679 end if; 6680 6681 Append_List (Parameter_Associations (N), New_Actuals); 6682 New_Call := 6683 Make_Procedure_Call_Statement (Loc, 6684 Name => 6685 New_Occurrence_Of (PPC_Wrapper (Nam), Loc), 6686 Parameter_Associations => New_Actuals); 6687 Rewrite (N, New_Call); 6688 Analyze_And_Resolve (N); 6689 return; 6690 end; 6691 end if; 6692 6693 -- The operation name may have been overloaded. Order the actuals 6694 -- according to the formals of the resolved entity, and set the return 6695 -- type to that of the operation. 6696 6697 if Was_Over then 6698 Normalize_Actuals (N, Nam, False, Norm_OK); 6699 pragma Assert (Norm_OK); 6700 Set_Etype (N, Etype (Nam)); 6701 end if; 6702 6703 Resolve_Actuals (N, Nam); 6704 Check_Internal_Protected_Use (N, Nam); 6705 6706 -- Create a call reference to the entry 6707 6708 Generate_Reference (Nam, Entry_Name, 's'); 6709 6710 if Ekind_In (Nam, E_Entry, E_Entry_Family) then 6711 Check_Potentially_Blocking_Operation (N); 6712 end if; 6713 6714 -- Verify that a procedure call cannot masquerade as an entry 6715 -- call where an entry call is expected. 6716 6717 if Ekind (Nam) = E_Procedure then 6718 if Nkind (Parent (N)) = N_Entry_Call_Alternative 6719 and then N = Entry_Call_Statement (Parent (N)) 6720 then 6721 Error_Msg_N ("entry call required in select statement", N); 6722 6723 elsif Nkind (Parent (N)) = N_Triggering_Alternative 6724 and then N = Triggering_Statement (Parent (N)) 6725 then 6726 Error_Msg_N ("triggering statement cannot be procedure call", N); 6727 6728 elsif Ekind (Scope (Nam)) = E_Task_Type 6729 and then not In_Open_Scopes (Scope (Nam)) 6730 then 6731 Error_Msg_N ("task has no entry with this name", Entry_Name); 6732 end if; 6733 end if; 6734 6735 -- After resolution, entry calls and protected procedure calls are 6736 -- changed into entry calls, for expansion. The structure of the node 6737 -- does not change, so it can safely be done in place. Protected 6738 -- function calls must keep their structure because they are 6739 -- subexpressions. 6740 6741 if Ekind (Nam) /= E_Function then 6742 6743 -- A protected operation that is not a function may modify the 6744 -- corresponding object, and cannot apply to a constant. If this 6745 -- is an internal call, the prefix is the type itself. 6746 6747 if Is_Protected_Type (Scope (Nam)) 6748 and then not Is_Variable (Obj) 6749 and then (not Is_Entity_Name (Obj) 6750 or else not Is_Type (Entity (Obj))) 6751 then 6752 Error_Msg_N 6753 ("prefix of protected procedure or entry call must be variable", 6754 Entry_Name); 6755 end if; 6756 6757 Actuals := Parameter_Associations (N); 6758 First_Named := First_Named_Actual (N); 6759 6760 Rewrite (N, 6761 Make_Entry_Call_Statement (Loc, 6762 Name => Entry_Name, 6763 Parameter_Associations => Actuals)); 6764 6765 Set_First_Named_Actual (N, First_Named); 6766 Set_Analyzed (N, True); 6767 6768 -- Protected functions can return on the secondary stack, in which 6769 -- case we must trigger the transient scope mechanism. 6770 6771 elsif Full_Expander_Active 6772 and then Requires_Transient_Scope (Etype (Nam)) 6773 then 6774 Establish_Transient_Scope (N, Sec_Stack => True); 6775 end if; 6776 end Resolve_Entry_Call; 6777 6778 ------------------------- 6779 -- Resolve_Equality_Op -- 6780 ------------------------- 6781 6782 -- Both arguments must have the same type, and the boolean context does 6783 -- not participate in the resolution. The first pass verifies that the 6784 -- interpretation is not ambiguous, and the type of the left argument is 6785 -- correctly set, or is Any_Type in case of ambiguity. If both arguments 6786 -- are strings or aggregates, allocators, or Null, they are ambiguous even 6787 -- though they carry a single (universal) type. Diagnose this case here. 6788 6789 procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is 6790 L : constant Node_Id := Left_Opnd (N); 6791 R : constant Node_Id := Right_Opnd (N); 6792 T : Entity_Id := Find_Unique_Type (L, R); 6793 6794 procedure Check_If_Expression (Cond : Node_Id); 6795 -- The resolution rule for if expressions requires that each such must 6796 -- have a unique type. This means that if several dependent expressions 6797 -- are of a non-null anonymous access type, and the context does not 6798 -- impose an expected type (as can be the case in an equality operation) 6799 -- the expression must be rejected. 6800 6801 function Find_Unique_Access_Type return Entity_Id; 6802 -- In the case of allocators, make a last-ditch attempt to find a single 6803 -- access type with the right designated type. This is semantically 6804 -- dubious, and of no interest to any real code, but c48008a makes it 6805 -- all worthwhile. 6806 6807 ------------------------- 6808 -- Check_If_Expression -- 6809 ------------------------- 6810 6811 procedure Check_If_Expression (Cond : Node_Id) is 6812 Then_Expr : Node_Id; 6813 Else_Expr : Node_Id; 6814 6815 begin 6816 if Nkind (Cond) = N_If_Expression then 6817 Then_Expr := Next (First (Expressions (Cond))); 6818 Else_Expr := Next (Then_Expr); 6819 6820 if Nkind (Then_Expr) /= N_Null 6821 and then Nkind (Else_Expr) /= N_Null 6822 then 6823 Error_Msg_N ("cannot determine type of if expression", Cond); 6824 end if; 6825 end if; 6826 end Check_If_Expression; 6827 6828 ----------------------------- 6829 -- Find_Unique_Access_Type -- 6830 ----------------------------- 6831 6832 function Find_Unique_Access_Type return Entity_Id is 6833 Acc : Entity_Id; 6834 E : Entity_Id; 6835 S : Entity_Id; 6836 6837 begin 6838 if Ekind (Etype (R)) = E_Allocator_Type then 6839 Acc := Designated_Type (Etype (R)); 6840 elsif Ekind (Etype (L)) = E_Allocator_Type then 6841 Acc := Designated_Type (Etype (L)); 6842 else 6843 return Empty; 6844 end if; 6845 6846 S := Current_Scope; 6847 while S /= Standard_Standard loop 6848 E := First_Entity (S); 6849 while Present (E) loop 6850 if Is_Type (E) 6851 and then Is_Access_Type (E) 6852 and then Ekind (E) /= E_Allocator_Type 6853 and then Designated_Type (E) = Base_Type (Acc) 6854 then 6855 return E; 6856 end if; 6857 6858 Next_Entity (E); 6859 end loop; 6860 6861 S := Scope (S); 6862 end loop; 6863 6864 return Empty; 6865 end Find_Unique_Access_Type; 6866 6867 -- Start of processing for Resolve_Equality_Op 6868 6869 begin 6870 Set_Etype (N, Base_Type (Typ)); 6871 Generate_Reference (T, N, ' '); 6872 6873 if T = Any_Fixed then 6874 T := Unique_Fixed_Point_Type (L); 6875 end if; 6876 6877 if T /= Any_Type then 6878 if T = Any_String or else 6879 T = Any_Composite or else 6880 T = Any_Character 6881 then 6882 if T = Any_Character then 6883 Ambiguous_Character (L); 6884 else 6885 Error_Msg_N ("ambiguous operands for equality", N); 6886 end if; 6887 6888 Set_Etype (N, Any_Type); 6889 return; 6890 6891 elsif T = Any_Access 6892 or else Ekind_In (T, E_Allocator_Type, E_Access_Attribute_Type) 6893 then 6894 T := Find_Unique_Access_Type; 6895 6896 if No (T) then 6897 Error_Msg_N ("ambiguous operands for equality", N); 6898 Set_Etype (N, Any_Type); 6899 return; 6900 end if; 6901 6902 -- If expressions must have a single type, and if the context does 6903 -- not impose one the dependent expressions cannot be anonymous 6904 -- access types. 6905 6906 -- Why no similar processing for case expressions??? 6907 6908 elsif Ada_Version >= Ada_2012 6909 and then Ekind_In (Etype (L), E_Anonymous_Access_Type, 6910 E_Anonymous_Access_Subprogram_Type) 6911 and then Ekind_In (Etype (R), E_Anonymous_Access_Type, 6912 E_Anonymous_Access_Subprogram_Type) 6913 then 6914 Check_If_Expression (L); 6915 Check_If_Expression (R); 6916 end if; 6917 6918 Resolve (L, T); 6919 Resolve (R, T); 6920 6921 -- In SPARK, equality operators = and /= for array types other than 6922 -- String are only defined when, for each index position, the 6923 -- operands have equal static bounds. 6924 6925 if Is_Array_Type (T) then 6926 6927 -- Protect call to Matching_Static_Array_Bounds to avoid costly 6928 -- operation if not needed. 6929 6930 if Restriction_Check_Required (SPARK) 6931 and then Base_Type (T) /= Standard_String 6932 and then Base_Type (Etype (L)) = Base_Type (Etype (R)) 6933 and then Etype (L) /= Any_Composite -- or else L in error 6934 and then Etype (R) /= Any_Composite -- or else R in error 6935 and then not Matching_Static_Array_Bounds (Etype (L), Etype (R)) 6936 then 6937 Check_SPARK_Restriction 6938 ("array types should have matching static bounds", N); 6939 end if; 6940 end if; 6941 6942 -- If the unique type is a class-wide type then it will be expanded 6943 -- into a dispatching call to the predefined primitive. Therefore we 6944 -- check here for potential violation of such restriction. 6945 6946 if Is_Class_Wide_Type (T) then 6947 Check_Restriction (No_Dispatching_Calls, N); 6948 end if; 6949 6950 if Warn_On_Redundant_Constructs 6951 and then Comes_From_Source (N) 6952 and then Is_Entity_Name (R) 6953 and then Entity (R) = Standard_True 6954 and then Comes_From_Source (R) 6955 then 6956 Error_Msg_N -- CODEFIX 6957 ("?r?comparison with True is redundant!", R); 6958 end if; 6959 6960 Check_Unset_Reference (L); 6961 Check_Unset_Reference (R); 6962 Generate_Operator_Reference (N, T); 6963 Check_Low_Bound_Tested (N); 6964 6965 -- If this is an inequality, it may be the implicit inequality 6966 -- created for a user-defined operation, in which case the corres- 6967 -- ponding equality operation is not intrinsic, and the operation 6968 -- cannot be constant-folded. Else fold. 6969 6970 if Nkind (N) = N_Op_Eq 6971 or else Comes_From_Source (Entity (N)) 6972 or else Ekind (Entity (N)) = E_Operator 6973 or else Is_Intrinsic_Subprogram 6974 (Corresponding_Equality (Entity (N))) 6975 then 6976 Analyze_Dimension (N); 6977 Eval_Relational_Op (N); 6978 6979 elsif Nkind (N) = N_Op_Ne 6980 and then Is_Abstract_Subprogram (Entity (N)) 6981 then 6982 Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N)); 6983 end if; 6984 6985 -- Ada 2005: If one operand is an anonymous access type, convert the 6986 -- other operand to it, to ensure that the underlying types match in 6987 -- the back-end. Same for access_to_subprogram, and the conversion 6988 -- verifies that the types are subtype conformant. 6989 6990 -- We apply the same conversion in the case one of the operands is a 6991 -- private subtype of the type of the other. 6992 6993 -- Why the Expander_Active test here ??? 6994 6995 if Full_Expander_Active 6996 and then 6997 (Ekind_In (T, E_Anonymous_Access_Type, 6998 E_Anonymous_Access_Subprogram_Type) 6999 or else Is_Private_Type (T)) 7000 then 7001 if Etype (L) /= T then 7002 Rewrite (L, 7003 Make_Unchecked_Type_Conversion (Sloc (L), 7004 Subtype_Mark => New_Occurrence_Of (T, Sloc (L)), 7005 Expression => Relocate_Node (L))); 7006 Analyze_And_Resolve (L, T); 7007 end if; 7008 7009 if (Etype (R)) /= T then 7010 Rewrite (R, 7011 Make_Unchecked_Type_Conversion (Sloc (R), 7012 Subtype_Mark => New_Occurrence_Of (Etype (L), Sloc (R)), 7013 Expression => Relocate_Node (R))); 7014 Analyze_And_Resolve (R, T); 7015 end if; 7016 end if; 7017 end if; 7018 end Resolve_Equality_Op; 7019 7020 ---------------------------------- 7021 -- Resolve_Explicit_Dereference -- 7022 ---------------------------------- 7023 7024 procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is 7025 Loc : constant Source_Ptr := Sloc (N); 7026 New_N : Node_Id; 7027 P : constant Node_Id := Prefix (N); 7028 7029 P_Typ : Entity_Id; 7030 -- The candidate prefix type, if overloaded 7031 7032 I : Interp_Index; 7033 It : Interp; 7034 7035 begin 7036 Check_Fully_Declared_Prefix (Typ, P); 7037 P_Typ := Empty; 7038 7039 if Is_Overloaded (P) then 7040 7041 -- Use the context type to select the prefix that has the correct 7042 -- designated type. Keep the first match, which will be the inner- 7043 -- most. 7044 7045 Get_First_Interp (P, I, It); 7046 7047 while Present (It.Typ) loop 7048 if Is_Access_Type (It.Typ) 7049 and then Covers (Typ, Designated_Type (It.Typ)) 7050 then 7051 if No (P_Typ) then 7052 P_Typ := It.Typ; 7053 end if; 7054 7055 -- Remove access types that do not match, but preserve access 7056 -- to subprogram interpretations, in case a further dereference 7057 -- is needed (see below). 7058 7059 elsif Ekind (It.Typ) /= E_Access_Subprogram_Type then 7060 Remove_Interp (I); 7061 end if; 7062 7063 Get_Next_Interp (I, It); 7064 end loop; 7065 7066 if Present (P_Typ) then 7067 Resolve (P, P_Typ); 7068 Set_Etype (N, Designated_Type (P_Typ)); 7069 7070 else 7071 -- If no interpretation covers the designated type of the prefix, 7072 -- this is the pathological case where not all implementations of 7073 -- the prefix allow the interpretation of the node as a call. Now 7074 -- that the expected type is known, Remove other interpretations 7075 -- from prefix, rewrite it as a call, and resolve again, so that 7076 -- the proper call node is generated. 7077 7078 Get_First_Interp (P, I, It); 7079 while Present (It.Typ) loop 7080 if Ekind (It.Typ) /= E_Access_Subprogram_Type then 7081 Remove_Interp (I); 7082 end if; 7083 7084 Get_Next_Interp (I, It); 7085 end loop; 7086 7087 New_N := 7088 Make_Function_Call (Loc, 7089 Name => 7090 Make_Explicit_Dereference (Loc, 7091 Prefix => P), 7092 Parameter_Associations => New_List); 7093 7094 Save_Interps (N, New_N); 7095 Rewrite (N, New_N); 7096 Analyze_And_Resolve (N, Typ); 7097 return; 7098 end if; 7099 7100 -- If not overloaded, resolve P with its own type 7101 7102 else 7103 Resolve (P); 7104 end if; 7105 7106 if Is_Access_Type (Etype (P)) then 7107 Apply_Access_Check (N); 7108 end if; 7109 7110 -- If the designated type is a packed unconstrained array type, and the 7111 -- explicit dereference is not in the context of an attribute reference, 7112 -- then we must compute and set the actual subtype, since it is needed 7113 -- by Gigi. The reason we exclude the attribute case is that this is 7114 -- handled fine by Gigi, and in fact we use such attributes to build the 7115 -- actual subtype. We also exclude generated code (which builds actual 7116 -- subtypes directly if they are needed). 7117 7118 if Is_Array_Type (Etype (N)) 7119 and then Is_Packed (Etype (N)) 7120 and then not Is_Constrained (Etype (N)) 7121 and then Nkind (Parent (N)) /= N_Attribute_Reference 7122 and then Comes_From_Source (N) 7123 then 7124 Set_Etype (N, Get_Actual_Subtype (N)); 7125 end if; 7126 7127 -- Note: No Eval processing is required for an explicit dereference, 7128 -- because such a name can never be static. 7129 7130 end Resolve_Explicit_Dereference; 7131 7132 ------------------------------------- 7133 -- Resolve_Expression_With_Actions -- 7134 ------------------------------------- 7135 7136 procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id) is 7137 begin 7138 Set_Etype (N, Typ); 7139 end Resolve_Expression_With_Actions; 7140 7141 --------------------------- 7142 -- Resolve_If_Expression -- 7143 --------------------------- 7144 7145 procedure Resolve_If_Expression (N : Node_Id; Typ : Entity_Id) is 7146 Condition : constant Node_Id := First (Expressions (N)); 7147 Then_Expr : constant Node_Id := Next (Condition); 7148 Else_Expr : Node_Id := Next (Then_Expr); 7149 Else_Typ : Entity_Id; 7150 Then_Typ : Entity_Id; 7151 7152 begin 7153 Resolve (Condition, Any_Boolean); 7154 Resolve (Then_Expr, Typ); 7155 Then_Typ := Etype (Then_Expr); 7156 7157 -- When the "then" expression is of a scalar subtype different from the 7158 -- result subtype, then insert a conversion to ensure the generation of 7159 -- a constraint check. The same is done for the else part below, again 7160 -- comparing subtypes rather than base types. 7161 7162 if Is_Scalar_Type (Then_Typ) 7163 and then Then_Typ /= Typ 7164 then 7165 Rewrite (Then_Expr, Convert_To (Typ, Then_Expr)); 7166 Analyze_And_Resolve (Then_Expr, Typ); 7167 end if; 7168 7169 -- If ELSE expression present, just resolve using the determined type 7170 7171 if Present (Else_Expr) then 7172 Resolve (Else_Expr, Typ); 7173 Else_Typ := Etype (Else_Expr); 7174 7175 if Is_Scalar_Type (Else_Typ) 7176 and then Else_Typ /= Typ 7177 then 7178 Rewrite (Else_Expr, Convert_To (Typ, Else_Expr)); 7179 Analyze_And_Resolve (Else_Expr, Typ); 7180 end if; 7181 7182 -- If no ELSE expression is present, root type must be Standard.Boolean 7183 -- and we provide a Standard.True result converted to the appropriate 7184 -- Boolean type (in case it is a derived boolean type). 7185 7186 elsif Root_Type (Typ) = Standard_Boolean then 7187 Else_Expr := 7188 Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N))); 7189 Analyze_And_Resolve (Else_Expr, Typ); 7190 Append_To (Expressions (N), Else_Expr); 7191 7192 else 7193 Error_Msg_N ("can only omit ELSE expression in Boolean case", N); 7194 Append_To (Expressions (N), Error); 7195 end if; 7196 7197 Set_Etype (N, Typ); 7198 Eval_If_Expression (N); 7199 end Resolve_If_Expression; 7200 7201 ------------------------------- 7202 -- Resolve_Indexed_Component -- 7203 ------------------------------- 7204 7205 procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id) is 7206 Name : constant Node_Id := Prefix (N); 7207 Expr : Node_Id; 7208 Array_Type : Entity_Id := Empty; -- to prevent junk warning 7209 Index : Node_Id; 7210 7211 begin 7212 if Is_Overloaded (Name) then 7213 7214 -- Use the context type to select the prefix that yields the correct 7215 -- component type. 7216 7217 declare 7218 I : Interp_Index; 7219 It : Interp; 7220 I1 : Interp_Index := 0; 7221 P : constant Node_Id := Prefix (N); 7222 Found : Boolean := False; 7223 7224 begin 7225 Get_First_Interp (P, I, It); 7226 while Present (It.Typ) loop 7227 if (Is_Array_Type (It.Typ) 7228 and then Covers (Typ, Component_Type (It.Typ))) 7229 or else (Is_Access_Type (It.Typ) 7230 and then Is_Array_Type (Designated_Type (It.Typ)) 7231 and then 7232 Covers 7233 (Typ, 7234 Component_Type (Designated_Type (It.Typ)))) 7235 then 7236 if Found then 7237 It := Disambiguate (P, I1, I, Any_Type); 7238 7239 if It = No_Interp then 7240 Error_Msg_N ("ambiguous prefix for indexing", N); 7241 Set_Etype (N, Typ); 7242 return; 7243 7244 else 7245 Found := True; 7246 Array_Type := It.Typ; 7247 I1 := I; 7248 end if; 7249 7250 else 7251 Found := True; 7252 Array_Type := It.Typ; 7253 I1 := I; 7254 end if; 7255 end if; 7256 7257 Get_Next_Interp (I, It); 7258 end loop; 7259 end; 7260 7261 else 7262 Array_Type := Etype (Name); 7263 end if; 7264 7265 Resolve (Name, Array_Type); 7266 Array_Type := Get_Actual_Subtype_If_Available (Name); 7267 7268 -- If prefix is access type, dereference to get real array type. 7269 -- Note: we do not apply an access check because the expander always 7270 -- introduces an explicit dereference, and the check will happen there. 7271 7272 if Is_Access_Type (Array_Type) then 7273 Array_Type := Designated_Type (Array_Type); 7274 end if; 7275 7276 -- If name was overloaded, set component type correctly now 7277 -- If a misplaced call to an entry family (which has no index types) 7278 -- return. Error will be diagnosed from calling context. 7279 7280 if Is_Array_Type (Array_Type) then 7281 Set_Etype (N, Component_Type (Array_Type)); 7282 else 7283 return; 7284 end if; 7285 7286 Index := First_Index (Array_Type); 7287 Expr := First (Expressions (N)); 7288 7289 -- The prefix may have resolved to a string literal, in which case its 7290 -- etype has a special representation. This is only possible currently 7291 -- if the prefix is a static concatenation, written in functional 7292 -- notation. 7293 7294 if Ekind (Array_Type) = E_String_Literal_Subtype then 7295 Resolve (Expr, Standard_Positive); 7296 7297 else 7298 while Present (Index) and Present (Expr) loop 7299 Resolve (Expr, Etype (Index)); 7300 Check_Unset_Reference (Expr); 7301 7302 if Is_Scalar_Type (Etype (Expr)) then 7303 Apply_Scalar_Range_Check (Expr, Etype (Index)); 7304 else 7305 Apply_Range_Check (Expr, Get_Actual_Subtype (Index)); 7306 end if; 7307 7308 Next_Index (Index); 7309 Next (Expr); 7310 end loop; 7311 end if; 7312 7313 Analyze_Dimension (N); 7314 7315 -- Do not generate the warning on suspicious index if we are analyzing 7316 -- package Ada.Tags; otherwise we will report the warning with the 7317 -- Prims_Ptr field of the dispatch table. 7318 7319 if Scope (Etype (Prefix (N))) = Standard_Standard 7320 or else not 7321 Is_RTU (Cunit_Entity (Get_Source_Unit (Etype (Prefix (N)))), 7322 Ada_Tags) 7323 then 7324 Warn_On_Suspicious_Index (Name, First (Expressions (N))); 7325 Eval_Indexed_Component (N); 7326 end if; 7327 7328 -- If the array type is atomic, and is packed, and we are in a left side 7329 -- context, then this is worth a warning, since we have a situation 7330 -- where the access to the component may cause extra read/writes of 7331 -- the atomic array object, which could be considered unexpected. 7332 7333 if Nkind (N) = N_Indexed_Component 7334 and then (Is_Atomic (Array_Type) 7335 or else (Is_Entity_Name (Prefix (N)) 7336 and then Is_Atomic (Entity (Prefix (N))))) 7337 and then Is_Bit_Packed_Array (Array_Type) 7338 and then Is_LHS (N) 7339 then 7340 Error_Msg_N ("??assignment to component of packed atomic array", 7341 Prefix (N)); 7342 Error_Msg_N ("??\may cause unexpected accesses to atomic object", 7343 Prefix (N)); 7344 end if; 7345 end Resolve_Indexed_Component; 7346 7347 ----------------------------- 7348 -- Resolve_Integer_Literal -- 7349 ----------------------------- 7350 7351 procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id) is 7352 begin 7353 Set_Etype (N, Typ); 7354 Eval_Integer_Literal (N); 7355 end Resolve_Integer_Literal; 7356 7357 -------------------------------- 7358 -- Resolve_Intrinsic_Operator -- 7359 -------------------------------- 7360 7361 procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is 7362 Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); 7363 Op : Entity_Id; 7364 Orig_Op : constant Entity_Id := Entity (N); 7365 Arg1 : Node_Id; 7366 Arg2 : Node_Id; 7367 7368 function Convert_Operand (Opnd : Node_Id) return Node_Id; 7369 -- If the operand is a literal, it cannot be the expression in a 7370 -- conversion. Use a qualified expression instead. 7371 7372 function Convert_Operand (Opnd : Node_Id) return Node_Id is 7373 Loc : constant Source_Ptr := Sloc (Opnd); 7374 Res : Node_Id; 7375 begin 7376 if Nkind_In (Opnd, N_Integer_Literal, N_Real_Literal) then 7377 Res := 7378 Make_Qualified_Expression (Loc, 7379 Subtype_Mark => New_Occurrence_Of (Btyp, Loc), 7380 Expression => Relocate_Node (Opnd)); 7381 Analyze (Res); 7382 7383 else 7384 Res := Unchecked_Convert_To (Btyp, Opnd); 7385 end if; 7386 7387 return Res; 7388 end Convert_Operand; 7389 7390 -- Start of processing for Resolve_Intrinsic_Operator 7391 7392 begin 7393 -- We must preserve the original entity in a generic setting, so that 7394 -- the legality of the operation can be verified in an instance. 7395 7396 if not Full_Expander_Active then 7397 return; 7398 end if; 7399 7400 Op := Entity (N); 7401 while Scope (Op) /= Standard_Standard loop 7402 Op := Homonym (Op); 7403 pragma Assert (Present (Op)); 7404 end loop; 7405 7406 Set_Entity (N, Op); 7407 Set_Is_Overloaded (N, False); 7408 7409 -- If the result or operand types are private, rewrite with unchecked 7410 -- conversions on the operands and the result, to expose the proper 7411 -- underlying numeric type. 7412 7413 if Is_Private_Type (Typ) 7414 or else Is_Private_Type (Etype (Left_Opnd (N))) 7415 or else Is_Private_Type (Etype (Right_Opnd (N))) 7416 then 7417 Arg1 := Convert_Operand (Left_Opnd (N)); 7418 -- Unchecked_Convert_To (Btyp, Left_Opnd (N)); 7419 -- What on earth is this commented out fragment of code??? 7420 7421 if Nkind (N) = N_Op_Expon then 7422 Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N)); 7423 else 7424 Arg2 := Convert_Operand (Right_Opnd (N)); 7425 end if; 7426 7427 if Nkind (Arg1) = N_Type_Conversion then 7428 Save_Interps (Left_Opnd (N), Expression (Arg1)); 7429 end if; 7430 7431 if Nkind (Arg2) = N_Type_Conversion then 7432 Save_Interps (Right_Opnd (N), Expression (Arg2)); 7433 end if; 7434 7435 Set_Left_Opnd (N, Arg1); 7436 Set_Right_Opnd (N, Arg2); 7437 7438 Set_Etype (N, Btyp); 7439 Rewrite (N, Unchecked_Convert_To (Typ, N)); 7440 Resolve (N, Typ); 7441 7442 elsif Typ /= Etype (Left_Opnd (N)) 7443 or else Typ /= Etype (Right_Opnd (N)) 7444 then 7445 -- Add explicit conversion where needed, and save interpretations in 7446 -- case operands are overloaded. If the context is a VMS operation, 7447 -- assert that the conversion is legal (the operands have the proper 7448 -- types to select the VMS intrinsic). Note that in rare cases the 7449 -- VMS operators may be visible, but the default System is being used 7450 -- and Address is a private type. 7451 7452 Arg1 := Convert_To (Typ, Left_Opnd (N)); 7453 Arg2 := Convert_To (Typ, Right_Opnd (N)); 7454 7455 if Nkind (Arg1) = N_Type_Conversion then 7456 Save_Interps (Left_Opnd (N), Expression (Arg1)); 7457 7458 if Is_VMS_Operator (Orig_Op) then 7459 Set_Conversion_OK (Arg1); 7460 end if; 7461 else 7462 Save_Interps (Left_Opnd (N), Arg1); 7463 end if; 7464 7465 if Nkind (Arg2) = N_Type_Conversion then 7466 Save_Interps (Right_Opnd (N), Expression (Arg2)); 7467 7468 if Is_VMS_Operator (Orig_Op) then 7469 Set_Conversion_OK (Arg2); 7470 end if; 7471 else 7472 Save_Interps (Right_Opnd (N), Arg2); 7473 end if; 7474 7475 Rewrite (Left_Opnd (N), Arg1); 7476 Rewrite (Right_Opnd (N), Arg2); 7477 Analyze (Arg1); 7478 Analyze (Arg2); 7479 Resolve_Arithmetic_Op (N, Typ); 7480 7481 else 7482 Resolve_Arithmetic_Op (N, Typ); 7483 end if; 7484 end Resolve_Intrinsic_Operator; 7485 7486 -------------------------------------- 7487 -- Resolve_Intrinsic_Unary_Operator -- 7488 -------------------------------------- 7489 7490 procedure Resolve_Intrinsic_Unary_Operator 7491 (N : Node_Id; 7492 Typ : Entity_Id) 7493 is 7494 Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); 7495 Op : Entity_Id; 7496 Arg2 : Node_Id; 7497 7498 begin 7499 Op := Entity (N); 7500 while Scope (Op) /= Standard_Standard loop 7501 Op := Homonym (Op); 7502 pragma Assert (Present (Op)); 7503 end loop; 7504 7505 Set_Entity (N, Op); 7506 7507 if Is_Private_Type (Typ) then 7508 Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N)); 7509 Save_Interps (Right_Opnd (N), Expression (Arg2)); 7510 7511 Set_Right_Opnd (N, Arg2); 7512 7513 Set_Etype (N, Btyp); 7514 Rewrite (N, Unchecked_Convert_To (Typ, N)); 7515 Resolve (N, Typ); 7516 7517 else 7518 Resolve_Unary_Op (N, Typ); 7519 end if; 7520 end Resolve_Intrinsic_Unary_Operator; 7521 7522 ------------------------ 7523 -- Resolve_Logical_Op -- 7524 ------------------------ 7525 7526 procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is 7527 B_Typ : Entity_Id; 7528 7529 begin 7530 Check_No_Direct_Boolean_Operators (N); 7531 7532 -- Predefined operations on scalar types yield the base type. On the 7533 -- other hand, logical operations on arrays yield the type of the 7534 -- arguments (and the context). 7535 7536 if Is_Array_Type (Typ) then 7537 B_Typ := Typ; 7538 else 7539 B_Typ := Base_Type (Typ); 7540 end if; 7541 7542 -- OK if this is a VMS-specific intrinsic operation 7543 7544 if Is_VMS_Operator (Entity (N)) then 7545 null; 7546 7547 -- The following test is required because the operands of the operation 7548 -- may be literals, in which case the resulting type appears to be 7549 -- compatible with a signed integer type, when in fact it is compatible 7550 -- only with modular types. If the context itself is universal, the 7551 -- operation is illegal. 7552 7553 elsif not Valid_Boolean_Arg (Typ) then 7554 Error_Msg_N ("invalid context for logical operation", N); 7555 Set_Etype (N, Any_Type); 7556 return; 7557 7558 elsif Typ = Any_Modular then 7559 Error_Msg_N 7560 ("no modular type available in this context", N); 7561 Set_Etype (N, Any_Type); 7562 return; 7563 7564 elsif Is_Modular_Integer_Type (Typ) 7565 and then Etype (Left_Opnd (N)) = Universal_Integer 7566 and then Etype (Right_Opnd (N)) = Universal_Integer 7567 then 7568 Check_For_Visible_Operator (N, B_Typ); 7569 end if; 7570 7571 -- Replace AND by AND THEN, or OR by OR ELSE, if Short_Circuit_And_Or 7572 -- is active and the result type is standard Boolean (do not mess with 7573 -- ops that return a nonstandard Boolean type, because something strange 7574 -- is going on). 7575 7576 -- Note: you might expect this replacement to be done during expansion, 7577 -- but that doesn't work, because when the pragma Short_Circuit_And_Or 7578 -- is used, no part of the right operand of an "and" or "or" operator 7579 -- should be executed if the left operand would short-circuit the 7580 -- evaluation of the corresponding "and then" or "or else". If we left 7581 -- the replacement to expansion time, then run-time checks associated 7582 -- with such operands would be evaluated unconditionally, due to being 7583 -- before the condition prior to the rewriting as short-circuit forms 7584 -- during expansion. 7585 7586 if Short_Circuit_And_Or 7587 and then B_Typ = Standard_Boolean 7588 and then Nkind_In (N, N_Op_And, N_Op_Or) 7589 then 7590 if Nkind (N) = N_Op_And then 7591 Rewrite (N, 7592 Make_And_Then (Sloc (N), 7593 Left_Opnd => Relocate_Node (Left_Opnd (N)), 7594 Right_Opnd => Relocate_Node (Right_Opnd (N)))); 7595 Analyze_And_Resolve (N, B_Typ); 7596 7597 -- Case of OR changed to OR ELSE 7598 7599 else 7600 Rewrite (N, 7601 Make_Or_Else (Sloc (N), 7602 Left_Opnd => Relocate_Node (Left_Opnd (N)), 7603 Right_Opnd => Relocate_Node (Right_Opnd (N)))); 7604 Analyze_And_Resolve (N, B_Typ); 7605 end if; 7606 7607 -- Return now, since analysis of the rewritten ops will take care of 7608 -- other reference bookkeeping and expression folding. 7609 7610 return; 7611 end if; 7612 7613 Resolve (Left_Opnd (N), B_Typ); 7614 Resolve (Right_Opnd (N), B_Typ); 7615 7616 Check_Unset_Reference (Left_Opnd (N)); 7617 Check_Unset_Reference (Right_Opnd (N)); 7618 7619 Set_Etype (N, B_Typ); 7620 Generate_Operator_Reference (N, B_Typ); 7621 Eval_Logical_Op (N); 7622 7623 -- In SPARK, logical operations AND, OR and XOR for arrays are defined 7624 -- only when both operands have same static lower and higher bounds. Of 7625 -- course the types have to match, so only check if operands are 7626 -- compatible and the node itself has no errors. 7627 7628 if Is_Array_Type (B_Typ) 7629 and then Nkind (N) in N_Binary_Op 7630 then 7631 declare 7632 Left_Typ : constant Node_Id := Etype (Left_Opnd (N)); 7633 Right_Typ : constant Node_Id := Etype (Right_Opnd (N)); 7634 7635 begin 7636 -- Protect call to Matching_Static_Array_Bounds to avoid costly 7637 -- operation if not needed. 7638 7639 if Restriction_Check_Required (SPARK) 7640 and then Base_Type (Left_Typ) = Base_Type (Right_Typ) 7641 and then Left_Typ /= Any_Composite -- or Left_Opnd in error 7642 and then Right_Typ /= Any_Composite -- or Right_Opnd in error 7643 and then not Matching_Static_Array_Bounds (Left_Typ, Right_Typ) 7644 then 7645 Check_SPARK_Restriction 7646 ("array types should have matching static bounds", N); 7647 end if; 7648 end; 7649 end if; 7650 7651 Check_Function_Writable_Actuals (N); 7652 end Resolve_Logical_Op; 7653 7654 --------------------------- 7655 -- Resolve_Membership_Op -- 7656 --------------------------- 7657 7658 -- The context can only be a boolean type, and does not determine the 7659 -- arguments. Arguments should be unambiguous, but the preference rule for 7660 -- universal types applies. 7661 7662 procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is 7663 pragma Warnings (Off, Typ); 7664 7665 L : constant Node_Id := Left_Opnd (N); 7666 R : constant Node_Id := Right_Opnd (N); 7667 T : Entity_Id; 7668 7669 procedure Resolve_Set_Membership; 7670 -- Analysis has determined a unique type for the left operand. Use it to 7671 -- resolve the disjuncts. 7672 7673 ---------------------------- 7674 -- Resolve_Set_Membership -- 7675 ---------------------------- 7676 7677 procedure Resolve_Set_Membership is 7678 Alt : Node_Id; 7679 Ltyp : constant Entity_Id := Etype (L); 7680 7681 begin 7682 Resolve (L, Ltyp); 7683 7684 Alt := First (Alternatives (N)); 7685 while Present (Alt) loop 7686 7687 -- Alternative is an expression, a range 7688 -- or a subtype mark. 7689 7690 if not Is_Entity_Name (Alt) 7691 or else not Is_Type (Entity (Alt)) 7692 then 7693 Resolve (Alt, Ltyp); 7694 end if; 7695 7696 Next (Alt); 7697 end loop; 7698 7699 -- Check for duplicates for discrete case 7700 7701 if Is_Discrete_Type (Ltyp) then 7702 declare 7703 type Ent is record 7704 Alt : Node_Id; 7705 Val : Uint; 7706 end record; 7707 7708 Alts : array (0 .. List_Length (Alternatives (N))) of Ent; 7709 Nalts : Nat; 7710 7711 begin 7712 -- Loop checking duplicates. This is quadratic, but giant sets 7713 -- are unlikely in this context so it's a reasonable choice. 7714 7715 Nalts := 0; 7716 Alt := First (Alternatives (N)); 7717 while Present (Alt) loop 7718 if Is_Static_Expression (Alt) 7719 and then (Nkind_In (Alt, N_Integer_Literal, 7720 N_Character_Literal) 7721 or else Nkind (Alt) in N_Has_Entity) 7722 then 7723 Nalts := Nalts + 1; 7724 Alts (Nalts) := (Alt, Expr_Value (Alt)); 7725 7726 for J in 1 .. Nalts - 1 loop 7727 if Alts (J).Val = Alts (Nalts).Val then 7728 Error_Msg_Sloc := Sloc (Alts (J).Alt); 7729 Error_Msg_N ("duplicate of value given#??", Alt); 7730 end if; 7731 end loop; 7732 end if; 7733 7734 Alt := Next (Alt); 7735 end loop; 7736 end; 7737 end if; 7738 end Resolve_Set_Membership; 7739 7740 -- Start of processing for Resolve_Membership_Op 7741 7742 begin 7743 if L = Error or else R = Error then 7744 return; 7745 end if; 7746 7747 if Present (Alternatives (N)) then 7748 Resolve_Set_Membership; 7749 Check_Function_Writable_Actuals (N); 7750 return; 7751 7752 elsif not Is_Overloaded (R) 7753 and then 7754 (Etype (R) = Universal_Integer 7755 or else 7756 Etype (R) = Universal_Real) 7757 and then Is_Overloaded (L) 7758 then 7759 T := Etype (R); 7760 7761 -- Ada 2005 (AI-251): Support the following case: 7762 7763 -- type I is interface; 7764 -- type T is tagged ... 7765 7766 -- function Test (O : I'Class) is 7767 -- begin 7768 -- return O in T'Class. 7769 -- end Test; 7770 7771 -- In this case we have nothing else to do. The membership test will be 7772 -- done at run time. 7773 7774 elsif Ada_Version >= Ada_2005 7775 and then Is_Class_Wide_Type (Etype (L)) 7776 and then Is_Interface (Etype (L)) 7777 and then Is_Class_Wide_Type (Etype (R)) 7778 and then not Is_Interface (Etype (R)) 7779 then 7780 return; 7781 else 7782 T := Intersect_Types (L, R); 7783 end if; 7784 7785 -- If mixed-mode operations are present and operands are all literal, 7786 -- the only interpretation involves Duration, which is probably not 7787 -- the intention of the programmer. 7788 7789 if T = Any_Fixed then 7790 T := Unique_Fixed_Point_Type (N); 7791 7792 if T = Any_Type then 7793 return; 7794 end if; 7795 end if; 7796 7797 Resolve (L, T); 7798 Check_Unset_Reference (L); 7799 7800 if Nkind (R) = N_Range 7801 and then not Is_Scalar_Type (T) 7802 then 7803 Error_Msg_N ("scalar type required for range", R); 7804 end if; 7805 7806 if Is_Entity_Name (R) then 7807 Freeze_Expression (R); 7808 else 7809 Resolve (R, T); 7810 Check_Unset_Reference (R); 7811 end if; 7812 7813 Eval_Membership_Op (N); 7814 Check_Function_Writable_Actuals (N); 7815 end Resolve_Membership_Op; 7816 7817 ------------------ 7818 -- Resolve_Null -- 7819 ------------------ 7820 7821 procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is 7822 Loc : constant Source_Ptr := Sloc (N); 7823 7824 begin 7825 -- Handle restriction against anonymous null access values This 7826 -- restriction can be turned off using -gnatdj. 7827 7828 -- Ada 2005 (AI-231): Remove restriction 7829 7830 if Ada_Version < Ada_2005 7831 and then not Debug_Flag_J 7832 and then Ekind (Typ) = E_Anonymous_Access_Type 7833 and then Comes_From_Source (N) 7834 then 7835 -- In the common case of a call which uses an explicitly null value 7836 -- for an access parameter, give specialized error message. 7837 7838 if Nkind (Parent (N)) in N_Subprogram_Call then 7839 Error_Msg_N 7840 ("null is not allowed as argument for an access parameter", N); 7841 7842 -- Standard message for all other cases (are there any?) 7843 7844 else 7845 Error_Msg_N 7846 ("null cannot be of an anonymous access type", N); 7847 end if; 7848 end if; 7849 7850 -- Ada 2005 (AI-231): Generate the null-excluding check in case of 7851 -- assignment to a null-excluding object 7852 7853 if Ada_Version >= Ada_2005 7854 and then Can_Never_Be_Null (Typ) 7855 and then Nkind (Parent (N)) = N_Assignment_Statement 7856 then 7857 if not Inside_Init_Proc then 7858 Insert_Action 7859 (Compile_Time_Constraint_Error (N, 7860 "(Ada 2005) null not allowed in null-excluding objects??"), 7861 Make_Raise_Constraint_Error (Loc, 7862 Reason => CE_Access_Check_Failed)); 7863 else 7864 Insert_Action (N, 7865 Make_Raise_Constraint_Error (Loc, 7866 Reason => CE_Access_Check_Failed)); 7867 end if; 7868 end if; 7869 7870 -- In a distributed context, null for a remote access to subprogram may 7871 -- need to be replaced with a special record aggregate. In this case, 7872 -- return after having done the transformation. 7873 7874 if (Ekind (Typ) = E_Record_Type 7875 or else Is_Remote_Access_To_Subprogram_Type (Typ)) 7876 and then Remote_AST_Null_Value (N, Typ) 7877 then 7878 return; 7879 end if; 7880 7881 -- The null literal takes its type from the context 7882 7883 Set_Etype (N, Typ); 7884 end Resolve_Null; 7885 7886 ----------------------- 7887 -- Resolve_Op_Concat -- 7888 ----------------------- 7889 7890 procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is 7891 7892 -- We wish to avoid deep recursion, because concatenations are often 7893 -- deeply nested, as in A&B&...&Z. Therefore, we walk down the left 7894 -- operands nonrecursively until we find something that is not a simple 7895 -- concatenation (A in this case). We resolve that, and then walk back 7896 -- up the tree following Parent pointers, calling Resolve_Op_Concat_Rest 7897 -- to do the rest of the work at each level. The Parent pointers allow 7898 -- us to avoid recursion, and thus avoid running out of memory. See also 7899 -- Sem_Ch4.Analyze_Concatenation, where a similar approach is used. 7900 7901 NN : Node_Id := N; 7902 Op1 : Node_Id; 7903 7904 begin 7905 -- The following code is equivalent to: 7906 7907 -- Resolve_Op_Concat_First (NN, Typ); 7908 -- Resolve_Op_Concat_Arg (N, ...); 7909 -- Resolve_Op_Concat_Rest (N, Typ); 7910 7911 -- where the Resolve_Op_Concat_Arg call recurses back here if the left 7912 -- operand is a concatenation. 7913 7914 -- Walk down left operands 7915 7916 loop 7917 Resolve_Op_Concat_First (NN, Typ); 7918 Op1 := Left_Opnd (NN); 7919 exit when not (Nkind (Op1) = N_Op_Concat 7920 and then not Is_Array_Type (Component_Type (Typ)) 7921 and then Entity (Op1) = Entity (NN)); 7922 NN := Op1; 7923 end loop; 7924 7925 -- Now (given the above example) NN is A&B and Op1 is A 7926 7927 -- First resolve Op1 ... 7928 7929 Resolve_Op_Concat_Arg (NN, Op1, Typ, Is_Component_Left_Opnd (NN)); 7930 7931 -- ... then walk NN back up until we reach N (where we started), calling 7932 -- Resolve_Op_Concat_Rest along the way. 7933 7934 loop 7935 Resolve_Op_Concat_Rest (NN, Typ); 7936 exit when NN = N; 7937 NN := Parent (NN); 7938 end loop; 7939 7940 if Base_Type (Etype (N)) /= Standard_String then 7941 Check_SPARK_Restriction 7942 ("result of concatenation should have type String", N); 7943 end if; 7944 end Resolve_Op_Concat; 7945 7946 --------------------------- 7947 -- Resolve_Op_Concat_Arg -- 7948 --------------------------- 7949 7950 procedure Resolve_Op_Concat_Arg 7951 (N : Node_Id; 7952 Arg : Node_Id; 7953 Typ : Entity_Id; 7954 Is_Comp : Boolean) 7955 is 7956 Btyp : constant Entity_Id := Base_Type (Typ); 7957 Ctyp : constant Entity_Id := Component_Type (Typ); 7958 7959 begin 7960 if In_Instance then 7961 if Is_Comp 7962 or else (not Is_Overloaded (Arg) 7963 and then Etype (Arg) /= Any_Composite 7964 and then Covers (Ctyp, Etype (Arg))) 7965 then 7966 Resolve (Arg, Ctyp); 7967 else 7968 Resolve (Arg, Btyp); 7969 end if; 7970 7971 -- If both Array & Array and Array & Component are visible, there is a 7972 -- potential ambiguity that must be reported. 7973 7974 elsif Has_Compatible_Type (Arg, Ctyp) then 7975 if Nkind (Arg) = N_Aggregate 7976 and then Is_Composite_Type (Ctyp) 7977 then 7978 if Is_Private_Type (Ctyp) then 7979 Resolve (Arg, Btyp); 7980 7981 -- If the operation is user-defined and not overloaded use its 7982 -- profile. The operation may be a renaming, in which case it has 7983 -- been rewritten, and we want the original profile. 7984 7985 elsif not Is_Overloaded (N) 7986 and then Comes_From_Source (Entity (Original_Node (N))) 7987 and then Ekind (Entity (Original_Node (N))) = E_Function 7988 then 7989 Resolve (Arg, 7990 Etype 7991 (Next_Formal (First_Formal (Entity (Original_Node (N)))))); 7992 return; 7993 7994 -- Otherwise an aggregate may match both the array type and the 7995 -- component type. 7996 7997 else 7998 Error_Msg_N ("ambiguous aggregate must be qualified", Arg); 7999 Set_Etype (Arg, Any_Type); 8000 end if; 8001 8002 else 8003 if Is_Overloaded (Arg) 8004 and then Has_Compatible_Type (Arg, Typ) 8005 and then Etype (Arg) /= Any_Type 8006 then 8007 declare 8008 I : Interp_Index; 8009 It : Interp; 8010 Func : Entity_Id; 8011 8012 begin 8013 Get_First_Interp (Arg, I, It); 8014 Func := It.Nam; 8015 Get_Next_Interp (I, It); 8016 8017 -- Special-case the error message when the overloading is 8018 -- caused by a function that yields an array and can be 8019 -- called without parameters. 8020 8021 if It.Nam = Func then 8022 Error_Msg_Sloc := Sloc (Func); 8023 Error_Msg_N ("ambiguous call to function#", Arg); 8024 Error_Msg_NE 8025 ("\\interpretation as call yields&", Arg, Typ); 8026 Error_Msg_NE 8027 ("\\interpretation as indexing of call yields&", 8028 Arg, Component_Type (Typ)); 8029 8030 else 8031 Error_Msg_N ("ambiguous operand for concatenation!", Arg); 8032 8033 Get_First_Interp (Arg, I, It); 8034 while Present (It.Nam) loop 8035 Error_Msg_Sloc := Sloc (It.Nam); 8036 8037 if Base_Type (It.Typ) = Btyp 8038 or else 8039 Base_Type (It.Typ) = Base_Type (Ctyp) 8040 then 8041 Error_Msg_N -- CODEFIX 8042 ("\\possible interpretation#", Arg); 8043 end if; 8044 8045 Get_Next_Interp (I, It); 8046 end loop; 8047 end if; 8048 end; 8049 end if; 8050 8051 Resolve (Arg, Component_Type (Typ)); 8052 8053 if Nkind (Arg) = N_String_Literal then 8054 Set_Etype (Arg, Component_Type (Typ)); 8055 end if; 8056 8057 if Arg = Left_Opnd (N) then 8058 Set_Is_Component_Left_Opnd (N); 8059 else 8060 Set_Is_Component_Right_Opnd (N); 8061 end if; 8062 end if; 8063 8064 else 8065 Resolve (Arg, Btyp); 8066 end if; 8067 8068 -- Concatenation is restricted in SPARK: each operand must be either a 8069 -- string literal, the name of a string constant, a static character or 8070 -- string expression, or another concatenation. Arg cannot be a 8071 -- concatenation here as callers of Resolve_Op_Concat_Arg call it 8072 -- separately on each final operand, past concatenation operations. 8073 8074 if Is_Character_Type (Etype (Arg)) then 8075 if not Is_Static_Expression (Arg) then 8076 Check_SPARK_Restriction 8077 ("character operand for concatenation should be static", Arg); 8078 end if; 8079 8080 elsif Is_String_Type (Etype (Arg)) then 8081 if not (Nkind_In (Arg, N_Identifier, N_Expanded_Name) 8082 and then Is_Constant_Object (Entity (Arg))) 8083 and then not Is_Static_Expression (Arg) 8084 then 8085 Check_SPARK_Restriction 8086 ("string operand for concatenation should be static", Arg); 8087 end if; 8088 8089 -- Do not issue error on an operand that is neither a character nor a 8090 -- string, as the error is issued in Resolve_Op_Concat. 8091 8092 else 8093 null; 8094 end if; 8095 8096 Check_Unset_Reference (Arg); 8097 end Resolve_Op_Concat_Arg; 8098 8099 ----------------------------- 8100 -- Resolve_Op_Concat_First -- 8101 ----------------------------- 8102 8103 procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id) is 8104 Btyp : constant Entity_Id := Base_Type (Typ); 8105 Op1 : constant Node_Id := Left_Opnd (N); 8106 Op2 : constant Node_Id := Right_Opnd (N); 8107 8108 begin 8109 -- The parser folds an enormous sequence of concatenations of string 8110 -- literals into "" & "...", where the Is_Folded_In_Parser flag is set 8111 -- in the right operand. If the expression resolves to a predefined "&" 8112 -- operator, all is well. Otherwise, the parser's folding is wrong, so 8113 -- we give an error. See P_Simple_Expression in Par.Ch4. 8114 8115 if Nkind (Op2) = N_String_Literal 8116 and then Is_Folded_In_Parser (Op2) 8117 and then Ekind (Entity (N)) = E_Function 8118 then 8119 pragma Assert (Nkind (Op1) = N_String_Literal -- should be "" 8120 and then String_Length (Strval (Op1)) = 0); 8121 Error_Msg_N ("too many user-defined concatenations", N); 8122 return; 8123 end if; 8124 8125 Set_Etype (N, Btyp); 8126 8127 if Is_Limited_Composite (Btyp) then 8128 Error_Msg_N ("concatenation not available for limited array", N); 8129 Explain_Limited_Type (Btyp, N); 8130 end if; 8131 end Resolve_Op_Concat_First; 8132 8133 ---------------------------- 8134 -- Resolve_Op_Concat_Rest -- 8135 ---------------------------- 8136 8137 procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id) is 8138 Op1 : constant Node_Id := Left_Opnd (N); 8139 Op2 : constant Node_Id := Right_Opnd (N); 8140 8141 begin 8142 Resolve_Op_Concat_Arg (N, Op2, Typ, Is_Component_Right_Opnd (N)); 8143 8144 Generate_Operator_Reference (N, Typ); 8145 8146 if Is_String_Type (Typ) then 8147 Eval_Concatenation (N); 8148 end if; 8149 8150 -- If this is not a static concatenation, but the result is a string 8151 -- type (and not an array of strings) ensure that static string operands 8152 -- have their subtypes properly constructed. 8153 8154 if Nkind (N) /= N_String_Literal 8155 and then Is_Character_Type (Component_Type (Typ)) 8156 then 8157 Set_String_Literal_Subtype (Op1, Typ); 8158 Set_String_Literal_Subtype (Op2, Typ); 8159 end if; 8160 end Resolve_Op_Concat_Rest; 8161 8162 ---------------------- 8163 -- Resolve_Op_Expon -- 8164 ---------------------- 8165 8166 procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id) is 8167 B_Typ : constant Entity_Id := Base_Type (Typ); 8168 8169 begin 8170 -- Catch attempts to do fixed-point exponentiation with universal 8171 -- operands, which is a case where the illegality is not caught during 8172 -- normal operator analysis. 8173 8174 if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then 8175 Error_Msg_N ("exponentiation not available for fixed point", N); 8176 return; 8177 8178 elsif Nkind (Parent (N)) in N_Op 8179 and then Is_Fixed_Point_Type (Etype (Parent (N))) 8180 and then Etype (N) = Universal_Real 8181 and then Comes_From_Source (N) 8182 then 8183 Error_Msg_N ("exponentiation not available for fixed point", N); 8184 return; 8185 end if; 8186 8187 if Comes_From_Source (N) 8188 and then Ekind (Entity (N)) = E_Function 8189 and then Is_Imported (Entity (N)) 8190 and then Is_Intrinsic_Subprogram (Entity (N)) 8191 then 8192 Resolve_Intrinsic_Operator (N, Typ); 8193 return; 8194 end if; 8195 8196 if Etype (Left_Opnd (N)) = Universal_Integer 8197 or else Etype (Left_Opnd (N)) = Universal_Real 8198 then 8199 Check_For_Visible_Operator (N, B_Typ); 8200 end if; 8201 8202 -- We do the resolution using the base type, because intermediate values 8203 -- in expressions always are of the base type, not a subtype of it. 8204 8205 Resolve (Left_Opnd (N), B_Typ); 8206 Resolve (Right_Opnd (N), Standard_Integer); 8207 8208 Check_Unset_Reference (Left_Opnd (N)); 8209 Check_Unset_Reference (Right_Opnd (N)); 8210 8211 Set_Etype (N, B_Typ); 8212 Generate_Operator_Reference (N, B_Typ); 8213 8214 Analyze_Dimension (N); 8215 8216 if Ada_Version >= Ada_2012 and then Has_Dimension_System (B_Typ) then 8217 -- Evaluate the exponentiation operator for dimensioned type 8218 8219 Eval_Op_Expon_For_Dimensioned_Type (N, B_Typ); 8220 else 8221 Eval_Op_Expon (N); 8222 end if; 8223 8224 -- Set overflow checking bit. Much cleverer code needed here eventually 8225 -- and perhaps the Resolve routines should be separated for the various 8226 -- arithmetic operations, since they will need different processing. ??? 8227 8228 if Nkind (N) in N_Op then 8229 if not Overflow_Checks_Suppressed (Etype (N)) then 8230 Enable_Overflow_Check (N); 8231 end if; 8232 end if; 8233 end Resolve_Op_Expon; 8234 8235 -------------------- 8236 -- Resolve_Op_Not -- 8237 -------------------- 8238 8239 procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id) is 8240 B_Typ : Entity_Id; 8241 8242 function Parent_Is_Boolean return Boolean; 8243 -- This function determines if the parent node is a boolean operator or 8244 -- operation (comparison op, membership test, or short circuit form) and 8245 -- the not in question is the left operand of this operation. Note that 8246 -- if the not is in parens, then false is returned. 8247 8248 ----------------------- 8249 -- Parent_Is_Boolean -- 8250 ----------------------- 8251 8252 function Parent_Is_Boolean return Boolean is 8253 begin 8254 if Paren_Count (N) /= 0 then 8255 return False; 8256 8257 else 8258 case Nkind (Parent (N)) is 8259 when N_Op_And | 8260 N_Op_Eq | 8261 N_Op_Ge | 8262 N_Op_Gt | 8263 N_Op_Le | 8264 N_Op_Lt | 8265 N_Op_Ne | 8266 N_Op_Or | 8267 N_Op_Xor | 8268 N_In | 8269 N_Not_In | 8270 N_And_Then | 8271 N_Or_Else => 8272 8273 return Left_Opnd (Parent (N)) = N; 8274 8275 when others => 8276 return False; 8277 end case; 8278 end if; 8279 end Parent_Is_Boolean; 8280 8281 -- Start of processing for Resolve_Op_Not 8282 8283 begin 8284 -- Predefined operations on scalar types yield the base type. On the 8285 -- other hand, logical operations on arrays yield the type of the 8286 -- arguments (and the context). 8287 8288 if Is_Array_Type (Typ) then 8289 B_Typ := Typ; 8290 else 8291 B_Typ := Base_Type (Typ); 8292 end if; 8293 8294 if Is_VMS_Operator (Entity (N)) then 8295 null; 8296 8297 -- Straightforward case of incorrect arguments 8298 8299 elsif not Valid_Boolean_Arg (Typ) then 8300 Error_Msg_N ("invalid operand type for operator&", N); 8301 Set_Etype (N, Any_Type); 8302 return; 8303 8304 -- Special case of probable missing parens 8305 8306 elsif Typ = Universal_Integer or else Typ = Any_Modular then 8307 if Parent_Is_Boolean then 8308 Error_Msg_N 8309 ("operand of not must be enclosed in parentheses", 8310 Right_Opnd (N)); 8311 else 8312 Error_Msg_N 8313 ("no modular type available in this context", N); 8314 end if; 8315 8316 Set_Etype (N, Any_Type); 8317 return; 8318 8319 -- OK resolution of NOT 8320 8321 else 8322 -- Warn if non-boolean types involved. This is a case like not a < b 8323 -- where a and b are modular, where we will get (not a) < b and most 8324 -- likely not (a < b) was intended. 8325 8326 if Warn_On_Questionable_Missing_Parens 8327 and then not Is_Boolean_Type (Typ) 8328 and then Parent_Is_Boolean 8329 then 8330 Error_Msg_N ("?q?not expression should be parenthesized here!", N); 8331 end if; 8332 8333 -- Warn on double negation if checking redundant constructs 8334 8335 if Warn_On_Redundant_Constructs 8336 and then Comes_From_Source (N) 8337 and then Comes_From_Source (Right_Opnd (N)) 8338 and then Root_Type (Typ) = Standard_Boolean 8339 and then Nkind (Right_Opnd (N)) = N_Op_Not 8340 then 8341 Error_Msg_N ("redundant double negation?r?", N); 8342 end if; 8343 8344 -- Complete resolution and evaluation of NOT 8345 8346 Resolve (Right_Opnd (N), B_Typ); 8347 Check_Unset_Reference (Right_Opnd (N)); 8348 Set_Etype (N, B_Typ); 8349 Generate_Operator_Reference (N, B_Typ); 8350 Eval_Op_Not (N); 8351 end if; 8352 end Resolve_Op_Not; 8353 8354 ----------------------------- 8355 -- Resolve_Operator_Symbol -- 8356 ----------------------------- 8357 8358 -- Nothing to be done, all resolved already 8359 8360 procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id) is 8361 pragma Warnings (Off, N); 8362 pragma Warnings (Off, Typ); 8363 8364 begin 8365 null; 8366 end Resolve_Operator_Symbol; 8367 8368 ---------------------------------- 8369 -- Resolve_Qualified_Expression -- 8370 ---------------------------------- 8371 8372 procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id) is 8373 pragma Warnings (Off, Typ); 8374 8375 Target_Typ : constant Entity_Id := Entity (Subtype_Mark (N)); 8376 Expr : constant Node_Id := Expression (N); 8377 8378 begin 8379 Resolve (Expr, Target_Typ); 8380 8381 -- Protect call to Matching_Static_Array_Bounds to avoid costly 8382 -- operation if not needed. 8383 8384 if Restriction_Check_Required (SPARK) 8385 and then Is_Array_Type (Target_Typ) 8386 and then Is_Array_Type (Etype (Expr)) 8387 and then Etype (Expr) /= Any_Composite -- or else Expr in error 8388 and then not Matching_Static_Array_Bounds (Target_Typ, Etype (Expr)) 8389 then 8390 Check_SPARK_Restriction 8391 ("array types should have matching static bounds", N); 8392 end if; 8393 8394 -- A qualified expression requires an exact match of the type, class- 8395 -- wide matching is not allowed. However, if the qualifying type is 8396 -- specific and the expression has a class-wide type, it may still be 8397 -- okay, since it can be the result of the expansion of a call to a 8398 -- dispatching function, so we also have to check class-wideness of the 8399 -- type of the expression's original node. 8400 8401 if (Is_Class_Wide_Type (Target_Typ) 8402 or else 8403 (Is_Class_Wide_Type (Etype (Expr)) 8404 and then Is_Class_Wide_Type (Etype (Original_Node (Expr))))) 8405 and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ) 8406 then 8407 Wrong_Type (Expr, Target_Typ); 8408 end if; 8409 8410 -- If the target type is unconstrained, then we reset the type of the 8411 -- result from the type of the expression. For other cases, the actual 8412 -- subtype of the expression is the target type. 8413 8414 if Is_Composite_Type (Target_Typ) 8415 and then not Is_Constrained (Target_Typ) 8416 then 8417 Set_Etype (N, Etype (Expr)); 8418 end if; 8419 8420 Analyze_Dimension (N); 8421 Eval_Qualified_Expression (N); 8422 end Resolve_Qualified_Expression; 8423 8424 ------------------- 8425 -- Resolve_Range -- 8426 ------------------- 8427 8428 procedure Resolve_Range (N : Node_Id; Typ : Entity_Id) is 8429 L : constant Node_Id := Low_Bound (N); 8430 H : constant Node_Id := High_Bound (N); 8431 8432 function First_Last_Ref return Boolean; 8433 -- Returns True if N is of the form X'First .. X'Last where X is the 8434 -- same entity for both attributes. 8435 8436 -------------------- 8437 -- First_Last_Ref -- 8438 -------------------- 8439 8440 function First_Last_Ref return Boolean is 8441 Lorig : constant Node_Id := Original_Node (L); 8442 Horig : constant Node_Id := Original_Node (H); 8443 8444 begin 8445 if Nkind (Lorig) = N_Attribute_Reference 8446 and then Nkind (Horig) = N_Attribute_Reference 8447 and then Attribute_Name (Lorig) = Name_First 8448 and then Attribute_Name (Horig) = Name_Last 8449 then 8450 declare 8451 PL : constant Node_Id := Prefix (Lorig); 8452 PH : constant Node_Id := Prefix (Horig); 8453 begin 8454 if Is_Entity_Name (PL) 8455 and then Is_Entity_Name (PH) 8456 and then Entity (PL) = Entity (PH) 8457 then 8458 return True; 8459 end if; 8460 end; 8461 end if; 8462 8463 return False; 8464 end First_Last_Ref; 8465 8466 -- Start of processing for Resolve_Range 8467 8468 begin 8469 Set_Etype (N, Typ); 8470 Resolve (L, Typ); 8471 Resolve (H, Typ); 8472 8473 -- Check for inappropriate range on unordered enumeration type 8474 8475 if Bad_Unordered_Enumeration_Reference (N, Typ) 8476 8477 -- Exclude X'First .. X'Last if X is the same entity for both 8478 8479 and then not First_Last_Ref 8480 then 8481 Error_Msg ("subrange of unordered enumeration type?U?", Sloc (N)); 8482 end if; 8483 8484 Check_Unset_Reference (L); 8485 Check_Unset_Reference (H); 8486 8487 -- We have to check the bounds for being within the base range as 8488 -- required for a non-static context. Normally this is automatic and 8489 -- done as part of evaluating expressions, but the N_Range node is an 8490 -- exception, since in GNAT we consider this node to be a subexpression, 8491 -- even though in Ada it is not. The circuit in Sem_Eval could check for 8492 -- this, but that would put the test on the main evaluation path for 8493 -- expressions. 8494 8495 Check_Non_Static_Context (L); 8496 Check_Non_Static_Context (H); 8497 8498 -- Check for an ambiguous range over character literals. This will 8499 -- happen with a membership test involving only literals. 8500 8501 if Typ = Any_Character then 8502 Ambiguous_Character (L); 8503 Set_Etype (N, Any_Type); 8504 return; 8505 end if; 8506 8507 -- If bounds are static, constant-fold them, so size computations are 8508 -- identical between front-end and back-end. Do not perform this 8509 -- transformation while analyzing generic units, as type information 8510 -- would be lost when reanalyzing the constant node in the instance. 8511 8512 if Is_Discrete_Type (Typ) and then Full_Expander_Active then 8513 if Is_OK_Static_Expression (L) then 8514 Fold_Uint (L, Expr_Value (L), Is_Static_Expression (L)); 8515 end if; 8516 8517 if Is_OK_Static_Expression (H) then 8518 Fold_Uint (H, Expr_Value (H), Is_Static_Expression (H)); 8519 end if; 8520 end if; 8521 end Resolve_Range; 8522 8523 -------------------------- 8524 -- Resolve_Real_Literal -- 8525 -------------------------- 8526 8527 procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id) is 8528 Actual_Typ : constant Entity_Id := Etype (N); 8529 8530 begin 8531 -- Special processing for fixed-point literals to make sure that the 8532 -- value is an exact multiple of small where this is required. We skip 8533 -- this for the universal real case, and also for generic types. 8534 8535 if Is_Fixed_Point_Type (Typ) 8536 and then Typ /= Universal_Fixed 8537 and then Typ /= Any_Fixed 8538 and then not Is_Generic_Type (Typ) 8539 then 8540 declare 8541 Val : constant Ureal := Realval (N); 8542 Cintr : constant Ureal := Val / Small_Value (Typ); 8543 Cint : constant Uint := UR_Trunc (Cintr); 8544 Den : constant Uint := Norm_Den (Cintr); 8545 Stat : Boolean; 8546 8547 begin 8548 -- Case of literal is not an exact multiple of the Small 8549 8550 if Den /= 1 then 8551 8552 -- For a source program literal for a decimal fixed-point type, 8553 -- this is statically illegal (RM 4.9(36)). 8554 8555 if Is_Decimal_Fixed_Point_Type (Typ) 8556 and then Actual_Typ = Universal_Real 8557 and then Comes_From_Source (N) 8558 then 8559 Error_Msg_N ("value has extraneous low order digits", N); 8560 end if; 8561 8562 -- Generate a warning if literal from source 8563 8564 if Is_Static_Expression (N) 8565 and then Warn_On_Bad_Fixed_Value 8566 then 8567 Error_Msg_N 8568 ("?b?static fixed-point value is not a multiple of Small!", 8569 N); 8570 end if; 8571 8572 -- Replace literal by a value that is the exact representation 8573 -- of a value of the type, i.e. a multiple of the small value, 8574 -- by truncation, since Machine_Rounds is false for all GNAT 8575 -- fixed-point types (RM 4.9(38)). 8576 8577 Stat := Is_Static_Expression (N); 8578 Rewrite (N, 8579 Make_Real_Literal (Sloc (N), 8580 Realval => Small_Value (Typ) * Cint)); 8581 8582 Set_Is_Static_Expression (N, Stat); 8583 end if; 8584 8585 -- In all cases, set the corresponding integer field 8586 8587 Set_Corresponding_Integer_Value (N, Cint); 8588 end; 8589 end if; 8590 8591 -- Now replace the actual type by the expected type as usual 8592 8593 Set_Etype (N, Typ); 8594 Eval_Real_Literal (N); 8595 end Resolve_Real_Literal; 8596 8597 ----------------------- 8598 -- Resolve_Reference -- 8599 ----------------------- 8600 8601 procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id) is 8602 P : constant Node_Id := Prefix (N); 8603 8604 begin 8605 -- Replace general access with specific type 8606 8607 if Ekind (Etype (N)) = E_Allocator_Type then 8608 Set_Etype (N, Base_Type (Typ)); 8609 end if; 8610 8611 Resolve (P, Designated_Type (Etype (N))); 8612 8613 -- If we are taking the reference of a volatile entity, then treat it as 8614 -- a potential modification of this entity. This is too conservative, 8615 -- but necessary because remove side effects can cause transformations 8616 -- of normal assignments into reference sequences that otherwise fail to 8617 -- notice the modification. 8618 8619 if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then 8620 Note_Possible_Modification (P, Sure => False); 8621 end if; 8622 end Resolve_Reference; 8623 8624 -------------------------------- 8625 -- Resolve_Selected_Component -- 8626 -------------------------------- 8627 8628 procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is 8629 Comp : Entity_Id; 8630 Comp1 : Entity_Id := Empty; -- prevent junk warning 8631 P : constant Node_Id := Prefix (N); 8632 S : constant Node_Id := Selector_Name (N); 8633 T : Entity_Id := Etype (P); 8634 I : Interp_Index; 8635 I1 : Interp_Index := 0; -- prevent junk warning 8636 It : Interp; 8637 It1 : Interp; 8638 Found : Boolean; 8639 8640 function Init_Component return Boolean; 8641 -- Check whether this is the initialization of a component within an 8642 -- init proc (by assignment or call to another init proc). If true, 8643 -- there is no need for a discriminant check. 8644 8645 -------------------- 8646 -- Init_Component -- 8647 -------------------- 8648 8649 function Init_Component return Boolean is 8650 begin 8651 return Inside_Init_Proc 8652 and then Nkind (Prefix (N)) = N_Identifier 8653 and then Chars (Prefix (N)) = Name_uInit 8654 and then Nkind (Parent (Parent (N))) = N_Case_Statement_Alternative; 8655 end Init_Component; 8656 8657 -- Start of processing for Resolve_Selected_Component 8658 8659 begin 8660 if Is_Overloaded (P) then 8661 8662 -- Use the context type to select the prefix that has a selector 8663 -- of the correct name and type. 8664 8665 Found := False; 8666 Get_First_Interp (P, I, It); 8667 8668 Search : while Present (It.Typ) loop 8669 if Is_Access_Type (It.Typ) then 8670 T := Designated_Type (It.Typ); 8671 else 8672 T := It.Typ; 8673 end if; 8674 8675 -- Locate selected component. For a private prefix the selector 8676 -- can denote a discriminant. 8677 8678 if Is_Record_Type (T) or else Is_Private_Type (T) then 8679 8680 -- The visible components of a class-wide type are those of 8681 -- the root type. 8682 8683 if Is_Class_Wide_Type (T) then 8684 T := Etype (T); 8685 end if; 8686 8687 Comp := First_Entity (T); 8688 while Present (Comp) loop 8689 if Chars (Comp) = Chars (S) 8690 and then Covers (Etype (Comp), Typ) 8691 then 8692 if not Found then 8693 Found := True; 8694 I1 := I; 8695 It1 := It; 8696 Comp1 := Comp; 8697 8698 else 8699 It := Disambiguate (P, I1, I, Any_Type); 8700 8701 if It = No_Interp then 8702 Error_Msg_N 8703 ("ambiguous prefix for selected component", N); 8704 Set_Etype (N, Typ); 8705 return; 8706 8707 else 8708 It1 := It; 8709 8710 -- There may be an implicit dereference. Retrieve 8711 -- designated record type. 8712 8713 if Is_Access_Type (It1.Typ) then 8714 T := Designated_Type (It1.Typ); 8715 else 8716 T := It1.Typ; 8717 end if; 8718 8719 if Scope (Comp1) /= T then 8720 8721 -- Resolution chooses the new interpretation. 8722 -- Find the component with the right name. 8723 8724 Comp1 := First_Entity (T); 8725 while Present (Comp1) 8726 and then Chars (Comp1) /= Chars (S) 8727 loop 8728 Comp1 := Next_Entity (Comp1); 8729 end loop; 8730 end if; 8731 8732 exit Search; 8733 end if; 8734 end if; 8735 end if; 8736 8737 Comp := Next_Entity (Comp); 8738 end loop; 8739 end if; 8740 8741 Get_Next_Interp (I, It); 8742 end loop Search; 8743 8744 Resolve (P, It1.Typ); 8745 Set_Etype (N, Typ); 8746 Set_Entity_With_Style_Check (S, Comp1); 8747 8748 else 8749 -- Resolve prefix with its type 8750 8751 Resolve (P, T); 8752 end if; 8753 8754 -- Generate cross-reference. We needed to wait until full overloading 8755 -- resolution was complete to do this, since otherwise we can't tell if 8756 -- we are an lvalue or not. 8757 8758 if May_Be_Lvalue (N) then 8759 Generate_Reference (Entity (S), S, 'm'); 8760 else 8761 Generate_Reference (Entity (S), S, 'r'); 8762 end if; 8763 8764 -- If prefix is an access type, the node will be transformed into an 8765 -- explicit dereference during expansion. The type of the node is the 8766 -- designated type of that of the prefix. 8767 8768 if Is_Access_Type (Etype (P)) then 8769 T := Designated_Type (Etype (P)); 8770 Check_Fully_Declared_Prefix (T, P); 8771 else 8772 T := Etype (P); 8773 end if; 8774 8775 if Has_Discriminants (T) 8776 and then Ekind_In (Entity (S), E_Component, E_Discriminant) 8777 and then Present (Original_Record_Component (Entity (S))) 8778 and then Ekind (Original_Record_Component (Entity (S))) = E_Component 8779 and then Present (Discriminant_Checking_Func 8780 (Original_Record_Component (Entity (S)))) 8781 and then not Discriminant_Checks_Suppressed (T) 8782 and then not Init_Component 8783 then 8784 Set_Do_Discriminant_Check (N); 8785 end if; 8786 8787 if Ekind (Entity (S)) = E_Void then 8788 Error_Msg_N ("premature use of component", S); 8789 end if; 8790 8791 -- If the prefix is a record conversion, this may be a renamed 8792 -- discriminant whose bounds differ from those of the original 8793 -- one, so we must ensure that a range check is performed. 8794 8795 if Nkind (P) = N_Type_Conversion 8796 and then Ekind (Entity (S)) = E_Discriminant 8797 and then Is_Discrete_Type (Typ) 8798 then 8799 Set_Etype (N, Base_Type (Typ)); 8800 end if; 8801 8802 -- Note: No Eval processing is required, because the prefix is of a 8803 -- record type, or protected type, and neither can possibly be static. 8804 8805 -- If the array type is atomic, and is packed, and we are in a left side 8806 -- context, then this is worth a warning, since we have a situation 8807 -- where the access to the component may cause extra read/writes of the 8808 -- atomic array object, which could be considered unexpected. 8809 8810 if Nkind (N) = N_Selected_Component 8811 and then (Is_Atomic (T) 8812 or else (Is_Entity_Name (Prefix (N)) 8813 and then Is_Atomic (Entity (Prefix (N))))) 8814 and then Is_Packed (T) 8815 and then Is_LHS (N) 8816 then 8817 Error_Msg_N 8818 ("??assignment to component of packed atomic record", Prefix (N)); 8819 Error_Msg_N 8820 ("\??may cause unexpected accesses to atomic object", Prefix (N)); 8821 end if; 8822 8823 Analyze_Dimension (N); 8824 end Resolve_Selected_Component; 8825 8826 ------------------- 8827 -- Resolve_Shift -- 8828 ------------------- 8829 8830 procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id) is 8831 B_Typ : constant Entity_Id := Base_Type (Typ); 8832 L : constant Node_Id := Left_Opnd (N); 8833 R : constant Node_Id := Right_Opnd (N); 8834 8835 begin 8836 -- We do the resolution using the base type, because intermediate values 8837 -- in expressions always are of the base type, not a subtype of it. 8838 8839 Resolve (L, B_Typ); 8840 Resolve (R, Standard_Natural); 8841 8842 Check_Unset_Reference (L); 8843 Check_Unset_Reference (R); 8844 8845 Set_Etype (N, B_Typ); 8846 Generate_Operator_Reference (N, B_Typ); 8847 Eval_Shift (N); 8848 end Resolve_Shift; 8849 8850 --------------------------- 8851 -- Resolve_Short_Circuit -- 8852 --------------------------- 8853 8854 procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id) is 8855 B_Typ : constant Entity_Id := Base_Type (Typ); 8856 L : constant Node_Id := Left_Opnd (N); 8857 R : constant Node_Id := Right_Opnd (N); 8858 8859 begin 8860 Resolve (L, B_Typ); 8861 Resolve (R, B_Typ); 8862 8863 -- Check for issuing warning for always False assert/check, this happens 8864 -- when assertions are turned off, in which case the pragma Assert/Check 8865 -- was transformed into: 8866 8867 -- if False and then <condition> then ... 8868 8869 -- and we detect this pattern 8870 8871 if Warn_On_Assertion_Failure 8872 and then Is_Entity_Name (R) 8873 and then Entity (R) = Standard_False 8874 and then Nkind (Parent (N)) = N_If_Statement 8875 and then Nkind (N) = N_And_Then 8876 and then Is_Entity_Name (L) 8877 and then Entity (L) = Standard_False 8878 then 8879 declare 8880 Orig : constant Node_Id := Original_Node (Parent (N)); 8881 8882 begin 8883 if Nkind (Orig) = N_Pragma 8884 and then Pragma_Name (Orig) = Name_Assert 8885 then 8886 -- Don't want to warn if original condition is explicit False 8887 8888 declare 8889 Expr : constant Node_Id := 8890 Original_Node 8891 (Expression 8892 (First (Pragma_Argument_Associations (Orig)))); 8893 begin 8894 if Is_Entity_Name (Expr) 8895 and then Entity (Expr) = Standard_False 8896 then 8897 null; 8898 else 8899 -- Issue warning. We do not want the deletion of the 8900 -- IF/AND-THEN to take this message with it. We achieve 8901 -- this by making sure that the expanded code points to 8902 -- the Sloc of the expression, not the original pragma. 8903 8904 -- Note: Use Error_Msg_F here rather than Error_Msg_N. 8905 -- The source location of the expression is not usually 8906 -- the best choice here. For example, it gets located on 8907 -- the last AND keyword in a chain of boolean expressiond 8908 -- AND'ed together. It is best to put the message on the 8909 -- first character of the assertion, which is the effect 8910 -- of the First_Node call here. 8911 8912 Error_Msg_F 8913 ("?A?assertion would fail at run time!", 8914 Expression 8915 (First (Pragma_Argument_Associations (Orig)))); 8916 end if; 8917 end; 8918 8919 -- Similar processing for Check pragma 8920 8921 elsif Nkind (Orig) = N_Pragma 8922 and then Pragma_Name (Orig) = Name_Check 8923 then 8924 -- Don't want to warn if original condition is explicit False 8925 8926 declare 8927 Expr : constant Node_Id := 8928 Original_Node 8929 (Expression 8930 (Next (First (Pragma_Argument_Associations (Orig))))); 8931 begin 8932 if Is_Entity_Name (Expr) 8933 and then Entity (Expr) = Standard_False 8934 then 8935 null; 8936 8937 -- Post warning 8938 8939 else 8940 -- Again use Error_Msg_F rather than Error_Msg_N, see 8941 -- comment above for an explanation of why we do this. 8942 8943 Error_Msg_F 8944 ("?A?check would fail at run time!", 8945 Expression 8946 (Last (Pragma_Argument_Associations (Orig)))); 8947 end if; 8948 end; 8949 end if; 8950 end; 8951 end if; 8952 8953 -- Continue with processing of short circuit 8954 8955 Check_Unset_Reference (L); 8956 Check_Unset_Reference (R); 8957 8958 Set_Etype (N, B_Typ); 8959 Eval_Short_Circuit (N); 8960 end Resolve_Short_Circuit; 8961 8962 ------------------- 8963 -- Resolve_Slice -- 8964 ------------------- 8965 8966 procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id) is 8967 Drange : constant Node_Id := Discrete_Range (N); 8968 Name : constant Node_Id := Prefix (N); 8969 Array_Type : Entity_Id := Empty; 8970 Index_Type : Entity_Id; 8971 8972 begin 8973 if Is_Overloaded (Name) then 8974 8975 -- Use the context type to select the prefix that yields the correct 8976 -- array type. 8977 8978 declare 8979 I : Interp_Index; 8980 I1 : Interp_Index := 0; 8981 It : Interp; 8982 P : constant Node_Id := Prefix (N); 8983 Found : Boolean := False; 8984 8985 begin 8986 Get_First_Interp (P, I, It); 8987 while Present (It.Typ) loop 8988 if (Is_Array_Type (It.Typ) 8989 and then Covers (Typ, It.Typ)) 8990 or else (Is_Access_Type (It.Typ) 8991 and then Is_Array_Type (Designated_Type (It.Typ)) 8992 and then Covers (Typ, Designated_Type (It.Typ))) 8993 then 8994 if Found then 8995 It := Disambiguate (P, I1, I, Any_Type); 8996 8997 if It = No_Interp then 8998 Error_Msg_N ("ambiguous prefix for slicing", N); 8999 Set_Etype (N, Typ); 9000 return; 9001 else 9002 Found := True; 9003 Array_Type := It.Typ; 9004 I1 := I; 9005 end if; 9006 else 9007 Found := True; 9008 Array_Type := It.Typ; 9009 I1 := I; 9010 end if; 9011 end if; 9012 9013 Get_Next_Interp (I, It); 9014 end loop; 9015 end; 9016 9017 else 9018 Array_Type := Etype (Name); 9019 end if; 9020 9021 Resolve (Name, Array_Type); 9022 9023 if Is_Access_Type (Array_Type) then 9024 Apply_Access_Check (N); 9025 Array_Type := Designated_Type (Array_Type); 9026 9027 -- If the prefix is an access to an unconstrained array, we must use 9028 -- the actual subtype of the object to perform the index checks. The 9029 -- object denoted by the prefix is implicit in the node, so we build 9030 -- an explicit representation for it in order to compute the actual 9031 -- subtype. 9032 9033 if not Is_Constrained (Array_Type) then 9034 Remove_Side_Effects (Prefix (N)); 9035 9036 declare 9037 Obj : constant Node_Id := 9038 Make_Explicit_Dereference (Sloc (N), 9039 Prefix => New_Copy_Tree (Prefix (N))); 9040 begin 9041 Set_Etype (Obj, Array_Type); 9042 Set_Parent (Obj, Parent (N)); 9043 Array_Type := Get_Actual_Subtype (Obj); 9044 end; 9045 end if; 9046 9047 elsif Is_Entity_Name (Name) 9048 or else Nkind (Name) = N_Explicit_Dereference 9049 or else (Nkind (Name) = N_Function_Call 9050 and then not Is_Constrained (Etype (Name))) 9051 then 9052 Array_Type := Get_Actual_Subtype (Name); 9053 9054 -- If the name is a selected component that depends on discriminants, 9055 -- build an actual subtype for it. This can happen only when the name 9056 -- itself is overloaded; otherwise the actual subtype is created when 9057 -- the selected component is analyzed. 9058 9059 elsif Nkind (Name) = N_Selected_Component 9060 and then Full_Analysis 9061 and then Depends_On_Discriminant (First_Index (Array_Type)) 9062 then 9063 declare 9064 Act_Decl : constant Node_Id := 9065 Build_Actual_Subtype_Of_Component (Array_Type, Name); 9066 begin 9067 Insert_Action (N, Act_Decl); 9068 Array_Type := Defining_Identifier (Act_Decl); 9069 end; 9070 9071 -- Maybe this should just be "else", instead of checking for the 9072 -- specific case of slice??? This is needed for the case where the 9073 -- prefix is an Image attribute, which gets expanded to a slice, and so 9074 -- has a constrained subtype which we want to use for the slice range 9075 -- check applied below (the range check won't get done if the 9076 -- unconstrained subtype of the 'Image is used). 9077 9078 elsif Nkind (Name) = N_Slice then 9079 Array_Type := Etype (Name); 9080 end if; 9081 9082 -- If name was overloaded, set slice type correctly now 9083 9084 Set_Etype (N, Array_Type); 9085 9086 -- If the range is specified by a subtype mark, no resolution is 9087 -- necessary. Else resolve the bounds, and apply needed checks. 9088 9089 if not Is_Entity_Name (Drange) then 9090 if Ekind (Array_Type) = E_String_Literal_Subtype then 9091 Index_Type := Etype (String_Literal_Low_Bound (Array_Type)); 9092 else 9093 Index_Type := Etype (First_Index (Array_Type)); 9094 end if; 9095 9096 Resolve (Drange, Base_Type (Index_Type)); 9097 9098 if Nkind (Drange) = N_Range then 9099 9100 -- Ensure that side effects in the bounds are properly handled 9101 9102 Force_Evaluation (Low_Bound (Drange)); 9103 Force_Evaluation (High_Bound (Drange)); 9104 9105 -- Do not apply the range check to nodes associated with the 9106 -- frontend expansion of the dispatch table. We first check 9107 -- if Ada.Tags is already loaded to avoid the addition of an 9108 -- undesired dependence on such run-time unit. 9109 9110 if not Tagged_Type_Expansion 9111 or else not 9112 (RTU_Loaded (Ada_Tags) 9113 and then Nkind (Prefix (N)) = N_Selected_Component 9114 and then Present (Entity (Selector_Name (Prefix (N)))) 9115 and then Entity (Selector_Name (Prefix (N))) = 9116 RTE_Record_Component (RE_Prims_Ptr)) 9117 then 9118 Apply_Range_Check (Drange, Index_Type); 9119 end if; 9120 end if; 9121 end if; 9122 9123 Set_Slice_Subtype (N); 9124 9125 -- Check bad use of type with predicates 9126 9127 if Has_Predicates (Etype (Drange)) then 9128 Bad_Predicated_Subtype_Use 9129 ("subtype& has predicate, not allowed in slice", 9130 Drange, Etype (Drange)); 9131 9132 -- Otherwise here is where we check suspicious indexes 9133 9134 elsif Nkind (Drange) = N_Range then 9135 Warn_On_Suspicious_Index (Name, Low_Bound (Drange)); 9136 Warn_On_Suspicious_Index (Name, High_Bound (Drange)); 9137 end if; 9138 9139 Analyze_Dimension (N); 9140 Eval_Slice (N); 9141 end Resolve_Slice; 9142 9143 ---------------------------- 9144 -- Resolve_String_Literal -- 9145 ---------------------------- 9146 9147 procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id) is 9148 C_Typ : constant Entity_Id := Component_Type (Typ); 9149 R_Typ : constant Entity_Id := Root_Type (C_Typ); 9150 Loc : constant Source_Ptr := Sloc (N); 9151 Str : constant String_Id := Strval (N); 9152 Strlen : constant Nat := String_Length (Str); 9153 Subtype_Id : Entity_Id; 9154 Need_Check : Boolean; 9155 9156 begin 9157 -- For a string appearing in a concatenation, defer creation of the 9158 -- string_literal_subtype until the end of the resolution of the 9159 -- concatenation, because the literal may be constant-folded away. This 9160 -- is a useful optimization for long concatenation expressions. 9161 9162 -- If the string is an aggregate built for a single character (which 9163 -- happens in a non-static context) or a is null string to which special 9164 -- checks may apply, we build the subtype. Wide strings must also get a 9165 -- string subtype if they come from a one character aggregate. Strings 9166 -- generated by attributes might be static, but it is often hard to 9167 -- determine whether the enclosing context is static, so we generate 9168 -- subtypes for them as well, thus losing some rarer optimizations ??? 9169 -- Same for strings that come from a static conversion. 9170 9171 Need_Check := 9172 (Strlen = 0 and then Typ /= Standard_String) 9173 or else Nkind (Parent (N)) /= N_Op_Concat 9174 or else (N /= Left_Opnd (Parent (N)) 9175 and then N /= Right_Opnd (Parent (N))) 9176 or else ((Typ = Standard_Wide_String 9177 or else Typ = Standard_Wide_Wide_String) 9178 and then Nkind (Original_Node (N)) /= N_String_Literal); 9179 9180 -- If the resolving type is itself a string literal subtype, we can just 9181 -- reuse it, since there is no point in creating another. 9182 9183 if Ekind (Typ) = E_String_Literal_Subtype then 9184 Subtype_Id := Typ; 9185 9186 elsif Nkind (Parent (N)) = N_Op_Concat 9187 and then not Need_Check 9188 and then not Nkind_In (Original_Node (N), N_Character_Literal, 9189 N_Attribute_Reference, 9190 N_Qualified_Expression, 9191 N_Type_Conversion) 9192 then 9193 Subtype_Id := Typ; 9194 9195 -- Otherwise we must create a string literal subtype. Note that the 9196 -- whole idea of string literal subtypes is simply to avoid the need 9197 -- for building a full fledged array subtype for each literal. 9198 9199 else 9200 Set_String_Literal_Subtype (N, Typ); 9201 Subtype_Id := Etype (N); 9202 end if; 9203 9204 if Nkind (Parent (N)) /= N_Op_Concat 9205 or else Need_Check 9206 then 9207 Set_Etype (N, Subtype_Id); 9208 Eval_String_Literal (N); 9209 end if; 9210 9211 if Is_Limited_Composite (Typ) 9212 or else Is_Private_Composite (Typ) 9213 then 9214 Error_Msg_N ("string literal not available for private array", N); 9215 Set_Etype (N, Any_Type); 9216 return; 9217 end if; 9218 9219 -- The validity of a null string has been checked in the call to 9220 -- Eval_String_Literal. 9221 9222 if Strlen = 0 then 9223 return; 9224 9225 -- Always accept string literal with component type Any_Character, which 9226 -- occurs in error situations and in comparisons of literals, both of 9227 -- which should accept all literals. 9228 9229 elsif R_Typ = Any_Character then 9230 return; 9231 9232 -- If the type is bit-packed, then we always transform the string 9233 -- literal into a full fledged aggregate. 9234 9235 elsif Is_Bit_Packed_Array (Typ) then 9236 null; 9237 9238 -- Deal with cases of Wide_Wide_String, Wide_String, and String 9239 9240 else 9241 -- For Standard.Wide_Wide_String, or any other type whose component 9242 -- type is Standard.Wide_Wide_Character, we know that all the 9243 -- characters in the string must be acceptable, since the parser 9244 -- accepted the characters as valid character literals. 9245 9246 if R_Typ = Standard_Wide_Wide_Character then 9247 null; 9248 9249 -- For the case of Standard.String, or any other type whose component 9250 -- type is Standard.Character, we must make sure that there are no 9251 -- wide characters in the string, i.e. that it is entirely composed 9252 -- of characters in range of type Character. 9253 9254 -- If the string literal is the result of a static concatenation, the 9255 -- test has already been performed on the components, and need not be 9256 -- repeated. 9257 9258 elsif R_Typ = Standard_Character 9259 and then Nkind (Original_Node (N)) /= N_Op_Concat 9260 then 9261 for J in 1 .. Strlen loop 9262 if not In_Character_Range (Get_String_Char (Str, J)) then 9263 9264 -- If we are out of range, post error. This is one of the 9265 -- very few places that we place the flag in the middle of 9266 -- a token, right under the offending wide character. Not 9267 -- quite clear if this is right wrt wide character encoding 9268 -- sequences, but it's only an error message! 9269 9270 Error_Msg 9271 ("literal out of range of type Standard.Character", 9272 Source_Ptr (Int (Loc) + J)); 9273 return; 9274 end if; 9275 end loop; 9276 9277 -- For the case of Standard.Wide_String, or any other type whose 9278 -- component type is Standard.Wide_Character, we must make sure that 9279 -- there are no wide characters in the string, i.e. that it is 9280 -- entirely composed of characters in range of type Wide_Character. 9281 9282 -- If the string literal is the result of a static concatenation, 9283 -- the test has already been performed on the components, and need 9284 -- not be repeated. 9285 9286 elsif R_Typ = Standard_Wide_Character 9287 and then Nkind (Original_Node (N)) /= N_Op_Concat 9288 then 9289 for J in 1 .. Strlen loop 9290 if not In_Wide_Character_Range (Get_String_Char (Str, J)) then 9291 9292 -- If we are out of range, post error. This is one of the 9293 -- very few places that we place the flag in the middle of 9294 -- a token, right under the offending wide character. 9295 9296 -- This is not quite right, because characters in general 9297 -- will take more than one character position ??? 9298 9299 Error_Msg 9300 ("literal out of range of type Standard.Wide_Character", 9301 Source_Ptr (Int (Loc) + J)); 9302 return; 9303 end if; 9304 end loop; 9305 9306 -- If the root type is not a standard character, then we will convert 9307 -- the string into an aggregate and will let the aggregate code do 9308 -- the checking. Standard Wide_Wide_Character is also OK here. 9309 9310 else 9311 null; 9312 end if; 9313 9314 -- See if the component type of the array corresponding to the string 9315 -- has compile time known bounds. If yes we can directly check 9316 -- whether the evaluation of the string will raise constraint error. 9317 -- Otherwise we need to transform the string literal into the 9318 -- corresponding character aggregate and let the aggregate code do 9319 -- the checking. 9320 9321 if Is_Standard_Character_Type (R_Typ) then 9322 9323 -- Check for the case of full range, where we are definitely OK 9324 9325 if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then 9326 return; 9327 end if; 9328 9329 -- Here the range is not the complete base type range, so check 9330 9331 declare 9332 Comp_Typ_Lo : constant Node_Id := 9333 Type_Low_Bound (Component_Type (Typ)); 9334 Comp_Typ_Hi : constant Node_Id := 9335 Type_High_Bound (Component_Type (Typ)); 9336 9337 Char_Val : Uint; 9338 9339 begin 9340 if Compile_Time_Known_Value (Comp_Typ_Lo) 9341 and then Compile_Time_Known_Value (Comp_Typ_Hi) 9342 then 9343 for J in 1 .. Strlen loop 9344 Char_Val := UI_From_Int (Int (Get_String_Char (Str, J))); 9345 9346 if Char_Val < Expr_Value (Comp_Typ_Lo) 9347 or else Char_Val > Expr_Value (Comp_Typ_Hi) 9348 then 9349 Apply_Compile_Time_Constraint_Error 9350 (N, "character out of range??", 9351 CE_Range_Check_Failed, 9352 Loc => Source_Ptr (Int (Loc) + J)); 9353 end if; 9354 end loop; 9355 9356 return; 9357 end if; 9358 end; 9359 end if; 9360 end if; 9361 9362 -- If we got here we meed to transform the string literal into the 9363 -- equivalent qualified positional array aggregate. This is rather 9364 -- heavy artillery for this situation, but it is hard work to avoid. 9365 9366 declare 9367 Lits : constant List_Id := New_List; 9368 P : Source_Ptr := Loc + 1; 9369 C : Char_Code; 9370 9371 begin 9372 -- Build the character literals, we give them source locations that 9373 -- correspond to the string positions, which is a bit tricky given 9374 -- the possible presence of wide character escape sequences. 9375 9376 for J in 1 .. Strlen loop 9377 C := Get_String_Char (Str, J); 9378 Set_Character_Literal_Name (C); 9379 9380 Append_To (Lits, 9381 Make_Character_Literal (P, 9382 Chars => Name_Find, 9383 Char_Literal_Value => UI_From_CC (C))); 9384 9385 if In_Character_Range (C) then 9386 P := P + 1; 9387 9388 -- Should we have a call to Skip_Wide here ??? 9389 9390 -- ??? else 9391 -- Skip_Wide (P); 9392 9393 end if; 9394 end loop; 9395 9396 Rewrite (N, 9397 Make_Qualified_Expression (Loc, 9398 Subtype_Mark => New_Reference_To (Typ, Loc), 9399 Expression => 9400 Make_Aggregate (Loc, Expressions => Lits))); 9401 9402 Analyze_And_Resolve (N, Typ); 9403 end; 9404 end Resolve_String_Literal; 9405 9406 ----------------------------- 9407 -- Resolve_Subprogram_Info -- 9408 ----------------------------- 9409 9410 procedure Resolve_Subprogram_Info (N : Node_Id; Typ : Entity_Id) is 9411 begin 9412 Set_Etype (N, Typ); 9413 end Resolve_Subprogram_Info; 9414 9415 ----------------------------- 9416 -- Resolve_Type_Conversion -- 9417 ----------------------------- 9418 9419 procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is 9420 Conv_OK : constant Boolean := Conversion_OK (N); 9421 Operand : constant Node_Id := Expression (N); 9422 Operand_Typ : constant Entity_Id := Etype (Operand); 9423 Target_Typ : constant Entity_Id := Etype (N); 9424 Rop : Node_Id; 9425 Orig_N : Node_Id; 9426 Orig_T : Node_Id; 9427 9428 Test_Redundant : Boolean := Warn_On_Redundant_Constructs; 9429 -- Set to False to suppress cases where we want to suppress the test 9430 -- for redundancy to avoid possible false positives on this warning. 9431 9432 begin 9433 if not Conv_OK 9434 and then not Valid_Conversion (N, Target_Typ, Operand) 9435 then 9436 return; 9437 end if; 9438 9439 -- If the Operand Etype is Universal_Fixed, then the conversion is 9440 -- never redundant. We need this check because by the time we have 9441 -- finished the rather complex transformation, the conversion looks 9442 -- redundant when it is not. 9443 9444 if Operand_Typ = Universal_Fixed then 9445 Test_Redundant := False; 9446 9447 -- If the operand is marked as Any_Fixed, then special processing is 9448 -- required. This is also a case where we suppress the test for a 9449 -- redundant conversion, since most certainly it is not redundant. 9450 9451 elsif Operand_Typ = Any_Fixed then 9452 Test_Redundant := False; 9453 9454 -- Mixed-mode operation involving a literal. Context must be a fixed 9455 -- type which is applied to the literal subsequently. 9456 9457 if Is_Fixed_Point_Type (Typ) then 9458 Set_Etype (Operand, Universal_Real); 9459 9460 elsif Is_Numeric_Type (Typ) 9461 and then Nkind_In (Operand, N_Op_Multiply, N_Op_Divide) 9462 and then (Etype (Right_Opnd (Operand)) = Universal_Real 9463 or else 9464 Etype (Left_Opnd (Operand)) = Universal_Real) 9465 then 9466 -- Return if expression is ambiguous 9467 9468 if Unique_Fixed_Point_Type (N) = Any_Type then 9469 return; 9470 9471 -- If nothing else, the available fixed type is Duration 9472 9473 else 9474 Set_Etype (Operand, Standard_Duration); 9475 end if; 9476 9477 -- Resolve the real operand with largest available precision 9478 9479 if Etype (Right_Opnd (Operand)) = Universal_Real then 9480 Rop := New_Copy_Tree (Right_Opnd (Operand)); 9481 else 9482 Rop := New_Copy_Tree (Left_Opnd (Operand)); 9483 end if; 9484 9485 Resolve (Rop, Universal_Real); 9486 9487 -- If the operand is a literal (it could be a non-static and 9488 -- illegal exponentiation) check whether the use of Duration 9489 -- is potentially inaccurate. 9490 9491 if Nkind (Rop) = N_Real_Literal 9492 and then Realval (Rop) /= Ureal_0 9493 and then abs (Realval (Rop)) < Delta_Value (Standard_Duration) 9494 then 9495 Error_Msg_N 9496 ("??universal real operand can only " 9497 & "be interpreted as Duration!", Rop); 9498 Error_Msg_N 9499 ("\??precision will be lost in the conversion!", Rop); 9500 end if; 9501 9502 elsif Is_Numeric_Type (Typ) 9503 and then Nkind (Operand) in N_Op 9504 and then Unique_Fixed_Point_Type (N) /= Any_Type 9505 then 9506 Set_Etype (Operand, Standard_Duration); 9507 9508 else 9509 Error_Msg_N ("invalid context for mixed mode operation", N); 9510 Set_Etype (Operand, Any_Type); 9511 return; 9512 end if; 9513 end if; 9514 9515 Resolve (Operand); 9516 9517 -- In SPARK, a type conversion between array types should be restricted 9518 -- to types which have matching static bounds. 9519 9520 -- Protect call to Matching_Static_Array_Bounds to avoid costly 9521 -- operation if not needed. 9522 9523 if Restriction_Check_Required (SPARK) 9524 and then Is_Array_Type (Target_Typ) 9525 and then Is_Array_Type (Operand_Typ) 9526 and then Operand_Typ /= Any_Composite -- or else Operand in error 9527 and then not Matching_Static_Array_Bounds (Target_Typ, Operand_Typ) 9528 then 9529 Check_SPARK_Restriction 9530 ("array types should have matching static bounds", N); 9531 end if; 9532 9533 -- In formal mode, the operand of an ancestor type conversion must be an 9534 -- object (not an expression). 9535 9536 if Is_Tagged_Type (Target_Typ) 9537 and then not Is_Class_Wide_Type (Target_Typ) 9538 and then Is_Tagged_Type (Operand_Typ) 9539 and then not Is_Class_Wide_Type (Operand_Typ) 9540 and then Is_Ancestor (Target_Typ, Operand_Typ) 9541 and then not Is_SPARK_Object_Reference (Operand) 9542 then 9543 Check_SPARK_Restriction ("object required", Operand); 9544 end if; 9545 9546 Analyze_Dimension (N); 9547 9548 -- Note: we do the Eval_Type_Conversion call before applying the 9549 -- required checks for a subtype conversion. This is important, since 9550 -- both are prepared under certain circumstances to change the type 9551 -- conversion to a constraint error node, but in the case of 9552 -- Eval_Type_Conversion this may reflect an illegality in the static 9553 -- case, and we would miss the illegality (getting only a warning 9554 -- message), if we applied the type conversion checks first. 9555 9556 Eval_Type_Conversion (N); 9557 9558 -- Even when evaluation is not possible, we may be able to simplify the 9559 -- conversion or its expression. This needs to be done before applying 9560 -- checks, since otherwise the checks may use the original expression 9561 -- and defeat the simplifications. This is specifically the case for 9562 -- elimination of the floating-point Truncation attribute in 9563 -- float-to-int conversions. 9564 9565 Simplify_Type_Conversion (N); 9566 9567 -- If after evaluation we still have a type conversion, then we may need 9568 -- to apply checks required for a subtype conversion. 9569 9570 -- Skip these type conversion checks if universal fixed operands 9571 -- operands involved, since range checks are handled separately for 9572 -- these cases (in the appropriate Expand routines in unit Exp_Fixd). 9573 9574 if Nkind (N) = N_Type_Conversion 9575 and then not Is_Generic_Type (Root_Type (Target_Typ)) 9576 and then Target_Typ /= Universal_Fixed 9577 and then Operand_Typ /= Universal_Fixed 9578 then 9579 Apply_Type_Conversion_Checks (N); 9580 end if; 9581 9582 -- Issue warning for conversion of simple object to its own type. We 9583 -- have to test the original nodes, since they may have been rewritten 9584 -- by various optimizations. 9585 9586 Orig_N := Original_Node (N); 9587 9588 -- Here we test for a redundant conversion if the warning mode is 9589 -- active (and was not locally reset), and we have a type conversion 9590 -- from source not appearing in a generic instance. 9591 9592 if Test_Redundant 9593 and then Nkind (Orig_N) = N_Type_Conversion 9594 and then Comes_From_Source (Orig_N) 9595 and then not In_Instance 9596 then 9597 Orig_N := Original_Node (Expression (Orig_N)); 9598 Orig_T := Target_Typ; 9599 9600 -- If the node is part of a larger expression, the Target_Type 9601 -- may not be the original type of the node if the context is a 9602 -- condition. Recover original type to see if conversion is needed. 9603 9604 if Is_Boolean_Type (Orig_T) 9605 and then Nkind (Parent (N)) in N_Op 9606 then 9607 Orig_T := Etype (Parent (N)); 9608 end if; 9609 9610 -- If we have an entity name, then give the warning if the entity 9611 -- is the right type, or if it is a loop parameter covered by the 9612 -- original type (that's needed because loop parameters have an 9613 -- odd subtype coming from the bounds). 9614 9615 if (Is_Entity_Name (Orig_N) 9616 and then 9617 (Etype (Entity (Orig_N)) = Orig_T 9618 or else 9619 (Ekind (Entity (Orig_N)) = E_Loop_Parameter 9620 and then Covers (Orig_T, Etype (Entity (Orig_N)))))) 9621 9622 -- If not an entity, then type of expression must match 9623 9624 or else Etype (Orig_N) = Orig_T 9625 then 9626 -- One more check, do not give warning if the analyzed conversion 9627 -- has an expression with non-static bounds, and the bounds of the 9628 -- target are static. This avoids junk warnings in cases where the 9629 -- conversion is necessary to establish staticness, for example in 9630 -- a case statement. 9631 9632 if not Is_OK_Static_Subtype (Operand_Typ) 9633 and then Is_OK_Static_Subtype (Target_Typ) 9634 then 9635 null; 9636 9637 -- Finally, if this type conversion occurs in a context requiring 9638 -- a prefix, and the expression is a qualified expression then the 9639 -- type conversion is not redundant, since a qualified expression 9640 -- is not a prefix, whereas a type conversion is. For example, "X 9641 -- := T'(Funx(...)).Y;" is illegal because a selected component 9642 -- requires a prefix, but a type conversion makes it legal: "X := 9643 -- T(T'(Funx(...))).Y;" 9644 9645 -- In Ada 2012, a qualified expression is a name, so this idiom is 9646 -- no longer needed, but we still suppress the warning because it 9647 -- seems unfriendly for warnings to pop up when you switch to the 9648 -- newer language version. 9649 9650 elsif Nkind (Orig_N) = N_Qualified_Expression 9651 and then Nkind_In (Parent (N), N_Attribute_Reference, 9652 N_Indexed_Component, 9653 N_Selected_Component, 9654 N_Slice, 9655 N_Explicit_Dereference) 9656 then 9657 null; 9658 9659 -- Never warn on conversion to Long_Long_Integer'Base since 9660 -- that is most likely an artifact of the extended overflow 9661 -- checking and comes from complex expanded code. 9662 9663 elsif Orig_T = Base_Type (Standard_Long_Long_Integer) then 9664 null; 9665 9666 -- Here we give the redundant conversion warning. If it is an 9667 -- entity, give the name of the entity in the message. If not, 9668 -- just mention the expression. 9669 9670 -- Shoudn't we test Warn_On_Redundant_Constructs here ??? 9671 9672 else 9673 if Is_Entity_Name (Orig_N) then 9674 Error_Msg_Node_2 := Orig_T; 9675 Error_Msg_NE -- CODEFIX 9676 ("??redundant conversion, & is of type &!", 9677 N, Entity (Orig_N)); 9678 else 9679 Error_Msg_NE 9680 ("??redundant conversion, expression is of type&!", 9681 N, Orig_T); 9682 end if; 9683 end if; 9684 end if; 9685 end if; 9686 9687 -- Ada 2005 (AI-251): Handle class-wide interface type conversions. 9688 -- No need to perform any interface conversion if the type of the 9689 -- expression coincides with the target type. 9690 9691 if Ada_Version >= Ada_2005 9692 and then Full_Expander_Active 9693 and then Operand_Typ /= Target_Typ 9694 then 9695 declare 9696 Opnd : Entity_Id := Operand_Typ; 9697 Target : Entity_Id := Target_Typ; 9698 9699 begin 9700 if Is_Access_Type (Opnd) then 9701 Opnd := Designated_Type (Opnd); 9702 end if; 9703 9704 if Is_Access_Type (Target_Typ) then 9705 Target := Designated_Type (Target); 9706 end if; 9707 9708 if Opnd = Target then 9709 null; 9710 9711 -- Conversion from interface type 9712 9713 elsif Is_Interface (Opnd) then 9714 9715 -- Ada 2005 (AI-217): Handle entities from limited views 9716 9717 if From_With_Type (Opnd) then 9718 Error_Msg_Qual_Level := 99; 9719 Error_Msg_NE -- CODEFIX 9720 ("missing WITH clause on package &", N, 9721 Cunit_Entity (Get_Source_Unit (Base_Type (Opnd)))); 9722 Error_Msg_N 9723 ("type conversions require visibility of the full view", 9724 N); 9725 9726 elsif From_With_Type (Target) 9727 and then not 9728 (Is_Access_Type (Target_Typ) 9729 and then Present (Non_Limited_View (Etype (Target)))) 9730 then 9731 Error_Msg_Qual_Level := 99; 9732 Error_Msg_NE -- CODEFIX 9733 ("missing WITH clause on package &", N, 9734 Cunit_Entity (Get_Source_Unit (Base_Type (Target)))); 9735 Error_Msg_N 9736 ("type conversions require visibility of the full view", 9737 N); 9738 9739 else 9740 Expand_Interface_Conversion (N, Is_Static => False); 9741 end if; 9742 9743 -- Conversion to interface type 9744 9745 elsif Is_Interface (Target) then 9746 9747 -- Handle subtypes 9748 9749 if Ekind_In (Opnd, E_Protected_Subtype, E_Task_Subtype) then 9750 Opnd := Etype (Opnd); 9751 end if; 9752 9753 if not Interface_Present_In_Ancestor 9754 (Typ => Opnd, 9755 Iface => Target) 9756 then 9757 if Is_Class_Wide_Type (Opnd) then 9758 9759 -- The static analysis is not enough to know if the 9760 -- interface is implemented or not. Hence we must pass 9761 -- the work to the expander to generate code to evaluate 9762 -- the conversion at run time. 9763 9764 Expand_Interface_Conversion (N, Is_Static => False); 9765 9766 else 9767 Error_Msg_Name_1 := Chars (Etype (Target)); 9768 Error_Msg_Name_2 := Chars (Opnd); 9769 Error_Msg_N 9770 ("wrong interface conversion (% is not a progenitor " & 9771 "of %)", N); 9772 end if; 9773 9774 else 9775 Expand_Interface_Conversion (N); 9776 end if; 9777 end if; 9778 end; 9779 end if; 9780 9781 -- Ada 2012: if target type has predicates, the result requires a 9782 -- predicate check. If the context is a call to another predicate 9783 -- check we must prevent infinite recursion. 9784 9785 if Has_Predicates (Target_Typ) then 9786 if Nkind (Parent (N)) = N_Function_Call 9787 and then Present (Name (Parent (N))) 9788 and then Has_Predicates (Entity (Name (Parent (N)))) 9789 then 9790 null; 9791 9792 else 9793 Apply_Predicate_Check (N, Target_Typ); 9794 end if; 9795 end if; 9796 end Resolve_Type_Conversion; 9797 9798 ---------------------- 9799 -- Resolve_Unary_Op -- 9800 ---------------------- 9801 9802 procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is 9803 B_Typ : constant Entity_Id := Base_Type (Typ); 9804 R : constant Node_Id := Right_Opnd (N); 9805 OK : Boolean; 9806 Lo : Uint; 9807 Hi : Uint; 9808 9809 begin 9810 if Is_Modular_Integer_Type (Typ) and then Nkind (N) /= N_Op_Not then 9811 Error_Msg_Name_1 := Chars (Typ); 9812 Check_SPARK_Restriction 9813 ("unary operator not defined for modular type%", N); 9814 end if; 9815 9816 -- Deal with intrinsic unary operators 9817 9818 if Comes_From_Source (N) 9819 and then Ekind (Entity (N)) = E_Function 9820 and then Is_Imported (Entity (N)) 9821 and then Is_Intrinsic_Subprogram (Entity (N)) 9822 then 9823 Resolve_Intrinsic_Unary_Operator (N, Typ); 9824 return; 9825 end if; 9826 9827 -- Deal with universal cases 9828 9829 if Etype (R) = Universal_Integer 9830 or else 9831 Etype (R) = Universal_Real 9832 then 9833 Check_For_Visible_Operator (N, B_Typ); 9834 end if; 9835 9836 Set_Etype (N, B_Typ); 9837 Resolve (R, B_Typ); 9838 9839 -- Generate warning for expressions like abs (x mod 2) 9840 9841 if Warn_On_Redundant_Constructs 9842 and then Nkind (N) = N_Op_Abs 9843 then 9844 Determine_Range (Right_Opnd (N), OK, Lo, Hi); 9845 9846 if OK and then Hi >= Lo and then Lo >= 0 then 9847 Error_Msg_N -- CODEFIX 9848 ("?r?abs applied to known non-negative value has no effect", N); 9849 end if; 9850 end if; 9851 9852 -- Deal with reference generation 9853 9854 Check_Unset_Reference (R); 9855 Generate_Operator_Reference (N, B_Typ); 9856 Analyze_Dimension (N); 9857 Eval_Unary_Op (N); 9858 9859 -- Set overflow checking bit. Much cleverer code needed here eventually 9860 -- and perhaps the Resolve routines should be separated for the various 9861 -- arithmetic operations, since they will need different processing ??? 9862 9863 if Nkind (N) in N_Op then 9864 if not Overflow_Checks_Suppressed (Etype (N)) then 9865 Enable_Overflow_Check (N); 9866 end if; 9867 end if; 9868 9869 -- Generate warning for expressions like -5 mod 3 for integers. No need 9870 -- to worry in the floating-point case, since parens do not affect the 9871 -- result so there is no point in giving in a warning. 9872 9873 declare 9874 Norig : constant Node_Id := Original_Node (N); 9875 Rorig : Node_Id; 9876 Val : Uint; 9877 HB : Uint; 9878 LB : Uint; 9879 Lval : Uint; 9880 Opnd : Node_Id; 9881 9882 begin 9883 if Warn_On_Questionable_Missing_Parens 9884 and then Comes_From_Source (Norig) 9885 and then Is_Integer_Type (Typ) 9886 and then Nkind (Norig) = N_Op_Minus 9887 then 9888 Rorig := Original_Node (Right_Opnd (Norig)); 9889 9890 -- We are looking for cases where the right operand is not 9891 -- parenthesized, and is a binary operator, multiply, divide, or 9892 -- mod. These are the cases where the grouping can affect results. 9893 9894 if Paren_Count (Rorig) = 0 9895 and then Nkind_In (Rorig, N_Op_Mod, N_Op_Multiply, N_Op_Divide) 9896 then 9897 -- For mod, we always give the warning, since the value is 9898 -- affected by the parenthesization (e.g. (-5) mod 315 /= 9899 -- -(5 mod 315)). But for the other cases, the only concern is 9900 -- overflow, e.g. for the case of 8 big signed (-(2 * 64) 9901 -- overflows, but (-2) * 64 does not). So we try to give the 9902 -- message only when overflow is possible. 9903 9904 if Nkind (Rorig) /= N_Op_Mod 9905 and then Compile_Time_Known_Value (R) 9906 then 9907 Val := Expr_Value (R); 9908 9909 if Compile_Time_Known_Value (Type_High_Bound (Typ)) then 9910 HB := Expr_Value (Type_High_Bound (Typ)); 9911 else 9912 HB := Expr_Value (Type_High_Bound (Base_Type (Typ))); 9913 end if; 9914 9915 if Compile_Time_Known_Value (Type_Low_Bound (Typ)) then 9916 LB := Expr_Value (Type_Low_Bound (Typ)); 9917 else 9918 LB := Expr_Value (Type_Low_Bound (Base_Type (Typ))); 9919 end if; 9920 9921 -- Note that the test below is deliberately excluding the 9922 -- largest negative number, since that is a potentially 9923 -- troublesome case (e.g. -2 * x, where the result is the 9924 -- largest negative integer has an overflow with 2 * x). 9925 9926 if Val > LB and then Val <= HB then 9927 return; 9928 end if; 9929 end if; 9930 9931 -- For the multiplication case, the only case we have to worry 9932 -- about is when (-a)*b is exactly the largest negative number 9933 -- so that -(a*b) can cause overflow. This can only happen if 9934 -- a is a power of 2, and more generally if any operand is a 9935 -- constant that is not a power of 2, then the parentheses 9936 -- cannot affect whether overflow occurs. We only bother to 9937 -- test the left most operand 9938 9939 -- Loop looking at left operands for one that has known value 9940 9941 Opnd := Rorig; 9942 Opnd_Loop : while Nkind (Opnd) = N_Op_Multiply loop 9943 if Compile_Time_Known_Value (Left_Opnd (Opnd)) then 9944 Lval := UI_Abs (Expr_Value (Left_Opnd (Opnd))); 9945 9946 -- Operand value of 0 or 1 skips warning 9947 9948 if Lval <= 1 then 9949 return; 9950 9951 -- Otherwise check power of 2, if power of 2, warn, if 9952 -- anything else, skip warning. 9953 9954 else 9955 while Lval /= 2 loop 9956 if Lval mod 2 = 1 then 9957 return; 9958 else 9959 Lval := Lval / 2; 9960 end if; 9961 end loop; 9962 9963 exit Opnd_Loop; 9964 end if; 9965 end if; 9966 9967 -- Keep looking at left operands 9968 9969 Opnd := Left_Opnd (Opnd); 9970 end loop Opnd_Loop; 9971 9972 -- For rem or "/" we can only have a problematic situation 9973 -- if the divisor has a value of minus one or one. Otherwise 9974 -- overflow is impossible (divisor > 1) or we have a case of 9975 -- division by zero in any case. 9976 9977 if Nkind_In (Rorig, N_Op_Divide, N_Op_Rem) 9978 and then Compile_Time_Known_Value (Right_Opnd (Rorig)) 9979 and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1 9980 then 9981 return; 9982 end if; 9983 9984 -- If we fall through warning should be issued 9985 9986 -- Shouldn't we test Warn_On_Questionable_Missing_Parens ??? 9987 9988 Error_Msg_N 9989 ("??unary minus expression should be parenthesized here!", N); 9990 end if; 9991 end if; 9992 end; 9993 end Resolve_Unary_Op; 9994 9995 ---------------------------------- 9996 -- Resolve_Unchecked_Expression -- 9997 ---------------------------------- 9998 9999 procedure Resolve_Unchecked_Expression 10000 (N : Node_Id; 10001 Typ : Entity_Id) 10002 is 10003 begin 10004 Resolve (Expression (N), Typ, Suppress => All_Checks); 10005 Set_Etype (N, Typ); 10006 end Resolve_Unchecked_Expression; 10007 10008 --------------------------------------- 10009 -- Resolve_Unchecked_Type_Conversion -- 10010 --------------------------------------- 10011 10012 procedure Resolve_Unchecked_Type_Conversion 10013 (N : Node_Id; 10014 Typ : Entity_Id) 10015 is 10016 pragma Warnings (Off, Typ); 10017 10018 Operand : constant Node_Id := Expression (N); 10019 Opnd_Type : constant Entity_Id := Etype (Operand); 10020 10021 begin 10022 -- Resolve operand using its own type 10023 10024 Resolve (Operand, Opnd_Type); 10025 Analyze_Dimension (N); 10026 Eval_Unchecked_Conversion (N); 10027 end Resolve_Unchecked_Type_Conversion; 10028 10029 ------------------------------ 10030 -- Rewrite_Operator_As_Call -- 10031 ------------------------------ 10032 10033 procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is 10034 Loc : constant Source_Ptr := Sloc (N); 10035 Actuals : constant List_Id := New_List; 10036 New_N : Node_Id; 10037 10038 begin 10039 if Nkind (N) in N_Binary_Op then 10040 Append (Left_Opnd (N), Actuals); 10041 end if; 10042 10043 Append (Right_Opnd (N), Actuals); 10044 10045 New_N := 10046 Make_Function_Call (Sloc => Loc, 10047 Name => New_Occurrence_Of (Nam, Loc), 10048 Parameter_Associations => Actuals); 10049 10050 Preserve_Comes_From_Source (New_N, N); 10051 Preserve_Comes_From_Source (Name (New_N), N); 10052 Rewrite (N, New_N); 10053 Set_Etype (N, Etype (Nam)); 10054 end Rewrite_Operator_As_Call; 10055 10056 ------------------------------ 10057 -- Rewrite_Renamed_Operator -- 10058 ------------------------------ 10059 10060 procedure Rewrite_Renamed_Operator 10061 (N : Node_Id; 10062 Op : Entity_Id; 10063 Typ : Entity_Id) 10064 is 10065 Nam : constant Name_Id := Chars (Op); 10066 Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op; 10067 Op_Node : Node_Id; 10068 10069 begin 10070 -- Rewrite the operator node using the real operator, not its renaming. 10071 -- Exclude user-defined intrinsic operations of the same name, which are 10072 -- treated separately and rewritten as calls. 10073 10074 if Ekind (Op) /= E_Function or else Chars (N) /= Nam then 10075 Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N)); 10076 Set_Chars (Op_Node, Nam); 10077 Set_Etype (Op_Node, Etype (N)); 10078 Set_Entity (Op_Node, Op); 10079 Set_Right_Opnd (Op_Node, Right_Opnd (N)); 10080 10081 -- Indicate that both the original entity and its renaming are 10082 -- referenced at this point. 10083 10084 Generate_Reference (Entity (N), N); 10085 Generate_Reference (Op, N); 10086 10087 if Is_Binary then 10088 Set_Left_Opnd (Op_Node, Left_Opnd (N)); 10089 end if; 10090 10091 Rewrite (N, Op_Node); 10092 10093 -- If the context type is private, add the appropriate conversions so 10094 -- that the operator is applied to the full view. This is done in the 10095 -- routines that resolve intrinsic operators. 10096 10097 if Is_Intrinsic_Subprogram (Op) 10098 and then Is_Private_Type (Typ) 10099 then 10100 case Nkind (N) is 10101 when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide | 10102 N_Op_Expon | N_Op_Mod | N_Op_Rem => 10103 Resolve_Intrinsic_Operator (N, Typ); 10104 10105 when N_Op_Plus | N_Op_Minus | N_Op_Abs => 10106 Resolve_Intrinsic_Unary_Operator (N, Typ); 10107 10108 when others => 10109 Resolve (N, Typ); 10110 end case; 10111 end if; 10112 10113 elsif Ekind (Op) = E_Function and then Is_Intrinsic_Subprogram (Op) then 10114 10115 -- Operator renames a user-defined operator of the same name. Use the 10116 -- original operator in the node, which is the one Gigi knows about. 10117 10118 Set_Entity (N, Op); 10119 Set_Is_Overloaded (N, False); 10120 end if; 10121 end Rewrite_Renamed_Operator; 10122 10123 ----------------------- 10124 -- Set_Slice_Subtype -- 10125 ----------------------- 10126 10127 -- Build an implicit subtype declaration to represent the type delivered by 10128 -- the slice. This is an abbreviated version of an array subtype. We define 10129 -- an index subtype for the slice, using either the subtype name or the 10130 -- discrete range of the slice. To be consistent with index usage elsewhere 10131 -- we create a list header to hold the single index. This list is not 10132 -- otherwise attached to the syntax tree. 10133 10134 procedure Set_Slice_Subtype (N : Node_Id) is 10135 Loc : constant Source_Ptr := Sloc (N); 10136 Index_List : constant List_Id := New_List; 10137 Index : Node_Id; 10138 Index_Subtype : Entity_Id; 10139 Index_Type : Entity_Id; 10140 Slice_Subtype : Entity_Id; 10141 Drange : constant Node_Id := Discrete_Range (N); 10142 10143 begin 10144 if Is_Entity_Name (Drange) then 10145 Index_Subtype := Entity (Drange); 10146 10147 else 10148 -- We force the evaluation of a range. This is definitely needed in 10149 -- the renamed case, and seems safer to do unconditionally. Note in 10150 -- any case that since we will create and insert an Itype referring 10151 -- to this range, we must make sure any side effect removal actions 10152 -- are inserted before the Itype definition. 10153 10154 if Nkind (Drange) = N_Range then 10155 Force_Evaluation (Low_Bound (Drange)); 10156 Force_Evaluation (High_Bound (Drange)); 10157 end if; 10158 10159 Index_Type := Base_Type (Etype (Drange)); 10160 10161 Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N); 10162 10163 -- Take a new copy of Drange (where bounds have been rewritten to 10164 -- reference side-effect-free names). Using a separate tree ensures 10165 -- that further expansion (e.g. while rewriting a slice assignment 10166 -- into a FOR loop) does not attempt to remove side effects on the 10167 -- bounds again (which would cause the bounds in the index subtype 10168 -- definition to refer to temporaries before they are defined) (the 10169 -- reason is that some names are considered side effect free here 10170 -- for the subtype, but not in the context of a loop iteration 10171 -- scheme). 10172 10173 Set_Scalar_Range (Index_Subtype, New_Copy_Tree (Drange)); 10174 Set_Parent (Scalar_Range (Index_Subtype), Index_Subtype); 10175 Set_Etype (Index_Subtype, Index_Type); 10176 Set_Size_Info (Index_Subtype, Index_Type); 10177 Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); 10178 end if; 10179 10180 Slice_Subtype := Create_Itype (E_Array_Subtype, N); 10181 10182 Index := New_Occurrence_Of (Index_Subtype, Loc); 10183 Set_Etype (Index, Index_Subtype); 10184 Append (Index, Index_List); 10185 10186 Set_First_Index (Slice_Subtype, Index); 10187 Set_Etype (Slice_Subtype, Base_Type (Etype (N))); 10188 Set_Is_Constrained (Slice_Subtype, True); 10189 10190 Check_Compile_Time_Size (Slice_Subtype); 10191 10192 -- The Etype of the existing Slice node is reset to this slice subtype. 10193 -- Its bounds are obtained from its first index. 10194 10195 Set_Etype (N, Slice_Subtype); 10196 10197 -- For packed slice subtypes, freeze immediately (except in the case of 10198 -- being in a "spec expression" where we never freeze when we first see 10199 -- the expression). 10200 10201 if Is_Packed (Slice_Subtype) and not In_Spec_Expression then 10202 Freeze_Itype (Slice_Subtype, N); 10203 10204 -- For all other cases insert an itype reference in the slice's actions 10205 -- so that the itype is frozen at the proper place in the tree (i.e. at 10206 -- the point where actions for the slice are analyzed). Note that this 10207 -- is different from freezing the itype immediately, which might be 10208 -- premature (e.g. if the slice is within a transient scope). This needs 10209 -- to be done only if expansion is enabled. 10210 10211 elsif Full_Expander_Active then 10212 Ensure_Defined (Typ => Slice_Subtype, N => N); 10213 end if; 10214 end Set_Slice_Subtype; 10215 10216 -------------------------------- 10217 -- Set_String_Literal_Subtype -- 10218 -------------------------------- 10219 10220 procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is 10221 Loc : constant Source_Ptr := Sloc (N); 10222 Low_Bound : constant Node_Id := 10223 Type_Low_Bound (Etype (First_Index (Typ))); 10224 Subtype_Id : Entity_Id; 10225 10226 begin 10227 if Nkind (N) /= N_String_Literal then 10228 return; 10229 end if; 10230 10231 Subtype_Id := Create_Itype (E_String_Literal_Subtype, N); 10232 Set_String_Literal_Length (Subtype_Id, UI_From_Int 10233 (String_Length (Strval (N)))); 10234 Set_Etype (Subtype_Id, Base_Type (Typ)); 10235 Set_Is_Constrained (Subtype_Id); 10236 Set_Etype (N, Subtype_Id); 10237 10238 -- The low bound is set from the low bound of the corresponding index 10239 -- type. Note that we do not store the high bound in the string literal 10240 -- subtype, but it can be deduced if necessary from the length and the 10241 -- low bound. 10242 10243 if Is_OK_Static_Expression (Low_Bound) then 10244 Set_String_Literal_Low_Bound (Subtype_Id, Low_Bound); 10245 10246 -- If the lower bound is not static we create a range for the string 10247 -- literal, using the index type and the known length of the literal. 10248 -- The index type is not necessarily Positive, so the upper bound is 10249 -- computed as T'Val (T'Pos (Low_Bound) + L - 1). 10250 10251 else 10252 declare 10253 Index_List : constant List_Id := New_List; 10254 Index_Type : constant Entity_Id := Etype (First_Index (Typ)); 10255 High_Bound : constant Node_Id := 10256 Make_Attribute_Reference (Loc, 10257 Attribute_Name => Name_Val, 10258 Prefix => 10259 New_Occurrence_Of (Index_Type, Loc), 10260 Expressions => New_List ( 10261 Make_Op_Add (Loc, 10262 Left_Opnd => 10263 Make_Attribute_Reference (Loc, 10264 Attribute_Name => Name_Pos, 10265 Prefix => 10266 New_Occurrence_Of (Index_Type, Loc), 10267 Expressions => 10268 New_List (New_Copy_Tree (Low_Bound))), 10269 Right_Opnd => 10270 Make_Integer_Literal (Loc, 10271 String_Length (Strval (N)) - 1)))); 10272 10273 Array_Subtype : Entity_Id; 10274 Drange : Node_Id; 10275 Index : Node_Id; 10276 Index_Subtype : Entity_Id; 10277 10278 begin 10279 if Is_Integer_Type (Index_Type) then 10280 Set_String_Literal_Low_Bound 10281 (Subtype_Id, Make_Integer_Literal (Loc, 1)); 10282 10283 else 10284 -- If the index type is an enumeration type, build bounds 10285 -- expression with attributes. 10286 10287 Set_String_Literal_Low_Bound 10288 (Subtype_Id, 10289 Make_Attribute_Reference (Loc, 10290 Attribute_Name => Name_First, 10291 Prefix => 10292 New_Occurrence_Of (Base_Type (Index_Type), Loc))); 10293 Set_Etype (String_Literal_Low_Bound (Subtype_Id), Index_Type); 10294 end if; 10295 10296 Analyze_And_Resolve (String_Literal_Low_Bound (Subtype_Id)); 10297 10298 -- Build bona fide subtype for the string, and wrap it in an 10299 -- unchecked conversion, because the backend expects the 10300 -- String_Literal_Subtype to have a static lower bound. 10301 10302 Index_Subtype := 10303 Create_Itype (Subtype_Kind (Ekind (Index_Type)), N); 10304 Drange := Make_Range (Loc, New_Copy_Tree (Low_Bound), High_Bound); 10305 Set_Scalar_Range (Index_Subtype, Drange); 10306 Set_Parent (Drange, N); 10307 Analyze_And_Resolve (Drange, Index_Type); 10308 10309 -- In the context, the Index_Type may already have a constraint, 10310 -- so use common base type on string subtype. The base type may 10311 -- be used when generating attributes of the string, for example 10312 -- in the context of a slice assignment. 10313 10314 Set_Etype (Index_Subtype, Base_Type (Index_Type)); 10315 Set_Size_Info (Index_Subtype, Index_Type); 10316 Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); 10317 10318 Array_Subtype := Create_Itype (E_Array_Subtype, N); 10319 10320 Index := New_Occurrence_Of (Index_Subtype, Loc); 10321 Set_Etype (Index, Index_Subtype); 10322 Append (Index, Index_List); 10323 10324 Set_First_Index (Array_Subtype, Index); 10325 Set_Etype (Array_Subtype, Base_Type (Typ)); 10326 Set_Is_Constrained (Array_Subtype, True); 10327 10328 Rewrite (N, 10329 Make_Unchecked_Type_Conversion (Loc, 10330 Subtype_Mark => New_Occurrence_Of (Array_Subtype, Loc), 10331 Expression => Relocate_Node (N))); 10332 Set_Etype (N, Array_Subtype); 10333 end; 10334 end if; 10335 end Set_String_Literal_Subtype; 10336 10337 ------------------------------ 10338 -- Simplify_Type_Conversion -- 10339 ------------------------------ 10340 10341 procedure Simplify_Type_Conversion (N : Node_Id) is 10342 begin 10343 if Nkind (N) = N_Type_Conversion then 10344 declare 10345 Operand : constant Node_Id := Expression (N); 10346 Target_Typ : constant Entity_Id := Etype (N); 10347 Opnd_Typ : constant Entity_Id := Etype (Operand); 10348 10349 begin 10350 if Is_Floating_Point_Type (Opnd_Typ) 10351 and then 10352 (Is_Integer_Type (Target_Typ) 10353 or else (Is_Fixed_Point_Type (Target_Typ) 10354 and then Conversion_OK (N))) 10355 and then Nkind (Operand) = N_Attribute_Reference 10356 and then Attribute_Name (Operand) = Name_Truncation 10357 10358 -- Special processing required if the conversion is the expression 10359 -- of a Truncation attribute reference. In this case we replace: 10360 10361 -- ityp (ftyp'Truncation (x)) 10362 10363 -- by 10364 10365 -- ityp (x) 10366 10367 -- with the Float_Truncate flag set, which is more efficient. 10368 10369 then 10370 Rewrite (Operand, 10371 Relocate_Node (First (Expressions (Operand)))); 10372 Set_Float_Truncate (N, True); 10373 end if; 10374 end; 10375 end if; 10376 end Simplify_Type_Conversion; 10377 10378 ----------------------------- 10379 -- Unique_Fixed_Point_Type -- 10380 ----------------------------- 10381 10382 function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id is 10383 T1 : Entity_Id := Empty; 10384 T2 : Entity_Id; 10385 Item : Node_Id; 10386 Scop : Entity_Id; 10387 10388 procedure Fixed_Point_Error; 10389 -- Give error messages for true ambiguity. Messages are posted on node 10390 -- N, and entities T1, T2 are the possible interpretations. 10391 10392 ----------------------- 10393 -- Fixed_Point_Error -- 10394 ----------------------- 10395 10396 procedure Fixed_Point_Error is 10397 begin 10398 Error_Msg_N ("ambiguous universal_fixed_expression", N); 10399 Error_Msg_NE ("\\possible interpretation as}", N, T1); 10400 Error_Msg_NE ("\\possible interpretation as}", N, T2); 10401 end Fixed_Point_Error; 10402 10403 -- Start of processing for Unique_Fixed_Point_Type 10404 10405 begin 10406 -- The operations on Duration are visible, so Duration is always a 10407 -- possible interpretation. 10408 10409 T1 := Standard_Duration; 10410 10411 -- Look for fixed-point types in enclosing scopes 10412 10413 Scop := Current_Scope; 10414 while Scop /= Standard_Standard loop 10415 T2 := First_Entity (Scop); 10416 while Present (T2) loop 10417 if Is_Fixed_Point_Type (T2) 10418 and then Current_Entity (T2) = T2 10419 and then Scope (Base_Type (T2)) = Scop 10420 then 10421 if Present (T1) then 10422 Fixed_Point_Error; 10423 return Any_Type; 10424 else 10425 T1 := T2; 10426 end if; 10427 end if; 10428 10429 Next_Entity (T2); 10430 end loop; 10431 10432 Scop := Scope (Scop); 10433 end loop; 10434 10435 -- Look for visible fixed type declarations in the context 10436 10437 Item := First (Context_Items (Cunit (Current_Sem_Unit))); 10438 while Present (Item) loop 10439 if Nkind (Item) = N_With_Clause then 10440 Scop := Entity (Name (Item)); 10441 T2 := First_Entity (Scop); 10442 while Present (T2) loop 10443 if Is_Fixed_Point_Type (T2) 10444 and then Scope (Base_Type (T2)) = Scop 10445 and then (Is_Potentially_Use_Visible (T2) or else In_Use (T2)) 10446 then 10447 if Present (T1) then 10448 Fixed_Point_Error; 10449 return Any_Type; 10450 else 10451 T1 := T2; 10452 end if; 10453 end if; 10454 10455 Next_Entity (T2); 10456 end loop; 10457 end if; 10458 10459 Next (Item); 10460 end loop; 10461 10462 if Nkind (N) = N_Real_Literal then 10463 Error_Msg_NE 10464 ("??real literal interpreted as }!", N, T1); 10465 else 10466 Error_Msg_NE 10467 ("??universal_fixed expression interpreted as }!", N, T1); 10468 end if; 10469 10470 return T1; 10471 end Unique_Fixed_Point_Type; 10472 10473 ---------------------- 10474 -- Valid_Conversion -- 10475 ---------------------- 10476 10477 function Valid_Conversion 10478 (N : Node_Id; 10479 Target : Entity_Id; 10480 Operand : Node_Id; 10481 Report_Errs : Boolean := True) return Boolean 10482 is 10483 Target_Type : constant Entity_Id := Base_Type (Target); 10484 Opnd_Type : Entity_Id := Etype (Operand); 10485 10486 function Conversion_Check 10487 (Valid : Boolean; 10488 Msg : String) return Boolean; 10489 -- Little routine to post Msg if Valid is False, returns Valid value 10490 10491 -- The following are badly named, this kind of overloading is actively 10492 -- confusing in reading code, please rename to something like 10493 -- Error_Msg_N_If_Reporting ??? 10494 10495 procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id); 10496 -- If Report_Errs, then calls Errout.Error_Msg_N with its arguments 10497 10498 procedure Error_Msg_NE 10499 (Msg : String; 10500 N : Node_Or_Entity_Id; 10501 E : Node_Or_Entity_Id); 10502 -- If Report_Errs, then calls Errout.Error_Msg_NE with its arguments 10503 10504 function Valid_Tagged_Conversion 10505 (Target_Type : Entity_Id; 10506 Opnd_Type : Entity_Id) return Boolean; 10507 -- Specifically test for validity of tagged conversions 10508 10509 function Valid_Array_Conversion return Boolean; 10510 -- Check index and component conformance, and accessibility levels if 10511 -- the component types are anonymous access types (Ada 2005). 10512 10513 ---------------------- 10514 -- Conversion_Check -- 10515 ---------------------- 10516 10517 function Conversion_Check 10518 (Valid : Boolean; 10519 Msg : String) return Boolean 10520 is 10521 begin 10522 if not Valid 10523 10524 -- A generic unit has already been analyzed and we have verified 10525 -- that a particular conversion is OK in that context. Since the 10526 -- instance is reanalyzed without relying on the relationships 10527 -- established during the analysis of the generic, it is possible 10528 -- to end up with inconsistent views of private types. Do not emit 10529 -- the error message in such cases. The rest of the machinery in 10530 -- Valid_Conversion still ensures the proper compatibility of 10531 -- target and operand types. 10532 10533 and then not In_Instance 10534 then 10535 Error_Msg_N (Msg, Operand); 10536 end if; 10537 10538 return Valid; 10539 end Conversion_Check; 10540 10541 ----------------- 10542 -- Error_Msg_N -- 10543 ----------------- 10544 10545 procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is 10546 begin 10547 if Report_Errs then 10548 Errout.Error_Msg_N (Msg, N); 10549 end if; 10550 end Error_Msg_N; 10551 10552 ------------------ 10553 -- Error_Msg_NE -- 10554 ------------------ 10555 10556 procedure Error_Msg_NE 10557 (Msg : String; 10558 N : Node_Or_Entity_Id; 10559 E : Node_Or_Entity_Id) 10560 is 10561 begin 10562 if Report_Errs then 10563 Errout.Error_Msg_NE (Msg, N, E); 10564 end if; 10565 end Error_Msg_NE; 10566 10567 ---------------------------- 10568 -- Valid_Array_Conversion -- 10569 ---------------------------- 10570 10571 function Valid_Array_Conversion return Boolean 10572 is 10573 Opnd_Comp_Type : constant Entity_Id := Component_Type (Opnd_Type); 10574 Opnd_Comp_Base : constant Entity_Id := Base_Type (Opnd_Comp_Type); 10575 10576 Opnd_Index : Node_Id; 10577 Opnd_Index_Type : Entity_Id; 10578 10579 Target_Comp_Type : constant Entity_Id := 10580 Component_Type (Target_Type); 10581 Target_Comp_Base : constant Entity_Id := 10582 Base_Type (Target_Comp_Type); 10583 10584 Target_Index : Node_Id; 10585 Target_Index_Type : Entity_Id; 10586 10587 begin 10588 -- Error if wrong number of dimensions 10589 10590 if 10591 Number_Dimensions (Target_Type) /= Number_Dimensions (Opnd_Type) 10592 then 10593 Error_Msg_N 10594 ("incompatible number of dimensions for conversion", Operand); 10595 return False; 10596 10597 -- Number of dimensions matches 10598 10599 else 10600 -- Loop through indexes of the two arrays 10601 10602 Target_Index := First_Index (Target_Type); 10603 Opnd_Index := First_Index (Opnd_Type); 10604 while Present (Target_Index) and then Present (Opnd_Index) loop 10605 Target_Index_Type := Etype (Target_Index); 10606 Opnd_Index_Type := Etype (Opnd_Index); 10607 10608 -- Error if index types are incompatible 10609 10610 if not (Is_Integer_Type (Target_Index_Type) 10611 and then Is_Integer_Type (Opnd_Index_Type)) 10612 and then (Root_Type (Target_Index_Type) 10613 /= Root_Type (Opnd_Index_Type)) 10614 then 10615 Error_Msg_N 10616 ("incompatible index types for array conversion", 10617 Operand); 10618 return False; 10619 end if; 10620 10621 Next_Index (Target_Index); 10622 Next_Index (Opnd_Index); 10623 end loop; 10624 10625 -- If component types have same base type, all set 10626 10627 if Target_Comp_Base = Opnd_Comp_Base then 10628 null; 10629 10630 -- Here if base types of components are not the same. The only 10631 -- time this is allowed is if we have anonymous access types. 10632 10633 -- The conversion of arrays of anonymous access types can lead 10634 -- to dangling pointers. AI-392 formalizes the accessibility 10635 -- checks that must be applied to such conversions to prevent 10636 -- out-of-scope references. 10637 10638 elsif Ekind_In 10639 (Target_Comp_Base, E_Anonymous_Access_Type, 10640 E_Anonymous_Access_Subprogram_Type) 10641 and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base) 10642 and then 10643 Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) 10644 then 10645 if Type_Access_Level (Target_Type) < 10646 Deepest_Type_Access_Level (Opnd_Type) 10647 then 10648 if In_Instance_Body then 10649 Error_Msg_N 10650 ("??source array type has " & 10651 "deeper accessibility level than target", Operand); 10652 Error_Msg_N 10653 ("\??Program_Error will be raised at run time", 10654 Operand); 10655 Rewrite (N, 10656 Make_Raise_Program_Error (Sloc (N), 10657 Reason => PE_Accessibility_Check_Failed)); 10658 Set_Etype (N, Target_Type); 10659 return False; 10660 10661 -- Conversion not allowed because of accessibility levels 10662 10663 else 10664 Error_Msg_N 10665 ("source array type has " & 10666 "deeper accessibility level than target", Operand); 10667 return False; 10668 end if; 10669 10670 else 10671 null; 10672 end if; 10673 10674 -- All other cases where component base types do not match 10675 10676 else 10677 Error_Msg_N 10678 ("incompatible component types for array conversion", 10679 Operand); 10680 return False; 10681 end if; 10682 10683 -- Check that component subtypes statically match. For numeric 10684 -- types this means that both must be either constrained or 10685 -- unconstrained. For enumeration types the bounds must match. 10686 -- All of this is checked in Subtypes_Statically_Match. 10687 10688 if not Subtypes_Statically_Match 10689 (Target_Comp_Type, Opnd_Comp_Type) 10690 then 10691 Error_Msg_N 10692 ("component subtypes must statically match", Operand); 10693 return False; 10694 end if; 10695 end if; 10696 10697 return True; 10698 end Valid_Array_Conversion; 10699 10700 ----------------------------- 10701 -- Valid_Tagged_Conversion -- 10702 ----------------------------- 10703 10704 function Valid_Tagged_Conversion 10705 (Target_Type : Entity_Id; 10706 Opnd_Type : Entity_Id) return Boolean 10707 is 10708 begin 10709 -- Upward conversions are allowed (RM 4.6(22)) 10710 10711 if Covers (Target_Type, Opnd_Type) 10712 or else Is_Ancestor (Target_Type, Opnd_Type) 10713 then 10714 return True; 10715 10716 -- Downward conversion are allowed if the operand is class-wide 10717 -- (RM 4.6(23)). 10718 10719 elsif Is_Class_Wide_Type (Opnd_Type) 10720 and then Covers (Opnd_Type, Target_Type) 10721 then 10722 return True; 10723 10724 elsif Covers (Opnd_Type, Target_Type) 10725 or else Is_Ancestor (Opnd_Type, Target_Type) 10726 then 10727 return 10728 Conversion_Check (False, 10729 "downward conversion of tagged objects not allowed"); 10730 10731 -- Ada 2005 (AI-251): The conversion to/from interface types is 10732 -- always valid 10733 10734 elsif Is_Interface (Target_Type) or else Is_Interface (Opnd_Type) then 10735 return True; 10736 10737 -- If the operand is a class-wide type obtained through a limited_ 10738 -- with clause, and the context includes the non-limited view, use 10739 -- it to determine whether the conversion is legal. 10740 10741 elsif Is_Class_Wide_Type (Opnd_Type) 10742 and then From_With_Type (Opnd_Type) 10743 and then Present (Non_Limited_View (Etype (Opnd_Type))) 10744 and then Is_Interface (Non_Limited_View (Etype (Opnd_Type))) 10745 then 10746 return True; 10747 10748 elsif Is_Access_Type (Opnd_Type) 10749 and then Is_Interface (Directly_Designated_Type (Opnd_Type)) 10750 then 10751 return True; 10752 10753 else 10754 Error_Msg_NE 10755 ("invalid tagged conversion, not compatible with}", 10756 N, First_Subtype (Opnd_Type)); 10757 return False; 10758 end if; 10759 end Valid_Tagged_Conversion; 10760 10761 -- Start of processing for Valid_Conversion 10762 10763 begin 10764 Check_Parameterless_Call (Operand); 10765 10766 if Is_Overloaded (Operand) then 10767 declare 10768 I : Interp_Index; 10769 I1 : Interp_Index; 10770 It : Interp; 10771 It1 : Interp; 10772 N1 : Entity_Id; 10773 T1 : Entity_Id; 10774 10775 begin 10776 -- Remove procedure calls, which syntactically cannot appear in 10777 -- this context, but which cannot be removed by type checking, 10778 -- because the context does not impose a type. 10779 10780 -- When compiling for VMS, spurious ambiguities can be produced 10781 -- when arithmetic operations have a literal operand and return 10782 -- System.Address or a descendant of it. These ambiguities are 10783 -- otherwise resolved by the context, but for conversions there 10784 -- is no context type and the removal of the spurious operations 10785 -- must be done explicitly here. 10786 10787 -- The node may be labelled overloaded, but still contain only one 10788 -- interpretation because others were discarded earlier. If this 10789 -- is the case, retain the single interpretation if legal. 10790 10791 Get_First_Interp (Operand, I, It); 10792 Opnd_Type := It.Typ; 10793 Get_Next_Interp (I, It); 10794 10795 if Present (It.Typ) 10796 and then Opnd_Type /= Standard_Void_Type 10797 then 10798 -- More than one candidate interpretation is available 10799 10800 Get_First_Interp (Operand, I, It); 10801 while Present (It.Typ) loop 10802 if It.Typ = Standard_Void_Type then 10803 Remove_Interp (I); 10804 end if; 10805 10806 if Present (System_Aux_Id) 10807 and then Is_Descendent_Of_Address (It.Typ) 10808 then 10809 Remove_Interp (I); 10810 end if; 10811 10812 Get_Next_Interp (I, It); 10813 end loop; 10814 end if; 10815 10816 Get_First_Interp (Operand, I, It); 10817 I1 := I; 10818 It1 := It; 10819 10820 if No (It.Typ) then 10821 Error_Msg_N ("illegal operand in conversion", Operand); 10822 return False; 10823 end if; 10824 10825 Get_Next_Interp (I, It); 10826 10827 if Present (It.Typ) then 10828 N1 := It1.Nam; 10829 T1 := It1.Typ; 10830 It1 := Disambiguate (Operand, I1, I, Any_Type); 10831 10832 if It1 = No_Interp then 10833 Error_Msg_N ("ambiguous operand in conversion", Operand); 10834 10835 -- If the interpretation involves a standard operator, use 10836 -- the location of the type, which may be user-defined. 10837 10838 if Sloc (It.Nam) = Standard_Location then 10839 Error_Msg_Sloc := Sloc (It.Typ); 10840 else 10841 Error_Msg_Sloc := Sloc (It.Nam); 10842 end if; 10843 10844 Error_Msg_N -- CODEFIX 10845 ("\\possible interpretation#!", Operand); 10846 10847 if Sloc (N1) = Standard_Location then 10848 Error_Msg_Sloc := Sloc (T1); 10849 else 10850 Error_Msg_Sloc := Sloc (N1); 10851 end if; 10852 10853 Error_Msg_N -- CODEFIX 10854 ("\\possible interpretation#!", Operand); 10855 10856 return False; 10857 end if; 10858 end if; 10859 10860 Set_Etype (Operand, It1.Typ); 10861 Opnd_Type := It1.Typ; 10862 end; 10863 end if; 10864 10865 -- Numeric types 10866 10867 if Is_Numeric_Type (Target_Type) then 10868 10869 -- A universal fixed expression can be converted to any numeric type 10870 10871 if Opnd_Type = Universal_Fixed then 10872 return True; 10873 10874 -- Also no need to check when in an instance or inlined body, because 10875 -- the legality has been established when the template was analyzed. 10876 -- Furthermore, numeric conversions may occur where only a private 10877 -- view of the operand type is visible at the instantiation point. 10878 -- This results in a spurious error if we check that the operand type 10879 -- is a numeric type. 10880 10881 -- Note: in a previous version of this unit, the following tests were 10882 -- applied only for generated code (Comes_From_Source set to False), 10883 -- but in fact the test is required for source code as well, since 10884 -- this situation can arise in source code. 10885 10886 elsif In_Instance or else In_Inlined_Body then 10887 return True; 10888 10889 -- Otherwise we need the conversion check 10890 10891 else 10892 return Conversion_Check 10893 (Is_Numeric_Type (Opnd_Type), 10894 "illegal operand for numeric conversion"); 10895 end if; 10896 10897 -- Array types 10898 10899 elsif Is_Array_Type (Target_Type) then 10900 if not Is_Array_Type (Opnd_Type) 10901 or else Opnd_Type = Any_Composite 10902 or else Opnd_Type = Any_String 10903 then 10904 Error_Msg_N ("illegal operand for array conversion", Operand); 10905 return False; 10906 else 10907 return Valid_Array_Conversion; 10908 end if; 10909 10910 -- Ada 2005 (AI-251): Anonymous access types where target references an 10911 -- interface type. 10912 10913 elsif Ekind_In (Target_Type, E_General_Access_Type, 10914 E_Anonymous_Access_Type) 10915 and then Is_Interface (Directly_Designated_Type (Target_Type)) 10916 then 10917 -- Check the static accessibility rule of 4.6(17). Note that the 10918 -- check is not enforced when within an instance body, since the 10919 -- RM requires such cases to be caught at run time. 10920 10921 -- If the operand is a rewriting of an allocator no check is needed 10922 -- because there are no accessibility issues. 10923 10924 if Nkind (Original_Node (N)) = N_Allocator then 10925 null; 10926 10927 elsif Ekind (Target_Type) /= E_Anonymous_Access_Type then 10928 if Type_Access_Level (Opnd_Type) > 10929 Deepest_Type_Access_Level (Target_Type) 10930 then 10931 -- In an instance, this is a run-time check, but one we know 10932 -- will fail, so generate an appropriate warning. The raise 10933 -- will be generated by Expand_N_Type_Conversion. 10934 10935 if In_Instance_Body then 10936 Error_Msg_N 10937 ("??cannot convert local pointer to non-local access type", 10938 Operand); 10939 Error_Msg_N 10940 ("\??Program_Error will be raised at run time", Operand); 10941 10942 else 10943 Error_Msg_N 10944 ("cannot convert local pointer to non-local access type", 10945 Operand); 10946 return False; 10947 end if; 10948 10949 -- Special accessibility checks are needed in the case of access 10950 -- discriminants declared for a limited type. 10951 10952 elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type 10953 and then not Is_Local_Anonymous_Access (Opnd_Type) 10954 then 10955 -- When the operand is a selected access discriminant the check 10956 -- needs to be made against the level of the object denoted by 10957 -- the prefix of the selected name (Object_Access_Level handles 10958 -- checking the prefix of the operand for this case). 10959 10960 if Nkind (Operand) = N_Selected_Component 10961 and then Object_Access_Level (Operand) > 10962 Deepest_Type_Access_Level (Target_Type) 10963 then 10964 -- In an instance, this is a run-time check, but one we know 10965 -- will fail, so generate an appropriate warning. The raise 10966 -- will be generated by Expand_N_Type_Conversion. 10967 10968 if In_Instance_Body then 10969 Error_Msg_N 10970 ("??cannot convert access discriminant to non-local" & 10971 " access type", Operand); 10972 Error_Msg_N 10973 ("\??Program_Error will be raised at run time", 10974 Operand); 10975 else 10976 Error_Msg_N 10977 ("cannot convert access discriminant to non-local" & 10978 " access type", Operand); 10979 return False; 10980 end if; 10981 end if; 10982 10983 -- The case of a reference to an access discriminant from 10984 -- within a limited type declaration (which will appear as 10985 -- a discriminal) is always illegal because the level of the 10986 -- discriminant is considered to be deeper than any (nameable) 10987 -- access type. 10988 10989 if Is_Entity_Name (Operand) 10990 and then not Is_Local_Anonymous_Access (Opnd_Type) 10991 and then 10992 Ekind_In (Entity (Operand), E_In_Parameter, E_Constant) 10993 and then Present (Discriminal_Link (Entity (Operand))) 10994 then 10995 Error_Msg_N 10996 ("discriminant has deeper accessibility level than target", 10997 Operand); 10998 return False; 10999 end if; 11000 end if; 11001 end if; 11002 11003 return True; 11004 11005 -- General and anonymous access types 11006 11007 elsif Ekind_In (Target_Type, E_General_Access_Type, 11008 E_Anonymous_Access_Type) 11009 and then 11010 Conversion_Check 11011 (Is_Access_Type (Opnd_Type) 11012 and then not 11013 Ekind_In (Opnd_Type, E_Access_Subprogram_Type, 11014 E_Access_Protected_Subprogram_Type), 11015 "must be an access-to-object type") 11016 then 11017 if Is_Access_Constant (Opnd_Type) 11018 and then not Is_Access_Constant (Target_Type) 11019 then 11020 Error_Msg_N 11021 ("access-to-constant operand type not allowed", Operand); 11022 return False; 11023 end if; 11024 11025 -- Check the static accessibility rule of 4.6(17). Note that the 11026 -- check is not enforced when within an instance body, since the RM 11027 -- requires such cases to be caught at run time. 11028 11029 if Ekind (Target_Type) /= E_Anonymous_Access_Type 11030 or else Is_Local_Anonymous_Access (Target_Type) 11031 or else Nkind (Associated_Node_For_Itype (Target_Type)) = 11032 N_Object_Declaration 11033 then 11034 -- Ada 2012 (AI05-0149): Perform legality checking on implicit 11035 -- conversions from an anonymous access type to a named general 11036 -- access type. Such conversions are not allowed in the case of 11037 -- access parameters and stand-alone objects of an anonymous 11038 -- access type. The implicit conversion case is recognized by 11039 -- testing that Comes_From_Source is False and that it's been 11040 -- rewritten. The Comes_From_Source test isn't sufficient because 11041 -- nodes in inlined calls to predefined library routines can have 11042 -- Comes_From_Source set to False. (Is there a better way to test 11043 -- for implicit conversions???) 11044 11045 if Ada_Version >= Ada_2012 11046 and then not Comes_From_Source (N) 11047 and then N /= Original_Node (N) 11048 and then Ekind (Target_Type) = E_General_Access_Type 11049 and then Ekind (Opnd_Type) = E_Anonymous_Access_Type 11050 then 11051 if Is_Itype (Opnd_Type) then 11052 11053 -- Implicit conversions aren't allowed for objects of an 11054 -- anonymous access type, since such objects have nonstatic 11055 -- levels in Ada 2012. 11056 11057 if Nkind (Associated_Node_For_Itype (Opnd_Type)) = 11058 N_Object_Declaration 11059 then 11060 Error_Msg_N 11061 ("implicit conversion of stand-alone anonymous " & 11062 "access object not allowed", Operand); 11063 return False; 11064 11065 -- Implicit conversions aren't allowed for anonymous access 11066 -- parameters. The "not Is_Local_Anonymous_Access_Type" test 11067 -- is done to exclude anonymous access results. 11068 11069 elsif not Is_Local_Anonymous_Access (Opnd_Type) 11070 and then Nkind_In (Associated_Node_For_Itype (Opnd_Type), 11071 N_Function_Specification, 11072 N_Procedure_Specification) 11073 then 11074 Error_Msg_N 11075 ("implicit conversion of anonymous access formal " & 11076 "not allowed", Operand); 11077 return False; 11078 11079 -- This is a case where there's an enclosing object whose 11080 -- to which the "statically deeper than" relationship does 11081 -- not apply (such as an access discriminant selected from 11082 -- a dereference of an access parameter). 11083 11084 elsif Object_Access_Level (Operand) 11085 = Scope_Depth (Standard_Standard) 11086 then 11087 Error_Msg_N 11088 ("implicit conversion of anonymous access value " & 11089 "not allowed", Operand); 11090 return False; 11091 11092 -- In other cases, the level of the operand's type must be 11093 -- statically less deep than that of the target type, else 11094 -- implicit conversion is disallowed (by RM12-8.6(27.1/3)). 11095 11096 elsif Type_Access_Level (Opnd_Type) > 11097 Deepest_Type_Access_Level (Target_Type) 11098 then 11099 Error_Msg_N 11100 ("implicit conversion of anonymous access value " & 11101 "violates accessibility", Operand); 11102 return False; 11103 end if; 11104 end if; 11105 11106 elsif Type_Access_Level (Opnd_Type) > 11107 Deepest_Type_Access_Level (Target_Type) 11108 then 11109 -- In an instance, this is a run-time check, but one we know 11110 -- will fail, so generate an appropriate warning. The raise 11111 -- will be generated by Expand_N_Type_Conversion. 11112 11113 if In_Instance_Body then 11114 Error_Msg_N 11115 ("??cannot convert local pointer to non-local access type", 11116 Operand); 11117 Error_Msg_N 11118 ("\??Program_Error will be raised at run time", Operand); 11119 11120 else 11121 -- Avoid generation of spurious error message 11122 11123 if not Error_Posted (N) then 11124 Error_Msg_N 11125 ("cannot convert local pointer to non-local access type", 11126 Operand); 11127 end if; 11128 11129 return False; 11130 end if; 11131 11132 -- Special accessibility checks are needed in the case of access 11133 -- discriminants declared for a limited type. 11134 11135 elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type 11136 and then not Is_Local_Anonymous_Access (Opnd_Type) 11137 then 11138 -- When the operand is a selected access discriminant the check 11139 -- needs to be made against the level of the object denoted by 11140 -- the prefix of the selected name (Object_Access_Level handles 11141 -- checking the prefix of the operand for this case). 11142 11143 if Nkind (Operand) = N_Selected_Component 11144 and then Object_Access_Level (Operand) > 11145 Deepest_Type_Access_Level (Target_Type) 11146 then 11147 -- In an instance, this is a run-time check, but one we know 11148 -- will fail, so generate an appropriate warning. The raise 11149 -- will be generated by Expand_N_Type_Conversion. 11150 11151 if In_Instance_Body then 11152 Error_Msg_N 11153 ("??cannot convert access discriminant to non-local" 11154 & " access type", Operand); 11155 Error_Msg_N 11156 ("\??Program_Error will be raised at run time", 11157 Operand); 11158 11159 else 11160 Error_Msg_N 11161 ("cannot convert access discriminant to non-local" & 11162 " access type", Operand); 11163 return False; 11164 end if; 11165 end if; 11166 11167 -- The case of a reference to an access discriminant from 11168 -- within a limited type declaration (which will appear as 11169 -- a discriminal) is always illegal because the level of the 11170 -- discriminant is considered to be deeper than any (nameable) 11171 -- access type. 11172 11173 if Is_Entity_Name (Operand) 11174 and then 11175 Ekind_In (Entity (Operand), E_In_Parameter, E_Constant) 11176 and then Present (Discriminal_Link (Entity (Operand))) 11177 then 11178 Error_Msg_N 11179 ("discriminant has deeper accessibility level than target", 11180 Operand); 11181 return False; 11182 end if; 11183 end if; 11184 end if; 11185 11186 -- In the presence of limited_with clauses we have to use non-limited 11187 -- views, if available. 11188 11189 Check_Limited : declare 11190 function Full_Designated_Type (T : Entity_Id) return Entity_Id; 11191 -- Helper function to handle limited views 11192 11193 -------------------------- 11194 -- Full_Designated_Type -- 11195 -------------------------- 11196 11197 function Full_Designated_Type (T : Entity_Id) return Entity_Id is 11198 Desig : constant Entity_Id := Designated_Type (T); 11199 11200 begin 11201 -- Handle the limited view of a type 11202 11203 if Is_Incomplete_Type (Desig) 11204 and then From_With_Type (Desig) 11205 and then Present (Non_Limited_View (Desig)) 11206 then 11207 return Available_View (Desig); 11208 else 11209 return Desig; 11210 end if; 11211 end Full_Designated_Type; 11212 11213 -- Local Declarations 11214 11215 Target : constant Entity_Id := Full_Designated_Type (Target_Type); 11216 Opnd : constant Entity_Id := Full_Designated_Type (Opnd_Type); 11217 11218 Same_Base : constant Boolean := 11219 Base_Type (Target) = Base_Type (Opnd); 11220 11221 -- Start of processing for Check_Limited 11222 11223 begin 11224 if Is_Tagged_Type (Target) then 11225 return Valid_Tagged_Conversion (Target, Opnd); 11226 11227 else 11228 if not Same_Base then 11229 Error_Msg_NE 11230 ("target designated type not compatible with }", 11231 N, Base_Type (Opnd)); 11232 return False; 11233 11234 -- Ada 2005 AI-384: legality rule is symmetric in both 11235 -- designated types. The conversion is legal (with possible 11236 -- constraint check) if either designated type is 11237 -- unconstrained. 11238 11239 elsif Subtypes_Statically_Match (Target, Opnd) 11240 or else 11241 (Has_Discriminants (Target) 11242 and then 11243 (not Is_Constrained (Opnd) 11244 or else not Is_Constrained (Target))) 11245 then 11246 -- Special case, if Value_Size has been used to make the 11247 -- sizes different, the conversion is not allowed even 11248 -- though the subtypes statically match. 11249 11250 if Known_Static_RM_Size (Target) 11251 and then Known_Static_RM_Size (Opnd) 11252 and then RM_Size (Target) /= RM_Size (Opnd) 11253 then 11254 Error_Msg_NE 11255 ("target designated subtype not compatible with }", 11256 N, Opnd); 11257 Error_Msg_NE 11258 ("\because sizes of the two designated subtypes differ", 11259 N, Opnd); 11260 return False; 11261 11262 -- Normal case where conversion is allowed 11263 11264 else 11265 return True; 11266 end if; 11267 11268 else 11269 Error_Msg_NE 11270 ("target designated subtype not compatible with }", 11271 N, Opnd); 11272 return False; 11273 end if; 11274 end if; 11275 end Check_Limited; 11276 11277 -- Access to subprogram types. If the operand is an access parameter, 11278 -- the type has a deeper accessibility that any master, and cannot be 11279 -- assigned. We must make an exception if the conversion is part of an 11280 -- assignment and the target is the return object of an extended return 11281 -- statement, because in that case the accessibility check takes place 11282 -- after the return. 11283 11284 elsif Is_Access_Subprogram_Type (Target_Type) 11285 and then No (Corresponding_Remote_Type (Opnd_Type)) 11286 then 11287 if Ekind (Base_Type (Opnd_Type)) = E_Anonymous_Access_Subprogram_Type 11288 and then Is_Entity_Name (Operand) 11289 and then Ekind (Entity (Operand)) = E_In_Parameter 11290 and then 11291 (Nkind (Parent (N)) /= N_Assignment_Statement 11292 or else not Is_Entity_Name (Name (Parent (N))) 11293 or else not Is_Return_Object (Entity (Name (Parent (N))))) 11294 then 11295 Error_Msg_N 11296 ("illegal attempt to store anonymous access to subprogram", 11297 Operand); 11298 Error_Msg_N 11299 ("\value has deeper accessibility than any master " & 11300 "(RM 3.10.2 (13))", 11301 Operand); 11302 11303 Error_Msg_NE 11304 ("\use named access type for& instead of access parameter", 11305 Operand, Entity (Operand)); 11306 end if; 11307 11308 -- Check that the designated types are subtype conformant 11309 11310 Check_Subtype_Conformant (New_Id => Designated_Type (Target_Type), 11311 Old_Id => Designated_Type (Opnd_Type), 11312 Err_Loc => N); 11313 11314 -- Check the static accessibility rule of 4.6(20) 11315 11316 if Type_Access_Level (Opnd_Type) > 11317 Deepest_Type_Access_Level (Target_Type) 11318 then 11319 Error_Msg_N 11320 ("operand type has deeper accessibility level than target", 11321 Operand); 11322 11323 -- Check that if the operand type is declared in a generic body, 11324 -- then the target type must be declared within that same body 11325 -- (enforces last sentence of 4.6(20)). 11326 11327 elsif Present (Enclosing_Generic_Body (Opnd_Type)) then 11328 declare 11329 O_Gen : constant Node_Id := 11330 Enclosing_Generic_Body (Opnd_Type); 11331 11332 T_Gen : Node_Id; 11333 11334 begin 11335 T_Gen := Enclosing_Generic_Body (Target_Type); 11336 while Present (T_Gen) and then T_Gen /= O_Gen loop 11337 T_Gen := Enclosing_Generic_Body (T_Gen); 11338 end loop; 11339 11340 if T_Gen /= O_Gen then 11341 Error_Msg_N 11342 ("target type must be declared in same generic body" 11343 & " as operand type", N); 11344 end if; 11345 end; 11346 end if; 11347 11348 return True; 11349 11350 -- Remote subprogram access types 11351 11352 elsif Is_Remote_Access_To_Subprogram_Type (Target_Type) 11353 and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type) 11354 then 11355 -- It is valid to convert from one RAS type to another provided 11356 -- that their specification statically match. 11357 11358 Check_Subtype_Conformant 11359 (New_Id => 11360 Designated_Type (Corresponding_Remote_Type (Target_Type)), 11361 Old_Id => 11362 Designated_Type (Corresponding_Remote_Type (Opnd_Type)), 11363 Err_Loc => 11364 N); 11365 return True; 11366 11367 -- If it was legal in the generic, it's legal in the instance 11368 11369 elsif In_Instance_Body then 11370 return True; 11371 11372 -- If both are tagged types, check legality of view conversions 11373 11374 elsif Is_Tagged_Type (Target_Type) 11375 and then 11376 Is_Tagged_Type (Opnd_Type) 11377 then 11378 return Valid_Tagged_Conversion (Target_Type, Opnd_Type); 11379 11380 -- Types derived from the same root type are convertible 11381 11382 elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then 11383 return True; 11384 11385 -- In an instance or an inlined body, there may be inconsistent views of 11386 -- the same type, or of types derived from a common root. 11387 11388 elsif (In_Instance or In_Inlined_Body) 11389 and then 11390 Root_Type (Underlying_Type (Target_Type)) = 11391 Root_Type (Underlying_Type (Opnd_Type)) 11392 then 11393 return True; 11394 11395 -- Special check for common access type error case 11396 11397 elsif Ekind (Target_Type) = E_Access_Type 11398 and then Is_Access_Type (Opnd_Type) 11399 then 11400 Error_Msg_N ("target type must be general access type!", N); 11401 Error_Msg_NE -- CODEFIX 11402 ("add ALL to }!", N, Target_Type); 11403 return False; 11404 11405 else 11406 Error_Msg_NE ("invalid conversion, not compatible with }", 11407 N, Opnd_Type); 11408 return False; 11409 end if; 11410 end Valid_Conversion; 11411 11412end Sem_Res; 11413