1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ A T T R -- 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 Ada.Characters.Latin_1; use Ada.Characters.Latin_1; 27 28with Atree; use Atree; 29with Casing; use Casing; 30with Checks; use Checks; 31with Debug; use Debug; 32with Einfo; use Einfo; 33with Elists; use Elists; 34with Errout; use Errout; 35with Eval_Fat; 36with Exp_Dist; use Exp_Dist; 37with Exp_Util; use Exp_Util; 38with Expander; use Expander; 39with Freeze; use Freeze; 40with Gnatvsn; use Gnatvsn; 41with Itypes; use Itypes; 42with Lib; use Lib; 43with Lib.Xref; use Lib.Xref; 44with Nlists; use Nlists; 45with Nmake; use Nmake; 46with Opt; use Opt; 47with Restrict; use Restrict; 48with Rident; use Rident; 49with Rtsfind; use Rtsfind; 50with Sdefault; 51with Sem; use Sem; 52with Sem_Aux; use Sem_Aux; 53with Sem_Cat; use Sem_Cat; 54with Sem_Ch6; use Sem_Ch6; 55with Sem_Ch8; use Sem_Ch8; 56with Sem_Ch10; use Sem_Ch10; 57with Sem_Dim; use Sem_Dim; 58with Sem_Dist; use Sem_Dist; 59with Sem_Elab; use Sem_Elab; 60with Sem_Elim; use Sem_Elim; 61with Sem_Eval; use Sem_Eval; 62with Sem_Prag; use Sem_Prag; 63with Sem_Res; use Sem_Res; 64with Sem_Type; use Sem_Type; 65with Sem_Util; use Sem_Util; 66with Sem_Warn; 67with Stand; use Stand; 68with Sinfo; use Sinfo; 69with Sinput; use Sinput; 70with System; 71with Stringt; use Stringt; 72with Style; 73with Stylesw; use Stylesw; 74with Targparm; use Targparm; 75with Ttypes; use Ttypes; 76with Tbuild; use Tbuild; 77with Uintp; use Uintp; 78with Uname; use Uname; 79with Urealp; use Urealp; 80 81with System.CRC32; use System.CRC32; 82 83package body Sem_Attr is 84 85 True_Value : constant Uint := Uint_1; 86 False_Value : constant Uint := Uint_0; 87 -- Synonyms to be used when these constants are used as Boolean values 88 89 Bad_Attribute : exception; 90 -- Exception raised if an error is detected during attribute processing, 91 -- used so that we can abandon the processing so we don't run into 92 -- trouble with cascaded errors. 93 94 -- The following array is the list of attributes defined in the Ada 83 RM. 95 -- In Ada 83 mode, these are the only recognized attributes. In other Ada 96 -- modes all these attributes are recognized, even if removed in Ada 95. 97 98 Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'( 99 Attribute_Address | 100 Attribute_Aft | 101 Attribute_Alignment | 102 Attribute_Base | 103 Attribute_Callable | 104 Attribute_Constrained | 105 Attribute_Count | 106 Attribute_Delta | 107 Attribute_Digits | 108 Attribute_Emax | 109 Attribute_Epsilon | 110 Attribute_First | 111 Attribute_First_Bit | 112 Attribute_Fore | 113 Attribute_Image | 114 Attribute_Large | 115 Attribute_Last | 116 Attribute_Last_Bit | 117 Attribute_Leading_Part | 118 Attribute_Length | 119 Attribute_Machine_Emax | 120 Attribute_Machine_Emin | 121 Attribute_Machine_Mantissa | 122 Attribute_Machine_Overflows | 123 Attribute_Machine_Radix | 124 Attribute_Machine_Rounds | 125 Attribute_Mantissa | 126 Attribute_Pos | 127 Attribute_Position | 128 Attribute_Pred | 129 Attribute_Range | 130 Attribute_Safe_Emax | 131 Attribute_Safe_Large | 132 Attribute_Safe_Small | 133 Attribute_Size | 134 Attribute_Small | 135 Attribute_Storage_Size | 136 Attribute_Succ | 137 Attribute_Terminated | 138 Attribute_Val | 139 Attribute_Value | 140 Attribute_Width => True, 141 others => False); 142 143 -- The following array is the list of attributes defined in the Ada 2005 144 -- RM which are not defined in Ada 95. These are recognized in Ada 95 mode, 145 -- but in Ada 95 they are considered to be implementation defined. 146 147 Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'( 148 Attribute_Machine_Rounding | 149 Attribute_Mod | 150 Attribute_Priority | 151 Attribute_Stream_Size | 152 Attribute_Wide_Wide_Width => True, 153 others => False); 154 155 -- The following array is the list of attributes defined in the Ada 2012 156 -- RM which are not defined in Ada 2005. These are recognized in Ada 95 157 -- and Ada 2005 modes, but are considered to be implementation defined. 158 159 Attribute_12 : constant Attribute_Class_Array := Attribute_Class_Array'( 160 Attribute_First_Valid | 161 Attribute_Has_Same_Storage | 162 Attribute_Last_Valid | 163 Attribute_Max_Alignment_For_Allocation => True, 164 others => False); 165 166 -- The following array contains all attributes that imply a modification 167 -- of their prefixes or result in an access value. Such prefixes can be 168 -- considered as lvalues. 169 170 Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array := 171 Attribute_Class_Array'( 172 Attribute_Access | 173 Attribute_Address | 174 Attribute_Input | 175 Attribute_Read | 176 Attribute_Unchecked_Access | 177 Attribute_Unrestricted_Access => True, 178 others => False); 179 180 ----------------------- 181 -- Local_Subprograms -- 182 ----------------------- 183 184 procedure Eval_Attribute (N : Node_Id); 185 -- Performs compile time evaluation of attributes where possible, leaving 186 -- the Is_Static_Expression/Raises_Constraint_Error flags appropriately 187 -- set, and replacing the node with a literal node if the value can be 188 -- computed at compile time. All static attribute references are folded, 189 -- as well as a number of cases of non-static attributes that can always 190 -- be computed at compile time (e.g. floating-point model attributes that 191 -- are applied to non-static subtypes). Of course in such cases, the 192 -- Is_Static_Expression flag will not be set on the resulting literal. 193 -- Note that the only required action of this procedure is to catch the 194 -- static expression cases as described in the RM. Folding of other cases 195 -- is done where convenient, but some additional non-static folding is in 196 -- Expand_N_Attribute_Reference in cases where this is more convenient. 197 198 function Is_Anonymous_Tagged_Base 199 (Anon : Entity_Id; 200 Typ : Entity_Id) return Boolean; 201 -- For derived tagged types that constrain parent discriminants we build 202 -- an anonymous unconstrained base type. We need to recognize the relation 203 -- between the two when analyzing an access attribute for a constrained 204 -- component, before the full declaration for Typ has been analyzed, and 205 -- where therefore the prefix of the attribute does not match the enclosing 206 -- scope. 207 208 procedure Set_Boolean_Result (N : Node_Id; B : Boolean); 209 -- Rewrites node N with an occurrence of either Standard_False or 210 -- Standard_True, depending on the value of the parameter B. The 211 -- result is marked as a static expression. 212 213 function Statically_Denotes_Object (N : Node_Id) return Boolean; 214 -- Predicate used to check the legality of the prefix to 'Loop_Entry and 215 -- 'Old, when the prefix is not an entity name. Current RM specfies that 216 -- the prefix must be a direct or expanded name, but it has been proposed 217 -- that the prefix be allowed to be a selected component that does not 218 -- depend on a discriminant, or an indexed component with static indices. 219 -- Current code for this predicate implements this more permissive 220 -- implementation. 221 222 ----------------------- 223 -- Analyze_Attribute -- 224 ----------------------- 225 226 procedure Analyze_Attribute (N : Node_Id) is 227 Loc : constant Source_Ptr := Sloc (N); 228 Aname : constant Name_Id := Attribute_Name (N); 229 P : constant Node_Id := Prefix (N); 230 Exprs : constant List_Id := Expressions (N); 231 Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname); 232 E1 : Node_Id; 233 E2 : Node_Id; 234 235 P_Type : Entity_Id := Empty; 236 -- Type of prefix after analysis 237 238 P_Base_Type : Entity_Id := Empty; 239 -- Base type of prefix after analysis 240 241 ----------------------- 242 -- Local Subprograms -- 243 ----------------------- 244 245 procedure Address_Checks; 246 -- Semantic checks for valid use of Address attribute. This was made 247 -- a separate routine with the idea of using it for unrestricted access 248 -- which seems like it should follow the same rules, but that turned 249 -- out to be impractical. So now this is only used for Address. 250 251 procedure Analyze_Access_Attribute; 252 -- Used for Access, Unchecked_Access, Unrestricted_Access attributes. 253 -- Internally, Id distinguishes which of the three cases is involved. 254 255 procedure Analyze_Attribute_Old_Result 256 (Legal : out Boolean; 257 Spec_Id : out Entity_Id); 258 -- Common processing for attributes 'Old and 'Result. The routine checks 259 -- that the attribute appears in a postcondition-like aspect or pragma 260 -- associated with a suitable subprogram or a body. Flag Legal is set 261 -- when the above criteria are met. Spec_Id denotes the entity of the 262 -- subprogram [body] or Empty if the attribute is illegal. 263 264 procedure Analyze_Image_Attribute (Str_Typ : Entity_Id); 265 -- Common processing for attributes 'Img, 'Image, 'Wide_Image, and 266 -- 'Wide_Wide_Image. The routine checks that the prefix is valid and 267 -- sets the type of the attribute to the one specified by Str_Typ (e.g. 268 -- Standard_String for 'Image and Standard_Wide_String for 'Wide_Image). 269 270 procedure Bad_Attribute_For_Predicate; 271 -- Output error message for use of a predicate (First, Last, Range) not 272 -- allowed with a type that has predicates. If the type is a generic 273 -- actual, then the message is a warning, and we generate code to raise 274 -- program error with an appropriate reason. No error message is given 275 -- for internally generated uses of the attributes. This legality rule 276 -- only applies to scalar types. 277 278 procedure Check_Array_Or_Scalar_Type; 279 -- Common procedure used by First, Last, Range attribute to check 280 -- that the prefix is a constrained array or scalar type, or a name 281 -- of an array object, and that an argument appears only if appropriate 282 -- (i.e. only in the array case). 283 284 procedure Check_Array_Type; 285 -- Common semantic checks for all array attributes. Checks that the 286 -- prefix is a constrained array type or the name of an array object. 287 -- The error message for non-arrays is specialized appropriately. 288 289 procedure Check_Asm_Attribute; 290 -- Common semantic checks for Asm_Input and Asm_Output attributes 291 292 procedure Check_Component; 293 -- Common processing for Bit_Position, First_Bit, Last_Bit, and 294 -- Position. Checks prefix is an appropriate selected component. 295 296 procedure Check_Decimal_Fixed_Point_Type; 297 -- Check that prefix of attribute N is a decimal fixed-point type 298 299 procedure Check_Dereference; 300 -- If the prefix of attribute is an object of an access type, then 301 -- introduce an explicit dereference, and adjust P_Type accordingly. 302 303 procedure Check_Discrete_Type; 304 -- Verify that prefix of attribute N is a discrete type 305 306 procedure Check_E0; 307 -- Check that no attribute arguments are present 308 309 procedure Check_Either_E0_Or_E1; 310 -- Check that there are zero or one attribute arguments present 311 312 procedure Check_E1; 313 -- Check that exactly one attribute argument is present 314 315 procedure Check_E2; 316 -- Check that two attribute arguments are present 317 318 procedure Check_Enum_Image; 319 -- If the prefix type of 'Image is an enumeration type, set all its 320 -- literals as referenced, since the image function could possibly end 321 -- up referencing any of the literals indirectly. Same for Enum_Val. 322 -- Set the flag only if the reference is in the main code unit. Same 323 -- restriction when resolving 'Value; otherwise an improperly set 324 -- reference when analyzing an inlined body will lose a proper 325 -- warning on a useless with_clause. 326 327 procedure Check_First_Last_Valid; 328 -- Perform all checks for First_Valid and Last_Valid attributes 329 330 procedure Check_Fixed_Point_Type; 331 -- Verify that prefix of attribute N is a fixed type 332 333 procedure Check_Fixed_Point_Type_0; 334 -- Verify that prefix of attribute N is a fixed type and that 335 -- no attribute expressions are present. 336 337 procedure Check_Floating_Point_Type; 338 -- Verify that prefix of attribute N is a float type 339 340 procedure Check_Floating_Point_Type_0; 341 -- Verify that prefix of attribute N is a float type and that 342 -- no attribute expressions are present. 343 344 procedure Check_Floating_Point_Type_1; 345 -- Verify that prefix of attribute N is a float type and that 346 -- exactly one attribute expression is present. 347 348 procedure Check_Floating_Point_Type_2; 349 -- Verify that prefix of attribute N is a float type and that 350 -- two attribute expressions are present 351 352 procedure Check_SPARK_05_Restriction_On_Attribute; 353 -- Issue an error in formal mode because attribute N is allowed 354 355 procedure Check_Integer_Type; 356 -- Verify that prefix of attribute N is an integer type 357 358 procedure Check_Modular_Integer_Type; 359 -- Verify that prefix of attribute N is a modular integer type 360 361 procedure Check_Not_CPP_Type; 362 -- Check that P (the prefix of the attribute) is not an CPP type 363 -- for which no Ada predefined primitive is available. 364 365 procedure Check_Not_Incomplete_Type; 366 -- Check that P (the prefix of the attribute) is not an incomplete 367 -- type or a private type for which no full view has been given. 368 369 procedure Check_Object_Reference (P : Node_Id); 370 -- Check that P is an object reference 371 372 procedure Check_PolyORB_Attribute; 373 -- Validity checking for PolyORB/DSA attribute 374 375 procedure Check_Program_Unit; 376 -- Verify that prefix of attribute N is a program unit 377 378 procedure Check_Real_Type; 379 -- Verify that prefix of attribute N is fixed or float type 380 381 procedure Check_Scalar_Type; 382 -- Verify that prefix of attribute N is a scalar type 383 384 procedure Check_Standard_Prefix; 385 -- Verify that prefix of attribute N is package Standard. Also checks 386 -- that there are no arguments. 387 388 procedure Check_Stream_Attribute (Nam : TSS_Name_Type); 389 -- Validity checking for stream attribute. Nam is the TSS name of the 390 -- corresponding possible defined attribute function (e.g. for the 391 -- Read attribute, Nam will be TSS_Stream_Read). 392 393 procedure Check_System_Prefix; 394 -- Verify that prefix of attribute N is package System 395 396 procedure Check_Task_Prefix; 397 -- Verify that prefix of attribute N is a task or task type 398 399 procedure Check_Type; 400 -- Verify that the prefix of attribute N is a type 401 402 procedure Check_Unit_Name (Nod : Node_Id); 403 -- Check that Nod is of the form of a library unit name, i.e that 404 -- it is an identifier, or a selected component whose prefix is 405 -- itself of the form of a library unit name. Note that this is 406 -- quite different from Check_Program_Unit, since it only checks 407 -- the syntactic form of the name, not the semantic identity. This 408 -- is because it is used with attributes (Elab_Body, Elab_Spec and 409 -- Elaborated) which can refer to non-visible unit. 410 411 procedure Error_Attr (Msg : String; Error_Node : Node_Id); 412 pragma No_Return (Error_Attr); 413 procedure Error_Attr; 414 pragma No_Return (Error_Attr); 415 -- Posts error using Error_Msg_N at given node, sets type of attribute 416 -- node to Any_Type, and then raises Bad_Attribute to avoid any further 417 -- semantic processing. The message typically contains a % insertion 418 -- character which is replaced by the attribute name. The call with 419 -- no arguments is used when the caller has already generated the 420 -- required error messages. 421 422 procedure Error_Attr_P (Msg : String); 423 pragma No_Return (Error_Attr_P); 424 -- Like Error_Attr, but error is posted at the start of the prefix 425 426 procedure Legal_Formal_Attribute; 427 -- Common processing for attributes Definite and Has_Discriminants. 428 -- Checks that prefix is generic indefinite formal type. 429 430 procedure Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements; 431 -- Common processing for attributes Max_Alignment_For_Allocation and 432 -- Max_Size_In_Storage_Elements. 433 434 procedure Min_Max; 435 -- Common processing for attributes Max and Min 436 437 procedure Standard_Attribute (Val : Int); 438 -- Used to process attributes whose prefix is package Standard which 439 -- yield values of type Universal_Integer. The attribute reference 440 -- node is rewritten with an integer literal of the given value which 441 -- is marked as static. 442 443 procedure Uneval_Old_Msg; 444 -- Called when Loop_Entry or Old is used in a potentially unevaluated 445 -- expression. Generates appropriate message or warning depending on 446 -- the setting of Opt.Uneval_Old (or flags in an N_Aspect_Specification 447 -- node in the aspect case). 448 449 procedure Unexpected_Argument (En : Node_Id); 450 pragma No_Return (Unexpected_Argument); 451 -- Signal unexpected attribute argument (En is the argument), and then 452 -- raises Bad_Attribute to avoid any further semantic processing. 453 454 procedure Validate_Non_Static_Attribute_Function_Call; 455 -- Called when processing an attribute that is a function call to a 456 -- non-static function, i.e. an attribute function that either takes 457 -- non-scalar arguments or returns a non-scalar result. Verifies that 458 -- such a call does not appear in a preelaborable context. 459 460 -------------------- 461 -- Address_Checks -- 462 -------------------- 463 464 procedure Address_Checks is 465 begin 466 -- An Address attribute created by expansion is legal even when it 467 -- applies to other entity-denoting expressions. 468 469 if not Comes_From_Source (N) then 470 return; 471 472 -- Address attribute on a protected object self reference is legal 473 474 elsif Is_Protected_Self_Reference (P) then 475 return; 476 477 -- Address applied to an entity 478 479 elsif Is_Entity_Name (P) then 480 declare 481 Ent : constant Entity_Id := Entity (P); 482 483 begin 484 if Is_Subprogram (Ent) then 485 Set_Address_Taken (Ent); 486 Kill_Current_Values (Ent); 487 488 -- An Address attribute is accepted when generated by the 489 -- compiler for dispatching operation, and an error is 490 -- issued once the subprogram is frozen (to avoid confusing 491 -- errors about implicit uses of Address in the dispatch 492 -- table initialization). 493 494 if Has_Pragma_Inline_Always (Entity (P)) 495 and then Comes_From_Source (P) 496 then 497 Error_Attr_P 498 ("prefix of % attribute cannot be Inline_Always " 499 & "subprogram"); 500 501 -- It is illegal to apply 'Address to an intrinsic 502 -- subprogram. This is now formalized in AI05-0095. 503 -- In an instance, an attempt to obtain 'Address of an 504 -- intrinsic subprogram (e.g the renaming of a predefined 505 -- operator that is an actual) raises Program_Error. 506 507 elsif Convention (Ent) = Convention_Intrinsic then 508 if In_Instance then 509 Rewrite (N, 510 Make_Raise_Program_Error (Loc, 511 Reason => PE_Address_Of_Intrinsic)); 512 513 else 514 Error_Msg_Name_1 := Aname; 515 Error_Msg_N 516 ("cannot take % of intrinsic subprogram", N); 517 end if; 518 519 -- Issue an error if prefix denotes an eliminated subprogram 520 521 else 522 Check_For_Eliminated_Subprogram (P, Ent); 523 end if; 524 525 -- Object or label reference 526 527 elsif Is_Object (Ent) or else Ekind (Ent) = E_Label then 528 Set_Address_Taken (Ent); 529 530 -- Deal with No_Implicit_Aliasing restriction 531 532 if Restriction_Check_Required (No_Implicit_Aliasing) then 533 if not Is_Aliased_View (P) then 534 Check_Restriction (No_Implicit_Aliasing, P); 535 else 536 Check_No_Implicit_Aliasing (P); 537 end if; 538 end if; 539 540 -- If we have an address of an object, and the attribute 541 -- comes from source, then set the object as potentially 542 -- source modified. We do this because the resulting address 543 -- can potentially be used to modify the variable and we 544 -- might not detect this, leading to some junk warnings. 545 546 Set_Never_Set_In_Source (Ent, False); 547 548 -- Allow Address to be applied to task or protected type, 549 -- returning null address (what is that about???) 550 551 elsif (Is_Concurrent_Type (Etype (Ent)) 552 and then Etype (Ent) = Base_Type (Ent)) 553 or else Ekind (Ent) = E_Package 554 or else Is_Generic_Unit (Ent) 555 then 556 Rewrite (N, 557 New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); 558 559 -- Anything else is illegal 560 561 else 562 Error_Attr ("invalid prefix for % attribute", P); 563 end if; 564 end; 565 566 -- Object is OK 567 568 elsif Is_Object_Reference (P) then 569 return; 570 571 -- Subprogram called using dot notation 572 573 elsif Nkind (P) = N_Selected_Component 574 and then Is_Subprogram (Entity (Selector_Name (P))) 575 then 576 return; 577 578 -- What exactly are we allowing here ??? and is this properly 579 -- documented in the sinfo documentation for this node ??? 580 581 elsif Relaxed_RM_Semantics 582 and then Nkind (P) = N_Attribute_Reference 583 then 584 return; 585 586 -- All other non-entity name cases are illegal 587 588 else 589 Error_Attr ("invalid prefix for % attribute", P); 590 end if; 591 end Address_Checks; 592 593 ------------------------------ 594 -- Analyze_Access_Attribute -- 595 ------------------------------ 596 597 procedure Analyze_Access_Attribute is 598 Acc_Type : Entity_Id; 599 600 Scop : Entity_Id; 601 Typ : Entity_Id; 602 603 function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id; 604 -- Build an access-to-object type whose designated type is DT, 605 -- and whose Ekind is appropriate to the attribute type. The 606 -- type that is constructed is returned as the result. 607 608 procedure Build_Access_Subprogram_Type (P : Node_Id); 609 -- Build an access to subprogram whose designated type is the type of 610 -- the prefix. If prefix is overloaded, so is the node itself. The 611 -- result is stored in Acc_Type. 612 613 function OK_Self_Reference return Boolean; 614 -- An access reference whose prefix is a type can legally appear 615 -- within an aggregate, where it is obtained by expansion of 616 -- a defaulted aggregate. The enclosing aggregate that contains 617 -- the self-referenced is flagged so that the self-reference can 618 -- be expanded into a reference to the target object (see exp_aggr). 619 620 ------------------------------ 621 -- Build_Access_Object_Type -- 622 ------------------------------ 623 624 function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id is 625 Typ : constant Entity_Id := 626 New_Internal_Entity 627 (E_Access_Attribute_Type, Current_Scope, Loc, 'A'); 628 begin 629 Set_Etype (Typ, Typ); 630 Set_Is_Itype (Typ); 631 Set_Associated_Node_For_Itype (Typ, N); 632 Set_Directly_Designated_Type (Typ, DT); 633 return Typ; 634 end Build_Access_Object_Type; 635 636 ---------------------------------- 637 -- Build_Access_Subprogram_Type -- 638 ---------------------------------- 639 640 procedure Build_Access_Subprogram_Type (P : Node_Id) is 641 Index : Interp_Index; 642 It : Interp; 643 644 procedure Check_Local_Access (E : Entity_Id); 645 -- Deal with possible access to local subprogram. If we have such 646 -- an access, we set a flag to kill all tracked values on any call 647 -- because this access value may be passed around, and any called 648 -- code might use it to access a local procedure which clobbers a 649 -- tracked value. If the scope is a loop or block, indicate that 650 -- value tracking is disabled for the enclosing subprogram. 651 652 function Get_Kind (E : Entity_Id) return Entity_Kind; 653 -- Distinguish between access to regular/protected subprograms 654 655 ------------------------ 656 -- Check_Local_Access -- 657 ------------------------ 658 659 procedure Check_Local_Access (E : Entity_Id) is 660 begin 661 if not Is_Library_Level_Entity (E) then 662 Set_Suppress_Value_Tracking_On_Call (Current_Scope); 663 Set_Suppress_Value_Tracking_On_Call 664 (Nearest_Dynamic_Scope (Current_Scope)); 665 end if; 666 end Check_Local_Access; 667 668 -------------- 669 -- Get_Kind -- 670 -------------- 671 672 function Get_Kind (E : Entity_Id) return Entity_Kind is 673 begin 674 if Convention (E) = Convention_Protected then 675 return E_Access_Protected_Subprogram_Type; 676 else 677 return E_Access_Subprogram_Type; 678 end if; 679 end Get_Kind; 680 681 -- Start of processing for Build_Access_Subprogram_Type 682 683 begin 684 -- In the case of an access to subprogram, use the name of the 685 -- subprogram itself as the designated type. Type-checking in 686 -- this case compares the signatures of the designated types. 687 688 -- Note: This fragment of the tree is temporarily malformed 689 -- because the correct tree requires an E_Subprogram_Type entity 690 -- as the designated type. In most cases this designated type is 691 -- later overridden by the semantics with the type imposed by the 692 -- context during the resolution phase. In the specific case of 693 -- the expression Address!(Prim'Unrestricted_Access), used to 694 -- initialize slots of dispatch tables, this work will be done by 695 -- the expander (see Exp_Aggr). 696 697 -- The reason to temporarily add this kind of node to the tree 698 -- instead of a proper E_Subprogram_Type itype, is the following: 699 -- in case of errors found in the source file we report better 700 -- error messages. For example, instead of generating the 701 -- following error: 702 703 -- "expected access to subprogram with profile 704 -- defined at line X" 705 706 -- we currently generate: 707 708 -- "expected access to function Z defined at line X" 709 710 Set_Etype (N, Any_Type); 711 712 if not Is_Overloaded (P) then 713 Check_Local_Access (Entity (P)); 714 715 if not Is_Intrinsic_Subprogram (Entity (P)) then 716 Acc_Type := Create_Itype (Get_Kind (Entity (P)), N); 717 Set_Is_Public (Acc_Type, False); 718 Set_Etype (Acc_Type, Acc_Type); 719 Set_Convention (Acc_Type, Convention (Entity (P))); 720 Set_Directly_Designated_Type (Acc_Type, Entity (P)); 721 Set_Etype (N, Acc_Type); 722 Freeze_Before (N, Acc_Type); 723 end if; 724 725 else 726 Get_First_Interp (P, Index, It); 727 while Present (It.Nam) loop 728 Check_Local_Access (It.Nam); 729 730 if not Is_Intrinsic_Subprogram (It.Nam) then 731 Acc_Type := Create_Itype (Get_Kind (It.Nam), N); 732 Set_Is_Public (Acc_Type, False); 733 Set_Etype (Acc_Type, Acc_Type); 734 Set_Convention (Acc_Type, Convention (It.Nam)); 735 Set_Directly_Designated_Type (Acc_Type, It.Nam); 736 Add_One_Interp (N, Acc_Type, Acc_Type); 737 Freeze_Before (N, Acc_Type); 738 end if; 739 740 Get_Next_Interp (Index, It); 741 end loop; 742 end if; 743 744 -- Cannot be applied to intrinsic. Looking at the tests above, 745 -- the only way Etype (N) can still be set to Any_Type is if 746 -- Is_Intrinsic_Subprogram was True for some referenced entity. 747 748 if Etype (N) = Any_Type then 749 Error_Attr_P ("prefix of % attribute cannot be intrinsic"); 750 end if; 751 end Build_Access_Subprogram_Type; 752 753 ---------------------- 754 -- OK_Self_Reference -- 755 ---------------------- 756 757 function OK_Self_Reference return Boolean is 758 Par : Node_Id; 759 760 begin 761 Par := Parent (N); 762 while Present (Par) 763 and then 764 (Nkind (Par) = N_Component_Association 765 or else Nkind (Par) in N_Subexpr) 766 loop 767 if Nkind_In (Par, N_Aggregate, N_Extension_Aggregate) then 768 if Etype (Par) = Typ then 769 Set_Has_Self_Reference (Par); 770 771 -- Check the context: the aggregate must be part of the 772 -- initialization of a type or component, or it is the 773 -- resulting expansion in an initialization procedure. 774 775 if Is_Init_Proc (Current_Scope) then 776 return True; 777 else 778 Par := Parent (Par); 779 while Present (Par) loop 780 if Nkind (Par) = N_Full_Type_Declaration then 781 return True; 782 end if; 783 784 Par := Parent (Par); 785 end loop; 786 end if; 787 788 return False; 789 end if; 790 end if; 791 792 Par := Parent (Par); 793 end loop; 794 795 -- No enclosing aggregate, or not a self-reference 796 797 return False; 798 end OK_Self_Reference; 799 800 -- Start of processing for Analyze_Access_Attribute 801 802 begin 803 Check_SPARK_05_Restriction_On_Attribute; 804 Check_E0; 805 806 if Nkind (P) = N_Character_Literal then 807 Error_Attr_P 808 ("prefix of % attribute cannot be enumeration literal"); 809 end if; 810 811 -- Preserve relevant elaboration-related attributes of the context 812 -- which are no longer available or very expensive to recompute once 813 -- analysis, resolution, and expansion are over. 814 815 Mark_Elaboration_Attributes 816 (N_Id => N, 817 Checks => True, 818 Modes => True); 819 820 -- Save the scenario for later examination by the ABE Processing 821 -- phase. 822 823 Record_Elaboration_Scenario (N); 824 825 -- Case of access to subprogram 826 827 if Is_Entity_Name (P) and then Is_Overloadable (Entity (P)) then 828 if Has_Pragma_Inline_Always (Entity (P)) then 829 Error_Attr_P 830 ("prefix of % attribute cannot be Inline_Always subprogram"); 831 832 elsif Aname = Name_Unchecked_Access then 833 Error_Attr ("attribute% cannot be applied to a subprogram", P); 834 end if; 835 836 -- Issue an error if the prefix denotes an eliminated subprogram 837 838 Check_For_Eliminated_Subprogram (P, Entity (P)); 839 840 -- Check for obsolescent subprogram reference 841 842 Check_Obsolescent_2005_Entity (Entity (P), P); 843 844 -- Build the appropriate subprogram type 845 846 Build_Access_Subprogram_Type (P); 847 848 -- For P'Access or P'Unrestricted_Access, where P is a nested 849 -- subprogram, we might be passing P to another subprogram (but we 850 -- don't check that here), which might call P. P could modify 851 -- local variables, so we need to kill current values. It is 852 -- important not to do this for library-level subprograms, because 853 -- Kill_Current_Values is very inefficient in the case of library 854 -- level packages with lots of tagged types. 855 856 if Is_Library_Level_Entity (Entity (Prefix (N))) then 857 null; 858 859 -- Do not kill values on nodes initializing dispatch tables 860 -- slots. The construct Prim_Ptr!(Prim'Unrestricted_Access) 861 -- is currently generated by the expander only for this 862 -- purpose. Done to keep the quality of warnings currently 863 -- generated by the compiler (otherwise any declaration of 864 -- a tagged type cleans constant indications from its scope). 865 866 elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion 867 and then (Etype (Parent (N)) = RTE (RE_Prim_Ptr) 868 or else 869 Etype (Parent (N)) = RTE (RE_Size_Ptr)) 870 and then Is_Dispatching_Operation 871 (Directly_Designated_Type (Etype (N))) 872 then 873 null; 874 875 else 876 Kill_Current_Values; 877 end if; 878 879 -- In the static elaboration model, treat the attribute reference 880 -- as a subprogram call for elaboration purposes. Suppress this 881 -- treatment under debug flag. In any case, we are all done. 882 883 if Legacy_Elaboration_Checks 884 and not Dynamic_Elaboration_Checks 885 and not Debug_Flag_Dot_UU 886 then 887 Check_Elab_Call (N); 888 end if; 889 890 return; 891 892 -- Component is an operation of a protected type 893 894 elsif Nkind (P) = N_Selected_Component 895 and then Is_Overloadable (Entity (Selector_Name (P))) 896 then 897 if Ekind (Entity (Selector_Name (P))) = E_Entry then 898 Error_Attr_P ("prefix of % attribute must be subprogram"); 899 end if; 900 901 Build_Access_Subprogram_Type (Selector_Name (P)); 902 return; 903 end if; 904 905 -- Deal with incorrect reference to a type, but note that some 906 -- accesses are allowed: references to the current type instance, 907 -- or in Ada 2005 self-referential pointer in a default-initialized 908 -- aggregate. 909 910 if Is_Entity_Name (P) then 911 Typ := Entity (P); 912 913 -- The reference may appear in an aggregate that has been expanded 914 -- into a loop. Locate scope of type definition, if any. 915 916 Scop := Current_Scope; 917 while Ekind (Scop) = E_Loop loop 918 Scop := Scope (Scop); 919 end loop; 920 921 if Is_Type (Typ) then 922 923 -- OK if we are within the scope of a limited type 924 -- let's mark the component as having per object constraint 925 926 if Is_Anonymous_Tagged_Base (Scop, Typ) then 927 Typ := Scop; 928 Set_Entity (P, Typ); 929 Set_Etype (P, Typ); 930 end if; 931 932 if Typ = Scop then 933 declare 934 Q : Node_Id := Parent (N); 935 936 begin 937 while Present (Q) 938 and then Nkind (Q) /= N_Component_Declaration 939 loop 940 Q := Parent (Q); 941 end loop; 942 943 if Present (Q) then 944 Set_Has_Per_Object_Constraint 945 (Defining_Identifier (Q), True); 946 end if; 947 end; 948 949 if Nkind (P) = N_Expanded_Name then 950 Error_Msg_F 951 ("current instance prefix must be a direct name", P); 952 end if; 953 954 -- If a current instance attribute appears in a component 955 -- constraint it must appear alone; other contexts (spec- 956 -- expressions, within a task body) are not subject to this 957 -- restriction. 958 959 if not In_Spec_Expression 960 and then not Has_Completion (Scop) 961 and then not 962 Nkind_In (Parent (N), N_Discriminant_Association, 963 N_Index_Or_Discriminant_Constraint) 964 then 965 Error_Msg_N 966 ("current instance attribute must appear alone", N); 967 end if; 968 969 if Is_CPP_Class (Root_Type (Typ)) then 970 Error_Msg_N 971 ("??current instance unsupported for derivations of " 972 & "'C'P'P types", N); 973 end if; 974 975 -- OK if we are in initialization procedure for the type 976 -- in question, in which case the reference to the type 977 -- is rewritten as a reference to the current object. 978 979 elsif Ekind (Scop) = E_Procedure 980 and then Is_Init_Proc (Scop) 981 and then Etype (First_Formal (Scop)) = Typ 982 then 983 Rewrite (N, 984 Make_Attribute_Reference (Loc, 985 Prefix => Make_Identifier (Loc, Name_uInit), 986 Attribute_Name => Name_Unrestricted_Access)); 987 Analyze (N); 988 return; 989 990 -- OK if a task type, this test needs sharpening up ??? 991 992 elsif Is_Task_Type (Typ) then 993 null; 994 995 -- OK if self-reference in an aggregate in Ada 2005, and 996 -- the reference comes from a copied default expression. 997 998 -- Note that we check legality of self-reference even if the 999 -- expression comes from source, e.g. when a single component 1000 -- association in an aggregate has a box association. 1001 1002 elsif Ada_Version >= Ada_2005 1003 and then OK_Self_Reference 1004 then 1005 null; 1006 1007 -- OK if reference to current instance of a protected object 1008 1009 elsif Is_Protected_Self_Reference (P) then 1010 null; 1011 1012 -- Otherwise we have an error case 1013 1014 else 1015 Error_Attr ("% attribute cannot be applied to type", P); 1016 return; 1017 end if; 1018 end if; 1019 end if; 1020 1021 -- If we fall through, we have a normal access to object case 1022 1023 -- Unrestricted_Access is (for now) legal wherever an allocator would 1024 -- be legal, so its Etype is set to E_Allocator. The expected type 1025 -- of the other attributes is a general access type, and therefore 1026 -- we label them with E_Access_Attribute_Type. 1027 1028 if not Is_Overloaded (P) then 1029 Acc_Type := Build_Access_Object_Type (P_Type); 1030 Set_Etype (N, Acc_Type); 1031 1032 else 1033 declare 1034 Index : Interp_Index; 1035 It : Interp; 1036 begin 1037 Set_Etype (N, Any_Type); 1038 Get_First_Interp (P, Index, It); 1039 while Present (It.Typ) loop 1040 Acc_Type := Build_Access_Object_Type (It.Typ); 1041 Add_One_Interp (N, Acc_Type, Acc_Type); 1042 Get_Next_Interp (Index, It); 1043 end loop; 1044 end; 1045 end if; 1046 1047 -- Special cases when we can find a prefix that is an entity name 1048 1049 declare 1050 PP : Node_Id; 1051 Ent : Entity_Id; 1052 1053 begin 1054 PP := P; 1055 loop 1056 if Is_Entity_Name (PP) then 1057 Ent := Entity (PP); 1058 1059 -- If we have an access to an object, and the attribute 1060 -- comes from source, then set the object as potentially 1061 -- source modified. We do this because the resulting access 1062 -- pointer can be used to modify the variable, and we might 1063 -- not detect this, leading to some junk warnings. 1064 1065 -- We only do this for source references, since otherwise 1066 -- we can suppress warnings, e.g. from the unrestricted 1067 -- access generated for validity checks in -gnatVa mode. 1068 1069 if Comes_From_Source (N) then 1070 Set_Never_Set_In_Source (Ent, False); 1071 end if; 1072 1073 -- Mark entity as address taken in the case of 1074 -- 'Unrestricted_Access or subprograms, and kill current 1075 -- values. 1076 1077 if Aname = Name_Unrestricted_Access 1078 or else Is_Subprogram (Ent) 1079 then 1080 Set_Address_Taken (Ent); 1081 end if; 1082 1083 Kill_Current_Values (Ent); 1084 exit; 1085 1086 elsif Nkind_In (PP, N_Selected_Component, 1087 N_Indexed_Component) 1088 then 1089 PP := Prefix (PP); 1090 1091 else 1092 exit; 1093 end if; 1094 end loop; 1095 end; 1096 end Analyze_Access_Attribute; 1097 1098 ---------------------------------- 1099 -- Analyze_Attribute_Old_Result -- 1100 ---------------------------------- 1101 1102 procedure Analyze_Attribute_Old_Result 1103 (Legal : out Boolean; 1104 Spec_Id : out Entity_Id) 1105 is 1106 procedure Check_Placement_In_Check (Prag : Node_Id); 1107 -- Verify that the attribute appears within pragma Check that mimics 1108 -- a postcondition. 1109 1110 procedure Check_Placement_In_Contract_Cases (Prag : Node_Id); 1111 -- Verify that the attribute appears within a consequence of aspect 1112 -- or pragma Contract_Cases denoted by Prag. 1113 1114 procedure Check_Placement_In_Test_Case (Prag : Node_Id); 1115 -- Verify that the attribute appears within the "Ensures" argument of 1116 -- aspect or pragma Test_Case denoted by Prag. 1117 1118 function Is_Within 1119 (Nod : Node_Id; 1120 Encl_Nod : Node_Id) return Boolean; 1121 -- Subsidiary to Check_Placemenet_In_XXX. Determine whether arbitrary 1122 -- node Nod is within enclosing node Encl_Nod. 1123 1124 procedure Placement_Error; 1125 pragma No_Return (Placement_Error); 1126 -- Emit a general error when the attributes does not appear in a 1127 -- postcondition-like aspect or pragma, and then raises Bad_Attribute 1128 -- to avoid any further semantic processing. 1129 1130 ------------------------------ 1131 -- Check_Placement_In_Check -- 1132 ------------------------------ 1133 1134 procedure Check_Placement_In_Check (Prag : Node_Id) is 1135 Args : constant List_Id := Pragma_Argument_Associations (Prag); 1136 Nam : constant Name_Id := Chars (Get_Pragma_Arg (First (Args))); 1137 1138 begin 1139 -- The "Name" argument of pragma Check denotes a postcondition 1140 1141 if Nam_In (Nam, Name_Post, 1142 Name_Post_Class, 1143 Name_Postcondition, 1144 Name_Refined_Post) 1145 then 1146 null; 1147 1148 -- Otherwise the placement of the attribute is illegal 1149 1150 else 1151 Placement_Error; 1152 end if; 1153 end Check_Placement_In_Check; 1154 1155 --------------------------------------- 1156 -- Check_Placement_In_Contract_Cases -- 1157 --------------------------------------- 1158 1159 procedure Check_Placement_In_Contract_Cases (Prag : Node_Id) is 1160 Arg : Node_Id; 1161 Cases : Node_Id; 1162 CCase : Node_Id; 1163 1164 begin 1165 -- Obtain the argument of the aspect or pragma 1166 1167 if Nkind (Prag) = N_Aspect_Specification then 1168 Arg := Prag; 1169 else 1170 Arg := First (Pragma_Argument_Associations (Prag)); 1171 end if; 1172 1173 Cases := Expression (Arg); 1174 1175 if Present (Component_Associations (Cases)) then 1176 CCase := First (Component_Associations (Cases)); 1177 while Present (CCase) loop 1178 1179 -- Detect whether the attribute appears within the 1180 -- consequence of the current contract case. 1181 1182 if Nkind (CCase) = N_Component_Association 1183 and then Is_Within (N, Expression (CCase)) 1184 then 1185 return; 1186 end if; 1187 1188 Next (CCase); 1189 end loop; 1190 end if; 1191 1192 -- Otherwise aspect or pragma Contract_Cases is either malformed 1193 -- or the attribute does not appear within a consequence. 1194 1195 Error_Attr 1196 ("attribute % must appear in the consequence of a contract case", 1197 P); 1198 end Check_Placement_In_Contract_Cases; 1199 1200 ---------------------------------- 1201 -- Check_Placement_In_Test_Case -- 1202 ---------------------------------- 1203 1204 procedure Check_Placement_In_Test_Case (Prag : Node_Id) is 1205 Arg : constant Node_Id := 1206 Test_Case_Arg 1207 (Prag => Prag, 1208 Arg_Nam => Name_Ensures, 1209 From_Aspect => Nkind (Prag) = N_Aspect_Specification); 1210 1211 begin 1212 -- Detect whether the attribute appears within the "Ensures" 1213 -- expression of aspect or pragma Test_Case. 1214 1215 if Present (Arg) and then Is_Within (N, Arg) then 1216 null; 1217 1218 else 1219 Error_Attr 1220 ("attribute % must appear in the ensures expression of a " 1221 & "test case", P); 1222 end if; 1223 end Check_Placement_In_Test_Case; 1224 1225 --------------- 1226 -- Is_Within -- 1227 --------------- 1228 1229 function Is_Within 1230 (Nod : Node_Id; 1231 Encl_Nod : Node_Id) return Boolean 1232 is 1233 Par : Node_Id; 1234 1235 begin 1236 Par := Nod; 1237 while Present (Par) loop 1238 if Par = Encl_Nod then 1239 return True; 1240 1241 -- Prevent the search from going too far 1242 1243 elsif Is_Body_Or_Package_Declaration (Par) then 1244 exit; 1245 end if; 1246 1247 Par := Parent (Par); 1248 end loop; 1249 1250 return False; 1251 end Is_Within; 1252 1253 --------------------- 1254 -- Placement_Error -- 1255 --------------------- 1256 1257 procedure Placement_Error is 1258 begin 1259 if Aname = Name_Old then 1260 Error_Attr ("attribute % can only appear in postcondition", P); 1261 1262 -- Specialize the error message for attribute 'Result 1263 1264 else 1265 Error_Attr 1266 ("attribute % can only appear in postcondition of function", 1267 P); 1268 end if; 1269 end Placement_Error; 1270 1271 -- Local variables 1272 1273 Prag : Node_Id; 1274 Prag_Nam : Name_Id; 1275 Subp_Decl : Node_Id; 1276 1277 -- Start of processing for Analyze_Attribute_Old_Result 1278 1279 begin 1280 -- Assume that the attribute is illegal 1281 1282 Legal := False; 1283 Spec_Id := Empty; 1284 1285 -- Traverse the parent chain to find the aspect or pragma where the 1286 -- attribute resides. 1287 1288 Prag := N; 1289 while Present (Prag) loop 1290 if Nkind_In (Prag, N_Aspect_Specification, N_Pragma) then 1291 exit; 1292 1293 -- Prevent the search from going too far 1294 1295 elsif Is_Body_Or_Package_Declaration (Prag) then 1296 exit; 1297 end if; 1298 1299 Prag := Parent (Prag); 1300 end loop; 1301 1302 -- The attribute is allowed to appear only in postcondition-like 1303 -- aspects or pragmas. 1304 1305 if Nkind_In (Prag, N_Aspect_Specification, N_Pragma) then 1306 if Nkind (Prag) = N_Aspect_Specification then 1307 Prag_Nam := Chars (Identifier (Prag)); 1308 else 1309 Prag_Nam := Pragma_Name (Prag); 1310 end if; 1311 1312 if Prag_Nam = Name_Check then 1313 Check_Placement_In_Check (Prag); 1314 1315 elsif Prag_Nam = Name_Contract_Cases then 1316 Check_Placement_In_Contract_Cases (Prag); 1317 1318 -- Attribute 'Result is allowed to appear in aspect or pragma 1319 -- [Refined_]Depends (SPARK RM 6.1.5(11)). 1320 1321 elsif Nam_In (Prag_Nam, Name_Depends, Name_Refined_Depends) 1322 and then Aname = Name_Result 1323 then 1324 null; 1325 1326 elsif Nam_In (Prag_Nam, Name_Post, 1327 Name_Post_Class, 1328 Name_Postcondition, 1329 Name_Refined_Post) 1330 then 1331 null; 1332 1333 elsif Prag_Nam = Name_Test_Case then 1334 Check_Placement_In_Test_Case (Prag); 1335 1336 else 1337 Placement_Error; 1338 return; 1339 end if; 1340 1341 -- Otherwise the placement of the attribute is illegal 1342 1343 else 1344 Placement_Error; 1345 return; 1346 end if; 1347 1348 -- Find the related subprogram subject to the aspect or pragma 1349 1350 if Nkind (Prag) = N_Aspect_Specification then 1351 Subp_Decl := Parent (Prag); 1352 else 1353 Subp_Decl := Find_Related_Declaration_Or_Body (Prag); 1354 end if; 1355 1356 -- The aspect or pragma where the attribute resides should be 1357 -- associated with a subprogram declaration or a body. If this is not 1358 -- the case, then the aspect or pragma is illegal. Return as analysis 1359 -- cannot be carried out. Note that it is legal to have the aspect 1360 -- appear on a subprogram renaming, when the renamed entity is an 1361 -- attribute reference. 1362 1363 -- Generating C code the internally built nested _postcondition 1364 -- subprograms are inlined; after expanded, inlined aspects are 1365 -- located in the internal block generated by the frontend. 1366 1367 if Nkind (Subp_Decl) = N_Block_Statement 1368 and then Modify_Tree_For_C 1369 and then In_Inlined_Body 1370 then 1371 null; 1372 1373 elsif not Nkind_In (Subp_Decl, N_Abstract_Subprogram_Declaration, 1374 N_Entry_Declaration, 1375 N_Expression_Function, 1376 N_Generic_Subprogram_Declaration, 1377 N_Subprogram_Body, 1378 N_Subprogram_Body_Stub, 1379 N_Subprogram_Declaration, 1380 N_Subprogram_Renaming_Declaration) 1381 then 1382 return; 1383 end if; 1384 1385 -- If we get here, then the attribute is legal 1386 1387 Legal := True; 1388 Spec_Id := Unique_Defining_Entity (Subp_Decl); 1389 1390 -- When generating C code, nested _postcondition subprograms are 1391 -- inlined by the front end to avoid problems (when unnested) with 1392 -- referenced itypes. Handle that here, since as part of inlining the 1393 -- expander nests subprogram within a dummy procedure named _parent 1394 -- (see Build_Postconditions_Procedure and Build_Body_To_Inline). 1395 -- Hence, in this context, the spec_id of _postconditions is the 1396 -- enclosing scope. 1397 1398 if Modify_Tree_For_C 1399 and then Chars (Spec_Id) = Name_uParent 1400 and then Chars (Scope (Spec_Id)) = Name_uPostconditions 1401 then 1402 -- This situation occurs only when preanalyzing the inlined body 1403 1404 pragma Assert (not Full_Analysis); 1405 1406 Spec_Id := Scope (Spec_Id); 1407 pragma Assert (Is_Inlined (Spec_Id)); 1408 end if; 1409 end Analyze_Attribute_Old_Result; 1410 1411 ----------------------------- 1412 -- Analyze_Image_Attribute -- 1413 ----------------------------- 1414 1415 procedure Analyze_Image_Attribute (Str_Typ : Entity_Id) is 1416 begin 1417 Check_SPARK_05_Restriction_On_Attribute; 1418 1419 -- AI12-00124: The ARG has adopted the GNAT semantics of 'Img for 1420 -- scalar types, so that the prefix can be an object, a named value, 1421 -- or a type, and there is no need for an argument in this case. 1422 1423 if Attr_Id = Attribute_Img 1424 or else (Ada_Version > Ada_2005 and then Is_Object_Image (P)) 1425 then 1426 Check_E0; 1427 Set_Etype (N, Str_Typ); 1428 1429 if Attr_Id = Attribute_Img and then not Is_Object_Image (P) then 1430 Error_Attr_P 1431 ("prefix of % attribute must be a scalar object name"); 1432 end if; 1433 else 1434 Check_E1; 1435 Set_Etype (N, Str_Typ); 1436 1437 -- Check that the prefix type is scalar - much in the same way as 1438 -- Check_Scalar_Type but with custom error messages to denote the 1439 -- variants of 'Image attributes. 1440 1441 if Is_Entity_Name (P) 1442 and then Is_Type (Entity (P)) 1443 and then Ekind (Entity (P)) = E_Incomplete_Type 1444 and then Present (Full_View (Entity (P))) 1445 then 1446 P_Type := Full_View (Entity (P)); 1447 Set_Entity (P, P_Type); 1448 end if; 1449 1450 if not Is_Entity_Name (P) 1451 or else not Is_Type (Entity (P)) 1452 or else not Is_Scalar_Type (P_Type) 1453 then 1454 if Ada_Version > Ada_2005 then 1455 Error_Attr_P 1456 ("prefix of % attribute must be a scalar type or a scalar " 1457 & "object name"); 1458 else 1459 Error_Attr_P ("prefix of % attribute must be a scalar type"); 1460 end if; 1461 1462 elsif Is_Protected_Self_Reference (P) then 1463 Error_Attr_P 1464 ("prefix of % attribute denotes current instance " 1465 & "(RM 9.4(21/2))"); 1466 end if; 1467 1468 Resolve (E1, P_Base_Type); 1469 Validate_Non_Static_Attribute_Function_Call; 1470 end if; 1471 1472 Check_Enum_Image; 1473 1474 -- Check restriction No_Fixed_IO. Note the check of Comes_From_Source 1475 -- to avoid giving a duplicate message for when Image attributes 1476 -- applied to object references get expanded into type-based Image 1477 -- attributes. 1478 1479 if Restriction_Check_Required (No_Fixed_IO) 1480 and then Comes_From_Source (N) 1481 and then Is_Fixed_Point_Type (P_Type) 1482 then 1483 Check_Restriction (No_Fixed_IO, P); 1484 end if; 1485 end Analyze_Image_Attribute; 1486 1487 --------------------------------- 1488 -- Bad_Attribute_For_Predicate -- 1489 --------------------------------- 1490 1491 procedure Bad_Attribute_For_Predicate is 1492 begin 1493 if Is_Scalar_Type (P_Type) 1494 and then Comes_From_Source (N) 1495 then 1496 Error_Msg_Name_1 := Aname; 1497 Bad_Predicated_Subtype_Use 1498 ("type& has predicates, attribute % not allowed", N, P_Type); 1499 end if; 1500 end Bad_Attribute_For_Predicate; 1501 1502 -------------------------------- 1503 -- Check_Array_Or_Scalar_Type -- 1504 -------------------------------- 1505 1506 procedure Check_Array_Or_Scalar_Type is 1507 function In_Aspect_Specification return Boolean; 1508 -- A current instance of a type in an aspect specification is an 1509 -- object and not a type, and therefore cannot be of a scalar type 1510 -- in the prefix of one of the array attributes if the attribute 1511 -- reference is part of an aspect expression. 1512 1513 ----------------------------- 1514 -- In_Aspect_Specification -- 1515 ----------------------------- 1516 1517 function In_Aspect_Specification return Boolean is 1518 P : Node_Id; 1519 1520 begin 1521 P := Parent (N); 1522 while Present (P) loop 1523 if Nkind (P) = N_Aspect_Specification then 1524 return P_Type = Entity (P); 1525 1526 elsif Nkind (P) in N_Declaration then 1527 return False; 1528 end if; 1529 1530 P := Parent (P); 1531 end loop; 1532 1533 return False; 1534 end In_Aspect_Specification; 1535 1536 -- Local variables 1537 1538 Dims : Int; 1539 Index : Entity_Id; 1540 1541 -- Start of processing for Check_Array_Or_Scalar_Type 1542 1543 begin 1544 -- Case of string literal or string literal subtype. These cases 1545 -- cannot arise from legal Ada code, but the expander is allowed 1546 -- to generate them. They require special handling because string 1547 -- literal subtypes do not have standard bounds (the whole idea 1548 -- of these subtypes is to avoid having to generate the bounds) 1549 1550 if Ekind (P_Type) = E_String_Literal_Subtype then 1551 Set_Etype (N, Etype (First_Index (P_Base_Type))); 1552 return; 1553 1554 -- Scalar types 1555 1556 elsif Is_Scalar_Type (P_Type) then 1557 Check_Type; 1558 1559 if Present (E1) then 1560 Error_Attr ("invalid argument in % attribute", E1); 1561 1562 elsif In_Aspect_Specification then 1563 Error_Attr 1564 ("prefix of % attribute cannot be the current instance of a " 1565 & "scalar type", P); 1566 1567 else 1568 Set_Etype (N, P_Base_Type); 1569 return; 1570 end if; 1571 1572 -- The following is a special test to allow 'First to apply to 1573 -- private scalar types if the attribute comes from generated 1574 -- code. This occurs in the case of Normalize_Scalars code. 1575 1576 elsif Is_Private_Type (P_Type) 1577 and then Present (Full_View (P_Type)) 1578 and then Is_Scalar_Type (Full_View (P_Type)) 1579 and then not Comes_From_Source (N) 1580 then 1581 Set_Etype (N, Implementation_Base_Type (P_Type)); 1582 1583 -- Array types other than string literal subtypes handled above 1584 1585 else 1586 Check_Array_Type; 1587 1588 -- We know prefix is an array type, or the name of an array 1589 -- object, and that the expression, if present, is static 1590 -- and within the range of the dimensions of the type. 1591 1592 pragma Assert (Is_Array_Type (P_Type)); 1593 Index := First_Index (P_Base_Type); 1594 1595 if No (E1) then 1596 1597 -- First dimension assumed 1598 1599 Set_Etype (N, Base_Type (Etype (Index))); 1600 1601 else 1602 Dims := UI_To_Int (Intval (E1)); 1603 1604 for J in 1 .. Dims - 1 loop 1605 Next_Index (Index); 1606 end loop; 1607 1608 Set_Etype (N, Base_Type (Etype (Index))); 1609 Set_Etype (E1, Standard_Integer); 1610 end if; 1611 end if; 1612 end Check_Array_Or_Scalar_Type; 1613 1614 ---------------------- 1615 -- Check_Array_Type -- 1616 ---------------------- 1617 1618 procedure Check_Array_Type is 1619 D : Int; 1620 -- Dimension number for array attributes 1621 1622 begin 1623 -- If the type is a string literal type, then this must be generated 1624 -- internally, and no further check is required on its legality. 1625 1626 if Ekind (P_Type) = E_String_Literal_Subtype then 1627 return; 1628 1629 -- If the type is a composite, it is an illegal aggregate, no point 1630 -- in going on. 1631 1632 elsif P_Type = Any_Composite then 1633 raise Bad_Attribute; 1634 end if; 1635 1636 -- Normal case of array type or subtype 1637 1638 Check_Either_E0_Or_E1; 1639 Check_Dereference; 1640 1641 if Is_Array_Type (P_Type) then 1642 if not Is_Constrained (P_Type) 1643 and then Is_Entity_Name (P) 1644 and then Is_Type (Entity (P)) 1645 then 1646 -- Note: we do not call Error_Attr here, since we prefer to 1647 -- continue, using the relevant index type of the array, 1648 -- even though it is unconstrained. This gives better error 1649 -- recovery behavior. 1650 1651 Error_Msg_Name_1 := Aname; 1652 Error_Msg_F 1653 ("prefix for % attribute must be constrained array", P); 1654 end if; 1655 1656 -- The attribute reference freezes the type, and thus the 1657 -- component type, even if the attribute may not depend on the 1658 -- component. Diagnose arrays with incomplete components now. 1659 -- If the prefix is an access to array, this does not freeze 1660 -- the designated type. 1661 1662 if Nkind (P) /= N_Explicit_Dereference then 1663 Check_Fully_Declared (Component_Type (P_Type), P); 1664 end if; 1665 1666 D := Number_Dimensions (P_Type); 1667 1668 else 1669 if Is_Private_Type (P_Type) then 1670 Error_Attr_P ("prefix for % attribute may not be private type"); 1671 1672 elsif Is_Access_Type (P_Type) 1673 and then Is_Array_Type (Designated_Type (P_Type)) 1674 and then Is_Entity_Name (P) 1675 and then Is_Type (Entity (P)) 1676 then 1677 Error_Attr_P ("prefix of % attribute cannot be access type"); 1678 1679 elsif Attr_Id = Attribute_First 1680 or else 1681 Attr_Id = Attribute_Last 1682 then 1683 Error_Attr ("invalid prefix for % attribute", P); 1684 1685 else 1686 Error_Attr_P ("prefix for % attribute must be array"); 1687 end if; 1688 end if; 1689 1690 if Present (E1) then 1691 Resolve (E1, Any_Integer); 1692 Set_Etype (E1, Standard_Integer); 1693 1694 if not Is_OK_Static_Expression (E1) 1695 or else Raises_Constraint_Error (E1) 1696 then 1697 Flag_Non_Static_Expr 1698 ("expression for dimension must be static!", E1); 1699 Error_Attr; 1700 1701 elsif UI_To_Int (Expr_Value (E1)) > D 1702 or else UI_To_Int (Expr_Value (E1)) < 1 1703 then 1704 Error_Attr ("invalid dimension number for array type", E1); 1705 end if; 1706 end if; 1707 1708 if (Style_Check and Style_Check_Array_Attribute_Index) 1709 and then Comes_From_Source (N) 1710 then 1711 Style.Check_Array_Attribute_Index (N, E1, D); 1712 end if; 1713 end Check_Array_Type; 1714 1715 ------------------------- 1716 -- Check_Asm_Attribute -- 1717 ------------------------- 1718 1719 procedure Check_Asm_Attribute is 1720 begin 1721 Check_Type; 1722 Check_E2; 1723 1724 -- Check first argument is static string expression 1725 1726 Analyze_And_Resolve (E1, Standard_String); 1727 1728 if Etype (E1) = Any_Type then 1729 return; 1730 1731 elsif not Is_OK_Static_Expression (E1) then 1732 Flag_Non_Static_Expr 1733 ("constraint argument must be static string expression!", E1); 1734 Error_Attr; 1735 end if; 1736 1737 -- Check second argument is right type 1738 1739 Analyze_And_Resolve (E2, Entity (P)); 1740 1741 -- Note: that is all we need to do, we don't need to check 1742 -- that it appears in a correct context. The Ada type system 1743 -- will do that for us. 1744 1745 end Check_Asm_Attribute; 1746 1747 --------------------- 1748 -- Check_Component -- 1749 --------------------- 1750 1751 procedure Check_Component is 1752 begin 1753 Check_E0; 1754 1755 if Nkind (P) /= N_Selected_Component 1756 or else 1757 (Ekind (Entity (Selector_Name (P))) /= E_Component 1758 and then 1759 Ekind (Entity (Selector_Name (P))) /= E_Discriminant) 1760 then 1761 Error_Attr_P ("prefix for % attribute must be selected component"); 1762 end if; 1763 end Check_Component; 1764 1765 ------------------------------------ 1766 -- Check_Decimal_Fixed_Point_Type -- 1767 ------------------------------------ 1768 1769 procedure Check_Decimal_Fixed_Point_Type is 1770 begin 1771 Check_Type; 1772 1773 if not Is_Decimal_Fixed_Point_Type (P_Type) then 1774 Error_Attr_P ("prefix of % attribute must be decimal type"); 1775 end if; 1776 end Check_Decimal_Fixed_Point_Type; 1777 1778 ----------------------- 1779 -- Check_Dereference -- 1780 ----------------------- 1781 1782 procedure Check_Dereference is 1783 begin 1784 1785 -- Case of a subtype mark 1786 1787 if Is_Entity_Name (P) and then Is_Type (Entity (P)) then 1788 return; 1789 end if; 1790 1791 -- Case of an expression 1792 1793 Resolve (P); 1794 1795 if Is_Access_Type (P_Type) then 1796 1797 -- If there is an implicit dereference, then we must freeze the 1798 -- designated type of the access type, since the type of the 1799 -- referenced array is this type (see AI95-00106). 1800 1801 -- As done elsewhere, freezing must not happen when pre-analyzing 1802 -- a pre- or postcondition or a default value for an object or for 1803 -- a formal parameter. 1804 1805 if not In_Spec_Expression then 1806 Freeze_Before (N, Designated_Type (P_Type)); 1807 end if; 1808 1809 Rewrite (P, 1810 Make_Explicit_Dereference (Sloc (P), 1811 Prefix => Relocate_Node (P))); 1812 1813 Analyze_And_Resolve (P); 1814 P_Type := Etype (P); 1815 1816 if P_Type = Any_Type then 1817 raise Bad_Attribute; 1818 end if; 1819 1820 P_Base_Type := Base_Type (P_Type); 1821 end if; 1822 end Check_Dereference; 1823 1824 ------------------------- 1825 -- Check_Discrete_Type -- 1826 ------------------------- 1827 1828 procedure Check_Discrete_Type is 1829 begin 1830 Check_Type; 1831 1832 if not Is_Discrete_Type (P_Type) then 1833 Error_Attr_P ("prefix of % attribute must be discrete type"); 1834 end if; 1835 end Check_Discrete_Type; 1836 1837 -------------- 1838 -- Check_E0 -- 1839 -------------- 1840 1841 procedure Check_E0 is 1842 begin 1843 if Present (E1) then 1844 Unexpected_Argument (E1); 1845 end if; 1846 end Check_E0; 1847 1848 -------------- 1849 -- Check_E1 -- 1850 -------------- 1851 1852 procedure Check_E1 is 1853 begin 1854 Check_Either_E0_Or_E1; 1855 1856 if No (E1) then 1857 1858 -- Special-case attributes that are functions and that appear as 1859 -- the prefix of another attribute. Error is posted on parent. 1860 1861 if Nkind (Parent (N)) = N_Attribute_Reference 1862 and then Nam_In (Attribute_Name (Parent (N)), Name_Address, 1863 Name_Code_Address, 1864 Name_Access) 1865 then 1866 Error_Msg_Name_1 := Attribute_Name (Parent (N)); 1867 Error_Msg_N ("illegal prefix for % attribute", Parent (N)); 1868 Set_Etype (Parent (N), Any_Type); 1869 Set_Entity (Parent (N), Any_Type); 1870 raise Bad_Attribute; 1871 1872 else 1873 Error_Attr ("missing argument for % attribute", N); 1874 end if; 1875 end if; 1876 end Check_E1; 1877 1878 -------------- 1879 -- Check_E2 -- 1880 -------------- 1881 1882 procedure Check_E2 is 1883 begin 1884 if No (E1) then 1885 Error_Attr ("missing arguments for % attribute (2 required)", N); 1886 elsif No (E2) then 1887 Error_Attr ("missing argument for % attribute (2 required)", N); 1888 end if; 1889 end Check_E2; 1890 1891 --------------------------- 1892 -- Check_Either_E0_Or_E1 -- 1893 --------------------------- 1894 1895 procedure Check_Either_E0_Or_E1 is 1896 begin 1897 if Present (E2) then 1898 Unexpected_Argument (E2); 1899 end if; 1900 end Check_Either_E0_Or_E1; 1901 1902 ---------------------- 1903 -- Check_Enum_Image -- 1904 ---------------------- 1905 1906 procedure Check_Enum_Image is 1907 Lit : Entity_Id; 1908 1909 begin 1910 -- When an enumeration type appears in an attribute reference, all 1911 -- literals of the type are marked as referenced. This must only be 1912 -- done if the attribute reference appears in the current source. 1913 -- Otherwise the information on references may differ between a 1914 -- normal compilation and one that performs inlining. 1915 1916 if Is_Enumeration_Type (P_Base_Type) 1917 and then In_Extended_Main_Code_Unit (N) 1918 then 1919 Lit := First_Literal (P_Base_Type); 1920 while Present (Lit) loop 1921 Set_Referenced (Lit); 1922 Next_Literal (Lit); 1923 end loop; 1924 end if; 1925 end Check_Enum_Image; 1926 1927 ---------------------------- 1928 -- Check_First_Last_Valid -- 1929 ---------------------------- 1930 1931 procedure Check_First_Last_Valid is 1932 begin 1933 Check_Discrete_Type; 1934 1935 -- Freeze the subtype now, so that the following test for predicates 1936 -- works (we set the predicates stuff up at freeze time) 1937 1938 Insert_Actions (N, Freeze_Entity (P_Type, P)); 1939 1940 -- Now test for dynamic predicate 1941 1942 if Has_Predicates (P_Type) 1943 and then not (Has_Static_Predicate (P_Type)) 1944 then 1945 Error_Attr_P 1946 ("prefix of % attribute may not have dynamic predicate"); 1947 end if; 1948 1949 -- Check non-static subtype 1950 1951 if not Is_OK_Static_Subtype (P_Type) then 1952 Error_Attr_P ("prefix of % attribute must be a static subtype"); 1953 end if; 1954 1955 -- Test case for no values 1956 1957 if Expr_Value (Type_Low_Bound (P_Type)) > 1958 Expr_Value (Type_High_Bound (P_Type)) 1959 or else (Has_Predicates (P_Type) 1960 and then 1961 Is_Empty_List (Static_Discrete_Predicate (P_Type))) 1962 then 1963 Error_Attr_P 1964 ("prefix of % attribute must be subtype with at least one " 1965 & "value"); 1966 end if; 1967 end Check_First_Last_Valid; 1968 1969 ---------------------------- 1970 -- Check_Fixed_Point_Type -- 1971 ---------------------------- 1972 1973 procedure Check_Fixed_Point_Type is 1974 begin 1975 Check_Type; 1976 1977 if not Is_Fixed_Point_Type (P_Type) then 1978 Error_Attr_P ("prefix of % attribute must be fixed point type"); 1979 end if; 1980 end Check_Fixed_Point_Type; 1981 1982 ------------------------------ 1983 -- Check_Fixed_Point_Type_0 -- 1984 ------------------------------ 1985 1986 procedure Check_Fixed_Point_Type_0 is 1987 begin 1988 Check_Fixed_Point_Type; 1989 Check_E0; 1990 end Check_Fixed_Point_Type_0; 1991 1992 ------------------------------- 1993 -- Check_Floating_Point_Type -- 1994 ------------------------------- 1995 1996 procedure Check_Floating_Point_Type is 1997 begin 1998 Check_Type; 1999 2000 if not Is_Floating_Point_Type (P_Type) then 2001 Error_Attr_P ("prefix of % attribute must be float type"); 2002 end if; 2003 end Check_Floating_Point_Type; 2004 2005 --------------------------------- 2006 -- Check_Floating_Point_Type_0 -- 2007 --------------------------------- 2008 2009 procedure Check_Floating_Point_Type_0 is 2010 begin 2011 Check_Floating_Point_Type; 2012 Check_E0; 2013 end Check_Floating_Point_Type_0; 2014 2015 --------------------------------- 2016 -- Check_Floating_Point_Type_1 -- 2017 --------------------------------- 2018 2019 procedure Check_Floating_Point_Type_1 is 2020 begin 2021 Check_Floating_Point_Type; 2022 Check_E1; 2023 end Check_Floating_Point_Type_1; 2024 2025 --------------------------------- 2026 -- Check_Floating_Point_Type_2 -- 2027 --------------------------------- 2028 2029 procedure Check_Floating_Point_Type_2 is 2030 begin 2031 Check_Floating_Point_Type; 2032 Check_E2; 2033 end Check_Floating_Point_Type_2; 2034 2035 ------------------------ 2036 -- Check_Integer_Type -- 2037 ------------------------ 2038 2039 procedure Check_Integer_Type is 2040 begin 2041 Check_Type; 2042 2043 if not Is_Integer_Type (P_Type) then 2044 Error_Attr_P ("prefix of % attribute must be integer type"); 2045 end if; 2046 end Check_Integer_Type; 2047 2048 -------------------------------- 2049 -- Check_Modular_Integer_Type -- 2050 -------------------------------- 2051 2052 procedure Check_Modular_Integer_Type is 2053 begin 2054 Check_Type; 2055 2056 if not Is_Modular_Integer_Type (P_Type) then 2057 Error_Attr_P 2058 ("prefix of % attribute must be modular integer type"); 2059 end if; 2060 end Check_Modular_Integer_Type; 2061 2062 ------------------------ 2063 -- Check_Not_CPP_Type -- 2064 ------------------------ 2065 2066 procedure Check_Not_CPP_Type is 2067 begin 2068 if Is_Tagged_Type (Etype (P)) 2069 and then Convention (Etype (P)) = Convention_CPP 2070 and then Is_CPP_Class (Root_Type (Etype (P))) 2071 then 2072 Error_Attr_P 2073 ("invalid use of % attribute with 'C'P'P tagged type"); 2074 end if; 2075 end Check_Not_CPP_Type; 2076 2077 ------------------------------- 2078 -- Check_Not_Incomplete_Type -- 2079 ------------------------------- 2080 2081 procedure Check_Not_Incomplete_Type is 2082 E : Entity_Id; 2083 Typ : Entity_Id; 2084 2085 begin 2086 -- Ada 2005 (AI-50217, AI-326): If the prefix is an explicit 2087 -- dereference we have to check wrong uses of incomplete types 2088 -- (other wrong uses are checked at their freezing point). 2089 2090 -- In Ada 2012, incomplete types can appear in subprogram 2091 -- profiles, but formals with incomplete types cannot be the 2092 -- prefix of attributes. 2093 2094 -- Example 1: Limited-with 2095 2096 -- limited with Pkg; 2097 -- package P is 2098 -- type Acc is access Pkg.T; 2099 -- X : Acc; 2100 -- S : Integer := X.all'Size; -- ERROR 2101 -- end P; 2102 2103 -- Example 2: Tagged incomplete 2104 2105 -- type T is tagged; 2106 -- type Acc is access all T; 2107 -- X : Acc; 2108 -- S : constant Integer := X.all'Size; -- ERROR 2109 -- procedure Q (Obj : Integer := X.all'Alignment); -- ERROR 2110 2111 if Ada_Version >= Ada_2005 2112 and then Nkind (P) = N_Explicit_Dereference 2113 then 2114 E := P; 2115 while Nkind (E) = N_Explicit_Dereference loop 2116 E := Prefix (E); 2117 end loop; 2118 2119 Typ := Etype (E); 2120 2121 if From_Limited_With (Typ) then 2122 Error_Attr_P 2123 ("prefix of % attribute cannot be an incomplete type"); 2124 2125 -- If the prefix is an access type check the designated type 2126 2127 elsif Is_Access_Type (Typ) 2128 and then Nkind (P) = N_Explicit_Dereference 2129 then 2130 Typ := Directly_Designated_Type (Typ); 2131 end if; 2132 2133 if Is_Class_Wide_Type (Typ) then 2134 Typ := Root_Type (Typ); 2135 end if; 2136 2137 -- A legal use of a shadow entity occurs only when the unit where 2138 -- the non-limited view resides is imported via a regular with 2139 -- clause in the current body. Such references to shadow entities 2140 -- may occur in subprogram formals. 2141 2142 if Is_Incomplete_Type (Typ) 2143 and then From_Limited_With (Typ) 2144 and then Present (Non_Limited_View (Typ)) 2145 and then Is_Legal_Shadow_Entity_In_Body (Typ) 2146 then 2147 Typ := Non_Limited_View (Typ); 2148 end if; 2149 2150 -- If still incomplete, it can be a local incomplete type, or a 2151 -- limited view whose scope is also a limited view. 2152 2153 if Ekind (Typ) = E_Incomplete_Type then 2154 if not From_Limited_With (Typ) 2155 and then No (Full_View (Typ)) 2156 then 2157 Error_Attr_P 2158 ("prefix of % attribute cannot be an incomplete type"); 2159 2160 -- The limited view may be available indirectly through 2161 -- an intermediate unit. If the non-limited view is available 2162 -- the attribute reference is legal. 2163 2164 elsif From_Limited_With (Typ) 2165 and then 2166 (No (Non_Limited_View (Typ)) 2167 or else Is_Incomplete_Type (Non_Limited_View (Typ))) 2168 then 2169 Error_Attr_P 2170 ("prefix of % attribute cannot be an incomplete type"); 2171 end if; 2172 end if; 2173 2174 -- Ada 2012 : formals in bodies may be incomplete, but no attribute 2175 -- legally applies. 2176 2177 elsif Is_Entity_Name (P) 2178 and then Is_Formal (Entity (P)) 2179 and then Is_Incomplete_Type (Etype (Etype (P))) 2180 then 2181 Error_Attr_P 2182 ("prefix of % attribute cannot be an incomplete type"); 2183 end if; 2184 2185 if not Is_Entity_Name (P) 2186 or else not Is_Type (Entity (P)) 2187 or else In_Spec_Expression 2188 then 2189 return; 2190 else 2191 Check_Fully_Declared (P_Type, P); 2192 end if; 2193 end Check_Not_Incomplete_Type; 2194 2195 ---------------------------- 2196 -- Check_Object_Reference -- 2197 ---------------------------- 2198 2199 procedure Check_Object_Reference (P : Node_Id) is 2200 Rtyp : Entity_Id; 2201 2202 begin 2203 -- If we need an object, and we have a prefix that is the name of 2204 -- a function entity, convert it into a function call. 2205 2206 if Is_Entity_Name (P) 2207 and then Ekind (Entity (P)) = E_Function 2208 then 2209 Rtyp := Etype (Entity (P)); 2210 2211 Rewrite (P, 2212 Make_Function_Call (Sloc (P), 2213 Name => Relocate_Node (P))); 2214 2215 Analyze_And_Resolve (P, Rtyp); 2216 2217 -- Otherwise we must have an object reference 2218 2219 elsif not Is_Object_Reference (P) then 2220 Error_Attr_P ("prefix of % attribute must be object"); 2221 end if; 2222 end Check_Object_Reference; 2223 2224 ---------------------------- 2225 -- Check_PolyORB_Attribute -- 2226 ---------------------------- 2227 2228 procedure Check_PolyORB_Attribute is 2229 begin 2230 Validate_Non_Static_Attribute_Function_Call; 2231 2232 Check_Type; 2233 Check_Not_CPP_Type; 2234 2235 if Get_PCS_Name /= Name_PolyORB_DSA then 2236 Error_Attr 2237 ("attribute% requires the 'Poly'O'R'B 'P'C'S", N); 2238 end if; 2239 end Check_PolyORB_Attribute; 2240 2241 ------------------------ 2242 -- Check_Program_Unit -- 2243 ------------------------ 2244 2245 procedure Check_Program_Unit is 2246 begin 2247 if Is_Entity_Name (P) then 2248 declare 2249 K : constant Entity_Kind := Ekind (Entity (P)); 2250 T : constant Entity_Id := Etype (Entity (P)); 2251 2252 begin 2253 if K in Subprogram_Kind 2254 or else K in Task_Kind 2255 or else K in Protected_Kind 2256 or else K = E_Package 2257 or else K in Generic_Unit_Kind 2258 or else (K = E_Variable 2259 and then 2260 (Is_Task_Type (T) 2261 or else 2262 Is_Protected_Type (T))) 2263 then 2264 return; 2265 end if; 2266 end; 2267 end if; 2268 2269 Error_Attr_P ("prefix of % attribute must be program unit"); 2270 end Check_Program_Unit; 2271 2272 --------------------- 2273 -- Check_Real_Type -- 2274 --------------------- 2275 2276 procedure Check_Real_Type is 2277 begin 2278 Check_Type; 2279 2280 if not Is_Real_Type (P_Type) then 2281 Error_Attr_P ("prefix of % attribute must be real type"); 2282 end if; 2283 end Check_Real_Type; 2284 2285 ----------------------- 2286 -- Check_Scalar_Type -- 2287 ----------------------- 2288 2289 procedure Check_Scalar_Type is 2290 begin 2291 Check_Type; 2292 2293 if not Is_Scalar_Type (P_Type) then 2294 Error_Attr_P ("prefix of % attribute must be scalar type"); 2295 end if; 2296 end Check_Scalar_Type; 2297 2298 ------------------------------------------ 2299 -- Check_SPARK_05_Restriction_On_Attribute -- 2300 ------------------------------------------ 2301 2302 procedure Check_SPARK_05_Restriction_On_Attribute is 2303 begin 2304 Error_Msg_Name_1 := Aname; 2305 Check_SPARK_05_Restriction ("attribute % is not allowed", P); 2306 end Check_SPARK_05_Restriction_On_Attribute; 2307 2308 --------------------------- 2309 -- Check_Standard_Prefix -- 2310 --------------------------- 2311 2312 procedure Check_Standard_Prefix is 2313 begin 2314 Check_E0; 2315 2316 if Nkind (P) /= N_Identifier or else Chars (P) /= Name_Standard then 2317 Error_Attr ("only allowed prefix for % attribute is Standard", P); 2318 end if; 2319 end Check_Standard_Prefix; 2320 2321 ---------------------------- 2322 -- Check_Stream_Attribute -- 2323 ---------------------------- 2324 2325 procedure Check_Stream_Attribute (Nam : TSS_Name_Type) is 2326 Etyp : Entity_Id; 2327 Btyp : Entity_Id; 2328 2329 In_Shared_Var_Procs : Boolean; 2330 -- True when compiling System.Shared_Storage.Shared_Var_Procs body. 2331 -- For this runtime package (always compiled in GNAT mode), we allow 2332 -- stream attributes references for limited types for the case where 2333 -- shared passive objects are implemented using stream attributes, 2334 -- which is the default in GNAT's persistent storage implementation. 2335 2336 begin 2337 Validate_Non_Static_Attribute_Function_Call; 2338 2339 -- With the exception of 'Input, Stream attributes are procedures, 2340 -- and can only appear at the position of procedure calls. We check 2341 -- for this here, before they are rewritten, to give a more precise 2342 -- diagnostic. 2343 2344 if Nam = TSS_Stream_Input then 2345 null; 2346 2347 elsif Is_List_Member (N) 2348 and then not Nkind_In (Parent (N), N_Procedure_Call_Statement, 2349 N_Aggregate) 2350 then 2351 null; 2352 2353 else 2354 Error_Attr 2355 ("invalid context for attribute%, which is a procedure", N); 2356 end if; 2357 2358 Check_Type; 2359 Btyp := Implementation_Base_Type (P_Type); 2360 2361 -- Stream attributes not allowed on limited types unless the 2362 -- attribute reference was generated by the expander (in which 2363 -- case the underlying type will be used, as described in Sinfo), 2364 -- or the attribute was specified explicitly for the type itself 2365 -- or one of its ancestors (taking visibility rules into account if 2366 -- in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp 2367 -- (with no visibility restriction). 2368 2369 declare 2370 Gen_Body : constant Node_Id := Enclosing_Generic_Body (N); 2371 begin 2372 if Present (Gen_Body) then 2373 In_Shared_Var_Procs := 2374 Is_RTE (Corresponding_Spec (Gen_Body), RE_Shared_Var_Procs); 2375 else 2376 In_Shared_Var_Procs := False; 2377 end if; 2378 end; 2379 2380 if (Comes_From_Source (N) 2381 and then not (In_Shared_Var_Procs or In_Instance)) 2382 and then not Stream_Attribute_Available (P_Type, Nam) 2383 and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert) 2384 then 2385 Error_Msg_Name_1 := Aname; 2386 2387 if Is_Limited_Type (P_Type) then 2388 Error_Msg_NE 2389 ("limited type& has no% attribute", P, P_Type); 2390 Explain_Limited_Type (P_Type, P); 2391 else 2392 Error_Msg_NE 2393 ("attribute% for type& is not available", P, P_Type); 2394 end if; 2395 end if; 2396 2397 -- Check for no stream operations allowed from No_Tagged_Streams 2398 2399 if Is_Tagged_Type (P_Type) 2400 and then Present (No_Tagged_Streams_Pragma (P_Type)) 2401 then 2402 Error_Msg_Sloc := Sloc (No_Tagged_Streams_Pragma (P_Type)); 2403 Error_Msg_NE 2404 ("no stream operations for & (No_Tagged_Streams #)", N, P_Type); 2405 return; 2406 end if; 2407 2408 -- Check restriction violations 2409 2410 -- First check the No_Streams restriction, which prohibits the use 2411 -- of explicit stream attributes in the source program. We do not 2412 -- prevent the occurrence of stream attributes in generated code, 2413 -- for instance those generated implicitly for dispatching purposes. 2414 2415 if Comes_From_Source (N) then 2416 Check_Restriction (No_Streams, P); 2417 end if; 2418 2419 -- AI05-0057: if restriction No_Default_Stream_Attributes is active, 2420 -- it is illegal to use a predefined elementary type stream attribute 2421 -- either by itself, or more importantly as part of the attribute 2422 -- subprogram for a composite type. However, if the broader 2423 -- restriction No_Streams is active, stream operations are not 2424 -- generated, and there is no error. 2425 2426 if Restriction_Active (No_Default_Stream_Attributes) 2427 and then not Restriction_Active (No_Streams) 2428 then 2429 declare 2430 T : Entity_Id; 2431 2432 begin 2433 if Nam = TSS_Stream_Input 2434 or else 2435 Nam = TSS_Stream_Read 2436 then 2437 T := 2438 Type_Without_Stream_Operation (P_Type, TSS_Stream_Read); 2439 else 2440 T := 2441 Type_Without_Stream_Operation (P_Type, TSS_Stream_Write); 2442 end if; 2443 2444 if Present (T) then 2445 Check_Restriction (No_Default_Stream_Attributes, N); 2446 2447 Error_Msg_NE 2448 ("missing user-defined Stream Read or Write for type&", 2449 N, T); 2450 if not Is_Elementary_Type (P_Type) then 2451 Error_Msg_NE 2452 ("\which is a component of type&", N, P_Type); 2453 end if; 2454 end if; 2455 end; 2456 end if; 2457 2458 -- Check special case of Exception_Id and Exception_Occurrence which 2459 -- are not allowed for restriction No_Exception_Registration. 2460 2461 if Restriction_Check_Required (No_Exception_Registration) 2462 and then (Is_RTE (P_Type, RE_Exception_Id) 2463 or else 2464 Is_RTE (P_Type, RE_Exception_Occurrence)) 2465 then 2466 Check_Restriction (No_Exception_Registration, P); 2467 end if; 2468 2469 -- Here we must check that the first argument is an access type 2470 -- that is compatible with Ada.Streams.Root_Stream_Type'Class. 2471 2472 Analyze_And_Resolve (E1); 2473 Etyp := Etype (E1); 2474 2475 -- Note: the double call to Root_Type here is needed because the 2476 -- root type of a class-wide type is the corresponding type (e.g. 2477 -- X for X'Class, and we really want to go to the root.) 2478 2479 if not Is_Access_Type (Etyp) 2480 or else Root_Type (Root_Type (Designated_Type (Etyp))) /= 2481 RTE (RE_Root_Stream_Type) 2482 then 2483 Error_Attr 2484 ("expected access to Ada.Streams.Root_Stream_Type''Class", E1); 2485 end if; 2486 2487 -- Check that the second argument is of the right type if there is 2488 -- one (the Input attribute has only one argument so this is skipped) 2489 2490 if Present (E2) then 2491 Analyze (E2); 2492 2493 if Nam = TSS_Stream_Read 2494 and then not Is_OK_Variable_For_Out_Formal (E2) 2495 then 2496 Error_Attr 2497 ("second argument of % attribute must be a variable", E2); 2498 end if; 2499 2500 Resolve (E2, P_Type); 2501 end if; 2502 2503 Check_Not_CPP_Type; 2504 end Check_Stream_Attribute; 2505 2506 ------------------------- 2507 -- Check_System_Prefix -- 2508 ------------------------- 2509 2510 procedure Check_System_Prefix is 2511 begin 2512 if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then 2513 Error_Attr ("only allowed prefix for % attribute is System", P); 2514 end if; 2515 end Check_System_Prefix; 2516 2517 ----------------------- 2518 -- Check_Task_Prefix -- 2519 ----------------------- 2520 2521 procedure Check_Task_Prefix is 2522 begin 2523 Analyze (P); 2524 2525 -- Ada 2005 (AI-345): Attribute 'Terminated can be applied to 2526 -- task interface class-wide types. 2527 2528 if Is_Task_Type (Etype (P)) 2529 or else (Is_Access_Type (Etype (P)) 2530 and then Is_Task_Type (Designated_Type (Etype (P)))) 2531 or else (Ada_Version >= Ada_2005 2532 and then Ekind (Etype (P)) = E_Class_Wide_Type 2533 and then Is_Interface (Etype (P)) 2534 and then Is_Task_Interface (Etype (P))) 2535 then 2536 Resolve (P); 2537 2538 else 2539 if Ada_Version >= Ada_2005 then 2540 Error_Attr_P 2541 ("prefix of % attribute must be a task or a task " & 2542 "interface class-wide object"); 2543 2544 else 2545 Error_Attr_P ("prefix of % attribute must be a task"); 2546 end if; 2547 end if; 2548 end Check_Task_Prefix; 2549 2550 ---------------- 2551 -- Check_Type -- 2552 ---------------- 2553 2554 -- The possibilities are an entity name denoting a type, or an 2555 -- attribute reference that denotes a type (Base or Class). If 2556 -- the type is incomplete, replace it with its full view. 2557 2558 procedure Check_Type is 2559 begin 2560 if not Is_Entity_Name (P) 2561 or else not Is_Type (Entity (P)) 2562 then 2563 Error_Attr_P ("prefix of % attribute must be a type"); 2564 2565 elsif Is_Protected_Self_Reference (P) then 2566 Error_Attr_P 2567 ("prefix of % attribute denotes current instance " 2568 & "(RM 9.4(21/2))"); 2569 2570 elsif Ekind (Entity (P)) = E_Incomplete_Type 2571 and then Present (Full_View (Entity (P))) 2572 then 2573 P_Type := Full_View (Entity (P)); 2574 Set_Entity (P, P_Type); 2575 end if; 2576 end Check_Type; 2577 2578 --------------------- 2579 -- Check_Unit_Name -- 2580 --------------------- 2581 2582 procedure Check_Unit_Name (Nod : Node_Id) is 2583 begin 2584 if Nkind (Nod) = N_Identifier then 2585 return; 2586 2587 elsif Nkind_In (Nod, N_Selected_Component, N_Expanded_Name) then 2588 Check_Unit_Name (Prefix (Nod)); 2589 2590 if Nkind (Selector_Name (Nod)) = N_Identifier then 2591 return; 2592 end if; 2593 end if; 2594 2595 Error_Attr ("argument for % attribute must be unit name", P); 2596 end Check_Unit_Name; 2597 2598 ---------------- 2599 -- Error_Attr -- 2600 ---------------- 2601 2602 procedure Error_Attr is 2603 begin 2604 Set_Etype (N, Any_Type); 2605 Set_Entity (N, Any_Type); 2606 raise Bad_Attribute; 2607 end Error_Attr; 2608 2609 procedure Error_Attr (Msg : String; Error_Node : Node_Id) is 2610 begin 2611 Error_Msg_Name_1 := Aname; 2612 Error_Msg_N (Msg, Error_Node); 2613 Error_Attr; 2614 end Error_Attr; 2615 2616 ------------------ 2617 -- Error_Attr_P -- 2618 ------------------ 2619 2620 procedure Error_Attr_P (Msg : String) is 2621 begin 2622 Error_Msg_Name_1 := Aname; 2623 Error_Msg_F (Msg, P); 2624 Error_Attr; 2625 end Error_Attr_P; 2626 2627 ---------------------------- 2628 -- Legal_Formal_Attribute -- 2629 ---------------------------- 2630 2631 procedure Legal_Formal_Attribute is 2632 begin 2633 Check_E0; 2634 2635 if not Is_Entity_Name (P) 2636 or else not Is_Type (Entity (P)) 2637 then 2638 Error_Attr_P ("prefix of % attribute must be generic type"); 2639 2640 elsif Is_Generic_Actual_Type (Entity (P)) 2641 or else In_Instance 2642 or else In_Inlined_Body 2643 then 2644 null; 2645 2646 elsif Is_Generic_Type (Entity (P)) then 2647 if Is_Definite_Subtype (Entity (P)) then 2648 Error_Attr_P 2649 ("prefix of % attribute must be indefinite generic type"); 2650 end if; 2651 2652 else 2653 Error_Attr_P 2654 ("prefix of % attribute must be indefinite generic type"); 2655 end if; 2656 2657 Set_Etype (N, Standard_Boolean); 2658 end Legal_Formal_Attribute; 2659 2660 --------------------------------------------------------------- 2661 -- Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements -- 2662 --------------------------------------------------------------- 2663 2664 procedure Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements is 2665 begin 2666 Check_E0; 2667 Check_Type; 2668 Check_Not_Incomplete_Type; 2669 Set_Etype (N, Universal_Integer); 2670 end Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements; 2671 2672 ------------- 2673 -- Min_Max -- 2674 ------------- 2675 2676 procedure Min_Max is 2677 begin 2678 Check_E2; 2679 Check_Scalar_Type; 2680 Resolve (E1, P_Base_Type); 2681 Resolve (E2, P_Base_Type); 2682 Set_Etype (N, P_Base_Type); 2683 2684 -- Check for comparison on unordered enumeration type 2685 2686 if Bad_Unordered_Enumeration_Reference (N, P_Base_Type) then 2687 Error_Msg_Sloc := Sloc (P_Base_Type); 2688 Error_Msg_NE 2689 ("comparison on unordered enumeration type& declared#?U?", 2690 N, P_Base_Type); 2691 end if; 2692 end Min_Max; 2693 2694 ------------------------ 2695 -- Standard_Attribute -- 2696 ------------------------ 2697 2698 procedure Standard_Attribute (Val : Int) is 2699 begin 2700 Check_Standard_Prefix; 2701 Rewrite (N, Make_Integer_Literal (Loc, Val)); 2702 Analyze (N); 2703 Set_Is_Static_Expression (N, True); 2704 end Standard_Attribute; 2705 2706 -------------------- 2707 -- Uneval_Old_Msg -- 2708 -------------------- 2709 2710 procedure Uneval_Old_Msg is 2711 Uneval_Old_Setting : Character; 2712 Prag : Node_Id; 2713 2714 begin 2715 -- If from aspect, then Uneval_Old_Setting comes from flags in the 2716 -- N_Aspect_Specification node that corresponds to the attribute. 2717 2718 -- First find the pragma in which we appear (note that at this stage, 2719 -- even if we appeared originally within an aspect specification, we 2720 -- are now within the corresponding pragma). 2721 2722 Prag := N; 2723 loop 2724 Prag := Parent (Prag); 2725 exit when No (Prag) or else Nkind (Prag) = N_Pragma; 2726 end loop; 2727 2728 if Present (Prag) then 2729 if Uneval_Old_Accept (Prag) then 2730 Uneval_Old_Setting := 'A'; 2731 elsif Uneval_Old_Warn (Prag) then 2732 Uneval_Old_Setting := 'W'; 2733 else 2734 Uneval_Old_Setting := 'E'; 2735 end if; 2736 2737 -- If we did not find the pragma, that's odd, just use the setting 2738 -- from Opt.Uneval_Old. Perhaps this is due to a previous error? 2739 2740 else 2741 Uneval_Old_Setting := Opt.Uneval_Old; 2742 end if; 2743 2744 -- Processing depends on the setting of Uneval_Old 2745 2746 case Uneval_Old_Setting is 2747 when 'E' => 2748 Error_Attr_P 2749 ("prefix of attribute % that is potentially " 2750 & "unevaluated must denote an entity"); 2751 2752 when 'W' => 2753 Error_Msg_Name_1 := Aname; 2754 Error_Msg_F 2755 ("??prefix of attribute % appears in potentially " 2756 & "unevaluated context, exception may be raised", P); 2757 2758 when 'A' => 2759 null; 2760 2761 when others => 2762 raise Program_Error; 2763 end case; 2764 end Uneval_Old_Msg; 2765 2766 ------------------------- 2767 -- Unexpected Argument -- 2768 ------------------------- 2769 2770 procedure Unexpected_Argument (En : Node_Id) is 2771 begin 2772 Error_Attr ("unexpected argument for % attribute", En); 2773 end Unexpected_Argument; 2774 2775 ------------------------------------------------- 2776 -- Validate_Non_Static_Attribute_Function_Call -- 2777 ------------------------------------------------- 2778 2779 -- This function should be moved to Sem_Dist ??? 2780 2781 procedure Validate_Non_Static_Attribute_Function_Call is 2782 begin 2783 if In_Preelaborated_Unit 2784 and then not In_Subprogram_Or_Concurrent_Unit 2785 then 2786 Flag_Non_Static_Expr 2787 ("non-static function call in preelaborated unit!", N); 2788 end if; 2789 end Validate_Non_Static_Attribute_Function_Call; 2790 2791 -- Start of processing for Analyze_Attribute 2792 2793 begin 2794 -- Immediate return if unrecognized attribute (already diagnosed by 2795 -- parser, so there is nothing more that we need to do). 2796 2797 if not Is_Attribute_Name (Aname) then 2798 raise Bad_Attribute; 2799 end if; 2800 2801 Check_Restriction_No_Use_Of_Attribute (N); 2802 2803 -- Deal with Ada 83 issues 2804 2805 if Comes_From_Source (N) then 2806 if not Attribute_83 (Attr_Id) then 2807 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 2808 Error_Msg_Name_1 := Aname; 2809 Error_Msg_N ("(Ada 83) attribute% is not standard??", N); 2810 end if; 2811 2812 if Attribute_Impl_Def (Attr_Id) then 2813 Check_Restriction (No_Implementation_Attributes, N); 2814 end if; 2815 end if; 2816 end if; 2817 2818 -- Deal with Ada 2005 attributes that are implementation attributes 2819 -- because they appear in a version of Ada before Ada 2005, and 2820 -- similarly for Ada 2012 attributes appearing in an earlier version. 2821 2822 if (Attribute_05 (Attr_Id) and then Ada_Version < Ada_2005) 2823 or else 2824 (Attribute_12 (Attr_Id) and then Ada_Version < Ada_2012) 2825 then 2826 Check_Restriction (No_Implementation_Attributes, N); 2827 end if; 2828 2829 -- Remote access to subprogram type access attribute reference needs 2830 -- unanalyzed copy for tree transformation. The analyzed copy is used 2831 -- for its semantic information (whether prefix is a remote subprogram 2832 -- name), the unanalyzed copy is used to construct new subtree rooted 2833 -- with N_Aggregate which represents a fat pointer aggregate. 2834 2835 if Aname = Name_Access then 2836 Discard_Node (Copy_Separate_Tree (N)); 2837 end if; 2838 2839 -- Analyze prefix and exit if error in analysis. If the prefix is an 2840 -- incomplete type, use full view if available. Note that there are 2841 -- some attributes for which we do not analyze the prefix, since the 2842 -- prefix is not a normal name, or else needs special handling. 2843 2844 if Aname /= Name_Elab_Body and then 2845 Aname /= Name_Elab_Spec and then 2846 Aname /= Name_Elab_Subp_Body and then 2847 Aname /= Name_Enabled and then 2848 Aname /= Name_Old 2849 then 2850 Analyze (P); 2851 P_Type := Etype (P); 2852 2853 if Is_Entity_Name (P) 2854 and then Present (Entity (P)) 2855 and then Is_Type (Entity (P)) 2856 then 2857 if Ekind (Entity (P)) = E_Incomplete_Type then 2858 P_Type := Get_Full_View (P_Type); 2859 Set_Entity (P, P_Type); 2860 Set_Etype (P, P_Type); 2861 2862 elsif Entity (P) = Current_Scope 2863 and then Is_Record_Type (Entity (P)) 2864 then 2865 -- Use of current instance within the type. Verify that if the 2866 -- attribute appears within a constraint, it yields an access 2867 -- type, other uses are illegal. 2868 2869 declare 2870 Par : Node_Id; 2871 2872 begin 2873 Par := Parent (N); 2874 while Present (Par) 2875 and then Nkind (Parent (Par)) /= N_Component_Definition 2876 loop 2877 Par := Parent (Par); 2878 end loop; 2879 2880 if Present (Par) 2881 and then Nkind (Par) = N_Subtype_Indication 2882 then 2883 if Attr_Id /= Attribute_Access 2884 and then Attr_Id /= Attribute_Unchecked_Access 2885 and then Attr_Id /= Attribute_Unrestricted_Access 2886 then 2887 Error_Msg_N 2888 ("in a constraint the current instance can only " 2889 & "be used with an access attribute", N); 2890 end if; 2891 end if; 2892 end; 2893 end if; 2894 end if; 2895 2896 if P_Type = Any_Type then 2897 raise Bad_Attribute; 2898 end if; 2899 2900 P_Base_Type := Base_Type (P_Type); 2901 end if; 2902 2903 -- Analyze expressions that may be present, exiting if an error occurs 2904 2905 if No (Exprs) then 2906 E1 := Empty; 2907 E2 := Empty; 2908 2909 else 2910 E1 := First (Exprs); 2911 2912 -- Skip analysis for case of Restriction_Set, we do not expect 2913 -- the argument to be analyzed in this case. 2914 2915 if Aname /= Name_Restriction_Set then 2916 Analyze (E1); 2917 2918 -- Check for missing/bad expression (result of previous error) 2919 2920 if No (E1) or else Etype (E1) = Any_Type then 2921 raise Bad_Attribute; 2922 end if; 2923 end if; 2924 2925 E2 := Next (E1); 2926 2927 if Present (E2) then 2928 Analyze (E2); 2929 2930 if Etype (E2) = Any_Type then 2931 raise Bad_Attribute; 2932 end if; 2933 2934 if Present (Next (E2)) then 2935 Unexpected_Argument (Next (E2)); 2936 end if; 2937 end if; 2938 end if; 2939 2940 -- Cases where prefix must be resolvable by itself 2941 2942 if Is_Overloaded (P) 2943 and then Aname /= Name_Access 2944 and then Aname /= Name_Address 2945 and then Aname /= Name_Code_Address 2946 and then Aname /= Name_Result 2947 and then Aname /= Name_Unchecked_Access 2948 then 2949 -- The prefix must be resolvable by itself, without reference to the 2950 -- attribute. One case that requires special handling is a prefix 2951 -- that is a function name, where one interpretation may be a 2952 -- parameterless call. Entry attributes are handled specially below. 2953 2954 if Is_Entity_Name (P) 2955 and then not Nam_In (Aname, Name_Count, Name_Caller) 2956 then 2957 Check_Parameterless_Call (P); 2958 end if; 2959 2960 if Is_Overloaded (P) then 2961 2962 -- Ada 2005 (AI-345): Since protected and task types have 2963 -- primitive entry wrappers, the attributes Count, and Caller 2964 -- require a context check 2965 2966 if Nam_In (Aname, Name_Count, Name_Caller) then 2967 declare 2968 Count : Natural := 0; 2969 I : Interp_Index; 2970 It : Interp; 2971 2972 begin 2973 Get_First_Interp (P, I, It); 2974 while Present (It.Nam) loop 2975 if Comes_From_Source (It.Nam) then 2976 Count := Count + 1; 2977 else 2978 Remove_Interp (I); 2979 end if; 2980 2981 Get_Next_Interp (I, It); 2982 end loop; 2983 2984 if Count > 1 then 2985 Error_Attr ("ambiguous prefix for % attribute", P); 2986 else 2987 Set_Is_Overloaded (P, False); 2988 end if; 2989 end; 2990 2991 else 2992 Error_Attr ("ambiguous prefix for % attribute", P); 2993 end if; 2994 end if; 2995 end if; 2996 2997 -- In SPARK, attributes of private types are only allowed if the full 2998 -- type declaration is visible. 2999 3000 -- Note: the check for Present (Entity (P)) defends against some error 3001 -- conditions where the Entity field is not set. 3002 3003 if Is_Entity_Name (P) and then Present (Entity (P)) 3004 and then Is_Type (Entity (P)) 3005 and then Is_Private_Type (P_Type) 3006 and then not In_Open_Scopes (Scope (P_Type)) 3007 and then not In_Spec_Expression 3008 then 3009 Check_SPARK_05_Restriction ("invisible attribute of type", N); 3010 end if; 3011 3012 -- Remaining processing depends on attribute 3013 3014 case Attr_Id is 3015 3016 -- Attributes related to Ada 2012 iterators. Attribute specifications 3017 -- exist for these, but they cannot be queried. 3018 3019 when Attribute_Constant_Indexing 3020 | Attribute_Default_Iterator 3021 | Attribute_Implicit_Dereference 3022 | Attribute_Iterator_Element 3023 | Attribute_Iterable 3024 | Attribute_Variable_Indexing 3025 => 3026 Error_Msg_N ("illegal attribute", N); 3027 3028 -- Internal attributes used to deal with Ada 2012 delayed aspects. These 3029 -- were already rejected by the parser. Thus they shouldn't appear here. 3030 3031 when Internal_Attribute_Id => 3032 raise Program_Error; 3033 3034 ------------------ 3035 -- Abort_Signal -- 3036 ------------------ 3037 3038 when Attribute_Abort_Signal => 3039 Check_Standard_Prefix; 3040 Rewrite (N, New_Occurrence_Of (Stand.Abort_Signal, Loc)); 3041 Analyze (N); 3042 3043 ------------ 3044 -- Access -- 3045 ------------ 3046 3047 when Attribute_Access => 3048 Analyze_Access_Attribute; 3049 Check_Not_Incomplete_Type; 3050 3051 ------------- 3052 -- Address -- 3053 ------------- 3054 3055 when Attribute_Address => 3056 Check_E0; 3057 Address_Checks; 3058 Check_Not_Incomplete_Type; 3059 Set_Etype (N, RTE (RE_Address)); 3060 3061 ------------------ 3062 -- Address_Size -- 3063 ------------------ 3064 3065 when Attribute_Address_Size => 3066 Standard_Attribute (System_Address_Size); 3067 3068 -------------- 3069 -- Adjacent -- 3070 -------------- 3071 3072 when Attribute_Adjacent => 3073 Check_Floating_Point_Type_2; 3074 Set_Etype (N, P_Base_Type); 3075 Resolve (E1, P_Base_Type); 3076 Resolve (E2, P_Base_Type); 3077 3078 --------- 3079 -- Aft -- 3080 --------- 3081 3082 when Attribute_Aft => 3083 Check_Fixed_Point_Type_0; 3084 Set_Etype (N, Universal_Integer); 3085 3086 --------------- 3087 -- Alignment -- 3088 --------------- 3089 3090 when Attribute_Alignment => 3091 3092 -- Don't we need more checking here, cf Size ??? 3093 3094 Check_E0; 3095 Check_Not_Incomplete_Type; 3096 Check_Not_CPP_Type; 3097 Set_Etype (N, Universal_Integer); 3098 3099 --------------- 3100 -- Asm_Input -- 3101 --------------- 3102 3103 when Attribute_Asm_Input => 3104 Check_Asm_Attribute; 3105 3106 -- The back end may need to take the address of E2 3107 3108 if Is_Entity_Name (E2) then 3109 Set_Address_Taken (Entity (E2)); 3110 end if; 3111 3112 Set_Etype (N, RTE (RE_Asm_Input_Operand)); 3113 3114 ---------------- 3115 -- Asm_Output -- 3116 ---------------- 3117 3118 when Attribute_Asm_Output => 3119 Check_Asm_Attribute; 3120 3121 if Etype (E2) = Any_Type then 3122 return; 3123 3124 elsif Aname = Name_Asm_Output then 3125 if not Is_Variable (E2) then 3126 Error_Attr 3127 ("second argument for Asm_Output is not variable", E2); 3128 end if; 3129 end if; 3130 3131 Note_Possible_Modification (E2, Sure => True); 3132 3133 -- The back end may need to take the address of E2 3134 3135 if Is_Entity_Name (E2) then 3136 Set_Address_Taken (Entity (E2)); 3137 end if; 3138 3139 Set_Etype (N, RTE (RE_Asm_Output_Operand)); 3140 3141 ----------------------------- 3142 -- Atomic_Always_Lock_Free -- 3143 ----------------------------- 3144 3145 when Attribute_Atomic_Always_Lock_Free => 3146 Check_E0; 3147 Check_Type; 3148 Set_Etype (N, Standard_Boolean); 3149 3150 ---------- 3151 -- Base -- 3152 ---------- 3153 3154 -- Note: when the base attribute appears in the context of a subtype 3155 -- mark, the analysis is done by Sem_Ch8.Find_Type, rather than by 3156 -- the following circuit. 3157 3158 when Attribute_Base => Base : declare 3159 Typ : Entity_Id; 3160 3161 begin 3162 Check_E0; 3163 Find_Type (P); 3164 Typ := Entity (P); 3165 3166 if Ada_Version >= Ada_95 3167 and then not Is_Scalar_Type (Typ) 3168 and then not Is_Generic_Type (Typ) 3169 then 3170 Error_Attr_P ("prefix of Base attribute must be scalar type"); 3171 3172 elsif Sloc (Typ) = Standard_Location 3173 and then Base_Type (Typ) = Typ 3174 and then Warn_On_Redundant_Constructs 3175 then 3176 Error_Msg_NE -- CODEFIX 3177 ("?r?redundant attribute, & is its own base type", N, Typ); 3178 end if; 3179 3180 if Nkind (Parent (N)) /= N_Attribute_Reference then 3181 Error_Msg_Name_1 := Aname; 3182 Check_SPARK_05_Restriction 3183 ("attribute% is only allowed as prefix of another attribute", P); 3184 end if; 3185 3186 Set_Etype (N, Base_Type (Entity (P))); 3187 Set_Entity (N, Base_Type (Entity (P))); 3188 Rewrite (N, New_Occurrence_Of (Entity (N), Loc)); 3189 Analyze (N); 3190 end Base; 3191 3192 --------- 3193 -- Bit -- 3194 --------- 3195 3196 when Attribute_Bit => 3197 Check_E0; 3198 3199 if not Is_Object_Reference (P) then 3200 Error_Attr_P ("prefix for % attribute must be object"); 3201 3202 -- What about the access object cases ??? 3203 3204 else 3205 null; 3206 end if; 3207 3208 Set_Etype (N, Universal_Integer); 3209 3210 --------------- 3211 -- Bit_Order -- 3212 --------------- 3213 3214 when Attribute_Bit_Order => 3215 Check_E0; 3216 Check_Type; 3217 3218 if not Is_Record_Type (P_Type) then 3219 Error_Attr_P ("prefix of % attribute must be record type"); 3220 end if; 3221 3222 if Bytes_Big_Endian xor Reverse_Bit_Order (P_Type) then 3223 Rewrite (N, 3224 New_Occurrence_Of (RTE (RE_High_Order_First), Loc)); 3225 else 3226 Rewrite (N, 3227 New_Occurrence_Of (RTE (RE_Low_Order_First), Loc)); 3228 end if; 3229 3230 Set_Etype (N, RTE (RE_Bit_Order)); 3231 Resolve (N); 3232 3233 -- Reset incorrect indication of staticness 3234 3235 Set_Is_Static_Expression (N, False); 3236 3237 ------------------ 3238 -- Bit_Position -- 3239 ------------------ 3240 3241 -- Note: in generated code, we can have a Bit_Position attribute 3242 -- applied to a (naked) record component (i.e. the prefix is an 3243 -- identifier that references an E_Component or E_Discriminant 3244 -- entity directly, and this is interpreted as expected by Gigi. 3245 -- The following code will not tolerate such usage, but when the 3246 -- expander creates this special case, it marks it as analyzed 3247 -- immediately and sets an appropriate type. 3248 3249 when Attribute_Bit_Position => 3250 if Comes_From_Source (N) then 3251 Check_Component; 3252 end if; 3253 3254 Set_Etype (N, Universal_Integer); 3255 3256 ------------------ 3257 -- Body_Version -- 3258 ------------------ 3259 3260 when Attribute_Body_Version => 3261 Check_E0; 3262 Check_Program_Unit; 3263 Set_Etype (N, RTE (RE_Version_String)); 3264 3265 -------------- 3266 -- Callable -- 3267 -------------- 3268 3269 when Attribute_Callable => 3270 Check_E0; 3271 Set_Etype (N, Standard_Boolean); 3272 Check_Task_Prefix; 3273 3274 ------------ 3275 -- Caller -- 3276 ------------ 3277 3278 when Attribute_Caller => Caller : declare 3279 Ent : Entity_Id; 3280 S : Entity_Id; 3281 3282 begin 3283 Check_E0; 3284 3285 if Nkind_In (P, N_Identifier, N_Expanded_Name) then 3286 Ent := Entity (P); 3287 3288 if not Is_Entry (Ent) then 3289 Error_Attr ("invalid entry name", N); 3290 end if; 3291 3292 else 3293 Error_Attr ("invalid entry name", N); 3294 return; 3295 end if; 3296 3297 for J in reverse 0 .. Scope_Stack.Last loop 3298 S := Scope_Stack.Table (J).Entity; 3299 3300 if S = Scope (Ent) then 3301 Error_Attr ("Caller must appear in matching accept or body", N); 3302 elsif S = Ent then 3303 exit; 3304 end if; 3305 end loop; 3306 3307 Set_Etype (N, RTE (RO_AT_Task_Id)); 3308 end Caller; 3309 3310 ------------- 3311 -- Ceiling -- 3312 ------------- 3313 3314 when Attribute_Ceiling => 3315 Check_Floating_Point_Type_1; 3316 Set_Etype (N, P_Base_Type); 3317 Resolve (E1, P_Base_Type); 3318 3319 ----------- 3320 -- Class -- 3321 ----------- 3322 3323 when Attribute_Class => 3324 Check_Restriction (No_Dispatch, N); 3325 Check_E0; 3326 Find_Type (N); 3327 3328 -- Applying Class to untagged incomplete type is obsolescent in Ada 3329 -- 2005. Note that we can't test Is_Tagged_Type here on P_Type, since 3330 -- this flag gets set by Find_Type in this situation. 3331 3332 if Restriction_Check_Required (No_Obsolescent_Features) 3333 and then Ada_Version >= Ada_2005 3334 and then Ekind (P_Type) = E_Incomplete_Type 3335 then 3336 declare 3337 DN : constant Node_Id := Declaration_Node (P_Type); 3338 begin 3339 if Nkind (DN) = N_Incomplete_Type_Declaration 3340 and then not Tagged_Present (DN) 3341 then 3342 Check_Restriction (No_Obsolescent_Features, P); 3343 end if; 3344 end; 3345 end if; 3346 3347 ------------------ 3348 -- Code_Address -- 3349 ------------------ 3350 3351 when Attribute_Code_Address => 3352 Check_E0; 3353 3354 if Nkind (P) = N_Attribute_Reference 3355 and then Nam_In (Attribute_Name (P), Name_Elab_Body, Name_Elab_Spec) 3356 then 3357 null; 3358 3359 elsif not Is_Entity_Name (P) 3360 or else (Ekind (Entity (P)) /= E_Function 3361 and then 3362 Ekind (Entity (P)) /= E_Procedure) 3363 then 3364 Error_Attr ("invalid prefix for % attribute", P); 3365 Set_Address_Taken (Entity (P)); 3366 3367 -- Issue an error if the prefix denotes an eliminated subprogram 3368 3369 else 3370 Check_For_Eliminated_Subprogram (P, Entity (P)); 3371 end if; 3372 3373 Set_Etype (N, RTE (RE_Address)); 3374 3375 ---------------------- 3376 -- Compiler_Version -- 3377 ---------------------- 3378 3379 when Attribute_Compiler_Version => 3380 Check_E0; 3381 Check_Standard_Prefix; 3382 Rewrite (N, Make_String_Literal (Loc, "GNAT " & Gnat_Version_String)); 3383 Analyze_And_Resolve (N, Standard_String); 3384 Set_Is_Static_Expression (N, True); 3385 3386 -------------------- 3387 -- Component_Size -- 3388 -------------------- 3389 3390 when Attribute_Component_Size => 3391 Check_E0; 3392 Set_Etype (N, Universal_Integer); 3393 3394 -- Note: unlike other array attributes, unconstrained arrays are OK 3395 3396 if Is_Array_Type (P_Type) and then not Is_Constrained (P_Type) then 3397 null; 3398 else 3399 Check_Array_Type; 3400 end if; 3401 3402 ------------- 3403 -- Compose -- 3404 ------------- 3405 3406 when Attribute_Compose => 3407 Check_Floating_Point_Type_2; 3408 Set_Etype (N, P_Base_Type); 3409 Resolve (E1, P_Base_Type); 3410 Resolve (E2, Any_Integer); 3411 3412 ----------------- 3413 -- Constrained -- 3414 ----------------- 3415 3416 when Attribute_Constrained => 3417 Check_E0; 3418 Set_Etype (N, Standard_Boolean); 3419 3420 -- Case from RM J.4(2) of constrained applied to private type 3421 3422 if Is_Entity_Name (P) and then Is_Type (Entity (P)) then 3423 Check_Restriction (No_Obsolescent_Features, P); 3424 3425 if Warn_On_Obsolescent_Feature then 3426 Error_Msg_N 3427 ("constrained for private type is an obsolescent feature " 3428 & "(RM J.4)?j?", N); 3429 end if; 3430 3431 -- If we are within an instance, the attribute must be legal 3432 -- because it was valid in the generic unit. Ditto if this is 3433 -- an inlining of a function declared in an instance. 3434 3435 if In_Instance or else In_Inlined_Body then 3436 return; 3437 3438 -- For sure OK if we have a real private type itself, but must 3439 -- be completed, cannot apply Constrained to incomplete type. 3440 3441 elsif Is_Private_Type (Entity (P)) then 3442 3443 -- Note: this is one of the Annex J features that does not 3444 -- generate a warning from -gnatwj, since in fact it seems 3445 -- very useful, and is used in the GNAT runtime. 3446 3447 Check_Not_Incomplete_Type; 3448 return; 3449 end if; 3450 3451 -- Normal (non-obsolescent case) of application to object of 3452 -- a discriminated type. 3453 3454 else 3455 Check_Object_Reference (P); 3456 3457 -- If N does not come from source, then we allow the 3458 -- the attribute prefix to be of a private type whose 3459 -- full type has discriminants. This occurs in cases 3460 -- involving expanded calls to stream attributes. 3461 3462 if not Comes_From_Source (N) then 3463 P_Type := Underlying_Type (P_Type); 3464 end if; 3465 3466 -- Must have discriminants or be an access type designating a type 3467 -- with discriminants. If it is a class-wide type it has unknown 3468 -- discriminants. 3469 3470 if Has_Discriminants (P_Type) 3471 or else Has_Unknown_Discriminants (P_Type) 3472 or else 3473 (Is_Access_Type (P_Type) 3474 and then Has_Discriminants (Designated_Type (P_Type))) 3475 then 3476 return; 3477 3478 -- The rule given in 3.7.2 is part of static semantics, but the 3479 -- intent is clearly that it be treated as a legality rule, and 3480 -- rechecked in the visible part of an instance. Nevertheless 3481 -- the intent also seems to be it should legally apply to the 3482 -- actual of a formal with unknown discriminants, regardless of 3483 -- whether the actual has discriminants, in which case the value 3484 -- of the attribute is determined using the J.4 rules. This choice 3485 -- seems the most useful, and is compatible with existing tests. 3486 3487 elsif In_Instance then 3488 return; 3489 3490 -- Also allow an object of a generic type if extensions allowed 3491 -- and allow this for any type at all. (this may be obsolete ???) 3492 3493 elsif (Is_Generic_Type (P_Type) 3494 or else Is_Generic_Actual_Type (P_Type)) 3495 and then Extensions_Allowed 3496 then 3497 return; 3498 end if; 3499 end if; 3500 3501 -- Fall through if bad prefix 3502 3503 Error_Attr_P 3504 ("prefix of % attribute must be object of discriminated type"); 3505 3506 --------------- 3507 -- Copy_Sign -- 3508 --------------- 3509 3510 when Attribute_Copy_Sign => 3511 Check_Floating_Point_Type_2; 3512 Set_Etype (N, P_Base_Type); 3513 Resolve (E1, P_Base_Type); 3514 Resolve (E2, P_Base_Type); 3515 3516 ----------- 3517 -- Count -- 3518 ----------- 3519 3520 when Attribute_Count => Count : declare 3521 Ent : Entity_Id; 3522 S : Entity_Id; 3523 Tsk : Entity_Id; 3524 3525 begin 3526 Check_E0; 3527 3528 if Nkind_In (P, N_Identifier, N_Expanded_Name) then 3529 Ent := Entity (P); 3530 3531 if Ekind (Ent) /= E_Entry then 3532 Error_Attr ("invalid entry name", N); 3533 end if; 3534 3535 elsif Nkind (P) = N_Indexed_Component then 3536 if not Is_Entity_Name (Prefix (P)) 3537 or else No (Entity (Prefix (P))) 3538 or else Ekind (Entity (Prefix (P))) /= E_Entry_Family 3539 then 3540 if Nkind (Prefix (P)) = N_Selected_Component 3541 and then Present (Entity (Selector_Name (Prefix (P)))) 3542 and then Ekind (Entity (Selector_Name (Prefix (P)))) = 3543 E_Entry_Family 3544 then 3545 Error_Attr 3546 ("attribute % must apply to entry of current task", P); 3547 3548 else 3549 Error_Attr ("invalid entry family name", P); 3550 end if; 3551 return; 3552 3553 else 3554 Ent := Entity (Prefix (P)); 3555 end if; 3556 3557 elsif Nkind (P) = N_Selected_Component 3558 and then Present (Entity (Selector_Name (P))) 3559 and then Ekind (Entity (Selector_Name (P))) = E_Entry 3560 then 3561 Error_Attr 3562 ("attribute % must apply to entry of current task", P); 3563 3564 else 3565 Error_Attr ("invalid entry name", N); 3566 return; 3567 end if; 3568 3569 for J in reverse 0 .. Scope_Stack.Last loop 3570 S := Scope_Stack.Table (J).Entity; 3571 3572 if S = Scope (Ent) then 3573 if Nkind (P) = N_Expanded_Name then 3574 Tsk := Entity (Prefix (P)); 3575 3576 -- The prefix denotes either the task type, or else a 3577 -- single task whose task type is being analyzed. 3578 3579 if (Is_Type (Tsk) and then Tsk = S) 3580 or else (not Is_Type (Tsk) 3581 and then Etype (Tsk) = S 3582 and then not (Comes_From_Source (S))) 3583 then 3584 null; 3585 else 3586 Error_Attr 3587 ("Attribute % must apply to entry of current task", N); 3588 end if; 3589 end if; 3590 3591 exit; 3592 3593 elsif Ekind (Scope (Ent)) in Task_Kind 3594 and then not Ekind_In (S, E_Block, 3595 E_Entry, 3596 E_Entry_Family, 3597 E_Loop) 3598 then 3599 Error_Attr ("Attribute % cannot appear in inner unit", N); 3600 3601 elsif Ekind (Scope (Ent)) = E_Protected_Type 3602 and then not Has_Completion (Scope (Ent)) 3603 then 3604 Error_Attr ("attribute % can only be used inside body", N); 3605 end if; 3606 end loop; 3607 3608 if Is_Overloaded (P) then 3609 declare 3610 Index : Interp_Index; 3611 It : Interp; 3612 3613 begin 3614 Get_First_Interp (P, Index, It); 3615 while Present (It.Nam) loop 3616 if It.Nam = Ent then 3617 null; 3618 3619 -- Ada 2005 (AI-345): Do not consider primitive entry 3620 -- wrappers generated for task or protected types. 3621 3622 elsif Ada_Version >= Ada_2005 3623 and then not Comes_From_Source (It.Nam) 3624 then 3625 null; 3626 3627 else 3628 Error_Attr ("ambiguous entry name", N); 3629 end if; 3630 3631 Get_Next_Interp (Index, It); 3632 end loop; 3633 end; 3634 end if; 3635 3636 Set_Etype (N, Universal_Integer); 3637 end Count; 3638 3639 ----------------------- 3640 -- Default_Bit_Order -- 3641 ----------------------- 3642 3643 when Attribute_Default_Bit_Order => Default_Bit_Order : declare 3644 Target_Default_Bit_Order : System.Bit_Order; 3645 3646 begin 3647 Check_Standard_Prefix; 3648 3649 if Bytes_Big_Endian then 3650 Target_Default_Bit_Order := System.High_Order_First; 3651 else 3652 Target_Default_Bit_Order := System.Low_Order_First; 3653 end if; 3654 3655 Rewrite (N, 3656 Make_Integer_Literal (Loc, 3657 UI_From_Int (System.Bit_Order'Pos (Target_Default_Bit_Order)))); 3658 3659 Set_Etype (N, Universal_Integer); 3660 Set_Is_Static_Expression (N); 3661 end Default_Bit_Order; 3662 3663 ---------------------------------- 3664 -- Default_Scalar_Storage_Order -- 3665 ---------------------------------- 3666 3667 when Attribute_Default_Scalar_Storage_Order => Default_SSO : declare 3668 RE_Default_SSO : RE_Id; 3669 3670 begin 3671 Check_Standard_Prefix; 3672 3673 case Opt.Default_SSO is 3674 when ' ' => 3675 if Bytes_Big_Endian then 3676 RE_Default_SSO := RE_High_Order_First; 3677 else 3678 RE_Default_SSO := RE_Low_Order_First; 3679 end if; 3680 3681 when 'H' => 3682 RE_Default_SSO := RE_High_Order_First; 3683 3684 when 'L' => 3685 RE_Default_SSO := RE_Low_Order_First; 3686 3687 when others => 3688 raise Program_Error; 3689 end case; 3690 3691 Rewrite (N, New_Occurrence_Of (RTE (RE_Default_SSO), Loc)); 3692 end Default_SSO; 3693 3694 -------------- 3695 -- Definite -- 3696 -------------- 3697 3698 when Attribute_Definite => 3699 Legal_Formal_Attribute; 3700 3701 ----------- 3702 -- Delta -- 3703 ----------- 3704 3705 when Attribute_Delta => 3706 Check_Fixed_Point_Type_0; 3707 Set_Etype (N, Universal_Real); 3708 3709 ------------ 3710 -- Denorm -- 3711 ------------ 3712 3713 when Attribute_Denorm => 3714 Check_Floating_Point_Type_0; 3715 Set_Etype (N, Standard_Boolean); 3716 3717 ----------- 3718 -- Deref -- 3719 ----------- 3720 3721 when Attribute_Deref => 3722 Check_Type; 3723 Check_E1; 3724 Resolve (E1, RTE (RE_Address)); 3725 Set_Etype (N, P_Type); 3726 3727 --------------------- 3728 -- Descriptor_Size -- 3729 --------------------- 3730 3731 when Attribute_Descriptor_Size => 3732 Check_E0; 3733 3734 if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then 3735 Error_Attr_P ("prefix of attribute % must denote a type"); 3736 end if; 3737 3738 Set_Etype (N, Universal_Integer); 3739 3740 ------------ 3741 -- Digits -- 3742 ------------ 3743 3744 when Attribute_Digits => 3745 Check_E0; 3746 Check_Type; 3747 3748 if not Is_Floating_Point_Type (P_Type) 3749 and then not Is_Decimal_Fixed_Point_Type (P_Type) 3750 then 3751 Error_Attr_P 3752 ("prefix of % attribute must be float or decimal type"); 3753 end if; 3754 3755 Set_Etype (N, Universal_Integer); 3756 3757 --------------- 3758 -- Elab_Body -- 3759 --------------- 3760 3761 -- Also handles processing for Elab_Spec and Elab_Subp_Body 3762 3763 when Attribute_Elab_Body 3764 | Attribute_Elab_Spec 3765 | Attribute_Elab_Subp_Body 3766 => 3767 Check_E0; 3768 Check_Unit_Name (P); 3769 Set_Etype (N, Standard_Void_Type); 3770 3771 -- We have to manually call the expander in this case to get 3772 -- the necessary expansion (normally attributes that return 3773 -- entities are not expanded). 3774 3775 Expand (N); 3776 3777 --------------- 3778 -- Elab_Spec -- 3779 --------------- 3780 3781 -- Shares processing with Elab_Body 3782 3783 ---------------- 3784 -- Elaborated -- 3785 ---------------- 3786 3787 when Attribute_Elaborated => 3788 Check_E0; 3789 Check_Unit_Name (P); 3790 Set_Etype (N, Standard_Boolean); 3791 3792 ---------- 3793 -- Emax -- 3794 ---------- 3795 3796 when Attribute_Emax => 3797 Check_Floating_Point_Type_0; 3798 Set_Etype (N, Universal_Integer); 3799 3800 ------------- 3801 -- Enabled -- 3802 ------------- 3803 3804 when Attribute_Enabled => 3805 Check_Either_E0_Or_E1; 3806 3807 if Present (E1) then 3808 if not Is_Entity_Name (E1) or else No (Entity (E1)) then 3809 Error_Msg_N ("entity name expected for Enabled attribute", E1); 3810 E1 := Empty; 3811 end if; 3812 end if; 3813 3814 if Nkind (P) /= N_Identifier then 3815 Error_Msg_N ("identifier expected (check name)", P); 3816 elsif Get_Check_Id (Chars (P)) = No_Check_Id then 3817 Error_Msg_N ("& is not a recognized check name", P); 3818 end if; 3819 3820 Set_Etype (N, Standard_Boolean); 3821 3822 -------------- 3823 -- Enum_Rep -- 3824 -------------- 3825 3826 when Attribute_Enum_Rep => 3827 3828 -- T'Enum_Rep (X) case 3829 3830 if Present (E1) then 3831 Check_E1; 3832 Check_Discrete_Type; 3833 Resolve (E1, P_Base_Type); 3834 3835 -- X'Enum_Rep case. X must be an object or enumeration literal, and 3836 -- it must be of a discrete type. 3837 3838 elsif not 3839 ((Is_Object_Reference (P) 3840 or else 3841 (Is_Entity_Name (P) 3842 and then Ekind (Entity (P)) = E_Enumeration_Literal)) 3843 and then Is_Discrete_Type (Etype (P))) 3844 then 3845 Error_Attr_P ("prefix of % attribute must be discrete object"); 3846 end if; 3847 3848 Set_Etype (N, Universal_Integer); 3849 3850 -------------- 3851 -- Enum_Val -- 3852 -------------- 3853 3854 when Attribute_Enum_Val => 3855 Check_E1; 3856 Check_Type; 3857 3858 if not Is_Enumeration_Type (P_Type) then 3859 Error_Attr_P ("prefix of % attribute must be enumeration type"); 3860 end if; 3861 3862 -- If the enumeration type has a standard representation, the effect 3863 -- is the same as 'Val, so rewrite the attribute as a 'Val. 3864 3865 if not Has_Non_Standard_Rep (P_Base_Type) then 3866 Rewrite (N, 3867 Make_Attribute_Reference (Loc, 3868 Prefix => Relocate_Node (Prefix (N)), 3869 Attribute_Name => Name_Val, 3870 Expressions => New_List (Relocate_Node (E1)))); 3871 Analyze_And_Resolve (N, P_Base_Type); 3872 3873 -- Non-standard representation case (enumeration with holes) 3874 3875 else 3876 Check_Enum_Image; 3877 Resolve (E1, Any_Integer); 3878 Set_Etype (N, P_Base_Type); 3879 end if; 3880 3881 ------------- 3882 -- Epsilon -- 3883 ------------- 3884 3885 when Attribute_Epsilon => 3886 Check_Floating_Point_Type_0; 3887 Set_Etype (N, Universal_Real); 3888 3889 -------------- 3890 -- Exponent -- 3891 -------------- 3892 3893 when Attribute_Exponent => 3894 Check_Floating_Point_Type_1; 3895 Set_Etype (N, Universal_Integer); 3896 Resolve (E1, P_Base_Type); 3897 3898 ------------------ 3899 -- External_Tag -- 3900 ------------------ 3901 3902 when Attribute_External_Tag => 3903 Check_E0; 3904 Check_Type; 3905 3906 Set_Etype (N, Standard_String); 3907 3908 if not Is_Tagged_Type (P_Type) then 3909 Error_Attr_P ("prefix of % attribute must be tagged"); 3910 end if; 3911 3912 --------------- 3913 -- Fast_Math -- 3914 --------------- 3915 3916 when Attribute_Fast_Math => 3917 Check_Standard_Prefix; 3918 Rewrite (N, New_Occurrence_Of (Boolean_Literals (Fast_Math), Loc)); 3919 3920 ----------------------- 3921 -- Finalization_Size -- 3922 ----------------------- 3923 3924 when Attribute_Finalization_Size => 3925 Check_E0; 3926 3927 -- The prefix denotes an object 3928 3929 if Is_Object_Reference (P) then 3930 Check_Object_Reference (P); 3931 3932 -- The prefix denotes a type 3933 3934 elsif Is_Entity_Name (P) and then Is_Type (Entity (P)) then 3935 Check_Type; 3936 Check_Not_Incomplete_Type; 3937 3938 -- Attribute 'Finalization_Size is not defined for class-wide 3939 -- types because it is not possible to know statically whether 3940 -- a definite type will have controlled components or not. 3941 3942 if Is_Class_Wide_Type (Etype (P)) then 3943 Error_Attr_P 3944 ("prefix of % attribute cannot denote a class-wide type"); 3945 end if; 3946 3947 -- The prefix denotes an illegal construct 3948 3949 else 3950 Error_Attr_P 3951 ("prefix of % attribute must be a definite type or an object"); 3952 end if; 3953 3954 Set_Etype (N, Universal_Integer); 3955 3956 ----------- 3957 -- First -- 3958 ----------- 3959 3960 when Attribute_First => 3961 Check_Array_Or_Scalar_Type; 3962 Bad_Attribute_For_Predicate; 3963 3964 --------------- 3965 -- First_Bit -- 3966 --------------- 3967 3968 when Attribute_First_Bit => 3969 Check_Component; 3970 Set_Etype (N, Universal_Integer); 3971 3972 ----------------- 3973 -- First_Valid -- 3974 ----------------- 3975 3976 when Attribute_First_Valid => 3977 Check_First_Last_Valid; 3978 Set_Etype (N, P_Type); 3979 3980 ----------------- 3981 -- Fixed_Value -- 3982 ----------------- 3983 3984 when Attribute_Fixed_Value => 3985 Check_E1; 3986 Check_Fixed_Point_Type; 3987 Resolve (E1, Any_Integer); 3988 Set_Etype (N, P_Base_Type); 3989 3990 ----------- 3991 -- Floor -- 3992 ----------- 3993 3994 when Attribute_Floor => 3995 Check_Floating_Point_Type_1; 3996 Set_Etype (N, P_Base_Type); 3997 Resolve (E1, P_Base_Type); 3998 3999 ---------- 4000 -- Fore -- 4001 ---------- 4002 4003 when Attribute_Fore => 4004 Check_Fixed_Point_Type_0; 4005 Set_Etype (N, Universal_Integer); 4006 4007 -------------- 4008 -- Fraction -- 4009 -------------- 4010 4011 when Attribute_Fraction => 4012 Check_Floating_Point_Type_1; 4013 Set_Etype (N, P_Base_Type); 4014 Resolve (E1, P_Base_Type); 4015 4016 -------------- 4017 -- From_Any -- 4018 -------------- 4019 4020 when Attribute_From_Any => 4021 Check_E1; 4022 Check_PolyORB_Attribute; 4023 Set_Etype (N, P_Base_Type); 4024 4025 ----------------------- 4026 -- Has_Access_Values -- 4027 ----------------------- 4028 4029 when Attribute_Has_Access_Values => 4030 Check_Type; 4031 Check_E0; 4032 Set_Etype (N, Standard_Boolean); 4033 4034 ---------------------- 4035 -- Has_Same_Storage -- 4036 ---------------------- 4037 4038 when Attribute_Has_Same_Storage => 4039 Check_E1; 4040 4041 -- The arguments must be objects of any type 4042 4043 Analyze_And_Resolve (P); 4044 Analyze_And_Resolve (E1); 4045 Check_Object_Reference (P); 4046 Check_Object_Reference (E1); 4047 Set_Etype (N, Standard_Boolean); 4048 4049 ----------------------- 4050 -- Has_Tagged_Values -- 4051 ----------------------- 4052 4053 when Attribute_Has_Tagged_Values => 4054 Check_Type; 4055 Check_E0; 4056 Set_Etype (N, Standard_Boolean); 4057 4058 ----------------------- 4059 -- Has_Discriminants -- 4060 ----------------------- 4061 4062 when Attribute_Has_Discriminants => 4063 Legal_Formal_Attribute; 4064 4065 -------------- 4066 -- Identity -- 4067 -------------- 4068 4069 when Attribute_Identity => 4070 Check_E0; 4071 Analyze (P); 4072 4073 if Etype (P) = Standard_Exception_Type then 4074 Set_Etype (N, RTE (RE_Exception_Id)); 4075 4076 -- Ada 2005 (AI-345): Attribute 'Identity may be applied to task 4077 -- interface class-wide types. 4078 4079 elsif Is_Task_Type (Etype (P)) 4080 or else (Is_Access_Type (Etype (P)) 4081 and then Is_Task_Type (Designated_Type (Etype (P)))) 4082 or else (Ada_Version >= Ada_2005 4083 and then Ekind (Etype (P)) = E_Class_Wide_Type 4084 and then Is_Interface (Etype (P)) 4085 and then Is_Task_Interface (Etype (P))) 4086 then 4087 Resolve (P); 4088 Set_Etype (N, RTE (RO_AT_Task_Id)); 4089 4090 else 4091 if Ada_Version >= Ada_2005 then 4092 Error_Attr_P 4093 ("prefix of % attribute must be an exception, a task or a " 4094 & "task interface class-wide object"); 4095 else 4096 Error_Attr_P 4097 ("prefix of % attribute must be a task or an exception"); 4098 end if; 4099 end if; 4100 4101 ----------- 4102 -- Image -- 4103 ----------- 4104 4105 when Attribute_Image => 4106 if Is_Real_Type (P_Type) then 4107 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 4108 Error_Msg_Name_1 := Aname; 4109 Error_Msg_N 4110 ("(Ada 83) % attribute not allowed for real types", N); 4111 end if; 4112 end if; 4113 4114 Analyze_Image_Attribute (Standard_String); 4115 4116 --------- 4117 -- Img -- 4118 --------- 4119 4120 when Attribute_Img => 4121 Analyze_Image_Attribute (Standard_String); 4122 4123 ----------- 4124 -- Input -- 4125 ----------- 4126 4127 when Attribute_Input => 4128 Check_E1; 4129 Check_Stream_Attribute (TSS_Stream_Input); 4130 Set_Etype (N, P_Base_Type); 4131 4132 ------------------- 4133 -- Integer_Value -- 4134 ------------------- 4135 4136 when Attribute_Integer_Value => 4137 Check_E1; 4138 Check_Integer_Type; 4139 Resolve (E1, Any_Fixed); 4140 4141 -- Signal an error if argument type is not a specific fixed-point 4142 -- subtype. An error has been signalled already if the argument 4143 -- was not of a fixed-point type. 4144 4145 if Etype (E1) = Any_Fixed and then not Error_Posted (E1) then 4146 Error_Attr ("argument of % must be of a fixed-point type", E1); 4147 end if; 4148 4149 Set_Etype (N, P_Base_Type); 4150 4151 ------------------- 4152 -- Invalid_Value -- 4153 ------------------- 4154 4155 when Attribute_Invalid_Value => 4156 Check_E0; 4157 Check_Scalar_Type; 4158 Set_Etype (N, P_Base_Type); 4159 Invalid_Value_Used := True; 4160 4161 ----------- 4162 -- Large -- 4163 ----------- 4164 4165 when Attribute_Large => 4166 Check_E0; 4167 Check_Real_Type; 4168 Set_Etype (N, Universal_Real); 4169 4170 ---------- 4171 -- Last -- 4172 ---------- 4173 4174 when Attribute_Last => 4175 Check_Array_Or_Scalar_Type; 4176 Bad_Attribute_For_Predicate; 4177 4178 -------------- 4179 -- Last_Bit -- 4180 -------------- 4181 4182 when Attribute_Last_Bit => 4183 Check_Component; 4184 Set_Etype (N, Universal_Integer); 4185 4186 ---------------- 4187 -- Last_Valid -- 4188 ---------------- 4189 4190 when Attribute_Last_Valid => 4191 Check_First_Last_Valid; 4192 Set_Etype (N, P_Type); 4193 4194 ------------------ 4195 -- Leading_Part -- 4196 ------------------ 4197 4198 when Attribute_Leading_Part => 4199 Check_Floating_Point_Type_2; 4200 Set_Etype (N, P_Base_Type); 4201 Resolve (E1, P_Base_Type); 4202 Resolve (E2, Any_Integer); 4203 4204 ------------ 4205 -- Length -- 4206 ------------ 4207 4208 when Attribute_Length => 4209 Check_Array_Type; 4210 Set_Etype (N, Universal_Integer); 4211 4212 ------------------- 4213 -- Library_Level -- 4214 ------------------- 4215 4216 when Attribute_Library_Level => 4217 Check_E0; 4218 4219 if not Is_Entity_Name (P) then 4220 Error_Attr_P ("prefix of % attribute must be an entity name"); 4221 end if; 4222 4223 if not Inside_A_Generic then 4224 Set_Boolean_Result (N, 4225 Is_Library_Level_Entity (Entity (P))); 4226 end if; 4227 4228 Set_Etype (N, Standard_Boolean); 4229 4230 --------------- 4231 -- Lock_Free -- 4232 --------------- 4233 4234 when Attribute_Lock_Free => 4235 Check_E0; 4236 Set_Etype (N, Standard_Boolean); 4237 4238 if not Is_Protected_Type (P_Type) then 4239 Error_Attr_P 4240 ("prefix of % attribute must be a protected object"); 4241 end if; 4242 4243 ---------------- 4244 -- Loop_Entry -- 4245 ---------------- 4246 4247 when Attribute_Loop_Entry => Loop_Entry : declare 4248 procedure Check_References_In_Prefix (Loop_Id : Entity_Id); 4249 -- Inspect the prefix for any uses of entities declared within the 4250 -- related loop. Loop_Id denotes the loop identifier. 4251 4252 -------------------------------- 4253 -- Check_References_In_Prefix -- 4254 -------------------------------- 4255 4256 procedure Check_References_In_Prefix (Loop_Id : Entity_Id) is 4257 Loop_Decl : constant Node_Id := Label_Construct (Parent (Loop_Id)); 4258 4259 function Check_Reference (Nod : Node_Id) return Traverse_Result; 4260 -- Determine whether a reference mentions an entity declared 4261 -- within the related loop. 4262 4263 function Declared_Within (Nod : Node_Id) return Boolean; 4264 -- Determine whether Nod appears in the subtree of Loop_Decl 4265 4266 --------------------- 4267 -- Check_Reference -- 4268 --------------------- 4269 4270 function Check_Reference (Nod : Node_Id) return Traverse_Result is 4271 begin 4272 if Nkind (Nod) = N_Identifier 4273 and then Present (Entity (Nod)) 4274 and then Declared_Within (Declaration_Node (Entity (Nod))) 4275 then 4276 Error_Attr 4277 ("prefix of attribute % cannot reference local entities", 4278 Nod); 4279 return Abandon; 4280 else 4281 return OK; 4282 end if; 4283 end Check_Reference; 4284 4285 procedure Check_References is new Traverse_Proc (Check_Reference); 4286 4287 --------------------- 4288 -- Declared_Within -- 4289 --------------------- 4290 4291 function Declared_Within (Nod : Node_Id) return Boolean is 4292 Stmt : Node_Id; 4293 4294 begin 4295 Stmt := Nod; 4296 while Present (Stmt) loop 4297 if Stmt = Loop_Decl then 4298 return True; 4299 4300 -- Prevent the search from going too far 4301 4302 elsif Is_Body_Or_Package_Declaration (Stmt) then 4303 exit; 4304 end if; 4305 4306 Stmt := Parent (Stmt); 4307 end loop; 4308 4309 return False; 4310 end Declared_Within; 4311 4312 -- Start of processing for Check_Prefix_For_Local_References 4313 4314 begin 4315 Check_References (P); 4316 end Check_References_In_Prefix; 4317 4318 -- Local variables 4319 4320 Context : constant Node_Id := Parent (N); 4321 Attr : Node_Id; 4322 Encl_Loop : Node_Id := Empty; 4323 Encl_Prag : Node_Id := Empty; 4324 Loop_Id : Entity_Id := Empty; 4325 Scop : Entity_Id; 4326 Stmt : Node_Id; 4327 4328 -- Start of processing for Loop_Entry 4329 4330 begin 4331 Attr := N; 4332 4333 -- Set the type of the attribute now to ensure the successful 4334 -- continuation of analysis even if the attribute is misplaced. 4335 4336 Set_Etype (Attr, P_Type); 4337 4338 -- Attribute 'Loop_Entry may appear in several flavors: 4339 4340 -- * Prefix'Loop_Entry - in this form, the attribute applies to the 4341 -- nearest enclosing loop. 4342 4343 -- * Prefix'Loop_Entry (Expr) - depending on what Expr denotes, the 4344 -- attribute may be related to a loop denoted by label Expr or 4345 -- the prefix may denote an array object and Expr may act as an 4346 -- indexed component. 4347 4348 -- * Prefix'Loop_Entry (Expr1, ..., ExprN) - the attribute applies 4349 -- to the nearest enclosing loop, all expressions are part of 4350 -- an indexed component. 4351 4352 -- * Prefix'Loop_Entry (Expr) (...) (...) - depending on what Expr 4353 -- denotes, the attribute may be related to a loop denoted by 4354 -- label Expr or the prefix may denote a multidimensional array 4355 -- array object and Expr along with the rest of the expressions 4356 -- may act as indexed components. 4357 4358 -- Regardless of variations, the attribute reference does not have an 4359 -- expression list. Instead, all available expressions are stored as 4360 -- indexed components. 4361 4362 -- When the attribute is part of an indexed component, find the first 4363 -- expression as it will determine the semantics of 'Loop_Entry. 4364 4365 -- If the attribute is itself an index in an indexed component, i.e. 4366 -- a member of a list, the context itself is not relevant (the code 4367 -- below would lead to an infinite loop) and the attribute applies 4368 -- to the enclosing loop. 4369 4370 if Nkind (Context) = N_Indexed_Component 4371 and then not Is_List_Member (N) 4372 then 4373 E1 := First (Expressions (Context)); 4374 E2 := Next (E1); 4375 4376 -- The attribute reference appears in the following form: 4377 4378 -- Prefix'Loop_Entry (Exp1, Expr2, ..., ExprN) [(...)] 4379 4380 -- In this case, the loop name is omitted and no rewriting is 4381 -- required. 4382 4383 if Present (E2) then 4384 null; 4385 4386 -- The form of the attribute is: 4387 4388 -- Prefix'Loop_Entry (Expr) [(...)] 4389 4390 -- If Expr denotes a loop entry, the whole attribute and indexed 4391 -- component will have to be rewritten to reflect this relation. 4392 4393 else 4394 pragma Assert (Present (E1)); 4395 4396 -- Do not expand the expression as it may have side effects. 4397 -- Simply preanalyze to determine whether it is a loop name or 4398 -- something else. 4399 4400 Preanalyze_And_Resolve (E1); 4401 4402 if Is_Entity_Name (E1) 4403 and then Present (Entity (E1)) 4404 and then Ekind (Entity (E1)) = E_Loop 4405 then 4406 Loop_Id := Entity (E1); 4407 4408 -- Transform the attribute and enclosing indexed component 4409 4410 Set_Expressions (N, Expressions (Context)); 4411 Rewrite (Context, N); 4412 Set_Etype (Context, P_Type); 4413 4414 Attr := Context; 4415 end if; 4416 end if; 4417 end if; 4418 4419 -- The prefix must denote an object 4420 4421 if not Is_Object_Reference (P) then 4422 Error_Attr_P ("prefix of attribute % must denote an object"); 4423 end if; 4424 4425 -- The prefix cannot be of a limited type because the expansion of 4426 -- Loop_Entry must create a constant initialized by the evaluated 4427 -- prefix. 4428 4429 if Is_Limited_View (Etype (P)) then 4430 Error_Attr_P ("prefix of attribute % cannot be limited"); 4431 end if; 4432 4433 -- Climb the parent chain to verify the location of the attribute and 4434 -- find the enclosing loop. 4435 4436 Stmt := Attr; 4437 while Present (Stmt) loop 4438 4439 -- Locate the corresponding enclosing pragma. Note that in the 4440 -- case of Assert[And_Cut] and Assume, we have already checked 4441 -- that the pragma appears in an appropriate loop location. 4442 4443 if Nkind (Original_Node (Stmt)) = N_Pragma 4444 and then Nam_In (Pragma_Name_Unmapped (Original_Node (Stmt)), 4445 Name_Loop_Invariant, 4446 Name_Loop_Variant, 4447 Name_Assert, 4448 Name_Assert_And_Cut, 4449 Name_Assume) 4450 then 4451 Encl_Prag := Original_Node (Stmt); 4452 4453 -- Locate the enclosing loop (if any). Note that Ada 2012 array 4454 -- iteration may be expanded into several nested loops, we are 4455 -- interested in the outermost one which has the loop identifier, 4456 -- and comes from source. 4457 4458 elsif Nkind (Stmt) = N_Loop_Statement 4459 and then Present (Identifier (Stmt)) 4460 and then Comes_From_Source (Original_Node (Stmt)) 4461 and then Nkind (Original_Node (Stmt)) = N_Loop_Statement 4462 then 4463 Encl_Loop := Stmt; 4464 4465 -- The original attribute reference may lack a loop name. Use 4466 -- the name of the enclosing loop because it is the related 4467 -- loop. 4468 4469 if No (Loop_Id) then 4470 Loop_Id := Entity (Identifier (Encl_Loop)); 4471 end if; 4472 4473 exit; 4474 4475 -- Prevent the search from going too far 4476 4477 elsif Is_Body_Or_Package_Declaration (Stmt) then 4478 exit; 4479 end if; 4480 4481 Stmt := Parent (Stmt); 4482 end loop; 4483 4484 -- Loop_Entry must appear within a Loop_Assertion pragma (Assert, 4485 -- Assert_And_Cut, Assume count as loop assertion pragmas for this 4486 -- purpose if they appear in an appropriate location in a loop, 4487 -- which was already checked by the top level pragma circuit). 4488 4489 -- Loop_Entry also denotes a value and as such can appear within an 4490 -- expression that is an argument for another loop aspect. In that 4491 -- case it will have been expanded into the corresponding assignment. 4492 4493 if Expander_Active 4494 and then Nkind (Parent (N)) = N_Assignment_Statement 4495 and then not Comes_From_Source (Parent (N)) 4496 then 4497 null; 4498 4499 elsif No (Encl_Prag) then 4500 Error_Attr ("attribute% must appear within appropriate pragma", N); 4501 end if; 4502 4503 -- A Loop_Entry that applies to a given loop statement must not 4504 -- appear within a body of accept statement, if this construct is 4505 -- itself enclosed by the given loop statement. 4506 4507 for Index in reverse 0 .. Scope_Stack.Last loop 4508 Scop := Scope_Stack.Table (Index).Entity; 4509 4510 if Ekind (Scop) = E_Loop and then Scop = Loop_Id then 4511 exit; 4512 elsif Ekind_In (Scop, E_Block, E_Loop, E_Return_Statement) then 4513 null; 4514 else 4515 Error_Attr 4516 ("attribute % cannot appear in body or accept statement", N); 4517 exit; 4518 end if; 4519 end loop; 4520 4521 -- The prefix cannot mention entities declared within the related 4522 -- loop because they will not be visible once the prefix is moved 4523 -- outside the loop. 4524 4525 Check_References_In_Prefix (Loop_Id); 4526 4527 -- The prefix must denote a static entity if the pragma does not 4528 -- apply to the innermost enclosing loop statement, or if it appears 4529 -- within a potentially unevaluated epxression. 4530 4531 if Is_Entity_Name (P) 4532 or else Nkind (Parent (P)) = N_Object_Renaming_Declaration 4533 or else Statically_Denotes_Object (P) 4534 then 4535 null; 4536 4537 elsif Present (Encl_Loop) 4538 and then Entity (Identifier (Encl_Loop)) /= Loop_Id 4539 then 4540 Error_Attr_P 4541 ("prefix of attribute % that applies to outer loop must denote " 4542 & "an entity"); 4543 4544 elsif Is_Potentially_Unevaluated (P) then 4545 Uneval_Old_Msg; 4546 end if; 4547 4548 -- Replace the Loop_Entry attribute reference by its prefix if the 4549 -- related pragma is ignored. This transformation is OK with respect 4550 -- to typing because Loop_Entry's type is that of its prefix. This 4551 -- early transformation also avoids the generation of a useless loop 4552 -- entry constant. 4553 4554 if Present (Encl_Prag) and then Is_Ignored (Encl_Prag) then 4555 Rewrite (N, Relocate_Node (P)); 4556 Preanalyze_And_Resolve (N); 4557 4558 else 4559 Preanalyze_And_Resolve (P); 4560 end if; 4561 end Loop_Entry; 4562 4563 ------------- 4564 -- Machine -- 4565 ------------- 4566 4567 when Attribute_Machine => 4568 Check_Floating_Point_Type_1; 4569 Set_Etype (N, P_Base_Type); 4570 Resolve (E1, P_Base_Type); 4571 4572 ------------------ 4573 -- Machine_Emax -- 4574 ------------------ 4575 4576 when Attribute_Machine_Emax => 4577 Check_Floating_Point_Type_0; 4578 Set_Etype (N, Universal_Integer); 4579 4580 ------------------ 4581 -- Machine_Emin -- 4582 ------------------ 4583 4584 when Attribute_Machine_Emin => 4585 Check_Floating_Point_Type_0; 4586 Set_Etype (N, Universal_Integer); 4587 4588 ---------------------- 4589 -- Machine_Mantissa -- 4590 ---------------------- 4591 4592 when Attribute_Machine_Mantissa => 4593 Check_Floating_Point_Type_0; 4594 Set_Etype (N, Universal_Integer); 4595 4596 ----------------------- 4597 -- Machine_Overflows -- 4598 ----------------------- 4599 4600 when Attribute_Machine_Overflows => 4601 Check_Real_Type; 4602 Check_E0; 4603 Set_Etype (N, Standard_Boolean); 4604 4605 ------------------- 4606 -- Machine_Radix -- 4607 ------------------- 4608 4609 when Attribute_Machine_Radix => 4610 Check_Real_Type; 4611 Check_E0; 4612 Set_Etype (N, Universal_Integer); 4613 4614 ---------------------- 4615 -- Machine_Rounding -- 4616 ---------------------- 4617 4618 when Attribute_Machine_Rounding => 4619 Check_Floating_Point_Type_1; 4620 Set_Etype (N, P_Base_Type); 4621 Resolve (E1, P_Base_Type); 4622 4623 -------------------- 4624 -- Machine_Rounds -- 4625 -------------------- 4626 4627 when Attribute_Machine_Rounds => 4628 Check_Real_Type; 4629 Check_E0; 4630 Set_Etype (N, Standard_Boolean); 4631 4632 ------------------ 4633 -- Machine_Size -- 4634 ------------------ 4635 4636 when Attribute_Machine_Size => 4637 Check_E0; 4638 Check_Type; 4639 Check_Not_Incomplete_Type; 4640 Set_Etype (N, Universal_Integer); 4641 4642 -------------- 4643 -- Mantissa -- 4644 -------------- 4645 4646 when Attribute_Mantissa => 4647 Check_E0; 4648 Check_Real_Type; 4649 Set_Etype (N, Universal_Integer); 4650 4651 --------- 4652 -- Max -- 4653 --------- 4654 4655 when Attribute_Max => 4656 Min_Max; 4657 4658 ---------------------------------- 4659 -- Max_Alignment_For_Allocation -- 4660 ---------------------------------- 4661 4662 when Attribute_Max_Size_In_Storage_Elements => 4663 Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements; 4664 4665 ---------------------------------- 4666 -- Max_Size_In_Storage_Elements -- 4667 ---------------------------------- 4668 4669 when Attribute_Max_Alignment_For_Allocation => 4670 Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements; 4671 4672 ----------------------- 4673 -- Maximum_Alignment -- 4674 ----------------------- 4675 4676 when Attribute_Maximum_Alignment => 4677 Standard_Attribute (Ttypes.Maximum_Alignment); 4678 4679 -------------------- 4680 -- Mechanism_Code -- 4681 -------------------- 4682 4683 when Attribute_Mechanism_Code => 4684 if not Is_Entity_Name (P) 4685 or else not Is_Subprogram (Entity (P)) 4686 then 4687 Error_Attr_P ("prefix of % attribute must be subprogram"); 4688 end if; 4689 4690 Check_Either_E0_Or_E1; 4691 4692 if Present (E1) then 4693 Resolve (E1, Any_Integer); 4694 Set_Etype (E1, Standard_Integer); 4695 4696 if not Is_OK_Static_Expression (E1) then 4697 Flag_Non_Static_Expr 4698 ("expression for parameter number must be static!", E1); 4699 Error_Attr; 4700 4701 elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P)) 4702 or else UI_To_Int (Intval (E1)) < 0 4703 then 4704 Error_Attr ("invalid parameter number for % attribute", E1); 4705 end if; 4706 end if; 4707 4708 Set_Etype (N, Universal_Integer); 4709 4710 --------- 4711 -- Min -- 4712 --------- 4713 4714 when Attribute_Min => 4715 Min_Max; 4716 4717 --------- 4718 -- Mod -- 4719 --------- 4720 4721 when Attribute_Mod => 4722 4723 -- Note: this attribute is only allowed in Ada 2005 mode, but 4724 -- we do not need to test that here, since Mod is only recognized 4725 -- as an attribute name in Ada 2005 mode during the parse. 4726 4727 Check_E1; 4728 Check_Modular_Integer_Type; 4729 Resolve (E1, Any_Integer); 4730 Set_Etype (N, P_Base_Type); 4731 4732 ----------- 4733 -- Model -- 4734 ----------- 4735 4736 when Attribute_Model => 4737 Check_Floating_Point_Type_1; 4738 Set_Etype (N, P_Base_Type); 4739 Resolve (E1, P_Base_Type); 4740 4741 ---------------- 4742 -- Model_Emin -- 4743 ---------------- 4744 4745 when Attribute_Model_Emin => 4746 Check_Floating_Point_Type_0; 4747 Set_Etype (N, Universal_Integer); 4748 4749 ------------------- 4750 -- Model_Epsilon -- 4751 ------------------- 4752 4753 when Attribute_Model_Epsilon => 4754 Check_Floating_Point_Type_0; 4755 Set_Etype (N, Universal_Real); 4756 4757 -------------------- 4758 -- Model_Mantissa -- 4759 -------------------- 4760 4761 when Attribute_Model_Mantissa => 4762 Check_Floating_Point_Type_0; 4763 Set_Etype (N, Universal_Integer); 4764 4765 ----------------- 4766 -- Model_Small -- 4767 ----------------- 4768 4769 when Attribute_Model_Small => 4770 Check_Floating_Point_Type_0; 4771 Set_Etype (N, Universal_Real); 4772 4773 ------------- 4774 -- Modulus -- 4775 ------------- 4776 4777 when Attribute_Modulus => 4778 Check_E0; 4779 Check_Modular_Integer_Type; 4780 Set_Etype (N, Universal_Integer); 4781 4782 -------------------- 4783 -- Null_Parameter -- 4784 -------------------- 4785 4786 when Attribute_Null_Parameter => Null_Parameter : declare 4787 Parnt : constant Node_Id := Parent (N); 4788 GParnt : constant Node_Id := Parent (Parnt); 4789 4790 procedure Bad_Null_Parameter (Msg : String); 4791 -- Used if bad Null parameter attribute node is found. Issues 4792 -- given error message, and also sets the type to Any_Type to 4793 -- avoid blowups later on from dealing with a junk node. 4794 4795 procedure Must_Be_Imported (Proc_Ent : Entity_Id); 4796 -- Called to check that Proc_Ent is imported subprogram 4797 4798 ------------------------ 4799 -- Bad_Null_Parameter -- 4800 ------------------------ 4801 4802 procedure Bad_Null_Parameter (Msg : String) is 4803 begin 4804 Error_Msg_N (Msg, N); 4805 Set_Etype (N, Any_Type); 4806 end Bad_Null_Parameter; 4807 4808 ---------------------- 4809 -- Must_Be_Imported -- 4810 ---------------------- 4811 4812 procedure Must_Be_Imported (Proc_Ent : Entity_Id) is 4813 Pent : constant Entity_Id := Ultimate_Alias (Proc_Ent); 4814 4815 begin 4816 -- Ignore check if procedure not frozen yet (we will get 4817 -- another chance when the default parameter is reanalyzed) 4818 4819 if not Is_Frozen (Pent) then 4820 return; 4821 4822 elsif not Is_Imported (Pent) then 4823 Bad_Null_Parameter 4824 ("Null_Parameter can only be used with imported subprogram"); 4825 4826 else 4827 return; 4828 end if; 4829 end Must_Be_Imported; 4830 4831 -- Start of processing for Null_Parameter 4832 4833 begin 4834 Check_Type; 4835 Check_E0; 4836 Set_Etype (N, P_Type); 4837 4838 -- Case of attribute used as default expression 4839 4840 if Nkind (Parnt) = N_Parameter_Specification then 4841 Must_Be_Imported (Defining_Entity (GParnt)); 4842 4843 -- Case of attribute used as actual for subprogram (positional) 4844 4845 elsif Nkind (Parnt) in N_Subprogram_Call 4846 and then Is_Entity_Name (Name (Parnt)) 4847 then 4848 Must_Be_Imported (Entity (Name (Parnt))); 4849 4850 -- Case of attribute used as actual for subprogram (named) 4851 4852 elsif Nkind (Parnt) = N_Parameter_Association 4853 and then Nkind (GParnt) in N_Subprogram_Call 4854 and then Is_Entity_Name (Name (GParnt)) 4855 then 4856 Must_Be_Imported (Entity (Name (GParnt))); 4857 4858 -- Not an allowed case 4859 4860 else 4861 Bad_Null_Parameter 4862 ("Null_Parameter must be actual or default parameter"); 4863 end if; 4864 end Null_Parameter; 4865 4866 ----------------- 4867 -- Object_Size -- 4868 ----------------- 4869 4870 when Attribute_Object_Size => 4871 Check_E0; 4872 Check_Type; 4873 Check_Not_Incomplete_Type; 4874 Set_Etype (N, Universal_Integer); 4875 4876 --------- 4877 -- Old -- 4878 --------- 4879 4880 when Attribute_Old => Old : declare 4881 procedure Check_References_In_Prefix (Subp_Id : Entity_Id); 4882 -- Inspect the contents of the prefix and detect illegal uses of a 4883 -- nested 'Old, attribute 'Result or a use of an entity declared in 4884 -- the related postcondition expression. Subp_Id is the subprogram to 4885 -- which the related postcondition applies. 4886 4887 -------------------------------- 4888 -- Check_References_In_Prefix -- 4889 -------------------------------- 4890 4891 procedure Check_References_In_Prefix (Subp_Id : Entity_Id) is 4892 function Check_Reference (Nod : Node_Id) return Traverse_Result; 4893 -- Detect attribute 'Old, attribute 'Result of a use of an entity 4894 -- and perform the appropriate semantic check. 4895 4896 --------------------- 4897 -- Check_Reference -- 4898 --------------------- 4899 4900 function Check_Reference (Nod : Node_Id) return Traverse_Result is 4901 begin 4902 -- Attributes 'Old and 'Result cannot appear in the prefix of 4903 -- another attribute 'Old. 4904 4905 if Nkind (Nod) = N_Attribute_Reference 4906 and then Nam_In (Attribute_Name (Nod), Name_Old, 4907 Name_Result) 4908 then 4909 Error_Msg_Name_1 := Attribute_Name (Nod); 4910 Error_Msg_Name_2 := Name_Old; 4911 Error_Msg_N 4912 ("attribute % cannot appear in the prefix of attribute %", 4913 Nod); 4914 return Abandon; 4915 4916 -- Entities mentioned within the prefix of attribute 'Old must 4917 -- be global to the related postcondition. If this is not the 4918 -- case, then the scope of the local entity is nested within 4919 -- that of the subprogram. 4920 4921 elsif Is_Entity_Name (Nod) 4922 and then Present (Entity (Nod)) 4923 and then Scope_Within (Scope (Entity (Nod)), Subp_Id) 4924 then 4925 Error_Attr 4926 ("prefix of attribute % cannot reference local entities", 4927 Nod); 4928 return Abandon; 4929 4930 -- Otherwise keep inspecting the prefix 4931 4932 else 4933 return OK; 4934 end if; 4935 end Check_Reference; 4936 4937 procedure Check_References is new Traverse_Proc (Check_Reference); 4938 4939 -- Start of processing for Check_References_In_Prefix 4940 4941 begin 4942 Check_References (P); 4943 end Check_References_In_Prefix; 4944 4945 -- Local variables 4946 4947 Legal : Boolean; 4948 Pref_Id : Entity_Id; 4949 Pref_Typ : Entity_Id; 4950 Spec_Id : Entity_Id; 4951 4952 -- Start of processing for Old 4953 4954 begin 4955 -- The attribute reference is a primary. If any expressions follow, 4956 -- then the attribute reference is an indexable object. Transform the 4957 -- attribute into an indexed component and analyze it. 4958 4959 if Present (E1) then 4960 Rewrite (N, 4961 Make_Indexed_Component (Loc, 4962 Prefix => 4963 Make_Attribute_Reference (Loc, 4964 Prefix => Relocate_Node (P), 4965 Attribute_Name => Name_Old), 4966 Expressions => Expressions (N))); 4967 Analyze (N); 4968 return; 4969 end if; 4970 4971 Analyze_Attribute_Old_Result (Legal, Spec_Id); 4972 4973 -- The aspect or pragma where attribute 'Old resides should be 4974 -- associated with a subprogram declaration or a body. If this is not 4975 -- the case, then the aspect or pragma is illegal. Return as analysis 4976 -- cannot be carried out. 4977 4978 -- The exception to this rule is when generating C since in this case 4979 -- postconditions are inlined. 4980 4981 if No (Spec_Id) 4982 and then Modify_Tree_For_C 4983 and then In_Inlined_Body 4984 then 4985 Spec_Id := Entity (P); 4986 4987 elsif not Legal then 4988 return; 4989 end if; 4990 4991 -- The prefix must be preanalyzed as the full analysis will take 4992 -- place during expansion. 4993 4994 Preanalyze_And_Resolve (P); 4995 4996 -- Ensure that the prefix does not contain attributes 'Old or 'Result 4997 4998 Check_References_In_Prefix (Spec_Id); 4999 5000 -- Set the type of the attribute now to prevent cascaded errors 5001 5002 Pref_Typ := Etype (P); 5003 Set_Etype (N, Pref_Typ); 5004 5005 -- Legality checks 5006 5007 if Is_Limited_Type (Pref_Typ) then 5008 Error_Attr ("attribute % cannot apply to limited objects", P); 5009 end if; 5010 5011 -- The prefix is a simple name 5012 5013 if Is_Entity_Name (P) and then Present (Entity (P)) then 5014 Pref_Id := Entity (P); 5015 5016 -- Emit a warning when the prefix is a constant. Note that the use 5017 -- of Error_Attr would reset the type of N to Any_Type even though 5018 -- this is a warning. Use Error_Msg_XXX instead. 5019 5020 if Is_Constant_Object (Pref_Id) then 5021 Error_Msg_Name_1 := Name_Old; 5022 Error_Msg_N 5023 ("??attribute % applied to constant has no effect", P); 5024 end if; 5025 5026 -- Otherwise the prefix is not a simple name 5027 5028 else 5029 -- Ensure that the prefix of attribute 'Old is an entity when it 5030 -- is potentially unevaluated (6.1.1 (27/3)). 5031 5032 if Is_Potentially_Unevaluated (N) 5033 and then not Statically_Denotes_Object (P) 5034 then 5035 Uneval_Old_Msg; 5036 5037 -- Detect a possible infinite recursion when the prefix denotes 5038 -- the related function. 5039 5040 -- function Func (...) return ... 5041 -- with Post => Func'Old ...; 5042 5043 -- The function may be specified in qualified form X.Y where X is 5044 -- a protected object and Y is a protected function. In that case 5045 -- ensure that the qualified form has an entity. 5046 5047 elsif Nkind (P) = N_Function_Call 5048 and then Nkind (Name (P)) in N_Has_Entity 5049 then 5050 Pref_Id := Entity (Name (P)); 5051 5052 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) 5053 and then Pref_Id = Spec_Id 5054 then 5055 Error_Msg_Warn := SPARK_Mode /= On; 5056 Error_Msg_N ("!possible infinite recursion<<", P); 5057 Error_Msg_N ("\!??Storage_Error ]<<", P); 5058 end if; 5059 end if; 5060 5061 -- The prefix of attribute 'Old may refer to a component of a 5062 -- formal parameter. In this case its expansion may generate 5063 -- actual subtypes that are referenced in an inner context and 5064 -- that must be elaborated within the subprogram itself. If the 5065 -- prefix includes a function call, it may involve finalization 5066 -- actions that should be inserted when the attribute has been 5067 -- rewritten as a declaration. Create a declaration for the prefix 5068 -- and insert it at the start of the enclosing subprogram. This is 5069 -- an expansion activity that has to be performed now to prevent 5070 -- out-of-order issues. 5071 5072 -- This expansion is both harmful and not needed in SPARK mode, 5073 -- since the formal verification back end relies on the types of 5074 -- nodes (hence is not robust w.r.t. a change to base type here), 5075 -- and does not suffer from the out-of-order issue described 5076 -- above. Thus, this expansion is skipped in SPARK mode. 5077 5078 -- The expansion is not relevant for discrete types, which will 5079 -- not generate extra declarations, and where use of the base type 5080 -- may lead to spurious errors if context is a case. 5081 5082 if not GNATprove_Mode then 5083 if not Is_Discrete_Type (Pref_Typ) then 5084 Pref_Typ := Base_Type (Pref_Typ); 5085 end if; 5086 5087 Set_Etype (N, Pref_Typ); 5088 Set_Etype (P, Pref_Typ); 5089 5090 Analyze_Dimension (N); 5091 Expand (N); 5092 end if; 5093 end if; 5094 end Old; 5095 5096 ---------------------- 5097 -- Overlaps_Storage -- 5098 ---------------------- 5099 5100 when Attribute_Overlaps_Storage => 5101 Check_E1; 5102 5103 -- Both arguments must be objects of any type 5104 5105 Analyze_And_Resolve (P); 5106 Analyze_And_Resolve (E1); 5107 Check_Object_Reference (P); 5108 Check_Object_Reference (E1); 5109 Set_Etype (N, Standard_Boolean); 5110 5111 ------------ 5112 -- Output -- 5113 ------------ 5114 5115 when Attribute_Output => 5116 Check_E2; 5117 Check_Stream_Attribute (TSS_Stream_Output); 5118 Set_Etype (N, Standard_Void_Type); 5119 Resolve (N, Standard_Void_Type); 5120 5121 ------------------ 5122 -- Partition_ID -- 5123 ------------------ 5124 5125 when Attribute_Partition_ID => 5126 Check_E0; 5127 5128 if P_Type /= Any_Type then 5129 if not Is_Library_Level_Entity (Entity (P)) then 5130 Error_Attr_P 5131 ("prefix of % attribute must be library-level entity"); 5132 5133 -- The defining entity of prefix should not be declared inside a 5134 -- Pure unit. RM E.1(8). Is_Pure was set during declaration. 5135 5136 elsif Is_Entity_Name (P) 5137 and then Is_Pure (Entity (P)) 5138 then 5139 Error_Attr_P ("prefix of% attribute must not be declared pure"); 5140 end if; 5141 end if; 5142 5143 Set_Etype (N, Universal_Integer); 5144 5145 ------------------------- 5146 -- Passed_By_Reference -- 5147 ------------------------- 5148 5149 when Attribute_Passed_By_Reference => 5150 Check_E0; 5151 Check_Type; 5152 Set_Etype (N, Standard_Boolean); 5153 5154 ------------------ 5155 -- Pool_Address -- 5156 ------------------ 5157 5158 when Attribute_Pool_Address => 5159 Check_E0; 5160 Set_Etype (N, RTE (RE_Address)); 5161 5162 --------- 5163 -- Pos -- 5164 --------- 5165 5166 when Attribute_Pos => 5167 Check_Discrete_Type; 5168 Check_E1; 5169 5170 if Is_Boolean_Type (P_Type) then 5171 Error_Msg_Name_1 := Aname; 5172 Error_Msg_Name_2 := Chars (P_Type); 5173 Check_SPARK_05_Restriction 5174 ("attribute% is not allowed for type%", P); 5175 end if; 5176 5177 Resolve (E1, P_Base_Type); 5178 Set_Etype (N, Universal_Integer); 5179 5180 -------------- 5181 -- Position -- 5182 -------------- 5183 5184 when Attribute_Position => 5185 Check_Component; 5186 Set_Etype (N, Universal_Integer); 5187 5188 ---------- 5189 -- Pred -- 5190 ---------- 5191 5192 when Attribute_Pred => 5193 Check_Scalar_Type; 5194 Check_E1; 5195 5196 if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then 5197 Error_Msg_Name_1 := Aname; 5198 Error_Msg_Name_2 := Chars (P_Type); 5199 Check_SPARK_05_Restriction 5200 ("attribute% is not allowed for type%", P); 5201 end if; 5202 5203 Resolve (E1, P_Base_Type); 5204 Set_Etype (N, P_Base_Type); 5205 5206 -- Since Pred works on the base type, we normally do no check for the 5207 -- floating-point case, since the base type is unconstrained. But we 5208 -- make an exception in Check_Float_Overflow mode. 5209 5210 if Is_Floating_Point_Type (P_Type) then 5211 if not Range_Checks_Suppressed (P_Base_Type) then 5212 Set_Do_Range_Check (E1); 5213 end if; 5214 5215 -- If not modular type, test for overflow check required 5216 5217 else 5218 if not Is_Modular_Integer_Type (P_Type) 5219 and then not Range_Checks_Suppressed (P_Base_Type) 5220 then 5221 Enable_Range_Check (E1); 5222 end if; 5223 end if; 5224 5225 -------------- 5226 -- Priority -- 5227 -------------- 5228 5229 -- Ada 2005 (AI-327): Dynamic ceiling priorities 5230 5231 when Attribute_Priority => 5232 if Ada_Version < Ada_2005 then 5233 Error_Attr ("% attribute is allowed only in Ada 2005 mode", P); 5234 end if; 5235 5236 Check_E0; 5237 5238 Check_Restriction (No_Dynamic_Priorities, N); 5239 5240 -- The prefix must be a protected object (AARM D.5.2 (2/2)) 5241 5242 Analyze (P); 5243 5244 if Is_Protected_Type (Etype (P)) 5245 or else (Is_Access_Type (Etype (P)) 5246 and then Is_Protected_Type (Designated_Type (Etype (P)))) 5247 then 5248 Resolve (P, Etype (P)); 5249 else 5250 Error_Attr_P ("prefix of % attribute must be a protected object"); 5251 end if; 5252 5253 Set_Etype (N, Standard_Integer); 5254 5255 -- Must be called from within a protected procedure or entry of the 5256 -- protected object. 5257 5258 declare 5259 S : Entity_Id; 5260 5261 begin 5262 S := Current_Scope; 5263 while S /= Etype (P) 5264 and then S /= Standard_Standard 5265 loop 5266 S := Scope (S); 5267 end loop; 5268 5269 if S = Standard_Standard then 5270 Error_Attr ("the attribute % is only allowed inside protected " 5271 & "operations", P); 5272 end if; 5273 end; 5274 5275 Validate_Non_Static_Attribute_Function_Call; 5276 5277 ----------- 5278 -- Range -- 5279 ----------- 5280 5281 when Attribute_Range => 5282 Check_Array_Or_Scalar_Type; 5283 Bad_Attribute_For_Predicate; 5284 5285 if Ada_Version = Ada_83 5286 and then Is_Scalar_Type (P_Type) 5287 and then Comes_From_Source (N) 5288 then 5289 Error_Attr 5290 ("(Ada 83) % attribute not allowed for scalar type", P); 5291 end if; 5292 5293 ------------ 5294 -- Result -- 5295 ------------ 5296 5297 when Attribute_Result => Result : declare 5298 function Denote_Same_Function 5299 (Pref_Id : Entity_Id; 5300 Spec_Id : Entity_Id) return Boolean; 5301 -- Determine whether the entity of the prefix Pref_Id denotes the 5302 -- same entity as that of the related subprogram Spec_Id. 5303 5304 -------------------------- 5305 -- Denote_Same_Function -- 5306 -------------------------- 5307 5308 function Denote_Same_Function 5309 (Pref_Id : Entity_Id; 5310 Spec_Id : Entity_Id) return Boolean 5311 is 5312 Over_Id : constant Entity_Id := Overridden_Operation (Spec_Id); 5313 Subp_Spec : constant Node_Id := Parent (Spec_Id); 5314 5315 begin 5316 -- The prefix denotes the related subprogram 5317 5318 if Pref_Id = Spec_Id then 5319 return True; 5320 5321 -- Account for a special case when attribute 'Result appears in 5322 -- the postcondition of a generic function. 5323 5324 -- generic 5325 -- function Gen_Func return ... 5326 -- with Post => Gen_Func'Result ...; 5327 5328 -- When the generic function is instantiated, the Chars field of 5329 -- the instantiated prefix still denotes the name of the generic 5330 -- function. Note that any preemptive transformation is impossible 5331 -- without a proper analysis. The structure of the wrapper package 5332 -- is as follows: 5333 5334 -- package Anon_Gen_Pack is 5335 -- <subtypes and renamings> 5336 -- function Subp_Decl return ...; -- (!) 5337 -- pragma Postcondition (Gen_Func'Result ...); -- (!) 5338 -- function Gen_Func ... renames Subp_Decl; 5339 -- end Anon_Gen_Pack; 5340 5341 elsif Nkind (Subp_Spec) = N_Function_Specification 5342 and then Present (Generic_Parent (Subp_Spec)) 5343 and then Ekind_In (Pref_Id, E_Generic_Function, E_Function) 5344 then 5345 if Generic_Parent (Subp_Spec) = Pref_Id then 5346 return True; 5347 5348 elsif Present (Alias (Pref_Id)) 5349 and then Alias (Pref_Id) = Spec_Id 5350 then 5351 return True; 5352 end if; 5353 5354 -- Account for a special case where a primitive of a tagged type 5355 -- inherits a class-wide postcondition from a parent type. In this 5356 -- case the prefix of attribute 'Result denotes the overriding 5357 -- primitive. 5358 5359 elsif Present (Over_Id) and then Pref_Id = Over_Id then 5360 return True; 5361 end if; 5362 5363 -- Otherwise the prefix does not denote the related subprogram 5364 5365 return False; 5366 end Denote_Same_Function; 5367 5368 -- Local variables 5369 5370 In_Inlined_C_Postcondition : constant Boolean := 5371 Modify_Tree_For_C 5372 and then In_Inlined_Body; 5373 5374 Legal : Boolean; 5375 Pref_Id : Entity_Id; 5376 Spec_Id : Entity_Id; 5377 5378 -- Start of processing for Result 5379 5380 begin 5381 -- The attribute reference is a primary. If any expressions follow, 5382 -- then the attribute reference is an indexable object. Transform the 5383 -- attribute into an indexed component and analyze it. 5384 5385 if Present (E1) then 5386 Rewrite (N, 5387 Make_Indexed_Component (Loc, 5388 Prefix => 5389 Make_Attribute_Reference (Loc, 5390 Prefix => Relocate_Node (P), 5391 Attribute_Name => Name_Result), 5392 Expressions => Expressions (N))); 5393 Analyze (N); 5394 return; 5395 end if; 5396 5397 Analyze_Attribute_Old_Result (Legal, Spec_Id); 5398 5399 -- The aspect or pragma where attribute 'Result resides should be 5400 -- associated with a subprogram declaration or a body. If this is not 5401 -- the case, then the aspect or pragma is illegal. Return as analysis 5402 -- cannot be carried out. 5403 5404 -- The exception to this rule is when generating C since in this case 5405 -- postconditions are inlined. 5406 5407 if No (Spec_Id) and then In_Inlined_C_Postcondition then 5408 Spec_Id := Entity (P); 5409 5410 elsif not Legal then 5411 return; 5412 end if; 5413 5414 -- Attribute 'Result is part of a _Postconditions procedure. There is 5415 -- no need to perform the semantic checks below as they were already 5416 -- verified when the attribute was analyzed in its original context. 5417 -- Instead, rewrite the attribute as a reference to formal parameter 5418 -- _Result of the _Postconditions procedure. 5419 5420 if Chars (Spec_Id) = Name_uPostconditions 5421 or else 5422 (In_Inlined_C_Postcondition 5423 and then Nkind (Parent (Spec_Id)) = N_Block_Statement) 5424 then 5425 Rewrite (N, Make_Identifier (Loc, Name_uResult)); 5426 5427 -- The type of formal parameter _Result is that of the function 5428 -- encapsulating the _Postconditions procedure. Resolution must 5429 -- be carried out against the function return type. 5430 5431 Analyze_And_Resolve (N, Etype (Scope (Spec_Id))); 5432 5433 -- Otherwise attribute 'Result appears in its original context and 5434 -- all semantic checks should be carried out. 5435 5436 else 5437 -- Verify the legality of the prefix. It must denotes the entity 5438 -- of the related [generic] function. 5439 5440 if Is_Entity_Name (P) then 5441 Pref_Id := Entity (P); 5442 5443 if Ekind_In (Pref_Id, E_Function, E_Generic_Function) 5444 and then Ekind (Spec_Id) = Ekind (Pref_Id) 5445 then 5446 if Denote_Same_Function (Pref_Id, Spec_Id) then 5447 5448 -- Correct the prefix of the attribute when the context 5449 -- is a generic function. 5450 5451 if Pref_Id /= Spec_Id then 5452 Rewrite (P, New_Occurrence_Of (Spec_Id, Loc)); 5453 Analyze (P); 5454 end if; 5455 5456 Set_Etype (N, Etype (Spec_Id)); 5457 5458 -- Otherwise the prefix denotes some unrelated function 5459 5460 else 5461 Error_Msg_Name_2 := Chars (Spec_Id); 5462 Error_Attr 5463 ("incorrect prefix for attribute %, expected %", P); 5464 end if; 5465 5466 -- Otherwise the prefix denotes some other form of subprogram 5467 -- entity. 5468 5469 else 5470 Error_Attr 5471 ("attribute % can only appear in postcondition of " 5472 & "function", P); 5473 end if; 5474 5475 -- Otherwise the prefix is illegal 5476 5477 else 5478 Error_Msg_Name_2 := Chars (Spec_Id); 5479 Error_Attr ("incorrect prefix for attribute %, expected %", P); 5480 end if; 5481 end if; 5482 end Result; 5483 5484 ------------------ 5485 -- Range_Length -- 5486 ------------------ 5487 5488 when Attribute_Range_Length => 5489 Check_E0; 5490 Check_Discrete_Type; 5491 Set_Etype (N, Universal_Integer); 5492 5493 ---------- 5494 -- Read -- 5495 ---------- 5496 5497 when Attribute_Read => 5498 Check_E2; 5499 Check_Stream_Attribute (TSS_Stream_Read); 5500 Set_Etype (N, Standard_Void_Type); 5501 Resolve (N, Standard_Void_Type); 5502 Note_Possible_Modification (E2, Sure => True); 5503 5504 --------- 5505 -- Ref -- 5506 --------- 5507 5508 when Attribute_Ref => 5509 Check_E1; 5510 Analyze (P); 5511 5512 if Nkind (P) /= N_Expanded_Name 5513 or else not Is_RTE (P_Type, RE_Address) 5514 then 5515 Error_Attr_P ("prefix of % attribute must be System.Address"); 5516 end if; 5517 5518 Analyze_And_Resolve (E1, Any_Integer); 5519 Set_Etype (N, RTE (RE_Address)); 5520 5521 --------------- 5522 -- Remainder -- 5523 --------------- 5524 5525 when Attribute_Remainder => 5526 Check_Floating_Point_Type_2; 5527 Set_Etype (N, P_Base_Type); 5528 Resolve (E1, P_Base_Type); 5529 Resolve (E2, P_Base_Type); 5530 5531 --------------------- 5532 -- Restriction_Set -- 5533 --------------------- 5534 5535 when Attribute_Restriction_Set => Restriction_Set : declare 5536 R : Restriction_Id; 5537 U : Node_Id; 5538 Unam : Unit_Name_Type; 5539 5540 begin 5541 Check_E1; 5542 Analyze (P); 5543 Check_System_Prefix; 5544 5545 -- No_Dependence case 5546 5547 if Nkind (E1) = N_Parameter_Association then 5548 pragma Assert (Chars (Selector_Name (E1)) = Name_No_Dependence); 5549 U := Explicit_Actual_Parameter (E1); 5550 5551 if not OK_No_Dependence_Unit_Name (U) then 5552 Set_Boolean_Result (N, False); 5553 Error_Attr; 5554 end if; 5555 5556 -- See if there is an entry already in the table. That's the 5557 -- case in which we can return True. 5558 5559 for J in No_Dependences.First .. No_Dependences.Last loop 5560 if Designate_Same_Unit (U, No_Dependences.Table (J).Unit) 5561 and then No_Dependences.Table (J).Warn = False 5562 then 5563 Set_Boolean_Result (N, True); 5564 return; 5565 end if; 5566 end loop; 5567 5568 -- If not in the No_Dependence table, result is False 5569 5570 Set_Boolean_Result (N, False); 5571 5572 -- In this case, we must ensure that the binder will reject any 5573 -- other unit in the partition that sets No_Dependence for this 5574 -- unit. We do that by making an entry in the special table kept 5575 -- for this purpose (if the entry is not there already). 5576 5577 Unam := Get_Spec_Name (Get_Unit_Name (U)); 5578 5579 for J in Restriction_Set_Dependences.First .. 5580 Restriction_Set_Dependences.Last 5581 loop 5582 if Restriction_Set_Dependences.Table (J) = Unam then 5583 return; 5584 end if; 5585 end loop; 5586 5587 Restriction_Set_Dependences.Append (Unam); 5588 5589 -- Normal restriction case 5590 5591 else 5592 if Nkind (E1) /= N_Identifier then 5593 Set_Boolean_Result (N, False); 5594 Error_Attr ("attribute % requires restriction identifier", E1); 5595 5596 else 5597 R := Get_Restriction_Id (Process_Restriction_Synonyms (E1)); 5598 5599 if R = Not_A_Restriction_Id then 5600 Set_Boolean_Result (N, False); 5601 Error_Msg_Node_1 := E1; 5602 Error_Attr ("invalid restriction identifier &", E1); 5603 5604 elsif R not in Partition_Boolean_Restrictions then 5605 Set_Boolean_Result (N, False); 5606 Error_Msg_Node_1 := E1; 5607 Error_Attr 5608 ("& is not a boolean partition-wide restriction", E1); 5609 end if; 5610 5611 if Restriction_Active (R) then 5612 Set_Boolean_Result (N, True); 5613 else 5614 Check_Restriction (R, N); 5615 Set_Boolean_Result (N, False); 5616 end if; 5617 end if; 5618 end if; 5619 end Restriction_Set; 5620 5621 ----------- 5622 -- Round -- 5623 ----------- 5624 5625 when Attribute_Round => 5626 Check_E1; 5627 Check_Decimal_Fixed_Point_Type; 5628 Set_Etype (N, P_Base_Type); 5629 5630 -- Because the context is universal_real (3.5.10(12)) it is a 5631 -- legal context for a universal fixed expression. This is the 5632 -- only attribute whose functional description involves U_R. 5633 5634 if Etype (E1) = Universal_Fixed then 5635 declare 5636 Conv : constant Node_Id := Make_Type_Conversion (Loc, 5637 Subtype_Mark => New_Occurrence_Of (Universal_Real, Loc), 5638 Expression => Relocate_Node (E1)); 5639 5640 begin 5641 Rewrite (E1, Conv); 5642 Analyze (E1); 5643 end; 5644 end if; 5645 5646 Resolve (E1, Any_Real); 5647 5648 -------------- 5649 -- Rounding -- 5650 -------------- 5651 5652 when Attribute_Rounding => 5653 Check_Floating_Point_Type_1; 5654 Set_Etype (N, P_Base_Type); 5655 Resolve (E1, P_Base_Type); 5656 5657 --------------- 5658 -- Safe_Emax -- 5659 --------------- 5660 5661 when Attribute_Safe_Emax => 5662 Check_Floating_Point_Type_0; 5663 Set_Etype (N, Universal_Integer); 5664 5665 ---------------- 5666 -- Safe_First -- 5667 ---------------- 5668 5669 when Attribute_Safe_First => 5670 Check_Floating_Point_Type_0; 5671 Set_Etype (N, Universal_Real); 5672 5673 ---------------- 5674 -- Safe_Large -- 5675 ---------------- 5676 5677 when Attribute_Safe_Large => 5678 Check_E0; 5679 Check_Real_Type; 5680 Set_Etype (N, Universal_Real); 5681 5682 --------------- 5683 -- Safe_Last -- 5684 --------------- 5685 5686 when Attribute_Safe_Last => 5687 Check_Floating_Point_Type_0; 5688 Set_Etype (N, Universal_Real); 5689 5690 ---------------- 5691 -- Safe_Small -- 5692 ---------------- 5693 5694 when Attribute_Safe_Small => 5695 Check_E0; 5696 Check_Real_Type; 5697 Set_Etype (N, Universal_Real); 5698 5699 -------------------------- 5700 -- Scalar_Storage_Order -- 5701 -------------------------- 5702 5703 when Attribute_Scalar_Storage_Order => Scalar_Storage_Order : declare 5704 Ent : Entity_Id := Empty; 5705 5706 begin 5707 Check_E0; 5708 Check_Type; 5709 5710 if not (Is_Record_Type (P_Type) or else Is_Array_Type (P_Type)) then 5711 5712 -- In GNAT mode, the attribute applies to generic types as well 5713 -- as composite types, and for non-composite types always returns 5714 -- the default bit order for the target. 5715 5716 if not (GNAT_Mode and then Is_Generic_Type (P_Type)) 5717 and then not In_Instance 5718 then 5719 Error_Attr_P 5720 ("prefix of % attribute must be record or array type"); 5721 5722 elsif not Is_Generic_Type (P_Type) then 5723 if Bytes_Big_Endian then 5724 Ent := RTE (RE_High_Order_First); 5725 else 5726 Ent := RTE (RE_Low_Order_First); 5727 end if; 5728 end if; 5729 5730 elsif Bytes_Big_Endian xor Reverse_Storage_Order (P_Type) then 5731 Ent := RTE (RE_High_Order_First); 5732 5733 else 5734 Ent := RTE (RE_Low_Order_First); 5735 end if; 5736 5737 if Present (Ent) then 5738 Rewrite (N, New_Occurrence_Of (Ent, Loc)); 5739 end if; 5740 5741 Set_Etype (N, RTE (RE_Bit_Order)); 5742 Resolve (N); 5743 5744 -- Reset incorrect indication of staticness 5745 5746 Set_Is_Static_Expression (N, False); 5747 end Scalar_Storage_Order; 5748 5749 ----------- 5750 -- Scale -- 5751 ----------- 5752 5753 when Attribute_Scale => 5754 Check_E0; 5755 Check_Decimal_Fixed_Point_Type; 5756 Set_Etype (N, Universal_Integer); 5757 5758 ------------- 5759 -- Scaling -- 5760 ------------- 5761 5762 when Attribute_Scaling => 5763 Check_Floating_Point_Type_2; 5764 Set_Etype (N, P_Base_Type); 5765 Resolve (E1, P_Base_Type); 5766 5767 ------------------ 5768 -- Signed_Zeros -- 5769 ------------------ 5770 5771 when Attribute_Signed_Zeros => 5772 Check_Floating_Point_Type_0; 5773 Set_Etype (N, Standard_Boolean); 5774 5775 ---------- 5776 -- Size -- 5777 ---------- 5778 5779 when Attribute_Size 5780 | Attribute_VADS_Size 5781 => 5782 Check_E0; 5783 5784 -- If prefix is parameterless function call, rewrite and resolve 5785 -- as such. 5786 5787 if Is_Entity_Name (P) 5788 and then Ekind (Entity (P)) = E_Function 5789 then 5790 Resolve (P); 5791 5792 -- Similar processing for a protected function call 5793 5794 elsif Nkind (P) = N_Selected_Component 5795 and then Ekind (Entity (Selector_Name (P))) = E_Function 5796 then 5797 Resolve (P); 5798 end if; 5799 5800 if Is_Object_Reference (P) then 5801 Check_Object_Reference (P); 5802 5803 elsif Is_Entity_Name (P) 5804 and then (Is_Type (Entity (P)) 5805 or else Ekind (Entity (P)) = E_Enumeration_Literal) 5806 then 5807 null; 5808 5809 elsif Nkind (P) = N_Type_Conversion 5810 and then not Comes_From_Source (P) 5811 then 5812 null; 5813 5814 -- Some other compilers allow dubious use of X'???'Size 5815 5816 elsif Relaxed_RM_Semantics 5817 and then Nkind (P) = N_Attribute_Reference 5818 then 5819 null; 5820 5821 else 5822 Error_Attr_P ("invalid prefix for % attribute"); 5823 end if; 5824 5825 Check_Not_Incomplete_Type; 5826 Check_Not_CPP_Type; 5827 Set_Etype (N, Universal_Integer); 5828 5829 -- If we are processing pragmas Compile_Time_Warning and Compile_ 5830 -- Time_Errors after the back end has been called and this occurrence 5831 -- of 'Size is known at compile time then it is safe to perform this 5832 -- evaluation. Needed to perform the static evaluation of the full 5833 -- boolean expression of these pragmas. 5834 5835 if In_Compile_Time_Warning_Or_Error 5836 and then Is_Entity_Name (P) 5837 and then (Is_Type (Entity (P)) 5838 or else Ekind (Entity (P)) = E_Enumeration_Literal) 5839 and then Size_Known_At_Compile_Time (Entity (P)) 5840 then 5841 Rewrite (N, Make_Integer_Literal (Sloc (N), Esize (Entity (P)))); 5842 Analyze (N); 5843 end if; 5844 5845 ----------- 5846 -- Small -- 5847 ----------- 5848 5849 when Attribute_Small => 5850 Check_E0; 5851 Check_Real_Type; 5852 Set_Etype (N, Universal_Real); 5853 5854 ------------------ 5855 -- Storage_Pool -- 5856 ------------------ 5857 5858 when Attribute_Storage_Pool 5859 | Attribute_Simple_Storage_Pool 5860 => 5861 Check_E0; 5862 5863 if Is_Access_Type (P_Type) then 5864 if Ekind (P_Type) = E_Access_Subprogram_Type then 5865 Error_Attr_P 5866 ("cannot use % attribute for access-to-subprogram type"); 5867 end if; 5868 5869 -- Set appropriate entity 5870 5871 if Present (Associated_Storage_Pool (Root_Type (P_Type))) then 5872 Set_Entity (N, Associated_Storage_Pool (Root_Type (P_Type))); 5873 else 5874 Set_Entity (N, RTE (RE_Global_Pool_Object)); 5875 end if; 5876 5877 if Attr_Id = Attribute_Storage_Pool then 5878 if Present (Get_Rep_Pragma (Etype (Entity (N)), 5879 Name_Simple_Storage_Pool_Type)) 5880 then 5881 Error_Msg_Name_1 := Aname; 5882 Error_Msg_Warn := SPARK_Mode /= On; 5883 Error_Msg_N 5884 ("cannot use % attribute for type with simple storage " 5885 & "pool<<", N); 5886 Error_Msg_N ("\Program_Error [<<", N); 5887 5888 Rewrite 5889 (N, Make_Raise_Program_Error 5890 (Sloc (N), Reason => PE_Explicit_Raise)); 5891 end if; 5892 5893 Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); 5894 5895 -- In the Simple_Storage_Pool case, verify that the pool entity is 5896 -- actually of a simple storage pool type, and set the attribute's 5897 -- type to the pool object's type. 5898 5899 else 5900 if not Present (Get_Rep_Pragma (Etype (Entity (N)), 5901 Name_Simple_Storage_Pool_Type)) 5902 then 5903 Error_Attr_P 5904 ("cannot use % attribute for type without simple " & 5905 "storage pool"); 5906 end if; 5907 5908 Set_Etype (N, Etype (Entity (N))); 5909 end if; 5910 5911 -- Validate_Remote_Access_To_Class_Wide_Type for attribute 5912 -- Storage_Pool since this attribute is not defined for such 5913 -- types (RM E.2.3(22)). 5914 5915 Validate_Remote_Access_To_Class_Wide_Type (N); 5916 5917 else 5918 Error_Attr_P ("prefix of % attribute must be access type"); 5919 end if; 5920 5921 ------------------ 5922 -- Storage_Size -- 5923 ------------------ 5924 5925 when Attribute_Storage_Size => 5926 Check_E0; 5927 5928 if Is_Task_Type (P_Type) then 5929 Set_Etype (N, Universal_Integer); 5930 5931 -- Use with tasks is an obsolescent feature 5932 5933 Check_Restriction (No_Obsolescent_Features, P); 5934 5935 elsif Is_Access_Type (P_Type) then 5936 if Ekind (P_Type) = E_Access_Subprogram_Type then 5937 Error_Attr_P 5938 ("cannot use % attribute for access-to-subprogram type"); 5939 end if; 5940 5941 if Is_Entity_Name (P) 5942 and then Is_Type (Entity (P)) 5943 then 5944 Check_Type; 5945 Set_Etype (N, Universal_Integer); 5946 5947 -- Validate_Remote_Access_To_Class_Wide_Type for attribute 5948 -- Storage_Size since this attribute is not defined for 5949 -- such types (RM E.2.3(22)). 5950 5951 Validate_Remote_Access_To_Class_Wide_Type (N); 5952 5953 -- The prefix is allowed to be an implicit dereference of an 5954 -- access value designating a task. 5955 5956 else 5957 Check_Task_Prefix; 5958 Set_Etype (N, Universal_Integer); 5959 end if; 5960 5961 else 5962 Error_Attr_P ("prefix of % attribute must be access or task type"); 5963 end if; 5964 5965 ------------------ 5966 -- Storage_Unit -- 5967 ------------------ 5968 5969 when Attribute_Storage_Unit => 5970 Standard_Attribute (Ttypes.System_Storage_Unit); 5971 5972 ----------------- 5973 -- Stream_Size -- 5974 ----------------- 5975 5976 when Attribute_Stream_Size => 5977 Check_E0; 5978 Check_Type; 5979 5980 if Is_Entity_Name (P) 5981 and then Is_Elementary_Type (Entity (P)) 5982 then 5983 Set_Etype (N, Universal_Integer); 5984 else 5985 Error_Attr_P ("invalid prefix for % attribute"); 5986 end if; 5987 5988 --------------- 5989 -- Stub_Type -- 5990 --------------- 5991 5992 when Attribute_Stub_Type => 5993 Check_Type; 5994 Check_E0; 5995 5996 if Is_Remote_Access_To_Class_Wide_Type (Base_Type (P_Type)) then 5997 5998 -- For a real RACW [sub]type, use corresponding stub type 5999 6000 if not Is_Generic_Type (P_Type) then 6001 Rewrite (N, 6002 New_Occurrence_Of 6003 (Corresponding_Stub_Type (Base_Type (P_Type)), Loc)); 6004 6005 -- For a generic type (that has been marked as an RACW using the 6006 -- Remote_Access_Type aspect or pragma), use a generic RACW stub 6007 -- type. Note that if the actual is not a remote access type, the 6008 -- instantiation will fail. 6009 6010 else 6011 -- Note: we go to the underlying type here because the view 6012 -- returned by RTE (RE_RACW_Stub_Type) might be incomplete. 6013 6014 Rewrite (N, 6015 New_Occurrence_Of 6016 (Underlying_Type (RTE (RE_RACW_Stub_Type)), Loc)); 6017 end if; 6018 6019 else 6020 Error_Attr_P 6021 ("prefix of% attribute must be remote access-to-class-wide"); 6022 end if; 6023 6024 ---------- 6025 -- Succ -- 6026 ---------- 6027 6028 when Attribute_Succ => 6029 Check_Scalar_Type; 6030 Check_E1; 6031 6032 if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then 6033 Error_Msg_Name_1 := Aname; 6034 Error_Msg_Name_2 := Chars (P_Type); 6035 Check_SPARK_05_Restriction 6036 ("attribute% is not allowed for type%", P); 6037 end if; 6038 6039 Resolve (E1, P_Base_Type); 6040 Set_Etype (N, P_Base_Type); 6041 6042 -- Since Pred works on the base type, we normally do no check for the 6043 -- floating-point case, since the base type is unconstrained. But we 6044 -- make an exception in Check_Float_Overflow mode. 6045 6046 if Is_Floating_Point_Type (P_Type) then 6047 if not Range_Checks_Suppressed (P_Base_Type) then 6048 Set_Do_Range_Check (E1); 6049 end if; 6050 6051 -- If not modular type, test for overflow check required 6052 6053 else 6054 if not Is_Modular_Integer_Type (P_Type) 6055 and then not Range_Checks_Suppressed (P_Base_Type) 6056 then 6057 Enable_Range_Check (E1); 6058 end if; 6059 end if; 6060 6061 -------------------------------- 6062 -- System_Allocator_Alignment -- 6063 -------------------------------- 6064 6065 when Attribute_System_Allocator_Alignment => 6066 Standard_Attribute (Ttypes.System_Allocator_Alignment); 6067 6068 --------- 6069 -- Tag -- 6070 --------- 6071 6072 when Attribute_Tag => 6073 Check_E0; 6074 Check_Dereference; 6075 6076 if not Is_Tagged_Type (P_Type) then 6077 Error_Attr_P ("prefix of % attribute must be tagged"); 6078 6079 -- Next test does not apply to generated code why not, and what does 6080 -- the illegal reference mean??? 6081 6082 elsif Is_Object_Reference (P) 6083 and then not Is_Class_Wide_Type (P_Type) 6084 and then Comes_From_Source (N) 6085 then 6086 Error_Attr_P 6087 ("% attribute can only be applied to objects " & 6088 "of class - wide type"); 6089 end if; 6090 6091 -- The prefix cannot be an incomplete type. However, references to 6092 -- 'Tag can be generated when expanding interface conversions, and 6093 -- this is legal. 6094 6095 if Comes_From_Source (N) then 6096 Check_Not_Incomplete_Type; 6097 end if; 6098 6099 -- Set appropriate type 6100 6101 Set_Etype (N, RTE (RE_Tag)); 6102 6103 ----------------- 6104 -- Target_Name -- 6105 ----------------- 6106 6107 when Attribute_Target_Name => Target_Name : declare 6108 TN : constant String := Sdefault.Target_Name.all; 6109 TL : Natural; 6110 6111 begin 6112 Check_Standard_Prefix; 6113 6114 TL := TN'Last; 6115 6116 if TN (TL) = '/' or else TN (TL) = '\' then 6117 TL := TL - 1; 6118 end if; 6119 6120 Rewrite (N, 6121 Make_String_Literal (Loc, 6122 Strval => TN (TN'First .. TL))); 6123 Analyze_And_Resolve (N, Standard_String); 6124 Set_Is_Static_Expression (N, True); 6125 end Target_Name; 6126 6127 ---------------- 6128 -- Terminated -- 6129 ---------------- 6130 6131 when Attribute_Terminated => 6132 Check_E0; 6133 Set_Etype (N, Standard_Boolean); 6134 Check_Task_Prefix; 6135 6136 ---------------- 6137 -- To_Address -- 6138 ---------------- 6139 6140 when Attribute_To_Address => To_Address : declare 6141 Val : Uint; 6142 6143 begin 6144 Check_E1; 6145 Analyze (P); 6146 Check_System_Prefix; 6147 6148 Generate_Reference (RTE (RE_Address), P); 6149 Analyze_And_Resolve (E1, Any_Integer); 6150 Set_Etype (N, RTE (RE_Address)); 6151 6152 if Is_Static_Expression (E1) then 6153 Set_Is_Static_Expression (N, True); 6154 end if; 6155 6156 -- OK static expression case, check range and set appropriate type 6157 6158 if Is_OK_Static_Expression (E1) then 6159 Val := Expr_Value (E1); 6160 6161 if Val < -(2 ** UI_From_Int (Standard'Address_Size - 1)) 6162 or else 6163 Val > 2 ** UI_From_Int (Standard'Address_Size) - 1 6164 then 6165 Error_Attr ("address value out of range for % attribute", E1); 6166 end if; 6167 6168 -- In most cases the expression is a numeric literal or some other 6169 -- address expression, but if it is a declared constant it may be 6170 -- of a compatible type that must be left on the node. 6171 6172 if Is_Entity_Name (E1) then 6173 null; 6174 6175 -- Set type to universal integer if negative 6176 6177 elsif Val < 0 then 6178 Set_Etype (E1, Universal_Integer); 6179 6180 -- Otherwise set type to Unsigned_64 to accommodate max values 6181 6182 else 6183 Set_Etype (E1, Standard_Unsigned_64); 6184 end if; 6185 end if; 6186 6187 Set_Is_Static_Expression (N, True); 6188 end To_Address; 6189 6190 ------------ 6191 -- To_Any -- 6192 ------------ 6193 6194 when Attribute_To_Any => 6195 Check_E1; 6196 Check_PolyORB_Attribute; 6197 Set_Etype (N, RTE (RE_Any)); 6198 6199 ---------------- 6200 -- Truncation -- 6201 ---------------- 6202 6203 when Attribute_Truncation => 6204 Check_Floating_Point_Type_1; 6205 Resolve (E1, P_Base_Type); 6206 Set_Etype (N, P_Base_Type); 6207 6208 ---------------- 6209 -- Type_Class -- 6210 ---------------- 6211 6212 when Attribute_Type_Class => 6213 Check_E0; 6214 Check_Type; 6215 Check_Not_Incomplete_Type; 6216 Set_Etype (N, RTE (RE_Type_Class)); 6217 6218 -------------- 6219 -- TypeCode -- 6220 -------------- 6221 6222 when Attribute_TypeCode => 6223 Check_E0; 6224 Check_PolyORB_Attribute; 6225 Set_Etype (N, RTE (RE_TypeCode)); 6226 6227 -------------- 6228 -- Type_Key -- 6229 -------------- 6230 6231 when Attribute_Type_Key => Type_Key : declare 6232 Full_Name : constant String_Id := 6233 Fully_Qualified_Name_String (Entity (P)); 6234 6235 CRC : CRC32; 6236 -- The computed signature for the type 6237 6238 Deref : Boolean; 6239 -- To simplify the handling of mutually recursive types, follow a 6240 -- single dereference link in a composite type. 6241 6242 procedure Compute_Type_Key (T : Entity_Id); 6243 -- Create a CRC integer from the declaration of the type. For a 6244 -- composite type, fold in the representation of its components in 6245 -- recursive fashion. We use directly the source representation of 6246 -- the types involved. 6247 6248 ---------------------- 6249 -- Compute_Type_Key -- 6250 ---------------------- 6251 6252 procedure Compute_Type_Key (T : Entity_Id) is 6253 Buffer : Source_Buffer_Ptr; 6254 P_Max : Source_Ptr; 6255 P_Min : Source_Ptr; 6256 Rep : Node_Id; 6257 SFI : Source_File_Index; 6258 6259 procedure Process_One_Declaration; 6260 -- Update CRC with the characters of one type declaration, or a 6261 -- representation pragma that applies to the type. 6262 6263 ----------------------------- 6264 -- Process_One_Declaration -- 6265 ----------------------------- 6266 6267 procedure Process_One_Declaration is 6268 begin 6269 -- Scan type declaration, skipping blanks 6270 6271 for Ptr in P_Min .. P_Max loop 6272 if Buffer (Ptr) /= ' ' then 6273 System.CRC32.Update (CRC, Buffer (Ptr)); 6274 end if; 6275 end loop; 6276 end Process_One_Declaration; 6277 6278 -- Start of processing for Compute_Type_Key 6279 6280 begin 6281 if Is_Itype (T) then 6282 return; 6283 end if; 6284 6285 -- If the type is declared in Standard, there is no source, so 6286 -- just use its name. 6287 6288 if Scope (T) = Standard_Standard then 6289 declare 6290 Name : constant String := Get_Name_String (Chars (T)); 6291 begin 6292 for J in Name'Range loop 6293 System.CRC32.Update (CRC, Name (J)); 6294 end loop; 6295 end; 6296 6297 return; 6298 end if; 6299 6300 Sloc_Range (Enclosing_Declaration (T), P_Min, P_Max); 6301 SFI := Get_Source_File_Index (P_Min); 6302 pragma Assert (SFI = Get_Source_File_Index (P_Max)); 6303 Buffer := Source_Text (SFI); 6304 6305 Process_One_Declaration; 6306 6307 -- Recurse on relevant component types 6308 6309 if Is_Array_Type (T) then 6310 Compute_Type_Key (Component_Type (T)); 6311 6312 elsif Is_Access_Type (T) then 6313 if not Deref then 6314 Deref := True; 6315 Compute_Type_Key (Designated_Type (T)); 6316 end if; 6317 6318 elsif Is_Derived_Type (T) then 6319 Compute_Type_Key (Etype (T)); 6320 6321 elsif Is_Record_Type (T) then 6322 declare 6323 Comp : Entity_Id; 6324 begin 6325 Comp := First_Component (T); 6326 while Present (Comp) loop 6327 Compute_Type_Key (Etype (Comp)); 6328 Next_Component (Comp); 6329 end loop; 6330 end; 6331 end if; 6332 6333 if Is_First_Subtype (T) then 6334 6335 -- Fold in representation aspects for the type, which appear in 6336 -- the same source buffer. If the representation aspects are in 6337 -- a different source file, then skip them; they apply to some 6338 -- other type, perhaps one we're derived from. 6339 6340 Rep := First_Rep_Item (T); 6341 6342 while Present (Rep) loop 6343 if Comes_From_Source (Rep) then 6344 Sloc_Range (Rep, P_Min, P_Max); 6345 6346 if SFI = Get_Source_File_Index (P_Min) then 6347 pragma Assert (SFI = Get_Source_File_Index (P_Max)); 6348 Process_One_Declaration; 6349 end if; 6350 end if; 6351 6352 Rep := Next_Rep_Item (Rep); 6353 end loop; 6354 end if; 6355 end Compute_Type_Key; 6356 6357 -- Start of processing for Type_Key 6358 6359 begin 6360 Check_E0; 6361 Check_Type; 6362 6363 Start_String; 6364 Deref := False; 6365 6366 -- Copy all characters in Full_Name but the trailing NUL 6367 6368 for J in 1 .. String_Length (Full_Name) - 1 loop 6369 Store_String_Char (Get_String_Char (Full_Name, Pos (J))); 6370 end loop; 6371 6372 -- Compute CRC and convert it to string one character at a time, so 6373 -- as not to use Image within the compiler. 6374 6375 Initialize (CRC); 6376 Compute_Type_Key (Entity (P)); 6377 6378 if not Is_Frozen (Entity (P)) then 6379 Error_Msg_N ("premature usage of Type_Key?", N); 6380 end if; 6381 6382 while CRC > 0 loop 6383 Store_String_Char (Character'Val (48 + (CRC rem 10))); 6384 CRC := CRC / 10; 6385 end loop; 6386 6387 Rewrite (N, Make_String_Literal (Loc, End_String)); 6388 Analyze_And_Resolve (N, Standard_String); 6389 end Type_Key; 6390 6391 ----------------------- 6392 -- Unbiased_Rounding -- 6393 ----------------------- 6394 6395 when Attribute_Unbiased_Rounding => 6396 Check_Floating_Point_Type_1; 6397 Set_Etype (N, P_Base_Type); 6398 Resolve (E1, P_Base_Type); 6399 6400 ---------------------- 6401 -- Unchecked_Access -- 6402 ---------------------- 6403 6404 when Attribute_Unchecked_Access => 6405 if Comes_From_Source (N) then 6406 Check_Restriction (No_Unchecked_Access, N); 6407 end if; 6408 6409 Analyze_Access_Attribute; 6410 Check_Not_Incomplete_Type; 6411 6412 ------------------------- 6413 -- Unconstrained_Array -- 6414 ------------------------- 6415 6416 when Attribute_Unconstrained_Array => 6417 Check_E0; 6418 Check_Type; 6419 Check_Not_Incomplete_Type; 6420 Set_Etype (N, Standard_Boolean); 6421 Set_Is_Static_Expression (N, True); 6422 6423 ------------------------------ 6424 -- Universal_Literal_String -- 6425 ------------------------------ 6426 6427 -- This is a GNAT specific attribute whose prefix must be a named 6428 -- number where the expression is either a single numeric literal, 6429 -- or a numeric literal immediately preceded by a minus sign. The 6430 -- result is equivalent to a string literal containing the text of 6431 -- the literal as it appeared in the source program with a possible 6432 -- leading minus sign. 6433 6434 when Attribute_Universal_Literal_String => 6435 Check_E0; 6436 6437 if not Is_Entity_Name (P) 6438 or else Ekind (Entity (P)) not in Named_Kind 6439 then 6440 Error_Attr_P ("prefix for % attribute must be named number"); 6441 6442 else 6443 declare 6444 Expr : Node_Id; 6445 Negative : Boolean; 6446 S : Source_Ptr; 6447 Src : Source_Buffer_Ptr; 6448 6449 begin 6450 Expr := Original_Node (Expression (Parent (Entity (P)))); 6451 6452 if Nkind (Expr) = N_Op_Minus then 6453 Negative := True; 6454 Expr := Original_Node (Right_Opnd (Expr)); 6455 else 6456 Negative := False; 6457 end if; 6458 6459 if not Nkind_In (Expr, N_Integer_Literal, N_Real_Literal) then 6460 Error_Attr 6461 ("named number for % attribute must be simple literal", N); 6462 end if; 6463 6464 -- Build string literal corresponding to source literal text 6465 6466 Start_String; 6467 6468 if Negative then 6469 Store_String_Char (Get_Char_Code ('-')); 6470 end if; 6471 6472 S := Sloc (Expr); 6473 Src := Source_Text (Get_Source_File_Index (S)); 6474 6475 while Src (S) /= ';' and then Src (S) /= ' ' loop 6476 Store_String_Char (Get_Char_Code (Src (S))); 6477 S := S + 1; 6478 end loop; 6479 6480 -- Now we rewrite the attribute with the string literal 6481 6482 Rewrite (N, 6483 Make_String_Literal (Loc, End_String)); 6484 Analyze (N); 6485 Set_Is_Static_Expression (N, True); 6486 end; 6487 end if; 6488 6489 ------------------------- 6490 -- Unrestricted_Access -- 6491 ------------------------- 6492 6493 -- This is a GNAT specific attribute which is like Access except that 6494 -- all scope checks and checks for aliased views are omitted. It is 6495 -- documented as being equivalent to the use of the Address attribute 6496 -- followed by an unchecked conversion to the target access type. 6497 6498 when Attribute_Unrestricted_Access => 6499 6500 -- If from source, deal with relevant restrictions 6501 6502 if Comes_From_Source (N) then 6503 Check_Restriction (No_Unchecked_Access, N); 6504 6505 if Nkind (P) in N_Has_Entity 6506 and then Present (Entity (P)) 6507 and then Is_Object (Entity (P)) 6508 then 6509 Check_Restriction (No_Implicit_Aliasing, N); 6510 end if; 6511 end if; 6512 6513 if Is_Entity_Name (P) then 6514 Set_Address_Taken (Entity (P)); 6515 end if; 6516 6517 -- It might seem reasonable to call Address_Checks here to apply the 6518 -- same set of semantic checks that we enforce for 'Address (after 6519 -- all we document Unrestricted_Access as being equivalent to the 6520 -- use of Address followed by an Unchecked_Conversion). However, if 6521 -- we do enable these checks, we get multiple failures in both the 6522 -- compiler run-time and in our regression test suite, so we leave 6523 -- out these checks for now. To be investigated further some time??? 6524 6525 -- Address_Checks; 6526 6527 -- Now complete analysis using common access processing 6528 6529 Analyze_Access_Attribute; 6530 6531 ------------ 6532 -- Update -- 6533 ------------ 6534 6535 when Attribute_Update => Update : declare 6536 Common_Typ : Entity_Id; 6537 -- The common type of a multiple component update for a record 6538 6539 Comps : Elist_Id := No_Elist; 6540 -- A list used in the resolution of a record update. It contains the 6541 -- entities of all record components processed so far. 6542 6543 procedure Analyze_Array_Component_Update (Assoc : Node_Id); 6544 -- Analyze and resolve array_component_association Assoc against the 6545 -- index of array type P_Type. 6546 6547 procedure Analyze_Record_Component_Update (Comp : Node_Id); 6548 -- Analyze and resolve record_component_association Comp against 6549 -- record type P_Type. 6550 6551 ------------------------------------ 6552 -- Analyze_Array_Component_Update -- 6553 ------------------------------------ 6554 6555 procedure Analyze_Array_Component_Update (Assoc : Node_Id) is 6556 Expr : Node_Id; 6557 High : Node_Id; 6558 Index : Node_Id; 6559 Index_Typ : Entity_Id; 6560 Low : Node_Id; 6561 6562 begin 6563 -- The current association contains a sequence of indexes denoting 6564 -- an element of a multidimensional array: 6565 6566 -- (Index_1, ..., Index_N) 6567 6568 -- Examine each individual index and resolve it against the proper 6569 -- index type of the array. 6570 6571 if Nkind (First (Choices (Assoc))) = N_Aggregate then 6572 Expr := First (Choices (Assoc)); 6573 while Present (Expr) loop 6574 6575 -- The use of others is illegal (SPARK RM 4.4.1(12)) 6576 6577 if Nkind (Expr) = N_Others_Choice then 6578 Error_Attr 6579 ("others choice not allowed in attribute %", Expr); 6580 6581 -- Otherwise analyze and resolve all indexes 6582 6583 else 6584 Index := First (Expressions (Expr)); 6585 Index_Typ := First_Index (P_Type); 6586 while Present (Index) and then Present (Index_Typ) loop 6587 Analyze_And_Resolve (Index, Etype (Index_Typ)); 6588 Next (Index); 6589 Next_Index (Index_Typ); 6590 end loop; 6591 6592 -- Detect a case where the association either lacks an 6593 -- index or contains an extra index. 6594 6595 if Present (Index) or else Present (Index_Typ) then 6596 Error_Msg_N 6597 ("dimension mismatch in index list", Assoc); 6598 end if; 6599 end if; 6600 6601 Next (Expr); 6602 end loop; 6603 6604 -- The current association denotes either a single component or a 6605 -- range of components of a one dimensional array: 6606 6607 -- 1, 2 .. 5 6608 6609 -- Resolve the index or its high and low bounds (if range) against 6610 -- the proper index type of the array. 6611 6612 else 6613 Index := First (Choices (Assoc)); 6614 Index_Typ := First_Index (P_Type); 6615 6616 if Present (Next_Index (Index_Typ)) then 6617 Error_Msg_N ("too few subscripts in array reference", Assoc); 6618 end if; 6619 6620 while Present (Index) loop 6621 6622 -- The use of others is illegal (SPARK RM 4.4.1(12)) 6623 6624 if Nkind (Index) = N_Others_Choice then 6625 Error_Attr 6626 ("others choice not allowed in attribute %", Index); 6627 6628 -- The index denotes a range of elements 6629 6630 elsif Nkind (Index) = N_Range then 6631 Low := Low_Bound (Index); 6632 High := High_Bound (Index); 6633 6634 Analyze_And_Resolve (Low, Etype (Index_Typ)); 6635 Analyze_And_Resolve (High, Etype (Index_Typ)); 6636 6637 -- Add a range check to ensure that the bounds of the 6638 -- range are within the index type when this cannot be 6639 -- determined statically. 6640 6641 if not Is_OK_Static_Expression (Low) then 6642 Set_Do_Range_Check (Low); 6643 end if; 6644 6645 if not Is_OK_Static_Expression (High) then 6646 Set_Do_Range_Check (High); 6647 end if; 6648 6649 -- Otherwise the index denotes a single element 6650 6651 else 6652 Analyze_And_Resolve (Index, Etype (Index_Typ)); 6653 6654 -- Add a range check to ensure that the index is within 6655 -- the index type when it is not possible to determine 6656 -- this statically. 6657 6658 if not Is_OK_Static_Expression (Index) then 6659 Set_Do_Range_Check (Index); 6660 end if; 6661 end if; 6662 6663 Next (Index); 6664 end loop; 6665 end if; 6666 end Analyze_Array_Component_Update; 6667 6668 ------------------------------------- 6669 -- Analyze_Record_Component_Update -- 6670 ------------------------------------- 6671 6672 procedure Analyze_Record_Component_Update (Comp : Node_Id) is 6673 Comp_Name : constant Name_Id := Chars (Comp); 6674 Base_Typ : Entity_Id; 6675 Comp_Or_Discr : Entity_Id; 6676 6677 begin 6678 -- Find the discriminant or component whose name corresponds to 6679 -- Comp. A simple character comparison is sufficient because all 6680 -- visible names within a record type are unique. 6681 6682 Comp_Or_Discr := First_Entity (P_Type); 6683 while Present (Comp_Or_Discr) loop 6684 if Chars (Comp_Or_Discr) = Comp_Name then 6685 6686 -- Decorate the component reference by setting its entity 6687 -- and type for resolution purposes. 6688 6689 Set_Entity (Comp, Comp_Or_Discr); 6690 Set_Etype (Comp, Etype (Comp_Or_Discr)); 6691 exit; 6692 end if; 6693 6694 Comp_Or_Discr := Next_Entity (Comp_Or_Discr); 6695 end loop; 6696 6697 -- Diagnose an illegal reference 6698 6699 if Present (Comp_Or_Discr) then 6700 if Ekind (Comp_Or_Discr) = E_Discriminant then 6701 Error_Attr 6702 ("attribute % may not modify record discriminants", Comp); 6703 6704 else pragma Assert (Ekind (Comp_Or_Discr) = E_Component); 6705 if Contains (Comps, Comp_Or_Discr) then 6706 Error_Msg_N ("component & already updated", Comp); 6707 6708 -- Mark this component as processed 6709 6710 else 6711 Append_New_Elmt (Comp_Or_Discr, Comps); 6712 end if; 6713 end if; 6714 6715 -- The update aggregate mentions an entity that does not belong to 6716 -- the record type. 6717 6718 else 6719 Error_Msg_N ("& is not a component of aggregate subtype", Comp); 6720 end if; 6721 6722 -- Verify the consistency of types when the current component is 6723 -- part of a miltiple component update. 6724 6725 -- Comp_1, ..., Comp_N => <value> 6726 6727 if Present (Etype (Comp)) then 6728 Base_Typ := Base_Type (Etype (Comp)); 6729 6730 -- Save the type of the first component reference as the 6731 -- remaning references (if any) must resolve to this type. 6732 6733 if No (Common_Typ) then 6734 Common_Typ := Base_Typ; 6735 6736 elsif Base_Typ /= Common_Typ then 6737 Error_Msg_N 6738 ("components in choice list must have same type", Comp); 6739 end if; 6740 end if; 6741 end Analyze_Record_Component_Update; 6742 6743 -- Local variables 6744 6745 Assoc : Node_Id; 6746 Comp : Node_Id; 6747 6748 -- Start of processing for Update 6749 6750 begin 6751 Check_E1; 6752 6753 if not Is_Object_Reference (P) then 6754 Error_Attr_P ("prefix of attribute % must denote an object"); 6755 6756 elsif not Is_Array_Type (P_Type) 6757 and then not Is_Record_Type (P_Type) 6758 then 6759 Error_Attr_P ("prefix of attribute % must be a record or array"); 6760 6761 elsif Is_Limited_View (P_Type) then 6762 Error_Attr ("prefix of attribute % cannot be limited", N); 6763 6764 elsif Nkind (E1) /= N_Aggregate then 6765 Error_Attr ("attribute % requires component association list", N); 6766 end if; 6767 6768 -- Inspect the update aggregate, looking at all the associations and 6769 -- choices. Perform the following checks: 6770 6771 -- 1) Legality of "others" in all cases 6772 -- 2) Legality of <> 6773 -- 3) Component legality for arrays 6774 -- 4) Component legality for records 6775 6776 -- The remaining checks are performed on the expanded attribute 6777 6778 Assoc := First (Component_Associations (E1)); 6779 while Present (Assoc) loop 6780 6781 -- The use of <> is illegal (SPARK RM 4.4.1(1)) 6782 6783 if Box_Present (Assoc) then 6784 Error_Attr 6785 ("default initialization not allowed in attribute %", Assoc); 6786 6787 -- Otherwise process the association 6788 6789 else 6790 Analyze (Expression (Assoc)); 6791 6792 if Is_Array_Type (P_Type) then 6793 Analyze_Array_Component_Update (Assoc); 6794 6795 elsif Is_Record_Type (P_Type) then 6796 6797 -- Reset the common type used in a multiple component update 6798 -- as we are processing the contents of a new association. 6799 6800 Common_Typ := Empty; 6801 6802 Comp := First (Choices (Assoc)); 6803 while Present (Comp) loop 6804 if Nkind (Comp) = N_Identifier then 6805 Analyze_Record_Component_Update (Comp); 6806 6807 -- The use of others is illegal (SPARK RM 4.4.1(5)) 6808 6809 elsif Nkind (Comp) = N_Others_Choice then 6810 Error_Attr 6811 ("others choice not allowed in attribute %", Comp); 6812 6813 -- The name of a record component cannot appear in any 6814 -- other form. 6815 6816 else 6817 Error_Msg_N 6818 ("name should be identifier or OTHERS", Comp); 6819 end if; 6820 6821 Next (Comp); 6822 end loop; 6823 end if; 6824 end if; 6825 6826 Next (Assoc); 6827 end loop; 6828 6829 -- The type of attribute 'Update is that of the prefix 6830 6831 Set_Etype (N, P_Type); 6832 6833 Sem_Warn.Warn_On_Suspicious_Update (N); 6834 end Update; 6835 6836 --------- 6837 -- Val -- 6838 --------- 6839 6840 when Attribute_Val => 6841 Check_E1; 6842 Check_Discrete_Type; 6843 6844 if Is_Boolean_Type (P_Type) then 6845 Error_Msg_Name_1 := Aname; 6846 Error_Msg_Name_2 := Chars (P_Type); 6847 Check_SPARK_05_Restriction 6848 ("attribute% is not allowed for type%", P); 6849 end if; 6850 6851 -- Note, we need a range check in general, but we wait for the 6852 -- Resolve call to do this, since we want to let Eval_Attribute 6853 -- have a chance to find an static illegality first. 6854 6855 Resolve (E1, Any_Integer); 6856 Set_Etype (N, P_Base_Type); 6857 6858 ----------- 6859 -- Valid -- 6860 ----------- 6861 6862 when Attribute_Valid => 6863 Check_E0; 6864 6865 -- Ignore check for object if we have a 'Valid reference generated 6866 -- by the expanded code, since in some cases valid checks can occur 6867 -- on items that are names, but are not objects (e.g. attributes). 6868 6869 if Comes_From_Source (N) then 6870 Check_Object_Reference (P); 6871 end if; 6872 6873 if not Is_Scalar_Type (P_Type) then 6874 Error_Attr_P ("object for % attribute must be of scalar type"); 6875 end if; 6876 6877 -- If the attribute appears within the subtype's own predicate 6878 -- function, then issue a warning that this will cause infinite 6879 -- recursion. 6880 6881 declare 6882 Pred_Func : constant Entity_Id := Predicate_Function (P_Type); 6883 6884 begin 6885 if Present (Pred_Func) and then Current_Scope = Pred_Func then 6886 Error_Msg_N 6887 ("attribute Valid requires a predicate check??", N); 6888 Error_Msg_N ("\and will result in infinite recursion??", N); 6889 end if; 6890 end; 6891 6892 Set_Etype (N, Standard_Boolean); 6893 6894 ------------------- 6895 -- Valid_Scalars -- 6896 ------------------- 6897 6898 when Attribute_Valid_Scalars => 6899 Check_E0; 6900 Check_Object_Reference (P); 6901 Set_Etype (N, Standard_Boolean); 6902 6903 -- Following checks are only for source types 6904 6905 if Comes_From_Source (N) then 6906 if not Scalar_Part_Present (P_Type) then 6907 Error_Attr_P 6908 ("??attribute % always True, no scalars to check"); 6909 end if; 6910 6911 -- Not allowed for unchecked union type 6912 6913 if Has_Unchecked_Union (P_Type) then 6914 Error_Attr_P 6915 ("attribute % not allowed for Unchecked_Union type"); 6916 end if; 6917 end if; 6918 6919 ----------- 6920 -- Value -- 6921 ----------- 6922 6923 when Attribute_Value => 6924 Check_SPARK_05_Restriction_On_Attribute; 6925 Check_E1; 6926 Check_Scalar_Type; 6927 6928 -- Case of enumeration type 6929 6930 -- When an enumeration type appears in an attribute reference, all 6931 -- literals of the type are marked as referenced. This must only be 6932 -- done if the attribute reference appears in the current source. 6933 -- Otherwise the information on references may differ between a 6934 -- normal compilation and one that performs inlining. 6935 6936 if Is_Enumeration_Type (P_Type) 6937 and then In_Extended_Main_Code_Unit (N) 6938 then 6939 Check_Restriction (No_Enumeration_Maps, N); 6940 6941 -- Mark all enumeration literals as referenced, since the use of 6942 -- the Value attribute can implicitly reference any of the 6943 -- literals of the enumeration base type. 6944 6945 declare 6946 Ent : Entity_Id := First_Literal (P_Base_Type); 6947 begin 6948 while Present (Ent) loop 6949 Set_Referenced (Ent); 6950 Next_Literal (Ent); 6951 end loop; 6952 end; 6953 end if; 6954 6955 -- Set Etype before resolving expression because expansion of 6956 -- expression may require enclosing type. Note that the type 6957 -- returned by 'Value is the base type of the prefix type. 6958 6959 Set_Etype (N, P_Base_Type); 6960 Validate_Non_Static_Attribute_Function_Call; 6961 6962 -- Check restriction No_Fixed_IO 6963 6964 if Restriction_Check_Required (No_Fixed_IO) 6965 and then Is_Fixed_Point_Type (P_Type) 6966 then 6967 Check_Restriction (No_Fixed_IO, P); 6968 end if; 6969 6970 ---------------- 6971 -- Value_Size -- 6972 ---------------- 6973 6974 when Attribute_Value_Size => 6975 Check_E0; 6976 Check_Type; 6977 Check_Not_Incomplete_Type; 6978 Set_Etype (N, Universal_Integer); 6979 6980 ------------- 6981 -- Version -- 6982 ------------- 6983 6984 when Attribute_Version => 6985 Check_E0; 6986 Check_Program_Unit; 6987 Set_Etype (N, RTE (RE_Version_String)); 6988 6989 ------------------ 6990 -- Wchar_T_Size -- 6991 ------------------ 6992 6993 when Attribute_Wchar_T_Size => 6994 Standard_Attribute (Interfaces_Wchar_T_Size); 6995 6996 ---------------- 6997 -- Wide_Image -- 6998 ---------------- 6999 7000 when Attribute_Wide_Image => 7001 Analyze_Image_Attribute (Standard_Wide_String); 7002 7003 --------------------- 7004 -- Wide_Wide_Image -- 7005 --------------------- 7006 7007 when Attribute_Wide_Wide_Image => 7008 Analyze_Image_Attribute (Standard_Wide_Wide_String); 7009 7010 ---------------- 7011 -- Wide_Value -- 7012 ---------------- 7013 7014 when Attribute_Wide_Value => 7015 Check_SPARK_05_Restriction_On_Attribute; 7016 Check_E1; 7017 Check_Scalar_Type; 7018 7019 -- Set Etype before resolving expression because expansion 7020 -- of expression may require enclosing type. 7021 7022 Set_Etype (N, P_Type); 7023 Validate_Non_Static_Attribute_Function_Call; 7024 7025 -- Check restriction No_Fixed_IO 7026 7027 if Restriction_Check_Required (No_Fixed_IO) 7028 and then Is_Fixed_Point_Type (P_Type) 7029 then 7030 Check_Restriction (No_Fixed_IO, P); 7031 end if; 7032 7033 --------------------- 7034 -- Wide_Wide_Value -- 7035 --------------------- 7036 7037 when Attribute_Wide_Wide_Value => 7038 Check_E1; 7039 Check_Scalar_Type; 7040 7041 -- Set Etype before resolving expression because expansion 7042 -- of expression may require enclosing type. 7043 7044 Set_Etype (N, P_Type); 7045 Validate_Non_Static_Attribute_Function_Call; 7046 7047 -- Check restriction No_Fixed_IO 7048 7049 if Restriction_Check_Required (No_Fixed_IO) 7050 and then Is_Fixed_Point_Type (P_Type) 7051 then 7052 Check_Restriction (No_Fixed_IO, P); 7053 end if; 7054 7055 --------------------- 7056 -- Wide_Wide_Width -- 7057 --------------------- 7058 7059 when Attribute_Wide_Wide_Width => 7060 Check_E0; 7061 Check_Scalar_Type; 7062 Set_Etype (N, Universal_Integer); 7063 7064 ---------------- 7065 -- Wide_Width -- 7066 ---------------- 7067 7068 when Attribute_Wide_Width => 7069 Check_SPARK_05_Restriction_On_Attribute; 7070 Check_E0; 7071 Check_Scalar_Type; 7072 Set_Etype (N, Universal_Integer); 7073 7074 ----------- 7075 -- Width -- 7076 ----------- 7077 7078 when Attribute_Width => 7079 Check_SPARK_05_Restriction_On_Attribute; 7080 Check_E0; 7081 Check_Scalar_Type; 7082 Set_Etype (N, Universal_Integer); 7083 7084 --------------- 7085 -- Word_Size -- 7086 --------------- 7087 7088 when Attribute_Word_Size => 7089 Standard_Attribute (System_Word_Size); 7090 7091 ----------- 7092 -- Write -- 7093 ----------- 7094 7095 when Attribute_Write => 7096 Check_E2; 7097 Check_Stream_Attribute (TSS_Stream_Write); 7098 Set_Etype (N, Standard_Void_Type); 7099 Resolve (N, Standard_Void_Type); 7100 7101 end case; 7102 7103 -- In SPARK certain attributes (see below) depend on Tasking_State. 7104 -- Ensure that the entity is available for gnat2why by loading it. 7105 -- See SPARK RM 9(18) for the relevant rule. 7106 7107 if GNATprove_Mode then 7108 declare 7109 Unused : Entity_Id; 7110 7111 begin 7112 case Attr_Id is 7113 when Attribute_Callable 7114 | Attribute_Caller 7115 | Attribute_Count 7116 | Attribute_Terminated 7117 => 7118 Unused := RTE (RE_Tasking_State); 7119 7120 when others => 7121 null; 7122 end case; 7123 end; 7124 end if; 7125 7126 -- All errors raise Bad_Attribute, so that we get out before any further 7127 -- damage occurs when an error is detected (for example, if we check for 7128 -- one attribute expression, and the check succeeds, we want to be able 7129 -- to proceed securely assuming that an expression is in fact present. 7130 7131 -- Note: we set the attribute analyzed in this case to prevent any 7132 -- attempt at reanalysis which could generate spurious error msgs. 7133 7134 exception 7135 when Bad_Attribute => 7136 Set_Analyzed (N); 7137 Set_Etype (N, Any_Type); 7138 return; 7139 end Analyze_Attribute; 7140 7141 -------------------- 7142 -- Eval_Attribute -- 7143 -------------------- 7144 7145 procedure Eval_Attribute (N : Node_Id) is 7146 Loc : constant Source_Ptr := Sloc (N); 7147 Aname : constant Name_Id := Attribute_Name (N); 7148 Id : constant Attribute_Id := Get_Attribute_Id (Aname); 7149 P : constant Node_Id := Prefix (N); 7150 7151 C_Type : constant Entity_Id := Etype (N); 7152 -- The type imposed by the context 7153 7154 E1 : Node_Id; 7155 -- First expression, or Empty if none 7156 7157 E2 : Node_Id; 7158 -- Second expression, or Empty if none 7159 7160 P_Entity : Entity_Id; 7161 -- Entity denoted by prefix 7162 7163 P_Type : Entity_Id; 7164 -- The type of the prefix 7165 7166 P_Base_Type : Entity_Id; 7167 -- The base type of the prefix type 7168 7169 P_Root_Type : Entity_Id; 7170 -- The root type of the prefix type 7171 7172 Static : Boolean; 7173 -- True if the result is Static. This is set by the general processing 7174 -- to true if the prefix is static, and all expressions are static. It 7175 -- can be reset as processing continues for particular attributes. This 7176 -- flag can still be True if the reference raises a constraint error. 7177 -- Is_Static_Expression (N) is set to follow this value as it is set 7178 -- and we could always reference this, but it is convenient to have a 7179 -- simple short name to use, since it is frequently referenced. 7180 7181 Lo_Bound, Hi_Bound : Node_Id; 7182 -- Expressions for low and high bounds of type or array index referenced 7183 -- by First, Last, or Length attribute for array, set by Set_Bounds. 7184 7185 CE_Node : Node_Id; 7186 -- Constraint error node used if we have an attribute reference has 7187 -- an argument that raises a constraint error. In this case we replace 7188 -- the attribute with a raise constraint_error node. This is important 7189 -- processing, since otherwise gigi might see an attribute which it is 7190 -- unprepared to deal with. 7191 7192 procedure Check_Concurrent_Discriminant (Bound : Node_Id); 7193 -- If Bound is a reference to a discriminant of a task or protected type 7194 -- occurring within the object's body, rewrite attribute reference into 7195 -- a reference to the corresponding discriminal. Use for the expansion 7196 -- of checks against bounds of entry family index subtypes. 7197 7198 procedure Check_Expressions; 7199 -- In case where the attribute is not foldable, the expressions, if 7200 -- any, of the attribute, are in a non-static context. This procedure 7201 -- performs the required additional checks. 7202 7203 function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean; 7204 -- Determines if the given type has compile time known bounds. Note 7205 -- that we enter the case statement even in cases where the prefix 7206 -- type does NOT have known bounds, so it is important to guard any 7207 -- attempt to evaluate both bounds with a call to this function. 7208 7209 procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint); 7210 -- This procedure is called when the attribute N has a non-static 7211 -- but compile time known value given by Val. It includes the 7212 -- necessary checks for out of range values. 7213 7214 function Fore_Value return Nat; 7215 -- Computes the Fore value for the current attribute prefix, which is 7216 -- known to be a static fixed-point type. Used by Fore and Width. 7217 7218 function Mantissa return Uint; 7219 -- Returns the Mantissa value for the prefix type 7220 7221 procedure Set_Bounds; 7222 -- Used for First, Last and Length attributes applied to an array or 7223 -- array subtype. Sets the variables Lo_Bound and Hi_Bound to the low 7224 -- and high bound expressions for the index referenced by the attribute 7225 -- designator (i.e. the first index if no expression is present, and the 7226 -- N'th index if the value N is present as an expression). Also used for 7227 -- First and Last of scalar types and for First_Valid and Last_Valid. 7228 -- Static is reset to False if the type or index type is not statically 7229 -- constrained. 7230 7231 function Statically_Denotes_Entity (N : Node_Id) return Boolean; 7232 -- Verify that the prefix of a potentially static array attribute 7233 -- satisfies the conditions of 4.9 (14). 7234 7235 ----------------------------------- 7236 -- Check_Concurrent_Discriminant -- 7237 ----------------------------------- 7238 7239 procedure Check_Concurrent_Discriminant (Bound : Node_Id) is 7240 Tsk : Entity_Id; 7241 -- The concurrent (task or protected) type 7242 7243 begin 7244 if Nkind (Bound) = N_Identifier 7245 and then Ekind (Entity (Bound)) = E_Discriminant 7246 and then Is_Concurrent_Record_Type (Scope (Entity (Bound))) 7247 then 7248 Tsk := Corresponding_Concurrent_Type (Scope (Entity (Bound))); 7249 7250 if In_Open_Scopes (Tsk) and then Has_Completion (Tsk) then 7251 7252 -- Find discriminant of original concurrent type, and use 7253 -- its current discriminal, which is the renaming within 7254 -- the task/protected body. 7255 7256 Rewrite (N, 7257 New_Occurrence_Of 7258 (Find_Body_Discriminal (Entity (Bound)), Loc)); 7259 end if; 7260 end if; 7261 end Check_Concurrent_Discriminant; 7262 7263 ----------------------- 7264 -- Check_Expressions -- 7265 ----------------------- 7266 7267 procedure Check_Expressions is 7268 E : Node_Id; 7269 begin 7270 E := E1; 7271 while Present (E) loop 7272 Check_Non_Static_Context (E); 7273 Next (E); 7274 end loop; 7275 end Check_Expressions; 7276 7277 ---------------------------------- 7278 -- Compile_Time_Known_Attribute -- 7279 ---------------------------------- 7280 7281 procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint) is 7282 T : constant Entity_Id := Etype (N); 7283 7284 begin 7285 Fold_Uint (N, Val, False); 7286 7287 -- Check that result is in bounds of the type if it is static 7288 7289 if Is_In_Range (N, T, Assume_Valid => False) then 7290 null; 7291 7292 elsif Is_Out_Of_Range (N, T) then 7293 Apply_Compile_Time_Constraint_Error 7294 (N, "value not in range of}??", CE_Range_Check_Failed); 7295 7296 elsif not Range_Checks_Suppressed (T) then 7297 Enable_Range_Check (N); 7298 7299 else 7300 Set_Do_Range_Check (N, False); 7301 end if; 7302 end Compile_Time_Known_Attribute; 7303 7304 ------------------------------- 7305 -- Compile_Time_Known_Bounds -- 7306 ------------------------------- 7307 7308 function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean is 7309 begin 7310 return 7311 Compile_Time_Known_Value (Type_Low_Bound (Typ)) 7312 and then 7313 Compile_Time_Known_Value (Type_High_Bound (Typ)); 7314 end Compile_Time_Known_Bounds; 7315 7316 ---------------- 7317 -- Fore_Value -- 7318 ---------------- 7319 7320 -- Note that the Fore calculation is based on the actual values 7321 -- of the bounds, and does not take into account possible rounding. 7322 7323 function Fore_Value return Nat is 7324 Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type)); 7325 Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type)); 7326 Small : constant Ureal := Small_Value (P_Type); 7327 Lo_Real : constant Ureal := Lo * Small; 7328 Hi_Real : constant Ureal := Hi * Small; 7329 T : Ureal; 7330 R : Nat; 7331 7332 begin 7333 -- Bounds are given in terms of small units, so first compute 7334 -- proper values as reals. 7335 7336 T := UR_Max (abs Lo_Real, abs Hi_Real); 7337 R := 2; 7338 7339 -- Loop to compute proper value if more than one digit required 7340 7341 while T >= Ureal_10 loop 7342 R := R + 1; 7343 T := T / Ureal_10; 7344 end loop; 7345 7346 return R; 7347 end Fore_Value; 7348 7349 -------------- 7350 -- Mantissa -- 7351 -------------- 7352 7353 -- Table of mantissa values accessed by function Computed using 7354 -- the relation: 7355 7356 -- T'Mantissa = integer next above (D * log(10)/log(2)) + 1) 7357 7358 -- where D is T'Digits (RM83 3.5.7) 7359 7360 Mantissa_Value : constant array (Nat range 1 .. 40) of Nat := ( 7361 1 => 5, 7362 2 => 8, 7363 3 => 11, 7364 4 => 15, 7365 5 => 18, 7366 6 => 21, 7367 7 => 25, 7368 8 => 28, 7369 9 => 31, 7370 10 => 35, 7371 11 => 38, 7372 12 => 41, 7373 13 => 45, 7374 14 => 48, 7375 15 => 51, 7376 16 => 55, 7377 17 => 58, 7378 18 => 61, 7379 19 => 65, 7380 20 => 68, 7381 21 => 71, 7382 22 => 75, 7383 23 => 78, 7384 24 => 81, 7385 25 => 85, 7386 26 => 88, 7387 27 => 91, 7388 28 => 95, 7389 29 => 98, 7390 30 => 101, 7391 31 => 104, 7392 32 => 108, 7393 33 => 111, 7394 34 => 114, 7395 35 => 118, 7396 36 => 121, 7397 37 => 124, 7398 38 => 128, 7399 39 => 131, 7400 40 => 134); 7401 7402 function Mantissa return Uint is 7403 begin 7404 return 7405 UI_From_Int (Mantissa_Value (UI_To_Int (Digits_Value (P_Type)))); 7406 end Mantissa; 7407 7408 ---------------- 7409 -- Set_Bounds -- 7410 ---------------- 7411 7412 procedure Set_Bounds is 7413 Ndim : Nat; 7414 Indx : Node_Id; 7415 Ityp : Entity_Id; 7416 7417 begin 7418 -- For a string literal subtype, we have to construct the bounds. 7419 -- Valid Ada code never applies attributes to string literals, but 7420 -- it is convenient to allow the expander to generate attribute 7421 -- references of this type (e.g. First and Last applied to a string 7422 -- literal). 7423 7424 -- Note that the whole point of the E_String_Literal_Subtype is to 7425 -- avoid this construction of bounds, but the cases in which we 7426 -- have to materialize them are rare enough that we don't worry. 7427 7428 -- The low bound is simply the low bound of the base type. The 7429 -- high bound is computed from the length of the string and this 7430 -- low bound. 7431 7432 if Ekind (P_Type) = E_String_Literal_Subtype then 7433 Ityp := Etype (First_Index (Base_Type (P_Type))); 7434 Lo_Bound := Type_Low_Bound (Ityp); 7435 7436 Hi_Bound := 7437 Make_Integer_Literal (Sloc (P), 7438 Intval => 7439 Expr_Value (Lo_Bound) + String_Literal_Length (P_Type) - 1); 7440 7441 Set_Parent (Hi_Bound, P); 7442 Analyze_And_Resolve (Hi_Bound, Etype (Lo_Bound)); 7443 return; 7444 7445 -- For non-array case, just get bounds of scalar type 7446 7447 elsif Is_Scalar_Type (P_Type) then 7448 Ityp := P_Type; 7449 7450 -- For a fixed-point type, we must freeze to get the attributes 7451 -- of the fixed-point type set now so we can reference them. 7452 7453 if Is_Fixed_Point_Type (P_Type) 7454 and then not Is_Frozen (Base_Type (P_Type)) 7455 and then Compile_Time_Known_Value (Type_Low_Bound (P_Type)) 7456 and then Compile_Time_Known_Value (Type_High_Bound (P_Type)) 7457 then 7458 Freeze_Fixed_Point_Type (Base_Type (P_Type)); 7459 end if; 7460 7461 -- For array case, get type of proper index 7462 7463 else 7464 if No (E1) then 7465 Ndim := 1; 7466 else 7467 Ndim := UI_To_Int (Expr_Value (E1)); 7468 end if; 7469 7470 Indx := First_Index (P_Type); 7471 for J in 1 .. Ndim - 1 loop 7472 Next_Index (Indx); 7473 end loop; 7474 7475 -- If no index type, get out (some other error occurred, and 7476 -- we don't have enough information to complete the job). 7477 7478 if No (Indx) then 7479 Lo_Bound := Error; 7480 Hi_Bound := Error; 7481 return; 7482 end if; 7483 7484 Ityp := Etype (Indx); 7485 end if; 7486 7487 -- A discrete range in an index constraint is allowed to be a 7488 -- subtype indication. This is syntactically a pain, but should 7489 -- not propagate to the entity for the corresponding index subtype. 7490 -- After checking that the subtype indication is legal, the range 7491 -- of the subtype indication should be transfered to the entity. 7492 -- The attributes for the bounds should remain the simple retrievals 7493 -- that they are now. 7494 7495 Lo_Bound := Type_Low_Bound (Ityp); 7496 Hi_Bound := Type_High_Bound (Ityp); 7497 7498 -- If subtype is non-static, result is definitely non-static 7499 7500 if not Is_Static_Subtype (Ityp) then 7501 Static := False; 7502 Set_Is_Static_Expression (N, False); 7503 7504 -- Subtype is static, does it raise CE? 7505 7506 elsif not Is_OK_Static_Subtype (Ityp) then 7507 Set_Raises_Constraint_Error (N); 7508 end if; 7509 end Set_Bounds; 7510 7511 ------------------------------- 7512 -- Statically_Denotes_Entity -- 7513 ------------------------------- 7514 7515 function Statically_Denotes_Entity (N : Node_Id) return Boolean is 7516 E : Entity_Id; 7517 7518 begin 7519 if not Is_Entity_Name (N) then 7520 return False; 7521 else 7522 E := Entity (N); 7523 end if; 7524 7525 return 7526 Nkind (Parent (E)) /= N_Object_Renaming_Declaration 7527 or else Statically_Denotes_Entity (Renamed_Object (E)); 7528 end Statically_Denotes_Entity; 7529 7530 -- Start of processing for Eval_Attribute 7531 7532 begin 7533 -- Initialize result as non-static, will be reset if appropriate 7534 7535 Set_Is_Static_Expression (N, False); 7536 Static := False; 7537 7538 -- Acquire first two expressions (at the moment, no attributes take more 7539 -- than two expressions in any case). 7540 7541 if Present (Expressions (N)) then 7542 E1 := First (Expressions (N)); 7543 E2 := Next (E1); 7544 else 7545 E1 := Empty; 7546 E2 := Empty; 7547 end if; 7548 7549 -- Special processing for Enabled attribute. This attribute has a very 7550 -- special prefix, and the easiest way to avoid lots of special checks 7551 -- to protect this special prefix from causing trouble is to deal with 7552 -- this attribute immediately and be done with it. 7553 7554 if Id = Attribute_Enabled then 7555 7556 -- We skip evaluation if the expander is not active. This is not just 7557 -- an optimization. It is of key importance that we not rewrite the 7558 -- attribute in a generic template, since we want to pick up the 7559 -- setting of the check in the instance, Testing Expander_Active 7560 -- might seem an easy way of doing this, but we need to account for 7561 -- ASIS needs, so check explicitly for a generic context. 7562 7563 if not Inside_A_Generic then 7564 declare 7565 C : constant Check_Id := Get_Check_Id (Chars (P)); 7566 R : Boolean; 7567 7568 begin 7569 if No (E1) then 7570 if C in Predefined_Check_Id then 7571 R := Scope_Suppress.Suppress (C); 7572 else 7573 R := Is_Check_Suppressed (Empty, C); 7574 end if; 7575 7576 else 7577 R := Is_Check_Suppressed (Entity (E1), C); 7578 end if; 7579 7580 Rewrite (N, New_Occurrence_Of (Boolean_Literals (not R), Loc)); 7581 end; 7582 end if; 7583 7584 return; 7585 end if; 7586 7587 -- Attribute 'Img applied to a static enumeration value is static, and 7588 -- we will do the folding right here (things get confused if we let this 7589 -- case go through the normal circuitry). 7590 7591 if Attribute_Name (N) = Name_Img 7592 and then Is_Entity_Name (P) 7593 and then Is_Enumeration_Type (Etype (Entity (P))) 7594 and then Is_OK_Static_Expression (P) 7595 then 7596 declare 7597 Lit : constant Entity_Id := Expr_Value_E (P); 7598 Str : String_Id; 7599 7600 begin 7601 Start_String; 7602 Get_Unqualified_Decoded_Name_String (Chars (Lit)); 7603 Set_Casing (All_Upper_Case); 7604 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 7605 Str := End_String; 7606 7607 Rewrite (N, Make_String_Literal (Loc, Strval => Str)); 7608 Analyze_And_Resolve (N, Standard_String); 7609 Set_Is_Static_Expression (N, True); 7610 end; 7611 7612 return; 7613 end if; 7614 7615 -- Special processing for cases where the prefix is an object. For this 7616 -- purpose, a string literal counts as an object (attributes of string 7617 -- literals can only appear in generated code). 7618 7619 if Is_Object_Reference (P) or else Nkind (P) = N_String_Literal then 7620 7621 -- For Component_Size, the prefix is an array object, and we apply 7622 -- the attribute to the type of the object. This is allowed for both 7623 -- unconstrained and constrained arrays, since the bounds have no 7624 -- influence on the value of this attribute. 7625 7626 if Id = Attribute_Component_Size then 7627 P_Entity := Etype (P); 7628 7629 -- For Enum_Rep, evaluation depends on the nature of the prefix and 7630 -- the optional argument. 7631 7632 elsif Id = Attribute_Enum_Rep then 7633 if Is_Entity_Name (P) then 7634 7635 declare 7636 Enum_Expr : Node_Id; 7637 -- The enumeration-type expression of interest 7638 7639 begin 7640 -- P'Enum_Rep case 7641 7642 if Ekind_In (Entity (P), E_Constant, 7643 E_Enumeration_Literal) 7644 then 7645 Enum_Expr := P; 7646 7647 -- Enum_Type'Enum_Rep (E1) case 7648 7649 elsif Is_Enumeration_Type (Entity (P)) then 7650 Enum_Expr := E1; 7651 7652 -- Otherwise the attribute must be expanded into a 7653 -- conversion and evaluated at run time. 7654 7655 else 7656 Check_Expressions; 7657 return; 7658 end if; 7659 7660 -- We can fold if the expression is an enumeration 7661 -- literal, or if it denotes a constant whose value 7662 -- is known at compile time. 7663 7664 if Nkind (Enum_Expr) in N_Has_Entity 7665 and then (Ekind (Entity (Enum_Expr)) = 7666 E_Enumeration_Literal 7667 or else 7668 (Ekind (Entity (Enum_Expr)) = E_Constant 7669 and then Nkind (Parent (Entity (Enum_Expr))) = 7670 N_Object_Declaration 7671 and then Compile_Time_Known_Value 7672 (Expression (Parent (Entity (P)))))) 7673 then 7674 P_Entity := Etype (P); 7675 else 7676 Check_Expressions; 7677 return; 7678 end if; 7679 end; 7680 7681 -- Otherwise the attribute is illegal, do not attempt to perform 7682 -- any kind of folding. 7683 7684 else 7685 return; 7686 end if; 7687 7688 -- For First and Last, the prefix is an array object, and we apply 7689 -- the attribute to the type of the array, but we need a constrained 7690 -- type for this, so we use the actual subtype if available. 7691 7692 elsif Id = Attribute_First or else 7693 Id = Attribute_Last or else 7694 Id = Attribute_Length 7695 then 7696 declare 7697 AS : constant Entity_Id := Get_Actual_Subtype_If_Available (P); 7698 7699 begin 7700 if Present (AS) and then Is_Constrained (AS) then 7701 P_Entity := AS; 7702 7703 -- If we have an unconstrained type we cannot fold 7704 7705 else 7706 Check_Expressions; 7707 return; 7708 end if; 7709 end; 7710 7711 -- For Size, give size of object if available, otherwise we 7712 -- cannot fold Size. 7713 7714 elsif Id = Attribute_Size then 7715 if Is_Entity_Name (P) 7716 and then Known_Esize (Entity (P)) 7717 then 7718 Compile_Time_Known_Attribute (N, Esize (Entity (P))); 7719 return; 7720 7721 else 7722 Check_Expressions; 7723 return; 7724 end if; 7725 7726 -- For Alignment, give size of object if available, otherwise we 7727 -- cannot fold Alignment. 7728 7729 elsif Id = Attribute_Alignment then 7730 if Is_Entity_Name (P) 7731 and then Known_Alignment (Entity (P)) 7732 then 7733 Fold_Uint (N, Alignment (Entity (P)), Static); 7734 return; 7735 7736 else 7737 Check_Expressions; 7738 return; 7739 end if; 7740 7741 -- For Lock_Free, we apply the attribute to the type of the object. 7742 -- This is allowed since we have already verified that the type is a 7743 -- protected type. 7744 7745 elsif Id = Attribute_Lock_Free then 7746 P_Entity := Etype (P); 7747 7748 -- No other attributes for objects are folded 7749 7750 else 7751 Check_Expressions; 7752 return; 7753 end if; 7754 7755 -- Cases where P is not an object. Cannot do anything if P is not the 7756 -- name of an entity. 7757 7758 elsif not Is_Entity_Name (P) then 7759 Check_Expressions; 7760 return; 7761 7762 -- Otherwise get prefix entity 7763 7764 else 7765 P_Entity := Entity (P); 7766 end if; 7767 7768 -- If we are asked to evaluate an attribute where the prefix is a 7769 -- non-frozen generic actual type whose RM_Size is still set to zero, 7770 -- then abandon the effort. 7771 7772 if Is_Type (P_Entity) 7773 and then (not Is_Frozen (P_Entity) 7774 and then Is_Generic_Actual_Type (P_Entity) 7775 and then RM_Size (P_Entity) = 0) 7776 7777 -- However, the attribute Unconstrained_Array must be evaluated, 7778 -- since it is documented to be a static attribute (and can for 7779 -- example appear in a Compile_Time_Warning pragma). The frozen 7780 -- status of the type does not affect its evaluation. 7781 7782 and then Id /= Attribute_Unconstrained_Array 7783 then 7784 return; 7785 end if; 7786 7787 -- At this stage P_Entity is the entity to which the attribute 7788 -- is to be applied. This is usually simply the entity of the 7789 -- prefix, except in some cases of attributes for objects, where 7790 -- as described above, we apply the attribute to the object type. 7791 7792 -- Here is where we make sure that static attributes are properly 7793 -- marked as such. These are attributes whose prefix is a static 7794 -- scalar subtype, whose result is scalar, and whose arguments, if 7795 -- present, are static scalar expressions. Note that such references 7796 -- are static expressions even if they raise Constraint_Error. 7797 7798 -- For example, Boolean'Pos (1/0 = 0) is a static expression, even 7799 -- though evaluating it raises constraint error. This means that a 7800 -- declaration like: 7801 7802 -- X : constant := (if True then 1 else Boolean'Pos (1/0 = 0)); 7803 7804 -- is legal, since here this expression appears in a statically 7805 -- unevaluated position, so it does not actually raise an exception. 7806 7807 if Is_Scalar_Type (P_Entity) 7808 and then (not Is_Generic_Type (P_Entity)) 7809 and then Is_Static_Subtype (P_Entity) 7810 and then Is_Scalar_Type (Etype (N)) 7811 and then 7812 (No (E1) 7813 or else (Is_Static_Expression (E1) 7814 and then Is_Scalar_Type (Etype (E1)))) 7815 and then 7816 (No (E2) 7817 or else (Is_Static_Expression (E2) 7818 and then Is_Scalar_Type (Etype (E1)))) 7819 then 7820 Static := True; 7821 Set_Is_Static_Expression (N, True); 7822 end if; 7823 7824 -- First foldable possibility is a scalar or array type (RM 4.9(7)) 7825 -- that is not generic (generic types are eliminated by RM 4.9(25)). 7826 -- Note we allow non-static non-generic types at this stage as further 7827 -- described below. 7828 7829 if Is_Type (P_Entity) 7830 and then (Is_Scalar_Type (P_Entity) or Is_Array_Type (P_Entity)) 7831 and then (not Is_Generic_Type (P_Entity)) 7832 then 7833 P_Type := P_Entity; 7834 7835 -- Second foldable possibility is an array object (RM 4.9(8)) 7836 7837 elsif Ekind_In (P_Entity, E_Variable, E_Constant) 7838 and then Is_Array_Type (Etype (P_Entity)) 7839 and then (not Is_Generic_Type (Etype (P_Entity))) 7840 then 7841 P_Type := Etype (P_Entity); 7842 7843 -- If the entity is an array constant with an unconstrained nominal 7844 -- subtype then get the type from the initial value. If the value has 7845 -- been expanded into assignments, there is no expression and the 7846 -- attribute reference remains dynamic. 7847 7848 -- We could do better here and retrieve the type ??? 7849 7850 if Ekind (P_Entity) = E_Constant 7851 and then not Is_Constrained (P_Type) 7852 then 7853 if No (Constant_Value (P_Entity)) then 7854 return; 7855 else 7856 P_Type := Etype (Constant_Value (P_Entity)); 7857 end if; 7858 end if; 7859 7860 -- Definite must be folded if the prefix is not a generic type, that 7861 -- is to say if we are within an instantiation. Same processing applies 7862 -- to the GNAT attributes Atomic_Always_Lock_Free, Has_Discriminants, 7863 -- Lock_Free, Type_Class, Has_Tagged_Value, and Unconstrained_Array. 7864 7865 elsif (Id = Attribute_Atomic_Always_Lock_Free or else 7866 Id = Attribute_Definite or else 7867 Id = Attribute_Has_Access_Values or else 7868 Id = Attribute_Has_Discriminants or else 7869 Id = Attribute_Has_Tagged_Values or else 7870 Id = Attribute_Lock_Free or else 7871 Id = Attribute_Type_Class or else 7872 Id = Attribute_Unconstrained_Array or else 7873 Id = Attribute_Max_Alignment_For_Allocation) 7874 and then not Is_Generic_Type (P_Entity) 7875 then 7876 P_Type := P_Entity; 7877 7878 -- We can fold 'Size applied to a type if the size is known (as happens 7879 -- for a size from an attribute definition clause). At this stage, this 7880 -- can happen only for types (e.g. record types) for which the size is 7881 -- always non-static. We exclude generic types from consideration (since 7882 -- they have bogus sizes set within templates). 7883 7884 elsif Id = Attribute_Size 7885 and then Is_Type (P_Entity) 7886 and then (not Is_Generic_Type (P_Entity)) 7887 and then Known_Static_RM_Size (P_Entity) 7888 then 7889 Compile_Time_Known_Attribute (N, RM_Size (P_Entity)); 7890 return; 7891 7892 -- We can fold 'Alignment applied to a type if the alignment is known 7893 -- (as happens for an alignment from an attribute definition clause). 7894 -- At this stage, this can happen only for types (e.g. record types) for 7895 -- which the size is always non-static. We exclude generic types from 7896 -- consideration (since they have bogus sizes set within templates). 7897 7898 elsif Id = Attribute_Alignment 7899 and then Is_Type (P_Entity) 7900 and then (not Is_Generic_Type (P_Entity)) 7901 and then Known_Alignment (P_Entity) 7902 then 7903 Compile_Time_Known_Attribute (N, Alignment (P_Entity)); 7904 return; 7905 7906 -- If this is an access attribute that is known to fail accessibility 7907 -- check, rewrite accordingly. 7908 7909 elsif Attribute_Name (N) = Name_Access 7910 and then Raises_Constraint_Error (N) 7911 then 7912 Rewrite (N, 7913 Make_Raise_Program_Error (Loc, 7914 Reason => PE_Accessibility_Check_Failed)); 7915 Set_Etype (N, C_Type); 7916 return; 7917 7918 -- No other cases are foldable (they certainly aren't static, and at 7919 -- the moment we don't try to fold any cases other than the ones above). 7920 7921 else 7922 Check_Expressions; 7923 return; 7924 end if; 7925 7926 -- If either attribute or the prefix is Any_Type, then propagate 7927 -- Any_Type to the result and don't do anything else at all. 7928 7929 if P_Type = Any_Type 7930 or else (Present (E1) and then Etype (E1) = Any_Type) 7931 or else (Present (E2) and then Etype (E2) = Any_Type) 7932 then 7933 Set_Etype (N, Any_Type); 7934 return; 7935 end if; 7936 7937 -- Scalar subtype case. We have not yet enforced the static requirement 7938 -- of (RM 4.9(7)) and we don't intend to just yet, since there are cases 7939 -- of non-static attribute references (e.g. S'Digits for a non-static 7940 -- floating-point type, which we can compute at compile time). 7941 7942 -- Note: this folding of non-static attributes is not simply a case of 7943 -- optimization. For many of the attributes affected, Gigi cannot handle 7944 -- the attribute and depends on the front end having folded them away. 7945 7946 -- Note: although we don't require staticness at this stage, we do set 7947 -- the Static variable to record the staticness, for easy reference by 7948 -- those attributes where it matters (e.g. Succ and Pred), and also to 7949 -- be used to ensure that non-static folded things are not marked as 7950 -- being static (a check that is done right at the end). 7951 7952 P_Root_Type := Root_Type (P_Type); 7953 P_Base_Type := Base_Type (P_Type); 7954 7955 -- If the root type or base type is generic, then we cannot fold. This 7956 -- test is needed because subtypes of generic types are not always 7957 -- marked as being generic themselves (which seems odd???) 7958 7959 if Is_Generic_Type (P_Root_Type) 7960 or else Is_Generic_Type (P_Base_Type) 7961 then 7962 return; 7963 end if; 7964 7965 if Is_Scalar_Type (P_Type) then 7966 if not Is_Static_Subtype (P_Type) then 7967 Static := False; 7968 Set_Is_Static_Expression (N, False); 7969 elsif not Is_OK_Static_Subtype (P_Type) then 7970 Set_Raises_Constraint_Error (N); 7971 end if; 7972 7973 -- Array case. We enforce the constrained requirement of (RM 4.9(7-8)) 7974 -- since we can't do anything with unconstrained arrays. In addition, 7975 -- only the First, Last and Length attributes are possibly static. 7976 7977 -- Atomic_Always_Lock_Free, Definite, Has_Access_Values, 7978 -- Has_Discriminants, Has_Tagged_Values, Lock_Free, Type_Class, and 7979 -- Unconstrained_Array are again exceptions, because they apply as well 7980 -- to unconstrained types. 7981 7982 -- In addition Component_Size is an exception since it is possibly 7983 -- foldable, even though it is never static, and it does apply to 7984 -- unconstrained arrays. Furthermore, it is essential to fold this 7985 -- in the packed case, since otherwise the value will be incorrect. 7986 7987 elsif Id = Attribute_Atomic_Always_Lock_Free or else 7988 Id = Attribute_Definite or else 7989 Id = Attribute_Has_Access_Values or else 7990 Id = Attribute_Has_Discriminants or else 7991 Id = Attribute_Has_Tagged_Values or else 7992 Id = Attribute_Lock_Free or else 7993 Id = Attribute_Type_Class or else 7994 Id = Attribute_Unconstrained_Array or else 7995 Id = Attribute_Component_Size 7996 then 7997 Static := False; 7998 Set_Is_Static_Expression (N, False); 7999 8000 elsif Id /= Attribute_Max_Alignment_For_Allocation then 8001 if not Is_Constrained (P_Type) 8002 or else (Id /= Attribute_First and then 8003 Id /= Attribute_Last and then 8004 Id /= Attribute_Length) 8005 then 8006 Check_Expressions; 8007 return; 8008 end if; 8009 8010 -- The rules in (RM 4.9(7,8)) require a static array, but as in the 8011 -- scalar case, we hold off on enforcing staticness, since there are 8012 -- cases which we can fold at compile time even though they are not 8013 -- static (e.g. 'Length applied to a static index, even though other 8014 -- non-static indexes make the array type non-static). This is only 8015 -- an optimization, but it falls out essentially free, so why not. 8016 -- Again we compute the variable Static for easy reference later 8017 -- (note that no array attributes are static in Ada 83). 8018 8019 -- We also need to set Static properly for subsequent legality checks 8020 -- which might otherwise accept non-static constants in contexts 8021 -- where they are not legal. 8022 8023 Static := 8024 Ada_Version >= Ada_95 and then Statically_Denotes_Entity (P); 8025 Set_Is_Static_Expression (N, Static); 8026 8027 declare 8028 Nod : Node_Id; 8029 8030 begin 8031 Nod := First_Index (P_Type); 8032 8033 -- The expression is static if the array type is constrained 8034 -- by given bounds, and not by an initial expression. Constant 8035 -- strings are static in any case. 8036 8037 if Root_Type (P_Type) /= Standard_String then 8038 Static := 8039 Static and then not Is_Constr_Subt_For_U_Nominal (P_Type); 8040 Set_Is_Static_Expression (N, Static); 8041 end if; 8042 8043 while Present (Nod) loop 8044 if not Is_Static_Subtype (Etype (Nod)) then 8045 Static := False; 8046 Set_Is_Static_Expression (N, False); 8047 8048 elsif not Is_OK_Static_Subtype (Etype (Nod)) then 8049 Set_Raises_Constraint_Error (N); 8050 Static := False; 8051 Set_Is_Static_Expression (N, False); 8052 end if; 8053 8054 -- If however the index type is generic, or derived from 8055 -- one, attributes cannot be folded. 8056 8057 if Is_Generic_Type (Root_Type (Etype (Nod))) 8058 and then Id /= Attribute_Component_Size 8059 then 8060 return; 8061 end if; 8062 8063 Next_Index (Nod); 8064 end loop; 8065 end; 8066 end if; 8067 8068 -- Check any expressions that are present. Note that these expressions, 8069 -- depending on the particular attribute type, are either part of the 8070 -- attribute designator, or they are arguments in a case where the 8071 -- attribute reference returns a function. In the latter case, the 8072 -- rule in (RM 4.9(22)) applies and in particular requires the type 8073 -- of the expressions to be scalar in order for the attribute to be 8074 -- considered to be static. 8075 8076 declare 8077 E : Node_Id; 8078 8079 begin 8080 E := E1; 8081 8082 while Present (E) loop 8083 8084 -- If expression is not static, then the attribute reference 8085 -- result certainly cannot be static. 8086 8087 if not Is_Static_Expression (E) then 8088 Static := False; 8089 Set_Is_Static_Expression (N, False); 8090 end if; 8091 8092 if Raises_Constraint_Error (E) then 8093 Set_Raises_Constraint_Error (N); 8094 end if; 8095 8096 -- If the result is not known at compile time, or is not of 8097 -- a scalar type, then the result is definitely not static, 8098 -- so we can quit now. 8099 8100 if not Compile_Time_Known_Value (E) 8101 or else not Is_Scalar_Type (Etype (E)) 8102 then 8103 -- An odd special case, if this is a Pos attribute, this 8104 -- is where we need to apply a range check since it does 8105 -- not get done anywhere else. 8106 8107 if Id = Attribute_Pos then 8108 if Is_Integer_Type (Etype (E)) then 8109 Apply_Range_Check (E, Etype (N)); 8110 end if; 8111 end if; 8112 8113 Check_Expressions; 8114 return; 8115 8116 -- If the expression raises a constraint error, then so does 8117 -- the attribute reference. We keep going in this case because 8118 -- we are still interested in whether the attribute reference 8119 -- is static even if it is not static. 8120 8121 elsif Raises_Constraint_Error (E) then 8122 Set_Raises_Constraint_Error (N); 8123 end if; 8124 8125 Next (E); 8126 end loop; 8127 8128 if Raises_Constraint_Error (Prefix (N)) then 8129 Set_Is_Static_Expression (N, False); 8130 return; 8131 end if; 8132 end; 8133 8134 -- Deal with the case of a static attribute reference that raises 8135 -- constraint error. The Raises_Constraint_Error flag will already 8136 -- have been set, and the Static flag shows whether the attribute 8137 -- reference is static. In any case we certainly can't fold such an 8138 -- attribute reference. 8139 8140 -- Note that the rewriting of the attribute node with the constraint 8141 -- error node is essential in this case, because otherwise Gigi might 8142 -- blow up on one of the attributes it never expects to see. 8143 8144 -- The constraint_error node must have the type imposed by the context, 8145 -- to avoid spurious errors in the enclosing expression. 8146 8147 if Raises_Constraint_Error (N) then 8148 CE_Node := 8149 Make_Raise_Constraint_Error (Sloc (N), 8150 Reason => CE_Range_Check_Failed); 8151 Set_Etype (CE_Node, Etype (N)); 8152 Set_Raises_Constraint_Error (CE_Node); 8153 Check_Expressions; 8154 Rewrite (N, Relocate_Node (CE_Node)); 8155 Set_Raises_Constraint_Error (N, True); 8156 return; 8157 end if; 8158 8159 -- At this point we have a potentially foldable attribute reference. 8160 -- If Static is set, then the attribute reference definitely obeys 8161 -- the requirements in (RM 4.9(7,8,22)), and it definitely can be 8162 -- folded. If Static is not set, then the attribute may or may not 8163 -- be foldable, and the individual attribute processing routines 8164 -- test Static as required in cases where it makes a difference. 8165 8166 -- In the case where Static is not set, we do know that all the 8167 -- expressions present are at least known at compile time (we assumed 8168 -- above that if this was not the case, then there was no hope of static 8169 -- evaluation). However, we did not require that the bounds of the 8170 -- prefix type be compile time known, let alone static). That's because 8171 -- there are many attributes that can be computed at compile time on 8172 -- non-static subtypes, even though such references are not static 8173 -- expressions. 8174 8175 -- For VAX float, the root type is an IEEE type. So make sure to use the 8176 -- base type instead of the root-type for floating point attributes. 8177 8178 case Id is 8179 8180 -- Attributes related to Ada 2012 iterators; nothing to evaluate for 8181 -- these. 8182 8183 when Attribute_Constant_Indexing 8184 | Attribute_Default_Iterator 8185 | Attribute_Implicit_Dereference 8186 | Attribute_Iterator_Element 8187 | Attribute_Iterable 8188 | Attribute_Variable_Indexing 8189 => 8190 null; 8191 8192 -- Internal attributes used to deal with Ada 2012 delayed aspects. 8193 -- These were already rejected by the parser. Thus they shouldn't 8194 -- appear here. 8195 8196 when Internal_Attribute_Id => 8197 raise Program_Error; 8198 8199 -------------- 8200 -- Adjacent -- 8201 -------------- 8202 8203 when Attribute_Adjacent => 8204 Fold_Ureal 8205 (N, 8206 Eval_Fat.Adjacent 8207 (P_Base_Type, Expr_Value_R (E1), Expr_Value_R (E2)), 8208 Static); 8209 8210 --------- 8211 -- Aft -- 8212 --------- 8213 8214 when Attribute_Aft => 8215 Fold_Uint (N, Aft_Value (P_Type), Static); 8216 8217 --------------- 8218 -- Alignment -- 8219 --------------- 8220 8221 when Attribute_Alignment => Alignment_Block : declare 8222 P_TypeA : constant Entity_Id := Underlying_Type (P_Type); 8223 8224 begin 8225 -- Fold if alignment is set and not otherwise 8226 8227 if Known_Alignment (P_TypeA) then 8228 Fold_Uint (N, Alignment (P_TypeA), Static); 8229 end if; 8230 end Alignment_Block; 8231 8232 ----------------------------- 8233 -- Atomic_Always_Lock_Free -- 8234 ----------------------------- 8235 8236 -- Atomic_Always_Lock_Free attribute is a Boolean, thus no need to fold 8237 -- here. 8238 8239 when Attribute_Atomic_Always_Lock_Free => Atomic_Always_Lock_Free : 8240 declare 8241 V : constant Entity_Id := 8242 Boolean_Literals 8243 (Support_Atomic_Primitives_On_Target 8244 and then Support_Atomic_Primitives (P_Type)); 8245 8246 begin 8247 Rewrite (N, New_Occurrence_Of (V, Loc)); 8248 8249 -- Analyze and resolve as boolean. Note that this attribute is a 8250 -- static attribute in GNAT. 8251 8252 Analyze_And_Resolve (N, Standard_Boolean); 8253 Static := True; 8254 Set_Is_Static_Expression (N, True); 8255 end Atomic_Always_Lock_Free; 8256 8257 --------- 8258 -- Bit -- 8259 --------- 8260 8261 -- Bit can never be folded 8262 8263 when Attribute_Bit => 8264 null; 8265 8266 ------------------ 8267 -- Body_Version -- 8268 ------------------ 8269 8270 -- Body_version can never be static 8271 8272 when Attribute_Body_Version => 8273 null; 8274 8275 ------------- 8276 -- Ceiling -- 8277 ------------- 8278 8279 when Attribute_Ceiling => 8280 Fold_Ureal 8281 (N, Eval_Fat.Ceiling (P_Base_Type, Expr_Value_R (E1)), Static); 8282 8283 -------------------- 8284 -- Component_Size -- 8285 -------------------- 8286 8287 when Attribute_Component_Size => 8288 if Known_Static_Component_Size (P_Type) then 8289 Fold_Uint (N, Component_Size (P_Type), Static); 8290 end if; 8291 8292 ------------- 8293 -- Compose -- 8294 ------------- 8295 8296 when Attribute_Compose => 8297 Fold_Ureal 8298 (N, 8299 Eval_Fat.Compose (P_Base_Type, Expr_Value_R (E1), Expr_Value (E2)), 8300 Static); 8301 8302 ----------------- 8303 -- Constrained -- 8304 ----------------- 8305 8306 -- Constrained is never folded for now, there may be cases that 8307 -- could be handled at compile time. To be looked at later. 8308 8309 when Attribute_Constrained => 8310 8311 -- The expander might fold it and set the static flag accordingly, 8312 -- but with expansion disabled (as in ASIS), it remains as an 8313 -- attribute reference, and this reference is not static. 8314 8315 Set_Is_Static_Expression (N, False); 8316 null; 8317 8318 --------------- 8319 -- Copy_Sign -- 8320 --------------- 8321 8322 when Attribute_Copy_Sign => 8323 Fold_Ureal 8324 (N, 8325 Eval_Fat.Copy_Sign 8326 (P_Base_Type, Expr_Value_R (E1), Expr_Value_R (E2)), 8327 Static); 8328 8329 -------------- 8330 -- Definite -- 8331 -------------- 8332 8333 when Attribute_Definite => 8334 Rewrite (N, New_Occurrence_Of ( 8335 Boolean_Literals (Is_Definite_Subtype (P_Entity)), Loc)); 8336 Analyze_And_Resolve (N, Standard_Boolean); 8337 8338 ----------- 8339 -- Delta -- 8340 ----------- 8341 8342 when Attribute_Delta => 8343 Fold_Ureal (N, Delta_Value (P_Type), True); 8344 8345 ------------ 8346 -- Denorm -- 8347 ------------ 8348 8349 when Attribute_Denorm => 8350 Fold_Uint 8351 (N, UI_From_Int (Boolean'Pos (Has_Denormals (P_Type))), Static); 8352 8353 --------------------- 8354 -- Descriptor_Size -- 8355 --------------------- 8356 8357 when Attribute_Descriptor_Size => 8358 null; 8359 8360 ------------ 8361 -- Digits -- 8362 ------------ 8363 8364 when Attribute_Digits => 8365 Fold_Uint (N, Digits_Value (P_Type), Static); 8366 8367 ---------- 8368 -- Emax -- 8369 ---------- 8370 8371 when Attribute_Emax => 8372 8373 -- Ada 83 attribute is defined as (RM83 3.5.8) 8374 8375 -- T'Emax = 4 * T'Mantissa 8376 8377 Fold_Uint (N, 4 * Mantissa, Static); 8378 8379 -------------- 8380 -- Enum_Rep -- 8381 -------------- 8382 8383 when Attribute_Enum_Rep => Enum_Rep : declare 8384 Val : Node_Id; 8385 8386 begin 8387 -- The attribute appears in the form: 8388 8389 -- Enum_Typ'Enum_Rep (Const) 8390 -- Enum_Typ'Enum_Rep (Enum_Lit) 8391 8392 if Present (E1) then 8393 Val := E1; 8394 8395 -- Otherwise the prefix denotes a constant or enumeration literal: 8396 8397 -- Const'Enum_Rep 8398 -- Enum_Lit'Enum_Rep 8399 8400 else 8401 Val := P; 8402 end if; 8403 8404 -- For an enumeration type with a non-standard representation use 8405 -- the Enumeration_Rep field of the proper constant. Note that this 8406 -- will not work for types Character/Wide_[Wide-]Character, since no 8407 -- real entities are created for the enumeration literals, but that 8408 -- does not matter since these two types do not have non-standard 8409 -- representations anyway. 8410 8411 if Is_Enumeration_Type (P_Type) 8412 and then Has_Non_Standard_Rep (P_Type) 8413 then 8414 Fold_Uint (N, Enumeration_Rep (Expr_Value_E (Val)), Static); 8415 8416 -- For enumeration types with standard representations and all other 8417 -- cases (i.e. all integer and modular types), Enum_Rep is equivalent 8418 -- to Pos. 8419 8420 else 8421 Fold_Uint (N, Expr_Value (Val), Static); 8422 end if; 8423 end Enum_Rep; 8424 8425 -------------- 8426 -- Enum_Val -- 8427 -------------- 8428 8429 when Attribute_Enum_Val => Enum_Val : declare 8430 Lit : Node_Id; 8431 8432 begin 8433 -- We have something like Enum_Type'Enum_Val (23), so search for a 8434 -- corresponding value in the list of Enum_Rep values for the type. 8435 8436 Lit := First_Literal (P_Base_Type); 8437 loop 8438 if Enumeration_Rep (Lit) = Expr_Value (E1) then 8439 Fold_Uint (N, Enumeration_Pos (Lit), Static); 8440 exit; 8441 end if; 8442 8443 Next_Literal (Lit); 8444 8445 if No (Lit) then 8446 Apply_Compile_Time_Constraint_Error 8447 (N, "no representation value matches", 8448 CE_Range_Check_Failed, 8449 Warn => not Static); 8450 exit; 8451 end if; 8452 end loop; 8453 end Enum_Val; 8454 8455 ------------- 8456 -- Epsilon -- 8457 ------------- 8458 8459 when Attribute_Epsilon => 8460 8461 -- Ada 83 attribute is defined as (RM83 3.5.8) 8462 8463 -- T'Epsilon = 2.0**(1 - T'Mantissa) 8464 8465 Fold_Ureal (N, Ureal_2 ** (1 - Mantissa), True); 8466 8467 -------------- 8468 -- Exponent -- 8469 -------------- 8470 8471 when Attribute_Exponent => 8472 Fold_Uint (N, 8473 Eval_Fat.Exponent (P_Base_Type, Expr_Value_R (E1)), Static); 8474 8475 ----------------------- 8476 -- Finalization_Size -- 8477 ----------------------- 8478 8479 when Attribute_Finalization_Size => 8480 null; 8481 8482 ----------- 8483 -- First -- 8484 ----------- 8485 8486 when Attribute_First => 8487 Set_Bounds; 8488 8489 if Compile_Time_Known_Value (Lo_Bound) then 8490 if Is_Real_Type (P_Type) then 8491 Fold_Ureal (N, Expr_Value_R (Lo_Bound), Static); 8492 else 8493 Fold_Uint (N, Expr_Value (Lo_Bound), Static); 8494 end if; 8495 8496 else 8497 Check_Concurrent_Discriminant (Lo_Bound); 8498 end if; 8499 8500 ----------------- 8501 -- First_Valid -- 8502 ----------------- 8503 8504 when Attribute_First_Valid => 8505 if Has_Predicates (P_Type) 8506 and then Has_Static_Predicate (P_Type) 8507 then 8508 declare 8509 FirstN : constant Node_Id := 8510 First (Static_Discrete_Predicate (P_Type)); 8511 begin 8512 if Nkind (FirstN) = N_Range then 8513 Fold_Uint (N, Expr_Value (Low_Bound (FirstN)), Static); 8514 else 8515 Fold_Uint (N, Expr_Value (FirstN), Static); 8516 end if; 8517 end; 8518 8519 else 8520 Set_Bounds; 8521 Fold_Uint (N, Expr_Value (Lo_Bound), Static); 8522 end if; 8523 8524 ----------------- 8525 -- Fixed_Value -- 8526 ----------------- 8527 8528 when Attribute_Fixed_Value => 8529 null; 8530 8531 ----------- 8532 -- Floor -- 8533 ----------- 8534 8535 when Attribute_Floor => 8536 Fold_Ureal 8537 (N, Eval_Fat.Floor (P_Base_Type, Expr_Value_R (E1)), Static); 8538 8539 ---------- 8540 -- Fore -- 8541 ---------- 8542 8543 when Attribute_Fore => 8544 if Compile_Time_Known_Bounds (P_Type) then 8545 Fold_Uint (N, UI_From_Int (Fore_Value), Static); 8546 end if; 8547 8548 -------------- 8549 -- Fraction -- 8550 -------------- 8551 8552 when Attribute_Fraction => 8553 Fold_Ureal 8554 (N, Eval_Fat.Fraction (P_Base_Type, Expr_Value_R (E1)), Static); 8555 8556 ----------------------- 8557 -- Has_Access_Values -- 8558 ----------------------- 8559 8560 when Attribute_Has_Access_Values => 8561 Rewrite (N, New_Occurrence_Of 8562 (Boolean_Literals (Has_Access_Values (P_Root_Type)), Loc)); 8563 Analyze_And_Resolve (N, Standard_Boolean); 8564 8565 ----------------------- 8566 -- Has_Discriminants -- 8567 ----------------------- 8568 8569 when Attribute_Has_Discriminants => 8570 Rewrite (N, New_Occurrence_Of ( 8571 Boolean_Literals (Has_Discriminants (P_Entity)), Loc)); 8572 Analyze_And_Resolve (N, Standard_Boolean); 8573 8574 ---------------------- 8575 -- Has_Same_Storage -- 8576 ---------------------- 8577 8578 when Attribute_Has_Same_Storage => 8579 null; 8580 8581 ----------------------- 8582 -- Has_Tagged_Values -- 8583 ----------------------- 8584 8585 when Attribute_Has_Tagged_Values => 8586 Rewrite (N, New_Occurrence_Of 8587 (Boolean_Literals (Has_Tagged_Component (P_Root_Type)), Loc)); 8588 Analyze_And_Resolve (N, Standard_Boolean); 8589 8590 -------------- 8591 -- Identity -- 8592 -------------- 8593 8594 when Attribute_Identity => 8595 null; 8596 8597 ----------- 8598 -- Image -- 8599 ----------- 8600 8601 -- Image is a scalar attribute, but is never static, because it is 8602 -- not a static function (having a non-scalar argument (RM 4.9(22)) 8603 -- However, we can constant-fold the image of an enumeration literal 8604 -- if names are available. 8605 8606 when Attribute_Image => 8607 if Is_Entity_Name (E1) 8608 and then Ekind (Entity (E1)) = E_Enumeration_Literal 8609 and then not Discard_Names (First_Subtype (Etype (E1))) 8610 and then not Global_Discard_Names 8611 then 8612 declare 8613 Lit : constant Entity_Id := Entity (E1); 8614 Str : String_Id; 8615 begin 8616 Start_String; 8617 Get_Unqualified_Decoded_Name_String (Chars (Lit)); 8618 Set_Casing (All_Upper_Case); 8619 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 8620 Str := End_String; 8621 Rewrite (N, Make_String_Literal (Loc, Strval => Str)); 8622 Analyze_And_Resolve (N, Standard_String); 8623 Set_Is_Static_Expression (N, False); 8624 end; 8625 end if; 8626 8627 ------------------- 8628 -- Integer_Value -- 8629 ------------------- 8630 8631 -- We never try to fold Integer_Value (though perhaps we could???) 8632 8633 when Attribute_Integer_Value => 8634 null; 8635 8636 ------------------- 8637 -- Invalid_Value -- 8638 ------------------- 8639 8640 -- Invalid_Value is a scalar attribute that is never static, because 8641 -- the value is by design out of range. 8642 8643 when Attribute_Invalid_Value => 8644 null; 8645 8646 ----------- 8647 -- Large -- 8648 ----------- 8649 8650 when Attribute_Large => 8651 8652 -- For fixed-point, we use the identity: 8653 8654 -- T'Large = (2.0**T'Mantissa - 1.0) * T'Small 8655 8656 if Is_Fixed_Point_Type (P_Type) then 8657 Rewrite (N, 8658 Make_Op_Multiply (Loc, 8659 Left_Opnd => 8660 Make_Op_Subtract (Loc, 8661 Left_Opnd => 8662 Make_Op_Expon (Loc, 8663 Left_Opnd => 8664 Make_Real_Literal (Loc, Ureal_2), 8665 Right_Opnd => 8666 Make_Attribute_Reference (Loc, 8667 Prefix => P, 8668 Attribute_Name => Name_Mantissa)), 8669 Right_Opnd => Make_Real_Literal (Loc, Ureal_1)), 8670 8671 Right_Opnd => 8672 Make_Real_Literal (Loc, Small_Value (Entity (P))))); 8673 8674 Analyze_And_Resolve (N, C_Type); 8675 8676 -- Floating-point (Ada 83 compatibility) 8677 8678 else 8679 -- Ada 83 attribute is defined as (RM83 3.5.8) 8680 8681 -- T'Large = 2.0**T'Emax * (1.0 - 2.0**(-T'Mantissa)) 8682 8683 -- where 8684 8685 -- T'Emax = 4 * T'Mantissa 8686 8687 Fold_Ureal 8688 (N, 8689 Ureal_2 ** (4 * Mantissa) * (Ureal_1 - Ureal_2 ** (-Mantissa)), 8690 True); 8691 end if; 8692 8693 --------------- 8694 -- Lock_Free -- 8695 --------------- 8696 8697 when Attribute_Lock_Free => Lock_Free : declare 8698 V : constant Entity_Id := Boolean_Literals (Uses_Lock_Free (P_Type)); 8699 8700 begin 8701 Rewrite (N, New_Occurrence_Of (V, Loc)); 8702 8703 -- Analyze and resolve as boolean. Note that this attribute is a 8704 -- static attribute in GNAT. 8705 8706 Analyze_And_Resolve (N, Standard_Boolean); 8707 Static := True; 8708 Set_Is_Static_Expression (N, True); 8709 end Lock_Free; 8710 8711 ---------- 8712 -- Last -- 8713 ---------- 8714 8715 when Attribute_Last => 8716 Set_Bounds; 8717 8718 if Compile_Time_Known_Value (Hi_Bound) then 8719 if Is_Real_Type (P_Type) then 8720 Fold_Ureal (N, Expr_Value_R (Hi_Bound), Static); 8721 else 8722 Fold_Uint (N, Expr_Value (Hi_Bound), Static); 8723 end if; 8724 8725 else 8726 Check_Concurrent_Discriminant (Hi_Bound); 8727 end if; 8728 8729 ---------------- 8730 -- Last_Valid -- 8731 ---------------- 8732 8733 when Attribute_Last_Valid => 8734 if Has_Predicates (P_Type) 8735 and then Has_Static_Predicate (P_Type) 8736 then 8737 declare 8738 LastN : constant Node_Id := 8739 Last (Static_Discrete_Predicate (P_Type)); 8740 begin 8741 if Nkind (LastN) = N_Range then 8742 Fold_Uint (N, Expr_Value (High_Bound (LastN)), Static); 8743 else 8744 Fold_Uint (N, Expr_Value (LastN), Static); 8745 end if; 8746 end; 8747 8748 else 8749 Set_Bounds; 8750 Fold_Uint (N, Expr_Value (Hi_Bound), Static); 8751 end if; 8752 8753 ------------------ 8754 -- Leading_Part -- 8755 ------------------ 8756 8757 when Attribute_Leading_Part => 8758 Fold_Ureal 8759 (N, 8760 Eval_Fat.Leading_Part 8761 (P_Base_Type, Expr_Value_R (E1), Expr_Value (E2)), 8762 Static); 8763 8764 ------------ 8765 -- Length -- 8766 ------------ 8767 8768 when Attribute_Length => Length : declare 8769 Ind : Node_Id; 8770 8771 begin 8772 -- If any index type is a formal type, or derived from one, the 8773 -- bounds are not static. Treating them as static can produce 8774 -- spurious warnings or improper constant folding. 8775 8776 Ind := First_Index (P_Type); 8777 while Present (Ind) loop 8778 if Is_Generic_Type (Root_Type (Etype (Ind))) then 8779 return; 8780 end if; 8781 8782 Next_Index (Ind); 8783 end loop; 8784 8785 Set_Bounds; 8786 8787 -- For two compile time values, we can compute length 8788 8789 if Compile_Time_Known_Value (Lo_Bound) 8790 and then Compile_Time_Known_Value (Hi_Bound) 8791 then 8792 Fold_Uint (N, 8793 UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))), 8794 Static); 8795 end if; 8796 8797 -- One more case is where Hi_Bound and Lo_Bound are compile-time 8798 -- comparable, and we can figure out the difference between them. 8799 8800 declare 8801 Diff : aliased Uint; 8802 8803 begin 8804 case 8805 Compile_Time_Compare 8806 (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False) 8807 is 8808 when EQ => 8809 Fold_Uint (N, Uint_1, Static); 8810 8811 when GT => 8812 Fold_Uint (N, Uint_0, Static); 8813 8814 when LT => 8815 if Diff /= No_Uint then 8816 Fold_Uint (N, Diff + 1, Static); 8817 end if; 8818 8819 when others => 8820 null; 8821 end case; 8822 end; 8823 end Length; 8824 8825 ---------------- 8826 -- Loop_Entry -- 8827 ---------------- 8828 8829 -- Loop_Entry acts as an alias of a constant initialized to the prefix 8830 -- of the said attribute at the point of entry into the related loop. As 8831 -- such, the attribute reference does not need to be evaluated because 8832 -- the prefix is the one that is evaluted. 8833 8834 when Attribute_Loop_Entry => 8835 null; 8836 8837 ------------- 8838 -- Machine -- 8839 ------------- 8840 8841 when Attribute_Machine => 8842 Fold_Ureal 8843 (N, 8844 Eval_Fat.Machine 8845 (P_Base_Type, Expr_Value_R (E1), Eval_Fat.Round, N), 8846 Static); 8847 8848 ------------------ 8849 -- Machine_Emax -- 8850 ------------------ 8851 8852 when Attribute_Machine_Emax => 8853 Fold_Uint (N, Machine_Emax_Value (P_Type), Static); 8854 8855 ------------------ 8856 -- Machine_Emin -- 8857 ------------------ 8858 8859 when Attribute_Machine_Emin => 8860 Fold_Uint (N, Machine_Emin_Value (P_Type), Static); 8861 8862 ---------------------- 8863 -- Machine_Mantissa -- 8864 ---------------------- 8865 8866 when Attribute_Machine_Mantissa => 8867 Fold_Uint (N, Machine_Mantissa_Value (P_Type), Static); 8868 8869 ----------------------- 8870 -- Machine_Overflows -- 8871 ----------------------- 8872 8873 when Attribute_Machine_Overflows => 8874 8875 -- Always true for fixed-point 8876 8877 if Is_Fixed_Point_Type (P_Type) then 8878 Fold_Uint (N, True_Value, Static); 8879 8880 -- Floating point case 8881 8882 else 8883 Fold_Uint (N, 8884 UI_From_Int (Boolean'Pos (Machine_Overflows_On_Target)), 8885 Static); 8886 end if; 8887 8888 ------------------- 8889 -- Machine_Radix -- 8890 ------------------- 8891 8892 when Attribute_Machine_Radix => 8893 if Is_Fixed_Point_Type (P_Type) then 8894 if Is_Decimal_Fixed_Point_Type (P_Type) 8895 and then Machine_Radix_10 (P_Type) 8896 then 8897 Fold_Uint (N, Uint_10, Static); 8898 else 8899 Fold_Uint (N, Uint_2, Static); 8900 end if; 8901 8902 -- All floating-point type always have radix 2 8903 8904 else 8905 Fold_Uint (N, Uint_2, Static); 8906 end if; 8907 8908 ---------------------- 8909 -- Machine_Rounding -- 8910 ---------------------- 8911 8912 -- Note: for the folding case, it is fine to treat Machine_Rounding 8913 -- exactly the same way as Rounding, since this is one of the allowed 8914 -- behaviors, and performance is not an issue here. It might be a bit 8915 -- better to give the same result as it would give at run time, even 8916 -- though the non-determinism is certainly permitted. 8917 8918 when Attribute_Machine_Rounding => 8919 Fold_Ureal 8920 (N, Eval_Fat.Rounding (P_Base_Type, Expr_Value_R (E1)), Static); 8921 8922 -------------------- 8923 -- Machine_Rounds -- 8924 -------------------- 8925 8926 when Attribute_Machine_Rounds => 8927 8928 -- Always False for fixed-point 8929 8930 if Is_Fixed_Point_Type (P_Type) then 8931 Fold_Uint (N, False_Value, Static); 8932 8933 -- Else yield proper floating-point result 8934 8935 else 8936 Fold_Uint 8937 (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)), 8938 Static); 8939 end if; 8940 8941 ------------------ 8942 -- Machine_Size -- 8943 ------------------ 8944 8945 -- Note: Machine_Size is identical to Object_Size 8946 8947 when Attribute_Machine_Size => Machine_Size : declare 8948 P_TypeA : constant Entity_Id := Underlying_Type (P_Type); 8949 8950 begin 8951 if Known_Esize (P_TypeA) then 8952 Fold_Uint (N, Esize (P_TypeA), Static); 8953 end if; 8954 end Machine_Size; 8955 8956 -------------- 8957 -- Mantissa -- 8958 -------------- 8959 8960 when Attribute_Mantissa => 8961 8962 -- Fixed-point mantissa 8963 8964 if Is_Fixed_Point_Type (P_Type) then 8965 8966 -- Compile time foldable case 8967 8968 if Compile_Time_Known_Value (Type_Low_Bound (P_Type)) 8969 and then 8970 Compile_Time_Known_Value (Type_High_Bound (P_Type)) 8971 then 8972 -- The calculation of the obsolete Ada 83 attribute Mantissa 8973 -- is annoying, because of AI00143, quoted here: 8974 8975 -- !question 84-01-10 8976 8977 -- Consider the model numbers for F: 8978 8979 -- type F is delta 1.0 range -7.0 .. 8.0; 8980 8981 -- The wording requires that F'MANTISSA be the SMALLEST 8982 -- integer number for which each bound of the specified 8983 -- range is either a model number or lies at most small 8984 -- distant from a model number. This means F'MANTISSA 8985 -- is required to be 3 since the range -7.0 .. 7.0 fits 8986 -- in 3 signed bits, and 8 is "at most" 1.0 from a model 8987 -- number, namely, 7. Is this analysis correct? Note that 8988 -- this implies the upper bound of the range is not 8989 -- represented as a model number. 8990 8991 -- !response 84-03-17 8992 8993 -- The analysis is correct. The upper and lower bounds for 8994 -- a fixed point type can lie outside the range of model 8995 -- numbers. 8996 8997 declare 8998 Siz : Uint; 8999 LBound : Ureal; 9000 UBound : Ureal; 9001 Bound : Ureal; 9002 Max_Man : Uint; 9003 9004 begin 9005 LBound := Expr_Value_R (Type_Low_Bound (P_Type)); 9006 UBound := Expr_Value_R (Type_High_Bound (P_Type)); 9007 Bound := UR_Max (UR_Abs (LBound), UR_Abs (UBound)); 9008 Max_Man := UR_Trunc (Bound / Small_Value (P_Type)); 9009 9010 -- If the Bound is exactly a model number, i.e. a multiple 9011 -- of Small, then we back it off by one to get the integer 9012 -- value that must be representable. 9013 9014 if Small_Value (P_Type) * Max_Man = Bound then 9015 Max_Man := Max_Man - 1; 9016 end if; 9017 9018 -- Now find corresponding size = Mantissa value 9019 9020 Siz := Uint_0; 9021 while 2 ** Siz < Max_Man loop 9022 Siz := Siz + 1; 9023 end loop; 9024 9025 Fold_Uint (N, Siz, Static); 9026 end; 9027 9028 else 9029 -- The case of dynamic bounds cannot be evaluated at compile 9030 -- time. Instead we use a runtime routine (see Exp_Attr). 9031 9032 null; 9033 end if; 9034 9035 -- Floating-point Mantissa 9036 9037 else 9038 Fold_Uint (N, Mantissa, Static); 9039 end if; 9040 9041 --------- 9042 -- Max -- 9043 --------- 9044 9045 when Attribute_Max => 9046 if Is_Real_Type (P_Type) then 9047 Fold_Ureal 9048 (N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2)), Static); 9049 else 9050 Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2)), Static); 9051 end if; 9052 9053 ---------------------------------- 9054 -- Max_Alignment_For_Allocation -- 9055 ---------------------------------- 9056 9057 -- Max_Alignment_For_Allocation is usually the Alignment. However, 9058 -- arrays are allocated with dope, so we need to take into account both 9059 -- the alignment of the array, which comes from the component alignment, 9060 -- and the alignment of the dope. Also, if the alignment is unknown, we 9061 -- use the max (it's OK to be pessimistic). 9062 9063 when Attribute_Max_Alignment_For_Allocation => Max_Align : declare 9064 A : Uint := UI_From_Int (Ttypes.Maximum_Alignment); 9065 begin 9066 if Known_Alignment (P_Type) 9067 and then (not Is_Array_Type (P_Type) or else Alignment (P_Type) > A) 9068 then 9069 A := Alignment (P_Type); 9070 end if; 9071 9072 Fold_Uint (N, A, Static); 9073 end Max_Align; 9074 9075 ---------------------------------- 9076 -- Max_Size_In_Storage_Elements -- 9077 ---------------------------------- 9078 9079 -- Max_Size_In_Storage_Elements is simply the Size rounded up to a 9080 -- Storage_Unit boundary. We can fold any cases for which the size 9081 -- is known by the front end. 9082 9083 when Attribute_Max_Size_In_Storage_Elements => 9084 if Known_Esize (P_Type) then 9085 Fold_Uint (N, 9086 (Esize (P_Type) + System_Storage_Unit - 1) / 9087 System_Storage_Unit, 9088 Static); 9089 end if; 9090 9091 -------------------- 9092 -- Mechanism_Code -- 9093 -------------------- 9094 9095 when Attribute_Mechanism_Code => Mechanism_Code : declare 9096 Formal : Entity_Id; 9097 Mech : Mechanism_Type; 9098 Val : Int; 9099 9100 begin 9101 if No (E1) then 9102 Mech := Mechanism (P_Entity); 9103 9104 else 9105 Val := UI_To_Int (Expr_Value (E1)); 9106 9107 Formal := First_Formal (P_Entity); 9108 for J in 1 .. Val - 1 loop 9109 Next_Formal (Formal); 9110 end loop; 9111 9112 Mech := Mechanism (Formal); 9113 end if; 9114 9115 if Mech < 0 then 9116 Fold_Uint (N, UI_From_Int (Int (-Mech)), Static); 9117 end if; 9118 end Mechanism_Code; 9119 9120 --------- 9121 -- Min -- 9122 --------- 9123 9124 when Attribute_Min => 9125 if Is_Real_Type (P_Type) then 9126 Fold_Ureal 9127 (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)), Static); 9128 else 9129 Fold_Uint 9130 (N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static); 9131 end if; 9132 9133 --------- 9134 -- Mod -- 9135 --------- 9136 9137 when Attribute_Mod => 9138 Fold_Uint 9139 (N, UI_Mod (Expr_Value (E1), Modulus (P_Base_Type)), Static); 9140 9141 ----------- 9142 -- Model -- 9143 ----------- 9144 9145 when Attribute_Model => 9146 Fold_Ureal 9147 (N, Eval_Fat.Model (P_Base_Type, Expr_Value_R (E1)), Static); 9148 9149 ---------------- 9150 -- Model_Emin -- 9151 ---------------- 9152 9153 when Attribute_Model_Emin => 9154 Fold_Uint (N, Model_Emin_Value (P_Base_Type), Static); 9155 9156 ------------------- 9157 -- Model_Epsilon -- 9158 ------------------- 9159 9160 when Attribute_Model_Epsilon => 9161 Fold_Ureal (N, Model_Epsilon_Value (P_Base_Type), Static); 9162 9163 -------------------- 9164 -- Model_Mantissa -- 9165 -------------------- 9166 9167 when Attribute_Model_Mantissa => 9168 Fold_Uint (N, Model_Mantissa_Value (P_Base_Type), Static); 9169 9170 ----------------- 9171 -- Model_Small -- 9172 ----------------- 9173 9174 when Attribute_Model_Small => 9175 Fold_Ureal (N, Model_Small_Value (P_Base_Type), Static); 9176 9177 ------------- 9178 -- Modulus -- 9179 ------------- 9180 9181 when Attribute_Modulus => 9182 Fold_Uint (N, Modulus (P_Type), Static); 9183 9184 -------------------- 9185 -- Null_Parameter -- 9186 -------------------- 9187 9188 -- Cannot fold, we know the value sort of, but the whole point is 9189 -- that there is no way to talk about this imaginary value except 9190 -- by using the attribute, so we leave it the way it is. 9191 9192 when Attribute_Null_Parameter => 9193 null; 9194 9195 ----------------- 9196 -- Object_Size -- 9197 ----------------- 9198 9199 -- The Object_Size attribute for a type returns the Esize of the 9200 -- type and can be folded if this value is known. 9201 9202 when Attribute_Object_Size => Object_Size : declare 9203 P_TypeA : constant Entity_Id := Underlying_Type (P_Type); 9204 9205 begin 9206 if Known_Esize (P_TypeA) then 9207 Fold_Uint (N, Esize (P_TypeA), Static); 9208 end if; 9209 end Object_Size; 9210 9211 ---------------------- 9212 -- Overlaps_Storage -- 9213 ---------------------- 9214 9215 when Attribute_Overlaps_Storage => 9216 null; 9217 9218 ------------------------- 9219 -- Passed_By_Reference -- 9220 ------------------------- 9221 9222 -- Scalar types are never passed by reference 9223 9224 when Attribute_Passed_By_Reference => 9225 Fold_Uint (N, False_Value, Static); 9226 9227 --------- 9228 -- Pos -- 9229 --------- 9230 9231 when Attribute_Pos => 9232 Fold_Uint (N, Expr_Value (E1), Static); 9233 9234 ---------- 9235 -- Pred -- 9236 ---------- 9237 9238 when Attribute_Pred => 9239 9240 -- Floating-point case 9241 9242 if Is_Floating_Point_Type (P_Type) then 9243 Fold_Ureal 9244 (N, Eval_Fat.Pred (P_Base_Type, Expr_Value_R (E1)), Static); 9245 9246 -- Fixed-point case 9247 9248 elsif Is_Fixed_Point_Type (P_Type) then 9249 Fold_Ureal 9250 (N, Expr_Value_R (E1) - Small_Value (P_Type), True); 9251 9252 -- Modular integer case (wraps) 9253 9254 elsif Is_Modular_Integer_Type (P_Type) then 9255 Fold_Uint (N, (Expr_Value (E1) - 1) mod Modulus (P_Type), Static); 9256 9257 -- Other scalar cases 9258 9259 else 9260 pragma Assert (Is_Scalar_Type (P_Type)); 9261 9262 if Is_Enumeration_Type (P_Type) 9263 and then Expr_Value (E1) = 9264 Expr_Value (Type_Low_Bound (P_Base_Type)) 9265 then 9266 Apply_Compile_Time_Constraint_Error 9267 (N, "Pred of `&''First`", 9268 CE_Overflow_Check_Failed, 9269 Ent => P_Base_Type, 9270 Warn => not Static); 9271 9272 Check_Expressions; 9273 return; 9274 end if; 9275 9276 Fold_Uint (N, Expr_Value (E1) - 1, Static); 9277 end if; 9278 9279 ----------- 9280 -- Range -- 9281 ----------- 9282 9283 -- No processing required, because by this stage, Range has been 9284 -- replaced by First .. Last, so this branch can never be taken. 9285 9286 when Attribute_Range => 9287 raise Program_Error; 9288 9289 ------------------ 9290 -- Range_Length -- 9291 ------------------ 9292 9293 when Attribute_Range_Length => Range_Length : declare 9294 Diff : aliased Uint; 9295 9296 begin 9297 Set_Bounds; 9298 9299 -- Can fold if both bounds are compile time known 9300 9301 if Compile_Time_Known_Value (Hi_Bound) 9302 and then Compile_Time_Known_Value (Lo_Bound) 9303 then 9304 Fold_Uint (N, 9305 UI_Max 9306 (0, Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound) + 1), 9307 Static); 9308 end if; 9309 9310 -- One more case is where Hi_Bound and Lo_Bound are compile-time 9311 -- comparable, and we can figure out the difference between them. 9312 9313 case Compile_Time_Compare 9314 (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False) 9315 is 9316 when EQ => 9317 Fold_Uint (N, Uint_1, Static); 9318 9319 when GT => 9320 Fold_Uint (N, Uint_0, Static); 9321 9322 when LT => 9323 if Diff /= No_Uint then 9324 Fold_Uint (N, Diff + 1, Static); 9325 end if; 9326 9327 when others => 9328 null; 9329 end case; 9330 end Range_Length; 9331 9332 --------- 9333 -- Ref -- 9334 --------- 9335 9336 when Attribute_Ref => 9337 Fold_Uint (N, Expr_Value (E1), Static); 9338 9339 --------------- 9340 -- Remainder -- 9341 --------------- 9342 9343 when Attribute_Remainder => Remainder : declare 9344 X : constant Ureal := Expr_Value_R (E1); 9345 Y : constant Ureal := Expr_Value_R (E2); 9346 9347 begin 9348 if UR_Is_Zero (Y) then 9349 Apply_Compile_Time_Constraint_Error 9350 (N, "division by zero in Remainder", 9351 CE_Overflow_Check_Failed, 9352 Warn => not Static); 9353 9354 Check_Expressions; 9355 return; 9356 end if; 9357 9358 Fold_Ureal (N, Eval_Fat.Remainder (P_Base_Type, X, Y), Static); 9359 end Remainder; 9360 9361 ----------------- 9362 -- Restriction -- 9363 ----------------- 9364 9365 when Attribute_Restriction_Set => 9366 Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); 9367 Set_Is_Static_Expression (N); 9368 9369 ----------- 9370 -- Round -- 9371 ----------- 9372 9373 when Attribute_Round => Round : declare 9374 Sr : Ureal; 9375 Si : Uint; 9376 9377 begin 9378 -- First we get the (exact result) in units of small 9379 9380 Sr := Expr_Value_R (E1) / Small_Value (C_Type); 9381 9382 -- Now round that exactly to an integer 9383 9384 Si := UR_To_Uint (Sr); 9385 9386 -- Finally the result is obtained by converting back to real 9387 9388 Fold_Ureal (N, Si * Small_Value (C_Type), Static); 9389 end Round; 9390 9391 -------------- 9392 -- Rounding -- 9393 -------------- 9394 9395 when Attribute_Rounding => 9396 Fold_Ureal 9397 (N, Eval_Fat.Rounding (P_Base_Type, Expr_Value_R (E1)), Static); 9398 9399 --------------- 9400 -- Safe_Emax -- 9401 --------------- 9402 9403 when Attribute_Safe_Emax => 9404 Fold_Uint (N, Safe_Emax_Value (P_Type), Static); 9405 9406 ---------------- 9407 -- Safe_First -- 9408 ---------------- 9409 9410 when Attribute_Safe_First => 9411 Fold_Ureal (N, Safe_First_Value (P_Type), Static); 9412 9413 ---------------- 9414 -- Safe_Large -- 9415 ---------------- 9416 9417 when Attribute_Safe_Large => 9418 if Is_Fixed_Point_Type (P_Type) then 9419 Fold_Ureal 9420 (N, Expr_Value_R (Type_High_Bound (P_Base_Type)), Static); 9421 else 9422 Fold_Ureal (N, Safe_Last_Value (P_Type), Static); 9423 end if; 9424 9425 --------------- 9426 -- Safe_Last -- 9427 --------------- 9428 9429 when Attribute_Safe_Last => 9430 Fold_Ureal (N, Safe_Last_Value (P_Type), Static); 9431 9432 ---------------- 9433 -- Safe_Small -- 9434 ---------------- 9435 9436 when Attribute_Safe_Small => 9437 9438 -- In Ada 95, the old Ada 83 attribute Safe_Small is redundant 9439 -- for fixed-point, since is the same as Small, but we implement 9440 -- it for backwards compatibility. 9441 9442 if Is_Fixed_Point_Type (P_Type) then 9443 Fold_Ureal (N, Small_Value (P_Type), Static); 9444 9445 -- Ada 83 Safe_Small for floating-point cases 9446 9447 else 9448 Fold_Ureal (N, Model_Small_Value (P_Type), Static); 9449 end if; 9450 9451 ----------- 9452 -- Scale -- 9453 ----------- 9454 9455 when Attribute_Scale => 9456 Fold_Uint (N, Scale_Value (P_Type), Static); 9457 9458 ------------- 9459 -- Scaling -- 9460 ------------- 9461 9462 when Attribute_Scaling => 9463 Fold_Ureal 9464 (N, 9465 Eval_Fat.Scaling 9466 (P_Base_Type, Expr_Value_R (E1), Expr_Value (E2)), 9467 Static); 9468 9469 ------------------ 9470 -- Signed_Zeros -- 9471 ------------------ 9472 9473 when Attribute_Signed_Zeros => 9474 Fold_Uint 9475 (N, UI_From_Int (Boolean'Pos (Has_Signed_Zeros (P_Type))), Static); 9476 9477 ---------- 9478 -- Size -- 9479 ---------- 9480 9481 -- Size attribute returns the RM size. All scalar types can be folded, 9482 -- as well as any types for which the size is known by the front end, 9483 -- including any type for which a size attribute is specified. This is 9484 -- one of the places where it is annoying that a size of zero means two 9485 -- things (zero size for scalars, unspecified size for non-scalars). 9486 9487 when Attribute_Size 9488 | Attribute_VADS_Size 9489 => 9490 Size : declare 9491 P_TypeA : constant Entity_Id := Underlying_Type (P_Type); 9492 9493 begin 9494 if Is_Scalar_Type (P_TypeA) 9495 or else RM_Size (P_TypeA) /= Uint_0 9496 then 9497 -- VADS_Size case 9498 9499 if Id = Attribute_VADS_Size or else Use_VADS_Size then 9500 declare 9501 S : constant Node_Id := Size_Clause (P_TypeA); 9502 9503 begin 9504 -- If a size clause applies, then use the size from it. 9505 -- This is one of the rare cases where we can use the 9506 -- Size_Clause field for a subtype when Has_Size_Clause 9507 -- is False. Consider: 9508 9509 -- type x is range 1 .. 64; 9510 -- for x'size use 12; 9511 -- subtype y is x range 0 .. 3; 9512 9513 -- Here y has a size clause inherited from x, but 9514 -- normally it does not apply, and y'size is 2. However, 9515 -- y'VADS_Size is indeed 12 and not 2. 9516 9517 if Present (S) 9518 and then Is_OK_Static_Expression (Expression (S)) 9519 then 9520 Fold_Uint (N, Expr_Value (Expression (S)), Static); 9521 9522 -- If no size is specified, then we simply use the object 9523 -- size in the VADS_Size case (e.g. Natural'Size is equal 9524 -- to Integer'Size, not one less). 9525 9526 else 9527 Fold_Uint (N, Esize (P_TypeA), Static); 9528 end if; 9529 end; 9530 9531 -- Normal case (Size) in which case we want the RM_Size 9532 9533 else 9534 Fold_Uint (N, RM_Size (P_TypeA), Static); 9535 end if; 9536 end if; 9537 end Size; 9538 9539 ----------- 9540 -- Small -- 9541 ----------- 9542 9543 when Attribute_Small => 9544 9545 -- The floating-point case is present only for Ada 83 compatibility. 9546 -- Note that strictly this is an illegal addition, since we are 9547 -- extending an Ada 95 defined attribute, but we anticipate an 9548 -- ARG ruling that will permit this. 9549 9550 if Is_Floating_Point_Type (P_Type) then 9551 9552 -- Ada 83 attribute is defined as (RM83 3.5.8) 9553 9554 -- T'Small = 2.0**(-T'Emax - 1) 9555 9556 -- where 9557 9558 -- T'Emax = 4 * T'Mantissa 9559 9560 Fold_Ureal (N, Ureal_2 ** ((-(4 * Mantissa)) - 1), Static); 9561 9562 -- Normal Ada 95 fixed-point case 9563 9564 else 9565 Fold_Ureal (N, Small_Value (P_Type), True); 9566 end if; 9567 9568 ----------------- 9569 -- Stream_Size -- 9570 ----------------- 9571 9572 when Attribute_Stream_Size => 9573 null; 9574 9575 ---------- 9576 -- Succ -- 9577 ---------- 9578 9579 when Attribute_Succ => 9580 -- Floating-point case 9581 9582 if Is_Floating_Point_Type (P_Type) then 9583 Fold_Ureal 9584 (N, Eval_Fat.Succ (P_Base_Type, Expr_Value_R (E1)), Static); 9585 9586 -- Fixed-point case 9587 9588 elsif Is_Fixed_Point_Type (P_Type) then 9589 Fold_Ureal (N, Expr_Value_R (E1) + Small_Value (P_Type), Static); 9590 9591 -- Modular integer case (wraps) 9592 9593 elsif Is_Modular_Integer_Type (P_Type) then 9594 Fold_Uint (N, (Expr_Value (E1) + 1) mod Modulus (P_Type), Static); 9595 9596 -- Other scalar cases 9597 9598 else 9599 pragma Assert (Is_Scalar_Type (P_Type)); 9600 9601 if Is_Enumeration_Type (P_Type) 9602 and then Expr_Value (E1) = 9603 Expr_Value (Type_High_Bound (P_Base_Type)) 9604 then 9605 Apply_Compile_Time_Constraint_Error 9606 (N, "Succ of `&''Last`", 9607 CE_Overflow_Check_Failed, 9608 Ent => P_Base_Type, 9609 Warn => not Static); 9610 9611 Check_Expressions; 9612 return; 9613 else 9614 Fold_Uint (N, Expr_Value (E1) + 1, Static); 9615 end if; 9616 end if; 9617 9618 ---------------- 9619 -- Truncation -- 9620 ---------------- 9621 9622 when Attribute_Truncation => 9623 Fold_Ureal 9624 (N, 9625 Eval_Fat.Truncation (P_Base_Type, Expr_Value_R (E1)), 9626 Static); 9627 9628 ---------------- 9629 -- Type_Class -- 9630 ---------------- 9631 9632 when Attribute_Type_Class => Type_Class : declare 9633 Typ : constant Entity_Id := Underlying_Type (P_Base_Type); 9634 Id : RE_Id; 9635 9636 begin 9637 if Is_Descendant_Of_Address (Typ) then 9638 Id := RE_Type_Class_Address; 9639 9640 elsif Is_Enumeration_Type (Typ) then 9641 Id := RE_Type_Class_Enumeration; 9642 9643 elsif Is_Integer_Type (Typ) then 9644 Id := RE_Type_Class_Integer; 9645 9646 elsif Is_Fixed_Point_Type (Typ) then 9647 Id := RE_Type_Class_Fixed_Point; 9648 9649 elsif Is_Floating_Point_Type (Typ) then 9650 Id := RE_Type_Class_Floating_Point; 9651 9652 elsif Is_Array_Type (Typ) then 9653 Id := RE_Type_Class_Array; 9654 9655 elsif Is_Record_Type (Typ) then 9656 Id := RE_Type_Class_Record; 9657 9658 elsif Is_Access_Type (Typ) then 9659 Id := RE_Type_Class_Access; 9660 9661 elsif Is_Task_Type (Typ) then 9662 Id := RE_Type_Class_Task; 9663 9664 -- We treat protected types like task types. It would make more 9665 -- sense to have another enumeration value, but after all the 9666 -- whole point of this feature is to be exactly DEC compatible, 9667 -- and changing the type Type_Class would not meet this requirement. 9668 9669 elsif Is_Protected_Type (Typ) then 9670 Id := RE_Type_Class_Task; 9671 9672 -- Not clear if there are any other possibilities, but if there 9673 -- are, then we will treat them as the address case. 9674 9675 else 9676 Id := RE_Type_Class_Address; 9677 end if; 9678 9679 Rewrite (N, New_Occurrence_Of (RTE (Id), Loc)); 9680 end Type_Class; 9681 9682 ----------------------- 9683 -- Unbiased_Rounding -- 9684 ----------------------- 9685 9686 when Attribute_Unbiased_Rounding => 9687 Fold_Ureal 9688 (N, 9689 Eval_Fat.Unbiased_Rounding (P_Base_Type, Expr_Value_R (E1)), 9690 Static); 9691 9692 ------------------------- 9693 -- Unconstrained_Array -- 9694 ------------------------- 9695 9696 when Attribute_Unconstrained_Array => Unconstrained_Array : declare 9697 Typ : constant Entity_Id := Underlying_Type (P_Type); 9698 9699 begin 9700 Rewrite (N, New_Occurrence_Of ( 9701 Boolean_Literals ( 9702 Is_Array_Type (P_Type) 9703 and then not Is_Constrained (Typ)), Loc)); 9704 9705 -- Analyze and resolve as boolean, note that this attribute is 9706 -- a static attribute in GNAT. 9707 9708 Analyze_And_Resolve (N, Standard_Boolean); 9709 Static := True; 9710 Set_Is_Static_Expression (N, True); 9711 end Unconstrained_Array; 9712 9713 -- Attribute Update is never static 9714 9715 when Attribute_Update => 9716 return; 9717 9718 --------------- 9719 -- VADS_Size -- 9720 --------------- 9721 9722 -- Processing is shared with Size 9723 9724 --------- 9725 -- Val -- 9726 --------- 9727 9728 when Attribute_Val => 9729 if Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Base_Type)) 9730 or else 9731 Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type)) 9732 then 9733 Apply_Compile_Time_Constraint_Error 9734 (N, "Val expression out of range", 9735 CE_Range_Check_Failed, 9736 Warn => not Static); 9737 9738 Check_Expressions; 9739 return; 9740 9741 else 9742 Fold_Uint (N, Expr_Value (E1), Static); 9743 end if; 9744 9745 ---------------- 9746 -- Value_Size -- 9747 ---------------- 9748 9749 -- The Value_Size attribute for a type returns the RM size of the type. 9750 -- This an always be folded for scalar types, and can also be folded for 9751 -- non-scalar types if the size is set. This is one of the places where 9752 -- it is annoying that a size of zero means two things! 9753 9754 when Attribute_Value_Size => Value_Size : declare 9755 P_TypeA : constant Entity_Id := Underlying_Type (P_Type); 9756 9757 begin 9758 if Is_Scalar_Type (P_TypeA) or else RM_Size (P_TypeA) /= Uint_0 then 9759 Fold_Uint (N, RM_Size (P_TypeA), Static); 9760 end if; 9761 end Value_Size; 9762 9763 ------------- 9764 -- Version -- 9765 ------------- 9766 9767 -- Version can never be static 9768 9769 when Attribute_Version => 9770 null; 9771 9772 ---------------- 9773 -- Wide_Image -- 9774 ---------------- 9775 9776 -- Wide_Image is a scalar attribute, but is never static, because it 9777 -- is not a static function (having a non-scalar argument (RM 4.9(22)) 9778 9779 when Attribute_Wide_Image => 9780 null; 9781 9782 --------------------- 9783 -- Wide_Wide_Image -- 9784 --------------------- 9785 9786 -- Wide_Wide_Image is a scalar attribute but is never static, because it 9787 -- is not a static function (having a non-scalar argument (RM 4.9(22)). 9788 9789 when Attribute_Wide_Wide_Image => 9790 null; 9791 9792 --------------------- 9793 -- Wide_Wide_Width -- 9794 --------------------- 9795 9796 -- Processing for Wide_Wide_Width is combined with Width 9797 9798 ---------------- 9799 -- Wide_Width -- 9800 ---------------- 9801 9802 -- Processing for Wide_Width is combined with Width 9803 9804 ----------- 9805 -- Width -- 9806 ----------- 9807 9808 -- This processing also handles the case of Wide_[Wide_]Width 9809 9810 when Attribute_Width 9811 | Attribute_Wide_Width 9812 | Attribute_Wide_Wide_Width 9813 => 9814 if Compile_Time_Known_Bounds (P_Type) then 9815 9816 -- Floating-point types 9817 9818 if Is_Floating_Point_Type (P_Type) then 9819 9820 -- Width is zero for a null range (RM 3.5 (38)) 9821 9822 if Expr_Value_R (Type_High_Bound (P_Type)) < 9823 Expr_Value_R (Type_Low_Bound (P_Type)) 9824 then 9825 Fold_Uint (N, Uint_0, Static); 9826 9827 else 9828 -- For floating-point, we have +N.dddE+nnn where length 9829 -- of ddd is determined by type'Digits - 1, but is one 9830 -- if Digits is one (RM 3.5 (33)). 9831 9832 -- nnn is set to 2 for Short_Float and Float (32 bit 9833 -- floats), and 3 for Long_Float and Long_Long_Float. 9834 -- For machines where Long_Long_Float is the IEEE 9835 -- extended precision type, the exponent takes 4 digits. 9836 9837 declare 9838 Len : Int := 9839 Int'Max (2, UI_To_Int (Digits_Value (P_Type))); 9840 9841 begin 9842 if Esize (P_Type) <= 32 then 9843 Len := Len + 6; 9844 elsif Esize (P_Type) = 64 then 9845 Len := Len + 7; 9846 else 9847 Len := Len + 8; 9848 end if; 9849 9850 Fold_Uint (N, UI_From_Int (Len), Static); 9851 end; 9852 end if; 9853 9854 -- Fixed-point types 9855 9856 elsif Is_Fixed_Point_Type (P_Type) then 9857 9858 -- Width is zero for a null range (RM 3.5 (38)) 9859 9860 if Expr_Value (Type_High_Bound (P_Type)) < 9861 Expr_Value (Type_Low_Bound (P_Type)) 9862 then 9863 Fold_Uint (N, Uint_0, Static); 9864 9865 -- The non-null case depends on the specific real type 9866 9867 else 9868 -- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34)) 9869 9870 Fold_Uint 9871 (N, UI_From_Int (Fore_Value + 1) + Aft_Value (P_Type), 9872 Static); 9873 end if; 9874 9875 -- Discrete types 9876 9877 else 9878 declare 9879 R : constant Entity_Id := Root_Type (P_Type); 9880 Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type)); 9881 Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type)); 9882 W : Nat; 9883 Wt : Nat; 9884 T : Uint; 9885 L : Node_Id; 9886 C : Character; 9887 9888 begin 9889 -- Empty ranges 9890 9891 if Lo > Hi then 9892 W := 0; 9893 9894 -- Width for types derived from Standard.Character 9895 -- and Standard.Wide_[Wide_]Character. 9896 9897 elsif Is_Standard_Character_Type (P_Type) then 9898 W := 0; 9899 9900 -- Set W larger if needed 9901 9902 for J in UI_To_Int (Lo) .. UI_To_Int (Hi) loop 9903 9904 -- All wide characters look like Hex_hhhhhhhh 9905 9906 if J > 255 then 9907 9908 -- No need to compute this more than once 9909 9910 exit; 9911 9912 else 9913 C := Character'Val (J); 9914 9915 -- Test for all cases where Character'Image 9916 -- yields an image that is longer than three 9917 -- characters. First the cases of Reserved_xxx 9918 -- names (length = 12). 9919 9920 case C is 9921 when Reserved_128 9922 | Reserved_129 9923 | Reserved_132 9924 | Reserved_153 9925 => 9926 Wt := 12; 9927 9928 when BS 9929 | CR 9930 | EM 9931 | FF 9932 | FS 9933 | GS 9934 | HT 9935 | LF 9936 | MW 9937 | PM 9938 | RI 9939 | RS 9940 | SI 9941 | SO 9942 | ST 9943 | US 9944 | VT 9945 => 9946 Wt := 2; 9947 9948 when ACK 9949 | APC 9950 | BEL 9951 | BPH 9952 | CAN 9953 | CCH 9954 | CSI 9955 | DC1 9956 | DC2 9957 | DC3 9958 | DC4 9959 | DCS 9960 | DEL 9961 | DLE 9962 | ENQ 9963 | EOT 9964 | EPA 9965 | ESA 9966 | ESC 9967 | ETB 9968 | ETX 9969 | HTJ 9970 | HTS 9971 | NAK 9972 | NBH 9973 | NEL 9974 | NUL 9975 | OSC 9976 | PLD 9977 | PLU 9978 | PU1 9979 | PU2 9980 | SCI 9981 | SOH 9982 | SOS 9983 | SPA 9984 | SS2 9985 | SS3 9986 | SSA 9987 | STS 9988 | STX 9989 | SUB 9990 | SYN 9991 | VTS 9992 => 9993 Wt := 3; 9994 9995 when Space .. Tilde 9996 | No_Break_Space .. LC_Y_Diaeresis 9997 => 9998 -- Special case of soft hyphen in Ada 2005 9999 10000 if C = Character'Val (16#AD#) 10001 and then Ada_Version >= Ada_2005 10002 then 10003 Wt := 11; 10004 else 10005 Wt := 3; 10006 end if; 10007 end case; 10008 10009 W := Int'Max (W, Wt); 10010 end if; 10011 end loop; 10012 10013 -- Width for types derived from Standard.Boolean 10014 10015 elsif R = Standard_Boolean then 10016 if Lo = 0 then 10017 W := 5; -- FALSE 10018 else 10019 W := 4; -- TRUE 10020 end if; 10021 10022 -- Width for integer types 10023 10024 elsif Is_Integer_Type (P_Type) then 10025 T := UI_Max (abs Lo, abs Hi); 10026 10027 W := 2; 10028 while T >= 10 loop 10029 W := W + 1; 10030 T := T / 10; 10031 end loop; 10032 10033 -- User declared enum type with discard names 10034 10035 elsif Discard_Names (R) then 10036 10037 -- If range is null, result is zero, that has already 10038 -- been dealt with, so what we need is the power of ten 10039 -- that accommodates the Pos of the largest value, which 10040 -- is the high bound of the range + one for the space. 10041 10042 W := 1; 10043 T := Hi; 10044 while T /= 0 loop 10045 T := T / 10; 10046 W := W + 1; 10047 end loop; 10048 10049 -- Only remaining possibility is user declared enum type 10050 -- with normal case of Discard_Names not active. 10051 10052 else 10053 pragma Assert (Is_Enumeration_Type (P_Type)); 10054 10055 W := 0; 10056 L := First_Literal (P_Type); 10057 while Present (L) loop 10058 10059 -- Only pay attention to in range characters 10060 10061 if Lo <= Enumeration_Pos (L) 10062 and then Enumeration_Pos (L) <= Hi 10063 then 10064 -- For Width case, use decoded name 10065 10066 if Id = Attribute_Width then 10067 Get_Decoded_Name_String (Chars (L)); 10068 Wt := Nat (Name_Len); 10069 10070 -- For Wide_[Wide_]Width, use encoded name, and 10071 -- then adjust for the encoding. 10072 10073 else 10074 Get_Name_String (Chars (L)); 10075 10076 -- Character literals are always of length 3 10077 10078 if Name_Buffer (1) = 'Q' then 10079 Wt := 3; 10080 10081 -- Otherwise loop to adjust for upper/wide chars 10082 10083 else 10084 Wt := Nat (Name_Len); 10085 10086 for J in 1 .. Name_Len loop 10087 if Name_Buffer (J) = 'U' then 10088 Wt := Wt - 2; 10089 elsif Name_Buffer (J) = 'W' then 10090 Wt := Wt - 4; 10091 end if; 10092 end loop; 10093 end if; 10094 end if; 10095 10096 W := Int'Max (W, Wt); 10097 end if; 10098 10099 Next_Literal (L); 10100 end loop; 10101 end if; 10102 10103 Fold_Uint (N, UI_From_Int (W), Static); 10104 end; 10105 end if; 10106 end if; 10107 10108 -- The following attributes denote functions that cannot be folded 10109 10110 when Attribute_From_Any 10111 | Attribute_To_Any 10112 | Attribute_TypeCode 10113 => 10114 null; 10115 10116 -- The following attributes can never be folded, and furthermore we 10117 -- should not even have entered the case statement for any of these. 10118 -- Note that in some cases, the values have already been folded as 10119 -- a result of the processing in Analyze_Attribute or earlier in 10120 -- this procedure. 10121 10122 when Attribute_Abort_Signal 10123 | Attribute_Access 10124 | Attribute_Address 10125 | Attribute_Address_Size 10126 | Attribute_Asm_Input 10127 | Attribute_Asm_Output 10128 | Attribute_Base 10129 | Attribute_Bit_Order 10130 | Attribute_Bit_Position 10131 | Attribute_Callable 10132 | Attribute_Caller 10133 | Attribute_Class 10134 | Attribute_Code_Address 10135 | Attribute_Compiler_Version 10136 | Attribute_Count 10137 | Attribute_Default_Bit_Order 10138 | Attribute_Default_Scalar_Storage_Order 10139 | Attribute_Deref 10140 | Attribute_Elaborated 10141 | Attribute_Elab_Body 10142 | Attribute_Elab_Spec 10143 | Attribute_Elab_Subp_Body 10144 | Attribute_Enabled 10145 | Attribute_External_Tag 10146 | Attribute_Fast_Math 10147 | Attribute_First_Bit 10148 | Attribute_Img 10149 | Attribute_Input 10150 | Attribute_Last_Bit 10151 | Attribute_Library_Level 10152 | Attribute_Maximum_Alignment 10153 | Attribute_Old 10154 | Attribute_Output 10155 | Attribute_Partition_ID 10156 | Attribute_Pool_Address 10157 | Attribute_Position 10158 | Attribute_Priority 10159 | Attribute_Read 10160 | Attribute_Result 10161 | Attribute_Scalar_Storage_Order 10162 | Attribute_Simple_Storage_Pool 10163 | Attribute_Storage_Pool 10164 | Attribute_Storage_Size 10165 | Attribute_Storage_Unit 10166 | Attribute_Stub_Type 10167 | Attribute_System_Allocator_Alignment 10168 | Attribute_Tag 10169 | Attribute_Target_Name 10170 | Attribute_Terminated 10171 | Attribute_To_Address 10172 | Attribute_Type_Key 10173 | Attribute_Unchecked_Access 10174 | Attribute_Universal_Literal_String 10175 | Attribute_Unrestricted_Access 10176 | Attribute_Valid 10177 | Attribute_Valid_Scalars 10178 | Attribute_Value 10179 | Attribute_Wchar_T_Size 10180 | Attribute_Wide_Value 10181 | Attribute_Wide_Wide_Value 10182 | Attribute_Word_Size 10183 | Attribute_Write 10184 => 10185 raise Program_Error; 10186 end case; 10187 10188 -- At the end of the case, one more check. If we did a static evaluation 10189 -- so that the result is now a literal, then set Is_Static_Expression 10190 -- in the constant only if the prefix type is a static subtype. For 10191 -- non-static subtypes, the folding is still OK, but not static. 10192 10193 -- An exception is the GNAT attribute Constrained_Array which is 10194 -- defined to be a static attribute in all cases. 10195 10196 if Nkind_In (N, N_Integer_Literal, 10197 N_Real_Literal, 10198 N_Character_Literal, 10199 N_String_Literal) 10200 or else (Is_Entity_Name (N) 10201 and then Ekind (Entity (N)) = E_Enumeration_Literal) 10202 then 10203 Set_Is_Static_Expression (N, Static); 10204 10205 -- If this is still an attribute reference, then it has not been folded 10206 -- and that means that its expressions are in a non-static context. 10207 10208 elsif Nkind (N) = N_Attribute_Reference then 10209 Check_Expressions; 10210 10211 -- Note: the else case not covered here are odd cases where the 10212 -- processing has transformed the attribute into something other 10213 -- than a constant. Nothing more to do in such cases. 10214 10215 else 10216 null; 10217 end if; 10218 end Eval_Attribute; 10219 10220 ------------------------------ 10221 -- Is_Anonymous_Tagged_Base -- 10222 ------------------------------ 10223 10224 function Is_Anonymous_Tagged_Base 10225 (Anon : Entity_Id; 10226 Typ : Entity_Id) return Boolean 10227 is 10228 begin 10229 return 10230 Anon = Current_Scope 10231 and then Is_Itype (Anon) 10232 and then Associated_Node_For_Itype (Anon) = Parent (Typ); 10233 end Is_Anonymous_Tagged_Base; 10234 10235 -------------------------------- 10236 -- Name_Implies_Lvalue_Prefix -- 10237 -------------------------------- 10238 10239 function Name_Implies_Lvalue_Prefix (Nam : Name_Id) return Boolean is 10240 pragma Assert (Is_Attribute_Name (Nam)); 10241 begin 10242 return Attribute_Name_Implies_Lvalue_Prefix (Get_Attribute_Id (Nam)); 10243 end Name_Implies_Lvalue_Prefix; 10244 10245 ----------------------- 10246 -- Resolve_Attribute -- 10247 ----------------------- 10248 10249 procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id) is 10250 Loc : constant Source_Ptr := Sloc (N); 10251 P : constant Node_Id := Prefix (N); 10252 Aname : constant Name_Id := Attribute_Name (N); 10253 Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname); 10254 Btyp : constant Entity_Id := Base_Type (Typ); 10255 Des_Btyp : Entity_Id; 10256 Index : Interp_Index; 10257 It : Interp; 10258 Nom_Subt : Entity_Id; 10259 10260 procedure Accessibility_Message; 10261 -- Error, or warning within an instance, if the static accessibility 10262 -- rules of 3.10.2 are violated. 10263 10264 function Declared_Within_Generic_Unit 10265 (Entity : Entity_Id; 10266 Generic_Unit : Node_Id) return Boolean; 10267 -- Returns True if Declared_Entity is declared within the declarative 10268 -- region of Generic_Unit; otherwise returns False. 10269 10270 --------------------------- 10271 -- Accessibility_Message -- 10272 --------------------------- 10273 10274 procedure Accessibility_Message is 10275 Indic : Node_Id := Parent (Parent (N)); 10276 10277 begin 10278 -- In an instance, this is a runtime check, but one we 10279 -- know will fail, so generate an appropriate warning. 10280 10281 if In_Instance_Body then 10282 Error_Msg_Warn := SPARK_Mode /= On; 10283 Error_Msg_F 10284 ("non-local pointer cannot point to local object<<", P); 10285 Error_Msg_F ("\Program_Error [<<", P); 10286 Rewrite (N, 10287 Make_Raise_Program_Error (Loc, 10288 Reason => PE_Accessibility_Check_Failed)); 10289 Set_Etype (N, Typ); 10290 return; 10291 10292 else 10293 Error_Msg_F ("non-local pointer cannot point to local object", P); 10294 10295 -- Check for case where we have a missing access definition 10296 10297 if Is_Record_Type (Current_Scope) 10298 and then 10299 Nkind_In (Parent (N), N_Discriminant_Association, 10300 N_Index_Or_Discriminant_Constraint) 10301 then 10302 Indic := Parent (Parent (N)); 10303 while Present (Indic) 10304 and then Nkind (Indic) /= N_Subtype_Indication 10305 loop 10306 Indic := Parent (Indic); 10307 end loop; 10308 10309 if Present (Indic) then 10310 Error_Msg_NE 10311 ("\use an access definition for" & 10312 " the access discriminant of&", 10313 N, Entity (Subtype_Mark (Indic))); 10314 end if; 10315 end if; 10316 end if; 10317 end Accessibility_Message; 10318 10319 ---------------------------------- 10320 -- Declared_Within_Generic_Unit -- 10321 ---------------------------------- 10322 10323 function Declared_Within_Generic_Unit 10324 (Entity : Entity_Id; 10325 Generic_Unit : Node_Id) return Boolean 10326 is 10327 Generic_Encloser : Node_Id := Enclosing_Generic_Unit (Entity); 10328 10329 begin 10330 while Present (Generic_Encloser) loop 10331 if Generic_Encloser = Generic_Unit then 10332 return True; 10333 end if; 10334 10335 -- We have to step to the scope of the generic's entity, because 10336 -- otherwise we'll just get back the same generic. 10337 10338 Generic_Encloser := 10339 Enclosing_Generic_Unit 10340 (Scope (Defining_Entity (Generic_Encloser))); 10341 end loop; 10342 10343 return False; 10344 end Declared_Within_Generic_Unit; 10345 10346 -- Start of processing for Resolve_Attribute 10347 10348 begin 10349 -- If error during analysis, no point in continuing, except for array 10350 -- types, where we get better recovery by using unconstrained indexes 10351 -- than nothing at all (see Check_Array_Type). 10352 10353 if Error_Posted (N) 10354 and then Attr_Id /= Attribute_First 10355 and then Attr_Id /= Attribute_Last 10356 and then Attr_Id /= Attribute_Length 10357 and then Attr_Id /= Attribute_Range 10358 then 10359 return; 10360 end if; 10361 10362 -- If attribute was universal type, reset to actual type 10363 10364 if Etype (N) = Universal_Integer 10365 or else Etype (N) = Universal_Real 10366 then 10367 Set_Etype (N, Typ); 10368 end if; 10369 10370 -- Remaining processing depends on attribute 10371 10372 case Attr_Id is 10373 10374 ------------ 10375 -- Access -- 10376 ------------ 10377 10378 -- For access attributes, if the prefix denotes an entity, it is 10379 -- interpreted as a name, never as a call. It may be overloaded, 10380 -- in which case resolution uses the profile of the context type. 10381 -- Otherwise prefix must be resolved. 10382 10383 when Attribute_Access 10384 | Attribute_Unchecked_Access 10385 | Attribute_Unrestricted_Access 10386 => 10387 -- Note possible modification if we have a variable 10388 10389 if Is_Variable (P) then 10390 declare 10391 PN : constant Node_Id := Parent (N); 10392 Nm : Node_Id; 10393 10394 Note : Boolean := True; 10395 -- Skip this for the case of Unrestricted_Access occuring in 10396 -- the context of a Valid check, since this otherwise leads 10397 -- to a missed warning (the Valid check does not really 10398 -- modify!) If this case, Note will be reset to False. 10399 10400 -- Skip it as well if the type is an Acccess_To_Constant, 10401 -- given that no use of the value can modify the prefix. 10402 10403 begin 10404 if Attr_Id = Attribute_Unrestricted_Access 10405 and then Nkind (PN) = N_Function_Call 10406 then 10407 Nm := Name (PN); 10408 10409 if Nkind (Nm) = N_Expanded_Name 10410 and then Chars (Nm) = Name_Valid 10411 and then Nkind (Prefix (Nm)) = N_Identifier 10412 and then Chars (Prefix (Nm)) = Name_Attr_Long_Float 10413 then 10414 Note := False; 10415 end if; 10416 10417 elsif Is_Access_Constant (Typ) then 10418 Note := False; 10419 end if; 10420 10421 if Note then 10422 Note_Possible_Modification (P, Sure => False); 10423 end if; 10424 end; 10425 end if; 10426 10427 -- The following comes from a query concerning improper use of 10428 -- universal_access in equality tests involving anonymous access 10429 -- types. Another good reason for 'Ref, but for now disable the 10430 -- test, which breaks several filed tests??? 10431 10432 if Ekind (Typ) = E_Anonymous_Access_Type 10433 and then Nkind_In (Parent (N), N_Op_Eq, N_Op_Ne) 10434 and then False 10435 then 10436 Error_Msg_N ("need unique type to resolve 'Access", N); 10437 Error_Msg_N ("\qualify attribute with some access type", N); 10438 end if; 10439 10440 -- Case where prefix is an entity name 10441 10442 if Is_Entity_Name (P) then 10443 10444 -- Deal with case where prefix itself is overloaded 10445 10446 if Is_Overloaded (P) then 10447 Get_First_Interp (P, Index, It); 10448 while Present (It.Nam) loop 10449 if Type_Conformant (Designated_Type (Typ), It.Nam) then 10450 Set_Entity (P, It.Nam); 10451 10452 -- The prefix is definitely NOT overloaded anymore at 10453 -- this point, so we reset the Is_Overloaded flag to 10454 -- avoid any confusion when reanalyzing the node. 10455 10456 Set_Is_Overloaded (P, False); 10457 Set_Is_Overloaded (N, False); 10458 Generate_Reference (Entity (P), P); 10459 exit; 10460 end if; 10461 10462 Get_Next_Interp (Index, It); 10463 end loop; 10464 10465 -- If Prefix is a subprogram name, this reference freezes, 10466 -- but not if within spec expression mode. The profile of 10467 -- the subprogram is not frozen at this point. 10468 10469 if not In_Spec_Expression then 10470 Freeze_Before (N, Entity (P), Do_Freeze_Profile => False); 10471 end if; 10472 10473 -- If it is a type, there is nothing to resolve. 10474 -- If it is a subprogram, do not freeze its profile. 10475 -- If it is an object, complete its resolution. 10476 10477 elsif Is_Overloadable (Entity (P)) then 10478 if not In_Spec_Expression then 10479 Freeze_Before (N, Entity (P), Do_Freeze_Profile => False); 10480 end if; 10481 10482 -- Nothing to do if prefix is a type name 10483 10484 elsif Is_Type (Entity (P)) then 10485 null; 10486 10487 -- Otherwise non-overloaded other case, resolve the prefix 10488 10489 else 10490 Resolve (P); 10491 end if; 10492 10493 -- Some further error checks 10494 10495 Error_Msg_Name_1 := Aname; 10496 10497 if not Is_Entity_Name (P) then 10498 null; 10499 10500 elsif Is_Overloadable (Entity (P)) 10501 and then Is_Abstract_Subprogram (Entity (P)) 10502 then 10503 Error_Msg_F ("prefix of % attribute cannot be abstract", P); 10504 Set_Etype (N, Any_Type); 10505 10506 elsif Ekind (Entity (P)) = E_Enumeration_Literal then 10507 Error_Msg_F 10508 ("prefix of % attribute cannot be enumeration literal", P); 10509 Set_Etype (N, Any_Type); 10510 10511 -- An attempt to take 'Access of a function that renames an 10512 -- enumeration literal. Issue a specialized error message. 10513 10514 elsif Ekind (Entity (P)) = E_Function 10515 and then Present (Alias (Entity (P))) 10516 and then Ekind (Alias (Entity (P))) = E_Enumeration_Literal 10517 then 10518 Error_Msg_F 10519 ("prefix of % attribute cannot be function renaming " 10520 & "an enumeration literal", P); 10521 Set_Etype (N, Any_Type); 10522 10523 elsif Convention (Entity (P)) = Convention_Intrinsic then 10524 Error_Msg_F ("prefix of % attribute cannot be intrinsic", P); 10525 Set_Etype (N, Any_Type); 10526 end if; 10527 10528 -- Assignments, return statements, components of aggregates, 10529 -- generic instantiations will require convention checks if 10530 -- the type is an access to subprogram. Given that there will 10531 -- also be accessibility checks on those, this is where the 10532 -- checks can eventually be centralized ??? 10533 10534 if Ekind_In (Btyp, E_Access_Protected_Subprogram_Type, 10535 E_Access_Subprogram_Type, 10536 E_Anonymous_Access_Protected_Subprogram_Type, 10537 E_Anonymous_Access_Subprogram_Type) 10538 then 10539 -- Deal with convention mismatch 10540 10541 if Convention (Designated_Type (Btyp)) /= 10542 Convention (Entity (P)) 10543 then 10544 -- The rule in 6.3.1 (8) deserves a special error 10545 -- message. 10546 10547 if Convention (Btyp) = Convention_Intrinsic 10548 and then Nkind (Parent (N)) = N_Procedure_Call_Statement 10549 and then Is_Entity_Name (Name (Parent (N))) 10550 and then Inside_A_Generic 10551 then 10552 declare 10553 Subp : constant Entity_Id := 10554 Entity (Name (Parent (N))); 10555 begin 10556 if Convention (Subp) = Convention_Intrinsic then 10557 Error_Msg_FE 10558 ("?subprogram and its formal access " 10559 & "parameters have convention Intrinsic", 10560 Parent (N), Subp); 10561 Error_Msg_N 10562 ("actual cannot be access attribute", N); 10563 end if; 10564 end; 10565 10566 else 10567 Error_Msg_FE 10568 ("subprogram & has wrong convention", P, Entity (P)); 10569 Error_Msg_Sloc := Sloc (Btyp); 10570 Error_Msg_FE ("\does not match & declared#", P, Btyp); 10571 end if; 10572 10573 if not Is_Itype (Btyp) 10574 and then not Has_Convention_Pragma (Btyp) 10575 then 10576 Error_Msg_FE 10577 ("\probable missing pragma Convention for &", 10578 P, Btyp); 10579 end if; 10580 10581 else 10582 Check_Subtype_Conformant 10583 (New_Id => Entity (P), 10584 Old_Id => Designated_Type (Btyp), 10585 Err_Loc => P); 10586 end if; 10587 10588 if Attr_Id = Attribute_Unchecked_Access then 10589 Error_Msg_Name_1 := Aname; 10590 Error_Msg_F 10591 ("attribute% cannot be applied to a subprogram", P); 10592 10593 elsif Aname = Name_Unrestricted_Access then 10594 null; -- Nothing to check 10595 10596 -- Check the static accessibility rule of 3.10.2(32). 10597 -- This rule also applies within the private part of an 10598 -- instantiation. This rule does not apply to anonymous 10599 -- access-to-subprogram types in access parameters. 10600 10601 elsif Attr_Id = Attribute_Access 10602 and then not In_Instance_Body 10603 and then 10604 (Ekind (Btyp) = E_Access_Subprogram_Type 10605 or else Is_Local_Anonymous_Access (Btyp)) 10606 and then Subprogram_Access_Level (Entity (P)) > 10607 Type_Access_Level (Btyp) 10608 then 10609 Error_Msg_F 10610 ("subprogram must not be deeper than access type", P); 10611 10612 -- Check the restriction of 3.10.2(32) that disallows the 10613 -- access attribute within a generic body when the ultimate 10614 -- ancestor of the type of the attribute is declared outside 10615 -- of the generic unit and the subprogram is declared within 10616 -- that generic unit. This includes any such attribute that 10617 -- occurs within the body of a generic unit that is a child 10618 -- of the generic unit where the subprogram is declared. 10619 10620 -- The rule also prohibits applying the attribute when the 10621 -- access type is a generic formal access type (since the 10622 -- level of the actual type is not known). This restriction 10623 -- does not apply when the attribute type is an anonymous 10624 -- access-to-subprogram type. Note that this check was 10625 -- revised by AI-229, because the original Ada 95 rule 10626 -- was too lax. The original rule only applied when the 10627 -- subprogram was declared within the body of the generic, 10628 -- which allowed the possibility of dangling references). 10629 -- The rule was also too strict in some cases, in that it 10630 -- didn't permit the access to be declared in the generic 10631 -- spec, whereas the revised rule does (as long as it's not 10632 -- a formal type). 10633 10634 -- There are a couple of subtleties of the test for applying 10635 -- the check that are worth noting. First, we only apply it 10636 -- when the levels of the subprogram and access type are the 10637 -- same (the case where the subprogram is statically deeper 10638 -- was applied above, and the case where the type is deeper 10639 -- is always safe). Second, we want the check to apply 10640 -- within nested generic bodies and generic child unit 10641 -- bodies, but not to apply to an attribute that appears in 10642 -- the generic unit's specification. This is done by testing 10643 -- that the attribute's innermost enclosing generic body is 10644 -- not the same as the innermost generic body enclosing the 10645 -- generic unit where the subprogram is declared (we don't 10646 -- want the check to apply when the access attribute is in 10647 -- the spec and there's some other generic body enclosing 10648 -- generic). Finally, there's no point applying the check 10649 -- when within an instance, because any violations will have 10650 -- been caught by the compilation of the generic unit. 10651 10652 -- We relax this check in Relaxed_RM_Semantics mode for 10653 -- compatibility with legacy code for use by Ada source 10654 -- code analyzers (e.g. CodePeer). 10655 10656 elsif Attr_Id = Attribute_Access 10657 and then not Relaxed_RM_Semantics 10658 and then not In_Instance 10659 and then Present (Enclosing_Generic_Unit (Entity (P))) 10660 and then Present (Enclosing_Generic_Body (N)) 10661 and then Enclosing_Generic_Body (N) /= 10662 Enclosing_Generic_Body 10663 (Enclosing_Generic_Unit (Entity (P))) 10664 and then Subprogram_Access_Level (Entity (P)) = 10665 Type_Access_Level (Btyp) 10666 and then Ekind (Btyp) /= 10667 E_Anonymous_Access_Subprogram_Type 10668 and then Ekind (Btyp) /= 10669 E_Anonymous_Access_Protected_Subprogram_Type 10670 then 10671 -- The attribute type's ultimate ancestor must be 10672 -- declared within the same generic unit as the 10673 -- subprogram is declared (including within another 10674 -- nested generic unit). The error message is 10675 -- specialized to say "ancestor" for the case where the 10676 -- access type is not its own ancestor, since saying 10677 -- simply "access type" would be very confusing. 10678 10679 if not Declared_Within_Generic_Unit 10680 (Root_Type (Btyp), 10681 Enclosing_Generic_Unit (Entity (P))) 10682 then 10683 Error_Msg_N 10684 ("''Access attribute not allowed in generic body", 10685 N); 10686 10687 if Root_Type (Btyp) = Btyp then 10688 Error_Msg_NE 10689 ("\because " & 10690 "access type & is declared outside " & 10691 "generic unit (RM 3.10.2(32))", N, Btyp); 10692 else 10693 Error_Msg_NE 10694 ("\because ancestor of " & 10695 "access type & is declared outside " & 10696 "generic unit (RM 3.10.2(32))", N, Btyp); 10697 end if; 10698 10699 Error_Msg_NE 10700 ("\move ''Access to private part, or " & 10701 "(Ada 2005) use anonymous access type instead of &", 10702 N, Btyp); 10703 10704 -- If the ultimate ancestor of the attribute's type is 10705 -- a formal type, then the attribute is illegal because 10706 -- the actual type might be declared at a higher level. 10707 -- The error message is specialized to say "ancestor" 10708 -- for the case where the access type is not its own 10709 -- ancestor, since saying simply "access type" would be 10710 -- very confusing. 10711 10712 elsif Is_Generic_Type (Root_Type (Btyp)) then 10713 if Root_Type (Btyp) = Btyp then 10714 Error_Msg_N 10715 ("access type must not be a generic formal type", 10716 N); 10717 else 10718 Error_Msg_N 10719 ("ancestor access type must not be a generic " & 10720 "formal type", N); 10721 end if; 10722 end if; 10723 end if; 10724 end if; 10725 10726 -- If this is a renaming, an inherited operation, or a 10727 -- subprogram instance, use the original entity. This may make 10728 -- the node type-inconsistent, so this transformation can only 10729 -- be done if the node will not be reanalyzed. In particular, 10730 -- if it is within a default expression, the transformation 10731 -- must be delayed until the default subprogram is created for 10732 -- it, when the enclosing subprogram is frozen. 10733 10734 if Is_Entity_Name (P) 10735 and then Is_Overloadable (Entity (P)) 10736 and then Present (Alias (Entity (P))) 10737 and then Expander_Active 10738 then 10739 Rewrite (P, 10740 New_Occurrence_Of (Alias (Entity (P)), Sloc (P))); 10741 end if; 10742 10743 elsif Nkind (P) = N_Selected_Component 10744 and then Is_Overloadable (Entity (Selector_Name (P))) 10745 then 10746 -- Protected operation. If operation is overloaded, must 10747 -- disambiguate. Prefix that denotes protected object itself 10748 -- is resolved with its own type. 10749 10750 if Attr_Id = Attribute_Unchecked_Access then 10751 Error_Msg_Name_1 := Aname; 10752 Error_Msg_F 10753 ("attribute% cannot be applied to protected operation", P); 10754 end if; 10755 10756 Resolve (Prefix (P)); 10757 Generate_Reference (Entity (Selector_Name (P)), P); 10758 10759 -- Implement check implied by 3.10.2 (18.1/2) : F.all'access is 10760 -- statically illegal if F is an anonymous access to subprogram. 10761 10762 elsif Nkind (P) = N_Explicit_Dereference 10763 and then Is_Entity_Name (Prefix (P)) 10764 and then Ekind (Etype (Entity (Prefix (P)))) = 10765 E_Anonymous_Access_Subprogram_Type 10766 then 10767 Error_Msg_N ("anonymous access to subprogram " 10768 & "has deeper accessibility than any master", P); 10769 10770 elsif Is_Overloaded (P) then 10771 10772 -- Use the designated type of the context to disambiguate 10773 -- Note that this was not strictly conformant to Ada 95, 10774 -- but was the implementation adopted by most Ada 95 compilers. 10775 -- The use of the context type to resolve an Access attribute 10776 -- reference is now mandated in AI-235 for Ada 2005. 10777 10778 declare 10779 Index : Interp_Index; 10780 It : Interp; 10781 10782 begin 10783 Get_First_Interp (P, Index, It); 10784 while Present (It.Typ) loop 10785 if Covers (Designated_Type (Typ), It.Typ) then 10786 Resolve (P, It.Typ); 10787 exit; 10788 end if; 10789 10790 Get_Next_Interp (Index, It); 10791 end loop; 10792 end; 10793 else 10794 Resolve (P); 10795 end if; 10796 10797 -- X'Access is illegal if X denotes a constant and the access type 10798 -- is access-to-variable. Same for 'Unchecked_Access. The rule 10799 -- does not apply to 'Unrestricted_Access. If the reference is a 10800 -- default-initialized aggregate component for a self-referential 10801 -- type the reference is legal. 10802 10803 if not (Ekind (Btyp) = E_Access_Subprogram_Type 10804 or else Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type 10805 or else (Is_Record_Type (Btyp) 10806 and then 10807 Present (Corresponding_Remote_Type (Btyp))) 10808 or else Ekind (Btyp) = E_Access_Protected_Subprogram_Type 10809 or else Ekind (Btyp) 10810 = E_Anonymous_Access_Protected_Subprogram_Type 10811 or else Is_Access_Constant (Btyp) 10812 or else Is_Variable (P) 10813 or else Attr_Id = Attribute_Unrestricted_Access) 10814 then 10815 if Is_Entity_Name (P) 10816 and then Is_Type (Entity (P)) 10817 then 10818 -- Legality of a self-reference through an access 10819 -- attribute has been verified in Analyze_Access_Attribute. 10820 10821 null; 10822 10823 elsif Comes_From_Source (N) then 10824 Error_Msg_F ("access-to-variable designates constant", P); 10825 end if; 10826 end if; 10827 10828 Des_Btyp := Designated_Type (Btyp); 10829 10830 if Ada_Version >= Ada_2005 10831 and then Is_Incomplete_Type (Des_Btyp) 10832 then 10833 -- Ada 2005 (AI-412): If the (sub)type is a limited view of an 10834 -- imported entity, and the non-limited view is visible, make 10835 -- use of it. If it is an incomplete subtype, use the base type 10836 -- in any case. 10837 10838 if From_Limited_With (Des_Btyp) 10839 and then Present (Non_Limited_View (Des_Btyp)) 10840 then 10841 Des_Btyp := Non_Limited_View (Des_Btyp); 10842 10843 elsif Ekind (Des_Btyp) = E_Incomplete_Subtype then 10844 Des_Btyp := Etype (Des_Btyp); 10845 end if; 10846 end if; 10847 10848 if (Attr_Id = Attribute_Access 10849 or else 10850 Attr_Id = Attribute_Unchecked_Access) 10851 and then (Ekind (Btyp) = E_General_Access_Type 10852 or else Ekind (Btyp) = E_Anonymous_Access_Type) 10853 then 10854 -- Ada 2005 (AI-230): Check the accessibility of anonymous 10855 -- access types for stand-alone objects, record and array 10856 -- components, and return objects. For a component definition 10857 -- the level is the same of the enclosing composite type. 10858 10859 if Ada_Version >= Ada_2005 10860 and then (Is_Local_Anonymous_Access (Btyp) 10861 10862 -- Handle cases where Btyp is the anonymous access 10863 -- type of an Ada 2012 stand-alone object. 10864 10865 or else Nkind (Associated_Node_For_Itype (Btyp)) = 10866 N_Object_Declaration) 10867 and then 10868 Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp) 10869 and then Attr_Id = Attribute_Access 10870 then 10871 -- In an instance, this is a runtime check, but one we know 10872 -- will fail, so generate an appropriate warning. As usual, 10873 -- this kind of warning is an error in SPARK mode. 10874 10875 if In_Instance_Body then 10876 Error_Msg_Warn := SPARK_Mode /= On; 10877 Error_Msg_F 10878 ("non-local pointer cannot point to local object<<", P); 10879 Error_Msg_F ("\Program_Error [<<", P); 10880 10881 Rewrite (N, 10882 Make_Raise_Program_Error (Loc, 10883 Reason => PE_Accessibility_Check_Failed)); 10884 Set_Etype (N, Typ); 10885 10886 else 10887 Error_Msg_F 10888 ("non-local pointer cannot point to local object", P); 10889 end if; 10890 end if; 10891 10892 if Is_Dependent_Component_Of_Mutable_Object (P) then 10893 Error_Msg_F 10894 ("illegal attribute for discriminant-dependent component", 10895 P); 10896 end if; 10897 10898 -- Check static matching rule of 3.10.2(27). Nominal subtype 10899 -- of the prefix must statically match the designated type. 10900 10901 Nom_Subt := Etype (P); 10902 10903 if Is_Constr_Subt_For_U_Nominal (Nom_Subt) then 10904 Nom_Subt := Base_Type (Nom_Subt); 10905 end if; 10906 10907 if Is_Tagged_Type (Designated_Type (Typ)) then 10908 10909 -- If the attribute is in the context of an access 10910 -- parameter, then the prefix is allowed to be of 10911 -- the class-wide type (by AI-127). 10912 10913 if Ekind (Typ) = E_Anonymous_Access_Type then 10914 if not Covers (Designated_Type (Typ), Nom_Subt) 10915 and then not Covers (Nom_Subt, Designated_Type (Typ)) 10916 then 10917 declare 10918 Desig : Entity_Id; 10919 10920 begin 10921 Desig := Designated_Type (Typ); 10922 10923 if Is_Class_Wide_Type (Desig) then 10924 Desig := Etype (Desig); 10925 end if; 10926 10927 if Is_Anonymous_Tagged_Base (Nom_Subt, Desig) then 10928 null; 10929 10930 else 10931 Error_Msg_FE 10932 ("type of prefix: & not compatible", 10933 P, Nom_Subt); 10934 Error_Msg_FE 10935 ("\with &, the expected designated type", 10936 P, Designated_Type (Typ)); 10937 end if; 10938 end; 10939 end if; 10940 10941 elsif not Covers (Designated_Type (Typ), Nom_Subt) 10942 or else 10943 (not Is_Class_Wide_Type (Designated_Type (Typ)) 10944 and then Is_Class_Wide_Type (Nom_Subt)) 10945 then 10946 Error_Msg_FE 10947 ("type of prefix: & is not covered", P, Nom_Subt); 10948 Error_Msg_FE 10949 ("\by &, the expected designated type" & 10950 " (RM 3.10.2 (27))", P, Designated_Type (Typ)); 10951 end if; 10952 10953 if Is_Class_Wide_Type (Designated_Type (Typ)) 10954 and then Has_Discriminants (Etype (Designated_Type (Typ))) 10955 and then Is_Constrained (Etype (Designated_Type (Typ))) 10956 and then Designated_Type (Typ) /= Nom_Subt 10957 then 10958 Apply_Discriminant_Check 10959 (N, Etype (Designated_Type (Typ))); 10960 end if; 10961 10962 -- Ada 2005 (AI-363): Require static matching when designated 10963 -- type has discriminants and a constrained partial view, since 10964 -- in general objects of such types are mutable, so we can't 10965 -- allow the access value to designate a constrained object 10966 -- (because access values must be assumed to designate mutable 10967 -- objects when designated type does not impose a constraint). 10968 10969 elsif Subtypes_Statically_Match (Des_Btyp, Nom_Subt) then 10970 null; 10971 10972 elsif Has_Discriminants (Designated_Type (Typ)) 10973 and then not Is_Constrained (Des_Btyp) 10974 and then 10975 (Ada_Version < Ada_2005 10976 or else 10977 not Object_Type_Has_Constrained_Partial_View 10978 (Typ => Designated_Type (Base_Type (Typ)), 10979 Scop => Current_Scope)) 10980 then 10981 null; 10982 10983 else 10984 Error_Msg_F 10985 ("object subtype must statically match " 10986 & "designated subtype", P); 10987 10988 if Is_Entity_Name (P) 10989 and then Is_Array_Type (Designated_Type (Typ)) 10990 then 10991 declare 10992 D : constant Node_Id := Declaration_Node (Entity (P)); 10993 begin 10994 Error_Msg_N 10995 ("aliased object has explicit bounds??", D); 10996 Error_Msg_N 10997 ("\declare without bounds (and with explicit " 10998 & "initialization)??", D); 10999 Error_Msg_N 11000 ("\for use with unconstrained access??", D); 11001 end; 11002 end if; 11003 end if; 11004 11005 -- Check the static accessibility rule of 3.10.2(28). Note that 11006 -- this check is not performed for the case of an anonymous 11007 -- access type, since the access attribute is always legal 11008 -- in such a context. 11009 11010 if Attr_Id /= Attribute_Unchecked_Access 11011 and then Ekind (Btyp) = E_General_Access_Type 11012 and then 11013 Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp) 11014 then 11015 Accessibility_Message; 11016 return; 11017 end if; 11018 end if; 11019 11020 if Ekind_In (Btyp, E_Access_Protected_Subprogram_Type, 11021 E_Anonymous_Access_Protected_Subprogram_Type) 11022 then 11023 if Is_Entity_Name (P) 11024 and then not Is_Protected_Type (Scope (Entity (P))) 11025 then 11026 Error_Msg_F ("context requires a protected subprogram", P); 11027 11028 -- Check accessibility of protected object against that of the 11029 -- access type, but only on user code, because the expander 11030 -- creates access references for handlers. If the context is an 11031 -- anonymous_access_to_protected, there are no accessibility 11032 -- checks either. Omit check entirely for Unrestricted_Access. 11033 11034 elsif Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp) 11035 and then Comes_From_Source (N) 11036 and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type 11037 and then Attr_Id /= Attribute_Unrestricted_Access 11038 then 11039 Accessibility_Message; 11040 return; 11041 11042 -- AI05-0225: If the context is not an access to protected 11043 -- function, the prefix must be a variable, given that it may 11044 -- be used subsequently in a protected call. 11045 11046 elsif Nkind (P) = N_Selected_Component 11047 and then not Is_Variable (Prefix (P)) 11048 and then Ekind (Entity (Selector_Name (P))) /= E_Function 11049 then 11050 Error_Msg_N 11051 ("target object of access to protected procedure " 11052 & "must be variable", N); 11053 11054 elsif Is_Entity_Name (P) then 11055 Check_Internal_Protected_Use (N, Entity (P)); 11056 end if; 11057 11058 elsif Ekind_In (Btyp, E_Access_Subprogram_Type, 11059 E_Anonymous_Access_Subprogram_Type) 11060 and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type 11061 then 11062 Error_Msg_F ("context requires a non-protected subprogram", P); 11063 end if; 11064 11065 -- The context cannot be a pool-specific type, but this is a 11066 -- legality rule, not a resolution rule, so it must be checked 11067 -- separately, after possibly disambiguation (see AI-245). 11068 11069 if Ekind (Btyp) = E_Access_Type 11070 and then Attr_Id /= Attribute_Unrestricted_Access 11071 then 11072 Wrong_Type (N, Typ); 11073 end if; 11074 11075 -- The context may be a constrained access type (however ill- 11076 -- advised such subtypes might be) so in order to generate a 11077 -- constraint check when needed set the type of the attribute 11078 -- reference to the base type of the context. 11079 11080 Set_Etype (N, Btyp); 11081 11082 -- Check for incorrect atomic/volatile reference (RM C.6(12)) 11083 11084 if Attr_Id /= Attribute_Unrestricted_Access then 11085 if Is_Atomic_Object (P) 11086 and then not Is_Atomic (Designated_Type (Typ)) 11087 then 11088 Error_Msg_F 11089 ("access to atomic object cannot yield access-to-" & 11090 "non-atomic type", P); 11091 11092 elsif Is_Volatile_Object (P) 11093 and then not Is_Volatile (Designated_Type (Typ)) 11094 then 11095 Error_Msg_F 11096 ("access to volatile object cannot yield access-to-" & 11097 "non-volatile type", P); 11098 end if; 11099 end if; 11100 11101 -- Check for aliased view. We allow a nonaliased prefix when in 11102 -- an instance because the prefix may have been a tagged formal 11103 -- object, which is defined to be aliased even when the actual 11104 -- might not be (other instance cases will have been caught in 11105 -- the generic). Similarly, within an inlined body we know that 11106 -- the attribute is legal in the original subprogram, therefore 11107 -- legal in the expansion. 11108 11109 if not (Is_Entity_Name (P) 11110 and then Is_Overloadable (Entity (P))) 11111 and then not (Nkind (P) = N_Selected_Component 11112 and then 11113 Is_Overloadable (Entity (Selector_Name (P)))) 11114 and then not Is_Aliased_View (Original_Node (P)) 11115 and then not In_Instance 11116 and then not In_Inlined_Body 11117 and then Comes_From_Source (N) 11118 then 11119 -- Here we have a non-aliased view. This is illegal unless we 11120 -- have the case of Unrestricted_Access, where for now we allow 11121 -- this (we will reject later if expected type is access to an 11122 -- unconstrained array with a thin pointer). 11123 11124 -- No need for an error message on a generated access reference 11125 -- for the controlling argument in a dispatching call: error 11126 -- will be reported when resolving the call. 11127 11128 if Attr_Id /= Attribute_Unrestricted_Access then 11129 Error_Msg_N ("prefix of % attribute must be aliased", P); 11130 11131 -- Check for unrestricted access where expected type is a thin 11132 -- pointer to an unconstrained array. 11133 11134 elsif Has_Size_Clause (Typ) 11135 and then RM_Size (Typ) = System_Address_Size 11136 then 11137 declare 11138 DT : constant Entity_Id := Designated_Type (Typ); 11139 begin 11140 if Is_Array_Type (DT) 11141 and then not Is_Constrained (DT) 11142 then 11143 Error_Msg_N 11144 ("illegal use of Unrestricted_Access attribute", P); 11145 Error_Msg_N 11146 ("\attempt to generate thin pointer to unaliased " 11147 & "object", P); 11148 end if; 11149 end; 11150 end if; 11151 end if; 11152 11153 -- Mark that address of entity is taken in case of 11154 -- 'Unrestricted_Access or in case of a subprogram. 11155 11156 if Is_Entity_Name (P) 11157 and then (Attr_Id = Attribute_Unrestricted_Access 11158 or else Is_Subprogram (Entity (P))) 11159 then 11160 Set_Address_Taken (Entity (P)); 11161 end if; 11162 11163 -- Deal with possible elaboration check 11164 11165 if Is_Entity_Name (P) and then Is_Subprogram (Entity (P)) then 11166 declare 11167 Subp_Id : constant Entity_Id := Entity (P); 11168 Scop : constant Entity_Id := Scope (Subp_Id); 11169 Subp_Decl : constant Node_Id := 11170 Unit_Declaration_Node (Subp_Id); 11171 Flag_Id : Entity_Id; 11172 Subp_Body : Node_Id; 11173 11174 -- If the access has been taken and the body of the subprogram 11175 -- has not been see yet, indirect calls must be protected with 11176 -- elaboration checks. We have the proper elaboration machinery 11177 -- for subprograms declared in packages, but within a block or 11178 -- a subprogram the body will appear in the same declarative 11179 -- part, and we must insert a check in the eventual body itself 11180 -- using the elaboration flag that we generate now. The check 11181 -- is then inserted when the body is expanded. This processing 11182 -- is not needed for a stand alone expression function because 11183 -- the internally generated spec and body are always inserted 11184 -- as a pair in the same declarative list. 11185 11186 begin 11187 if Expander_Active 11188 and then Comes_From_Source (Subp_Id) 11189 and then Comes_From_Source (N) 11190 and then In_Open_Scopes (Scop) 11191 and then Ekind_In (Scop, E_Block, E_Procedure, E_Function) 11192 and then not Has_Completion (Subp_Id) 11193 and then No (Elaboration_Entity (Subp_Id)) 11194 and then Nkind (Subp_Decl) = N_Subprogram_Declaration 11195 and then Nkind (Original_Node (Subp_Decl)) /= 11196 N_Expression_Function 11197 then 11198 -- Create elaboration variable for it 11199 11200 Flag_Id := Make_Temporary (Loc, 'E'); 11201 Set_Elaboration_Entity (Subp_Id, Flag_Id); 11202 Set_Is_Frozen (Flag_Id); 11203 11204 -- Insert declaration for flag after subprogram 11205 -- declaration. Note that attribute reference may 11206 -- appear within a nested scope. 11207 11208 Insert_After_And_Analyze (Subp_Decl, 11209 Make_Object_Declaration (Loc, 11210 Defining_Identifier => Flag_Id, 11211 Object_Definition => 11212 New_Occurrence_Of (Standard_Short_Integer, Loc), 11213 Expression => 11214 Make_Integer_Literal (Loc, Uint_0))); 11215 end if; 11216 11217 -- Taking the 'Access of an expression function freezes its 11218 -- expression (RM 13.14 10.3/3). This does not apply to an 11219 -- expression function that acts as a completion because the 11220 -- generated body is immediately analyzed and the expression 11221 -- is automatically frozen. 11222 11223 if Is_Expression_Function (Subp_Id) 11224 and then Present (Corresponding_Body (Subp_Decl)) 11225 then 11226 Subp_Body := 11227 Unit_Declaration_Node (Corresponding_Body (Subp_Decl)); 11228 11229 -- The body has already been analyzed when the expression 11230 -- function acts as a completion. 11231 11232 if Analyzed (Subp_Body) then 11233 null; 11234 11235 -- Attribute 'Access may appear within the generated body 11236 -- of the expression function subject to the attribute: 11237 11238 -- function F is (... F'Access ...); 11239 11240 -- If the expression function is on the scope stack, then 11241 -- the body is currently being analyzed. Do not reanalyze 11242 -- it because this will lead to infinite recursion. 11243 11244 elsif In_Open_Scopes (Subp_Id) then 11245 null; 11246 11247 -- If reference to the expression function appears in an 11248 -- inner scope, for example as an actual in an instance, 11249 -- this is not a freeze point either. 11250 11251 elsif Scope (Subp_Id) /= Current_Scope then 11252 null; 11253 11254 -- Analyze the body of the expression function to freeze 11255 -- the expression. This takes care of the case where the 11256 -- 'Access is part of dispatch table initialization and 11257 -- the generated body of the expression function has not 11258 -- been analyzed yet. 11259 11260 else 11261 Analyze (Subp_Body); 11262 end if; 11263 end if; 11264 end; 11265 end if; 11266 11267 ------------- 11268 -- Address -- 11269 ------------- 11270 11271 -- Deal with resolving the type for Address attribute, overloading 11272 -- is not permitted here, since there is no context to resolve it. 11273 11274 when Attribute_Address 11275 | Attribute_Code_Address 11276 => 11277 -- To be safe, assume that if the address of a variable is taken, 11278 -- it may be modified via this address, so note modification. 11279 11280 if Is_Variable (P) then 11281 Note_Possible_Modification (P, Sure => False); 11282 end if; 11283 11284 if Nkind (P) in N_Subexpr 11285 and then Is_Overloaded (P) 11286 then 11287 Get_First_Interp (P, Index, It); 11288 Get_Next_Interp (Index, It); 11289 11290 if Present (It.Nam) then 11291 Error_Msg_Name_1 := Aname; 11292 Error_Msg_F 11293 ("prefix of % attribute cannot be overloaded", P); 11294 end if; 11295 end if; 11296 11297 if not Is_Entity_Name (P) 11298 or else not Is_Overloadable (Entity (P)) 11299 then 11300 if not Is_Task_Type (Etype (P)) 11301 or else Nkind (P) = N_Explicit_Dereference 11302 then 11303 Resolve (P); 11304 end if; 11305 end if; 11306 11307 -- If this is the name of a derived subprogram, or that of a 11308 -- generic actual, the address is that of the original entity. 11309 11310 if Is_Entity_Name (P) 11311 and then Is_Overloadable (Entity (P)) 11312 and then Present (Alias (Entity (P))) 11313 then 11314 Rewrite (P, 11315 New_Occurrence_Of (Alias (Entity (P)), Sloc (P))); 11316 end if; 11317 11318 if Is_Entity_Name (P) then 11319 Set_Address_Taken (Entity (P)); 11320 end if; 11321 11322 if Nkind (P) = N_Slice then 11323 11324 -- Arr (X .. Y)'address is identical to Arr (X)'address, 11325 -- even if the array is packed and the slice itself is not 11326 -- addressable. Transform the prefix into an indexed component. 11327 11328 -- Note that the transformation is safe only if we know that 11329 -- the slice is non-null. That is because a null slice can have 11330 -- an out of bounds index value. 11331 11332 -- Right now, gigi blows up if given 'Address on a slice as a 11333 -- result of some incorrect freeze nodes generated by the front 11334 -- end, and this covers up that bug in one case, but the bug is 11335 -- likely still there in the cases not handled by this code ??? 11336 11337 -- It's not clear what 'Address *should* return for a null 11338 -- slice with out of bounds indexes, this might be worth an ARG 11339 -- discussion ??? 11340 11341 -- One approach would be to do a length check unconditionally, 11342 -- and then do the transformation below unconditionally, but 11343 -- analyze with checks off, avoiding the problem of the out of 11344 -- bounds index. This approach would interpret the address of 11345 -- an out of bounds null slice as being the address where the 11346 -- array element would be if there was one, which is probably 11347 -- as reasonable an interpretation as any ??? 11348 11349 declare 11350 Loc : constant Source_Ptr := Sloc (P); 11351 D : constant Node_Id := Discrete_Range (P); 11352 Lo : Node_Id; 11353 11354 begin 11355 if Is_Entity_Name (D) 11356 and then 11357 Not_Null_Range 11358 (Type_Low_Bound (Entity (D)), 11359 Type_High_Bound (Entity (D))) 11360 then 11361 Lo := 11362 Make_Attribute_Reference (Loc, 11363 Prefix => (New_Occurrence_Of (Entity (D), Loc)), 11364 Attribute_Name => Name_First); 11365 11366 elsif Nkind (D) = N_Range 11367 and then Not_Null_Range (Low_Bound (D), High_Bound (D)) 11368 then 11369 Lo := Low_Bound (D); 11370 11371 else 11372 Lo := Empty; 11373 end if; 11374 11375 if Present (Lo) then 11376 Rewrite (P, 11377 Make_Indexed_Component (Loc, 11378 Prefix => Relocate_Node (Prefix (P)), 11379 Expressions => New_List (Lo))); 11380 11381 Analyze_And_Resolve (P); 11382 end if; 11383 end; 11384 end if; 11385 11386 ------------------ 11387 -- Body_Version -- 11388 ------------------ 11389 11390 -- Prefix of Body_Version attribute can be a subprogram name which 11391 -- must not be resolved, since this is not a call. 11392 11393 when Attribute_Body_Version => 11394 null; 11395 11396 ------------ 11397 -- Caller -- 11398 ------------ 11399 11400 -- Prefix of Caller attribute is an entry name which must not 11401 -- be resolved, since this is definitely not an entry call. 11402 11403 when Attribute_Caller => 11404 null; 11405 11406 ------------------ 11407 -- Code_Address -- 11408 ------------------ 11409 11410 -- Shares processing with Address attribute 11411 11412 ----------- 11413 -- Count -- 11414 ----------- 11415 11416 -- If the prefix of the Count attribute is an entry name it must not 11417 -- be resolved, since this is definitely not an entry call. However, 11418 -- if it is an element of an entry family, the index itself may 11419 -- have to be resolved because it can be a general expression. 11420 11421 when Attribute_Count => 11422 if Nkind (P) = N_Indexed_Component 11423 and then Is_Entity_Name (Prefix (P)) 11424 then 11425 declare 11426 Indx : constant Node_Id := First (Expressions (P)); 11427 Fam : constant Entity_Id := Entity (Prefix (P)); 11428 begin 11429 Resolve (Indx, Entry_Index_Type (Fam)); 11430 Apply_Range_Check (Indx, Entry_Index_Type (Fam)); 11431 end; 11432 end if; 11433 11434 ---------------- 11435 -- Elaborated -- 11436 ---------------- 11437 11438 -- Prefix of the Elaborated attribute is a subprogram name which 11439 -- must not be resolved, since this is definitely not a call. Note 11440 -- that it is a library unit, so it cannot be overloaded here. 11441 11442 when Attribute_Elaborated => 11443 null; 11444 11445 ------------- 11446 -- Enabled -- 11447 ------------- 11448 11449 -- Prefix of Enabled attribute is a check name, which must be treated 11450 -- specially and not touched by Resolve. 11451 11452 when Attribute_Enabled => 11453 null; 11454 11455 ---------------- 11456 -- Loop_Entry -- 11457 ---------------- 11458 11459 -- Do not resolve the prefix of Loop_Entry, instead wait until the 11460 -- attribute has been expanded (see Expand_Loop_Entry_Attributes). 11461 -- The delay ensures that any generated checks or temporaries are 11462 -- inserted before the relocated prefix. 11463 11464 when Attribute_Loop_Entry => 11465 null; 11466 11467 -------------------- 11468 -- Mechanism_Code -- 11469 -------------------- 11470 11471 -- Prefix of the Mechanism_Code attribute is a function name 11472 -- which must not be resolved. Should we check for overloaded ??? 11473 11474 when Attribute_Mechanism_Code => 11475 null; 11476 11477 ------------------ 11478 -- Partition_ID -- 11479 ------------------ 11480 11481 -- Most processing is done in sem_dist, after determining the 11482 -- context type. Node is rewritten as a conversion to a runtime call. 11483 11484 when Attribute_Partition_ID => 11485 Process_Partition_Id (N); 11486 return; 11487 11488 ------------------ 11489 -- Pool_Address -- 11490 ------------------ 11491 11492 when Attribute_Pool_Address => 11493 Resolve (P); 11494 11495 ----------- 11496 -- Range -- 11497 ----------- 11498 11499 -- We replace the Range attribute node with a range expression whose 11500 -- bounds are the 'First and 'Last attributes applied to the same 11501 -- prefix. The reason that we do this transformation here instead of 11502 -- in the expander is that it simplifies other parts of the semantic 11503 -- analysis which assume that the Range has been replaced; thus it 11504 -- must be done even when in semantic-only mode (note that the RM 11505 -- specifically mentions this equivalence, we take care that the 11506 -- prefix is only evaluated once). 11507 11508 when Attribute_Range => Range_Attribute : declare 11509 Dims : List_Id; 11510 HB : Node_Id; 11511 LB : Node_Id; 11512 11513 begin 11514 if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then 11515 Resolve (P); 11516 end if; 11517 11518 Dims := Expressions (N); 11519 11520 HB := 11521 Make_Attribute_Reference (Loc, 11522 Prefix => Duplicate_Subexpr (P, Name_Req => True), 11523 Attribute_Name => Name_Last, 11524 Expressions => Dims); 11525 11526 LB := 11527 Make_Attribute_Reference (Loc, 11528 Prefix => P, 11529 Attribute_Name => Name_First, 11530 Expressions => (Dims)); 11531 11532 -- Do not share the dimension indicator, if present. Even though 11533 -- it is a static constant, its source location may be modified 11534 -- when printing expanded code and node sharing will lead to chaos 11535 -- in Sprint. 11536 11537 if Present (Dims) then 11538 Set_Expressions (LB, New_List (New_Copy_Tree (First (Dims)))); 11539 end if; 11540 11541 -- If the original was marked as Must_Not_Freeze (see code in 11542 -- Sem_Ch3.Make_Index), then make sure the rewriting does not 11543 -- freeze either. 11544 11545 if Must_Not_Freeze (N) then 11546 Set_Must_Not_Freeze (HB); 11547 Set_Must_Not_Freeze (LB); 11548 Set_Must_Not_Freeze (Prefix (HB)); 11549 Set_Must_Not_Freeze (Prefix (LB)); 11550 end if; 11551 11552 if Raises_Constraint_Error (Prefix (N)) then 11553 11554 -- Preserve Sloc of prefix in the new bounds, so that the 11555 -- posted warning can be removed if we are within unreachable 11556 -- code. 11557 11558 Set_Sloc (LB, Sloc (Prefix (N))); 11559 Set_Sloc (HB, Sloc (Prefix (N))); 11560 end if; 11561 11562 Rewrite (N, Make_Range (Loc, LB, HB)); 11563 Analyze_And_Resolve (N, Typ); 11564 11565 -- Ensure that the expanded range does not have side effects 11566 11567 Force_Evaluation (LB); 11568 Force_Evaluation (HB); 11569 11570 -- Normally after resolving attribute nodes, Eval_Attribute 11571 -- is called to do any possible static evaluation of the node. 11572 -- However, here since the Range attribute has just been 11573 -- transformed into a range expression it is no longer an 11574 -- attribute node and therefore the call needs to be avoided 11575 -- and is accomplished by simply returning from the procedure. 11576 11577 return; 11578 end Range_Attribute; 11579 11580 ------------ 11581 -- Result -- 11582 ------------ 11583 11584 -- We will only come here during the prescan of a spec expression 11585 -- containing a Result attribute. In that case the proper Etype has 11586 -- already been set, and nothing more needs to be done here. 11587 11588 when Attribute_Result => 11589 null; 11590 11591 ---------------------- 11592 -- Unchecked_Access -- 11593 ---------------------- 11594 11595 -- Processing is shared with Access 11596 11597 ------------------------- 11598 -- Unrestricted_Access -- 11599 ------------------------- 11600 11601 -- Processing is shared with Access 11602 11603 ------------ 11604 -- Update -- 11605 ------------ 11606 11607 -- Resolve aggregate components in component associations 11608 11609 when Attribute_Update => Update : declare 11610 Aggr : constant Node_Id := First (Expressions (N)); 11611 Typ : constant Entity_Id := Etype (Prefix (N)); 11612 Assoc : Node_Id; 11613 Comp : Node_Id; 11614 Expr : Node_Id; 11615 11616 begin 11617 -- Set the Etype of the aggregate to that of the prefix, even 11618 -- though the aggregate may not be a proper representation of a 11619 -- value of the type (missing or duplicated associations, etc.) 11620 -- Complete resolution of the prefix. Note that in Ada 2012 it 11621 -- can be a qualified expression that is e.g. an aggregate. 11622 11623 Set_Etype (Aggr, Typ); 11624 Resolve (Prefix (N), Typ); 11625 11626 -- For an array type, resolve expressions with the component type 11627 -- of the array, and apply constraint checks when needed. 11628 11629 if Is_Array_Type (Typ) then 11630 Assoc := First (Component_Associations (Aggr)); 11631 while Present (Assoc) loop 11632 Expr := Expression (Assoc); 11633 Resolve (Expr, Component_Type (Typ)); 11634 11635 -- For scalar array components set Do_Range_Check when 11636 -- needed. Constraint checking on non-scalar components 11637 -- is done in Aggregate_Constraint_Checks, but only if 11638 -- full analysis is enabled. These flags are not set in 11639 -- the front-end in GnatProve mode. 11640 11641 if Is_Scalar_Type (Component_Type (Typ)) 11642 and then not Is_OK_Static_Expression (Expr) 11643 and then not Range_Checks_Suppressed (Component_Type (Typ)) 11644 then 11645 if Is_Entity_Name (Expr) 11646 and then Etype (Expr) = Component_Type (Typ) 11647 then 11648 null; 11649 11650 else 11651 Set_Do_Range_Check (Expr); 11652 end if; 11653 end if; 11654 11655 -- The choices in the association are static constants, 11656 -- or static aggregates each of whose components belongs 11657 -- to the proper index type. However, they must also 11658 -- belong to the index subtype (s) of the prefix, which 11659 -- may be a subtype (e.g. given by a slice). 11660 11661 -- Choices may also be identifiers with no staticness 11662 -- requirements, in which case they must resolve to the 11663 -- index type. 11664 11665 declare 11666 C : Node_Id; 11667 C_E : Node_Id; 11668 Indx : Node_Id; 11669 11670 begin 11671 C := First (Choices (Assoc)); 11672 while Present (C) loop 11673 Indx := First_Index (Etype (Prefix (N))); 11674 11675 if Nkind (C) /= N_Aggregate then 11676 Analyze_And_Resolve (C, Etype (Indx)); 11677 Apply_Constraint_Check (C, Etype (Indx)); 11678 Check_Non_Static_Context (C); 11679 11680 else 11681 C_E := First (Expressions (C)); 11682 while Present (C_E) loop 11683 Analyze_And_Resolve (C_E, Etype (Indx)); 11684 Apply_Constraint_Check (C_E, Etype (Indx)); 11685 Check_Non_Static_Context (C_E); 11686 11687 Next (C_E); 11688 Next_Index (Indx); 11689 end loop; 11690 end if; 11691 11692 Next (C); 11693 end loop; 11694 end; 11695 11696 Next (Assoc); 11697 end loop; 11698 11699 -- For a record type, use type of each component, which is 11700 -- recorded during analysis. 11701 11702 else 11703 Assoc := First (Component_Associations (Aggr)); 11704 while Present (Assoc) loop 11705 Comp := First (Choices (Assoc)); 11706 Expr := Expression (Assoc); 11707 11708 if Nkind (Comp) /= N_Others_Choice 11709 and then not Error_Posted (Comp) 11710 then 11711 Resolve (Expr, Etype (Entity (Comp))); 11712 11713 if Is_Scalar_Type (Etype (Entity (Comp))) 11714 and then not Is_OK_Static_Expression (Expr) 11715 and then not Range_Checks_Suppressed 11716 (Etype (Entity (Comp))) 11717 then 11718 Set_Do_Range_Check (Expr); 11719 end if; 11720 end if; 11721 11722 Next (Assoc); 11723 end loop; 11724 end if; 11725 end Update; 11726 11727 --------- 11728 -- Val -- 11729 --------- 11730 11731 -- Apply range check. Note that we did not do this during the 11732 -- analysis phase, since we wanted Eval_Attribute to have a 11733 -- chance at finding an illegal out of range value. 11734 11735 when Attribute_Val => 11736 11737 -- Note that we do our own Eval_Attribute call here rather than 11738 -- use the common one, because we need to do processing after 11739 -- the call, as per above comment. 11740 11741 Eval_Attribute (N); 11742 11743 -- Eval_Attribute may replace the node with a raise CE, or 11744 -- fold it to a constant. Obviously we only apply a scalar 11745 -- range check if this did not happen. 11746 11747 if Nkind (N) = N_Attribute_Reference 11748 and then Attribute_Name (N) = Name_Val 11749 then 11750 Apply_Scalar_Range_Check (First (Expressions (N)), Btyp); 11751 end if; 11752 11753 return; 11754 11755 ------------- 11756 -- Version -- 11757 ------------- 11758 11759 -- Prefix of Version attribute can be a subprogram name which 11760 -- must not be resolved, since this is not a call. 11761 11762 when Attribute_Version => 11763 null; 11764 11765 ---------------------- 11766 -- Other Attributes -- 11767 ---------------------- 11768 11769 -- For other attributes, resolve prefix unless it is a type. If 11770 -- the attribute reference itself is a type name ('Base and 'Class) 11771 -- then this is only legal within a task or protected record. 11772 11773 when others => 11774 if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then 11775 Resolve (P); 11776 end if; 11777 11778 -- If the attribute reference itself is a type name ('Base, 11779 -- 'Class) then this is only legal within a task or protected 11780 -- record. What is this all about ??? 11781 11782 if Is_Entity_Name (N) and then Is_Type (Entity (N)) then 11783 if Is_Concurrent_Type (Entity (N)) 11784 and then In_Open_Scopes (Entity (P)) 11785 then 11786 null; 11787 else 11788 Error_Msg_N 11789 ("invalid use of subtype name in expression or call", N); 11790 end if; 11791 end if; 11792 11793 -- For attributes whose argument may be a string, complete 11794 -- resolution of argument now. This avoids premature expansion 11795 -- (and the creation of transient scopes) before the attribute 11796 -- reference is resolved. 11797 11798 case Attr_Id is 11799 when Attribute_Value => 11800 Resolve (First (Expressions (N)), Standard_String); 11801 11802 when Attribute_Wide_Value => 11803 Resolve (First (Expressions (N)), Standard_Wide_String); 11804 11805 when Attribute_Wide_Wide_Value => 11806 Resolve (First (Expressions (N)), Standard_Wide_Wide_String); 11807 11808 when others => null; 11809 end case; 11810 11811 -- If the prefix of the attribute is a class-wide type then it 11812 -- will be expanded into a dispatching call to a predefined 11813 -- primitive. Therefore we must check for potential violation 11814 -- of such restriction. 11815 11816 if Is_Class_Wide_Type (Etype (P)) then 11817 Check_Restriction (No_Dispatching_Calls, N); 11818 end if; 11819 end case; 11820 11821 -- Mark use clauses of the original prefix if the attribute is applied 11822 -- to an entity. 11823 11824 if Nkind (Original_Node (P)) in N_Has_Entity 11825 and then Present (Entity (Original_Node (P))) 11826 then 11827 Mark_Use_Clauses (Original_Node (P)); 11828 end if; 11829 11830 -- Normally the Freezing is done by Resolve but sometimes the Prefix 11831 -- is not resolved, in which case the freezing must be done now. 11832 11833 -- For an elaboration check on a subprogram, we do not freeze its type. 11834 -- It may be declared in an unrelated scope, in particular in the case 11835 -- of a generic function whose type may remain unelaborated. 11836 11837 if Attr_Id = Attribute_Elaborated then 11838 null; 11839 11840 else 11841 Freeze_Expression (P); 11842 end if; 11843 11844 -- Finally perform static evaluation on the attribute reference 11845 11846 Analyze_Dimension (N); 11847 Eval_Attribute (N); 11848 end Resolve_Attribute; 11849 11850 ------------------------ 11851 -- Set_Boolean_Result -- 11852 ------------------------ 11853 11854 procedure Set_Boolean_Result (N : Node_Id; B : Boolean) is 11855 Loc : constant Source_Ptr := Sloc (N); 11856 begin 11857 if B then 11858 Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); 11859 else 11860 Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); 11861 end if; 11862 end Set_Boolean_Result; 11863 11864 ------------------------------- 11865 -- Statically_Denotes_Object -- 11866 ------------------------------- 11867 11868 function Statically_Denotes_Object (N : Node_Id) return Boolean is 11869 Indx : Node_Id; 11870 11871 begin 11872 if Is_Entity_Name (N) then 11873 return True; 11874 11875 elsif Nkind (N) = N_Selected_Component 11876 and then Statically_Denotes_Object (Prefix (N)) 11877 and then Present (Entity (Selector_Name (N))) 11878 then 11879 declare 11880 Sel_Id : constant Entity_Id := Entity (Selector_Name (N)); 11881 Comp_Decl : constant Node_Id := Parent (Sel_Id); 11882 11883 begin 11884 if Depends_On_Discriminant (Sel_Id) then 11885 return False; 11886 11887 elsif Nkind (Parent (Parent (Comp_Decl))) = N_Variant then 11888 return False; 11889 11890 else 11891 return True; 11892 end if; 11893 end; 11894 11895 elsif Nkind (N) = N_Indexed_Component 11896 and then Statically_Denotes_Object (Prefix (N)) 11897 and then Is_Constrained (Etype (Prefix (N))) 11898 then 11899 Indx := First (Expressions (N)); 11900 while Present (Indx) loop 11901 if not Compile_Time_Known_Value (Indx) 11902 or else Do_Range_Check (Indx) 11903 then 11904 return False; 11905 end if; 11906 11907 Next (Indx); 11908 end loop; 11909 11910 return True; 11911 11912 else 11913 return False; 11914 end if; 11915 end Statically_Denotes_Object; 11916 11917 -------------------------------- 11918 -- Stream_Attribute_Available -- 11919 -------------------------------- 11920 11921 function Stream_Attribute_Available 11922 (Typ : Entity_Id; 11923 Nam : TSS_Name_Type; 11924 Partial_View : Node_Id := Empty) return Boolean 11925 is 11926 Etyp : Entity_Id := Typ; 11927 11928 -- Start of processing for Stream_Attribute_Available 11929 11930 begin 11931 -- We need some comments in this body ??? 11932 11933 if Has_Stream_Attribute_Definition (Typ, Nam) then 11934 return True; 11935 end if; 11936 11937 if Is_Class_Wide_Type (Typ) then 11938 return not Is_Limited_Type (Typ) 11939 or else Stream_Attribute_Available (Etype (Typ), Nam); 11940 end if; 11941 11942 if Nam = TSS_Stream_Input 11943 and then Is_Abstract_Type (Typ) 11944 and then not Is_Class_Wide_Type (Typ) 11945 then 11946 return False; 11947 end if; 11948 11949 if not (Is_Limited_Type (Typ) 11950 or else (Present (Partial_View) 11951 and then Is_Limited_Type (Partial_View))) 11952 then 11953 return True; 11954 end if; 11955 11956 -- In Ada 2005, Input can invoke Read, and Output can invoke Write 11957 11958 if Nam = TSS_Stream_Input 11959 and then Ada_Version >= Ada_2005 11960 and then Stream_Attribute_Available (Etyp, TSS_Stream_Read) 11961 then 11962 return True; 11963 11964 elsif Nam = TSS_Stream_Output 11965 and then Ada_Version >= Ada_2005 11966 and then Stream_Attribute_Available (Etyp, TSS_Stream_Write) 11967 then 11968 return True; 11969 end if; 11970 11971 -- Case of Read and Write: check for attribute definition clause that 11972 -- applies to an ancestor type. 11973 11974 while Etype (Etyp) /= Etyp loop 11975 Etyp := Etype (Etyp); 11976 11977 if Has_Stream_Attribute_Definition (Etyp, Nam) then 11978 return True; 11979 end if; 11980 end loop; 11981 11982 if Ada_Version < Ada_2005 then 11983 11984 -- In Ada 95 mode, also consider a non-visible definition 11985 11986 declare 11987 Btyp : constant Entity_Id := Implementation_Base_Type (Typ); 11988 begin 11989 return Btyp /= Typ 11990 and then Stream_Attribute_Available 11991 (Btyp, Nam, Partial_View => Typ); 11992 end; 11993 end if; 11994 11995 return False; 11996 end Stream_Attribute_Available; 11997 11998end Sem_Attr; 11999