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