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