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