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