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