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