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