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-2004, 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; 28 29with Atree; use Atree; 30with Checks; use Checks; 31with Einfo; use Einfo; 32with Errout; use Errout; 33with Eval_Fat; 34with Exp_Tss; use Exp_Tss; 35with Exp_Util; use Exp_Util; 36with Expander; use Expander; 37with Freeze; use Freeze; 38with Lib; use Lib; 39with Lib.Xref; use Lib.Xref; 40with Namet; use Namet; 41with Nlists; use Nlists; 42with Nmake; use Nmake; 43with Opt; use Opt; 44with Restrict; use Restrict; 45with Rtsfind; use Rtsfind; 46with Sdefault; use Sdefault; 47with Sem; use Sem; 48with Sem_Cat; use Sem_Cat; 49with Sem_Ch6; use Sem_Ch6; 50with Sem_Ch8; use Sem_Ch8; 51with Sem_Dist; use Sem_Dist; 52with Sem_Eval; use Sem_Eval; 53with Sem_Res; use Sem_Res; 54with Sem_Type; use Sem_Type; 55with Sem_Util; use Sem_Util; 56with Stand; use Stand; 57with Sinfo; use Sinfo; 58with Sinput; use Sinput; 59with Snames; use Snames; 60with Stand; 61with Stringt; use Stringt; 62with Targparm; use Targparm; 63with Ttypes; use Ttypes; 64with Ttypef; use Ttypef; 65with Tbuild; use Tbuild; 66with Uintp; use Uintp; 67with Urealp; use Urealp; 68with Widechar; use Widechar; 69 70package body Sem_Attr is 71 72 True_Value : constant Uint := Uint_1; 73 False_Value : constant Uint := Uint_0; 74 -- Synonyms to be used when these constants are used as Boolean values 75 76 Bad_Attribute : exception; 77 -- Exception raised if an error is detected during attribute processing, 78 -- used so that we can abandon the processing so we don't run into 79 -- trouble with cascaded errors. 80 81 -- The following array is the list of attributes defined in the Ada 83 RM 82 83 Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'( 84 Attribute_Address | 85 Attribute_Aft | 86 Attribute_Alignment | 87 Attribute_Base | 88 Attribute_Callable | 89 Attribute_Constrained | 90 Attribute_Count | 91 Attribute_Delta | 92 Attribute_Digits | 93 Attribute_Emax | 94 Attribute_Epsilon | 95 Attribute_First | 96 Attribute_First_Bit | 97 Attribute_Fore | 98 Attribute_Image | 99 Attribute_Large | 100 Attribute_Last | 101 Attribute_Last_Bit | 102 Attribute_Leading_Part | 103 Attribute_Length | 104 Attribute_Machine_Emax | 105 Attribute_Machine_Emin | 106 Attribute_Machine_Mantissa | 107 Attribute_Machine_Overflows | 108 Attribute_Machine_Radix | 109 Attribute_Machine_Rounds | 110 Attribute_Mantissa | 111 Attribute_Pos | 112 Attribute_Position | 113 Attribute_Pred | 114 Attribute_Range | 115 Attribute_Safe_Emax | 116 Attribute_Safe_Large | 117 Attribute_Safe_Small | 118 Attribute_Size | 119 Attribute_Small | 120 Attribute_Storage_Size | 121 Attribute_Succ | 122 Attribute_Terminated | 123 Attribute_Val | 124 Attribute_Value | 125 Attribute_Width => True, 126 others => False); 127 128 ----------------------- 129 -- Local_Subprograms -- 130 ----------------------- 131 132 procedure Eval_Attribute (N : Node_Id); 133 -- Performs compile time evaluation of attributes where possible, leaving 134 -- the Is_Static_Expression/Raises_Constraint_Error flags appropriately 135 -- set, and replacing the node with a literal node if the value can be 136 -- computed at compile time. All static attribute references are folded, 137 -- as well as a number of cases of non-static attributes that can always 138 -- be computed at compile time (e.g. floating-point model attributes that 139 -- are applied to non-static subtypes). Of course in such cases, the 140 -- Is_Static_Expression flag will not be set on the resulting literal. 141 -- Note that the only required action of this procedure is to catch the 142 -- static expression cases as described in the RM. Folding of other cases 143 -- is done where convenient, but some additional non-static folding is in 144 -- N_Expand_Attribute_Reference in cases where this is more convenient. 145 146 function Is_Anonymous_Tagged_Base 147 (Anon : Entity_Id; 148 Typ : Entity_Id) 149 return Boolean; 150 -- For derived tagged types that constrain parent discriminants we build 151 -- an anonymous unconstrained base type. We need to recognize the relation 152 -- between the two when analyzing an access attribute for a constrained 153 -- component, before the full declaration for Typ has been analyzed, and 154 -- where therefore the prefix of the attribute does not match the enclosing 155 -- scope. 156 157 ----------------------- 158 -- Analyze_Attribute -- 159 ----------------------- 160 161 procedure Analyze_Attribute (N : Node_Id) is 162 Loc : constant Source_Ptr := Sloc (N); 163 Aname : constant Name_Id := Attribute_Name (N); 164 P : constant Node_Id := Prefix (N); 165 Exprs : constant List_Id := Expressions (N); 166 Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname); 167 E1 : Node_Id; 168 E2 : Node_Id; 169 170 P_Type : Entity_Id; 171 -- Type of prefix after analysis 172 173 P_Base_Type : Entity_Id; 174 -- Base type of prefix after analysis 175 176 ----------------------- 177 -- Local Subprograms -- 178 ----------------------- 179 180 procedure Analyze_Access_Attribute; 181 -- Used for Access, Unchecked_Access, Unrestricted_Access attributes. 182 -- Internally, Id distinguishes which of the three cases is involved. 183 184 procedure Check_Array_Or_Scalar_Type; 185 -- Common procedure used by First, Last, Range attribute to check 186 -- that the prefix is a constrained array or scalar type, or a name 187 -- of an array object, and that an argument appears only if appropriate 188 -- (i.e. only in the array case). 189 190 procedure Check_Array_Type; 191 -- Common semantic checks for all array attributes. Checks that the 192 -- prefix is a constrained array type or the name of an array object. 193 -- The error message for non-arrays is specialized appropriately. 194 195 procedure Check_Asm_Attribute; 196 -- Common semantic checks for Asm_Input and Asm_Output attributes 197 198 procedure Check_Component; 199 -- Common processing for Bit_Position, First_Bit, Last_Bit, and 200 -- Position. Checks prefix is an appropriate selected component. 201 202 procedure Check_Decimal_Fixed_Point_Type; 203 -- Check that prefix of attribute N is a decimal fixed-point type 204 205 procedure Check_Dereference; 206 -- If the prefix of attribute is an object of an access type, then 207 -- introduce an explicit deference, and adjust P_Type accordingly. 208 209 procedure Check_Discrete_Type; 210 -- Verify that prefix of attribute N is a discrete type 211 212 procedure Check_E0; 213 -- Check that no attribute arguments are present 214 215 procedure Check_Either_E0_Or_E1; 216 -- Check that there are zero or one attribute arguments present 217 218 procedure Check_E1; 219 -- Check that exactly one attribute argument is present 220 221 procedure Check_E2; 222 -- Check that two attribute arguments are present 223 224 procedure Check_Enum_Image; 225 -- If the prefix type is an enumeration type, set all its literals 226 -- as referenced, since the image function could possibly end up 227 -- referencing any of the literals indirectly. 228 229 procedure Check_Fixed_Point_Type; 230 -- Verify that prefix of attribute N is a fixed type 231 232 procedure Check_Fixed_Point_Type_0; 233 -- Verify that prefix of attribute N is a fixed type and that 234 -- no attribute expressions are present 235 236 procedure Check_Floating_Point_Type; 237 -- Verify that prefix of attribute N is a float type 238 239 procedure Check_Floating_Point_Type_0; 240 -- Verify that prefix of attribute N is a float type and that 241 -- no attribute expressions are present 242 243 procedure Check_Floating_Point_Type_1; 244 -- Verify that prefix of attribute N is a float type and that 245 -- exactly one attribute expression is present 246 247 procedure Check_Floating_Point_Type_2; 248 -- Verify that prefix of attribute N is a float type and that 249 -- two attribute expressions are present 250 251 procedure Legal_Formal_Attribute; 252 -- Common processing for attributes Definite, and Has_Discriminants 253 254 procedure Check_Integer_Type; 255 -- Verify that prefix of attribute N is an integer type 256 257 procedure Check_Library_Unit; 258 -- Verify that prefix of attribute N is a library unit 259 260 procedure Check_Not_Incomplete_Type; 261 -- Check that P (the prefix of the attribute) is not an incomplete 262 -- type or a private type for which no full view has been given. 263 264 procedure Check_Object_Reference (P : Node_Id); 265 -- Check that P (the prefix of the attribute) is an object reference 266 267 procedure Check_Program_Unit; 268 -- Verify that prefix of attribute N is a program unit 269 270 procedure Check_Real_Type; 271 -- Verify that prefix of attribute N is fixed or float type 272 273 procedure Check_Scalar_Type; 274 -- Verify that prefix of attribute N is a scalar type 275 276 procedure Check_Standard_Prefix; 277 -- Verify that prefix of attribute N is package Standard 278 279 procedure Check_Stream_Attribute (Nam : TSS_Name_Type); 280 -- Validity checking for stream attribute. Nam is the TSS name of the 281 -- corresponding possible defined attribute function (e.g. for the 282 -- Read attribute, Nam will be TSS_Stream_Read). 283 284 procedure Check_Task_Prefix; 285 -- Verify that prefix of attribute N is a task or task type 286 287 procedure Check_Type; 288 -- Verify that the prefix of attribute N is a type 289 290 procedure Check_Unit_Name (Nod : Node_Id); 291 -- Check that Nod is of the form of a library unit name, i.e that 292 -- it is an identifier, or a selected component whose prefix is 293 -- itself of the form of a library unit name. Note that this is 294 -- quite different from Check_Program_Unit, since it only checks 295 -- the syntactic form of the name, not the semantic identity. This 296 -- is because it is used with attributes (Elab_Body, Elab_Spec, and 297 -- UET_Address) which can refer to non-visible unit. 298 299 procedure Error_Attr (Msg : String; Error_Node : Node_Id); 300 pragma No_Return (Error_Attr); 301 procedure Error_Attr; 302 pragma No_Return (Error_Attr); 303 -- Posts error using Error_Msg_N at given node, sets type of attribute 304 -- node to Any_Type, and then raises Bad_Attribute to avoid any further 305 -- semantic processing. The message typically contains a % insertion 306 -- character which is replaced by the attribute name. The call with 307 -- no arguments is used when the caller has already generated the 308 -- required error messages. 309 310 procedure Standard_Attribute (Val : Int); 311 -- Used to process attributes whose prefix is package Standard which 312 -- yield values of type Universal_Integer. The attribute reference 313 -- node is rewritten with an integer literal of the given value. 314 315 procedure Unexpected_Argument (En : Node_Id); 316 -- Signal unexpected attribute argument (En is the argument) 317 318 procedure Validate_Non_Static_Attribute_Function_Call; 319 -- Called when processing an attribute that is a function call to a 320 -- non-static function, i.e. an attribute function that either takes 321 -- non-scalar arguments or returns a non-scalar result. Verifies that 322 -- such a call does not appear in a preelaborable context. 323 324 ------------------------------ 325 -- Analyze_Access_Attribute -- 326 ------------------------------ 327 328 procedure Analyze_Access_Attribute is 329 Acc_Type : Entity_Id; 330 331 Scop : Entity_Id; 332 Typ : Entity_Id; 333 334 function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id; 335 -- Build an access-to-object type whose designated type is DT, 336 -- and whose Ekind is appropriate to the attribute type. The 337 -- type that is constructed is returned as the result. 338 339 procedure Build_Access_Subprogram_Type (P : Node_Id); 340 -- Build an access to subprogram whose designated type is 341 -- the type of the prefix. If prefix is overloaded, so it the 342 -- node itself. The result is stored in Acc_Type. 343 344 ------------------------------ 345 -- Build_Access_Object_Type -- 346 ------------------------------ 347 348 function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id is 349 Typ : Entity_Id; 350 351 begin 352 if Aname = Name_Unrestricted_Access then 353 Typ := 354 New_Internal_Entity 355 (E_Allocator_Type, Current_Scope, Loc, 'A'); 356 else 357 Typ := 358 New_Internal_Entity 359 (E_Access_Attribute_Type, Current_Scope, Loc, 'A'); 360 end if; 361 362 Set_Etype (Typ, Typ); 363 Init_Size_Align (Typ); 364 Set_Is_Itype (Typ); 365 Set_Associated_Node_For_Itype (Typ, N); 366 Set_Directly_Designated_Type (Typ, DT); 367 return Typ; 368 end Build_Access_Object_Type; 369 370 ---------------------------------- 371 -- Build_Access_Subprogram_Type -- 372 ---------------------------------- 373 374 procedure Build_Access_Subprogram_Type (P : Node_Id) is 375 Index : Interp_Index; 376 It : Interp; 377 378 function Get_Kind (E : Entity_Id) return Entity_Kind; 379 -- Distinguish between access to regular and protected 380 -- subprograms. 381 382 -------------- 383 -- Get_Kind -- 384 -------------- 385 386 function Get_Kind (E : Entity_Id) return Entity_Kind is 387 begin 388 if Convention (E) = Convention_Protected then 389 return E_Access_Protected_Subprogram_Type; 390 else 391 return E_Access_Subprogram_Type; 392 end if; 393 end Get_Kind; 394 395 -- Start of processing for Build_Access_Subprogram_Type 396 397 begin 398 -- In the case of an access to subprogram, use the name of the 399 -- subprogram itself as the designated type. Type-checking in 400 -- this case compares the signatures of the designated types. 401 402 if not Is_Overloaded (P) then 403 Acc_Type := 404 New_Internal_Entity 405 (Get_Kind (Entity (P)), Current_Scope, Loc, 'A'); 406 Set_Etype (Acc_Type, Acc_Type); 407 Set_Directly_Designated_Type (Acc_Type, Entity (P)); 408 Set_Etype (N, Acc_Type); 409 410 else 411 Get_First_Interp (P, Index, It); 412 Set_Etype (N, Any_Type); 413 414 while Present (It.Nam) loop 415 if not Is_Intrinsic_Subprogram (It.Nam) then 416 Acc_Type := 417 New_Internal_Entity 418 (Get_Kind (It.Nam), Current_Scope, Loc, 'A'); 419 Set_Etype (Acc_Type, Acc_Type); 420 Set_Directly_Designated_Type (Acc_Type, It.Nam); 421 Add_One_Interp (N, Acc_Type, Acc_Type); 422 end if; 423 424 Get_Next_Interp (Index, It); 425 end loop; 426 427 if Etype (N) = Any_Type then 428 Error_Attr ("prefix of % attribute cannot be intrinsic", P); 429 end if; 430 end if; 431 end Build_Access_Subprogram_Type; 432 433 -- Start of processing for Analyze_Access_Attribute 434 435 begin 436 Check_E0; 437 438 if Nkind (P) = N_Character_Literal then 439 Error_Attr 440 ("prefix of % attribute cannot be enumeration literal", P); 441 end if; 442 443 -- Case of access to subprogram 444 445 if Is_Entity_Name (P) 446 and then Is_Overloadable (Entity (P)) 447 then 448 -- Not allowed for nested subprograms if No_Implicit_Dynamic_Code 449 -- restriction set (since in general a trampoline is required). 450 451 if not Is_Library_Level_Entity (Entity (P)) then 452 Check_Restriction (No_Implicit_Dynamic_Code, P); 453 end if; 454 455 -- Build the appropriate subprogram type 456 457 Build_Access_Subprogram_Type (P); 458 459 -- For unrestricted access, kill current values, since this 460 -- attribute allows a reference to a local subprogram that 461 -- could modify local variables to be passed out of scope 462 463 if Aname = Name_Unrestricted_Access then 464 Kill_Current_Values; 465 end if; 466 467 return; 468 469 -- Component is an operation of a protected type 470 471 elsif Nkind (P) = N_Selected_Component 472 and then Is_Overloadable (Entity (Selector_Name (P))) 473 then 474 if Ekind (Entity (Selector_Name (P))) = E_Entry then 475 Error_Attr ("prefix of % attribute must be subprogram", P); 476 end if; 477 478 Build_Access_Subprogram_Type (Selector_Name (P)); 479 return; 480 end if; 481 482 -- Deal with incorrect reference to a type, but note that some 483 -- accesses are allowed (references to the current type instance). 484 485 if Is_Entity_Name (P) then 486 Scop := Current_Scope; 487 Typ := Entity (P); 488 489 if Is_Type (Typ) then 490 491 -- OK if we are within the scope of a limited type 492 -- let's mark the component as having per object constraint 493 494 if Is_Anonymous_Tagged_Base (Scop, Typ) then 495 Typ := Scop; 496 Set_Entity (P, Typ); 497 Set_Etype (P, Typ); 498 end if; 499 500 if Typ = Scop then 501 declare 502 Q : Node_Id := Parent (N); 503 504 begin 505 while Present (Q) 506 and then Nkind (Q) /= N_Component_Declaration 507 loop 508 Q := Parent (Q); 509 end loop; 510 if Present (Q) then 511 Set_Has_Per_Object_Constraint ( 512 Defining_Identifier (Q), True); 513 end if; 514 end; 515 516 if Nkind (P) = N_Expanded_Name then 517 Error_Msg_N 518 ("current instance prefix must be a direct name", P); 519 end if; 520 521 -- If a current instance attribute appears within a 522 -- a component constraint it must appear alone; other 523 -- contexts (default expressions, within a task body) 524 -- are not subject to this restriction. 525 526 if not In_Default_Expression 527 and then not Has_Completion (Scop) 528 and then 529 Nkind (Parent (N)) /= N_Discriminant_Association 530 and then 531 Nkind (Parent (N)) /= N_Index_Or_Discriminant_Constraint 532 then 533 Error_Msg_N 534 ("current instance attribute must appear alone", N); 535 end if; 536 537 -- OK if we are in initialization procedure for the type 538 -- in question, in which case the reference to the type 539 -- is rewritten as a reference to the current object. 540 541 elsif Ekind (Scop) = E_Procedure 542 and then Is_Init_Proc (Scop) 543 and then Etype (First_Formal (Scop)) = Typ 544 then 545 Rewrite (N, 546 Make_Attribute_Reference (Loc, 547 Prefix => Make_Identifier (Loc, Name_uInit), 548 Attribute_Name => Name_Unrestricted_Access)); 549 Analyze (N); 550 return; 551 552 -- OK if a task type, this test needs sharpening up ??? 553 554 elsif Is_Task_Type (Typ) then 555 null; 556 557 -- Otherwise we have an error case 558 559 else 560 Error_Attr ("% attribute cannot be applied to type", P); 561 return; 562 end if; 563 end if; 564 end if; 565 566 -- If we fall through, we have a normal access to object case. 567 -- Unrestricted_Access is legal wherever an allocator would be 568 -- legal, so its Etype is set to E_Allocator. The expected type 569 -- of the other attributes is a general access type, and therefore 570 -- we label them with E_Access_Attribute_Type. 571 572 if not Is_Overloaded (P) then 573 Acc_Type := Build_Access_Object_Type (P_Type); 574 Set_Etype (N, Acc_Type); 575 else 576 declare 577 Index : Interp_Index; 578 It : Interp; 579 580 begin 581 Set_Etype (N, Any_Type); 582 Get_First_Interp (P, Index, It); 583 584 while Present (It.Typ) loop 585 Acc_Type := Build_Access_Object_Type (It.Typ); 586 Add_One_Interp (N, Acc_Type, Acc_Type); 587 Get_Next_Interp (Index, It); 588 end loop; 589 end; 590 end if; 591 592 -- If we have an access to an object, and the attribute comes 593 -- from source, then set the object as potentially source modified. 594 -- We do this because the resulting access pointer can be used to 595 -- modify the variable, and we might not detect this, leading to 596 -- some junk warnings. 597 598 if Is_Entity_Name (P) then 599 Set_Never_Set_In_Source (Entity (P), False); 600 end if; 601 602 -- Check for aliased view unless unrestricted case. We allow 603 -- a nonaliased prefix when within an instance because the 604 -- prefix may have been a tagged formal object, which is 605 -- defined to be aliased even when the actual might not be 606 -- (other instance cases will have been caught in the generic). 607 608 if Aname /= Name_Unrestricted_Access 609 and then not Is_Aliased_View (P) 610 and then not In_Instance 611 then 612 Error_Attr ("prefix of % attribute must be aliased", P); 613 end if; 614 end Analyze_Access_Attribute; 615 616 -------------------------------- 617 -- Check_Array_Or_Scalar_Type -- 618 -------------------------------- 619 620 procedure Check_Array_Or_Scalar_Type is 621 Index : Entity_Id; 622 623 D : Int; 624 -- Dimension number for array attributes. 625 626 begin 627 -- Case of string literal or string literal subtype. These cases 628 -- cannot arise from legal Ada code, but the expander is allowed 629 -- to generate them. They require special handling because string 630 -- literal subtypes do not have standard bounds (the whole idea 631 -- of these subtypes is to avoid having to generate the bounds) 632 633 if Ekind (P_Type) = E_String_Literal_Subtype then 634 Set_Etype (N, Etype (First_Index (P_Base_Type))); 635 return; 636 637 -- Scalar types 638 639 elsif Is_Scalar_Type (P_Type) then 640 Check_Type; 641 642 if Present (E1) then 643 Error_Attr ("invalid argument in % attribute", E1); 644 else 645 Set_Etype (N, P_Base_Type); 646 return; 647 end if; 648 649 -- The following is a special test to allow 'First to apply to 650 -- private scalar types if the attribute comes from generated 651 -- code. This occurs in the case of Normalize_Scalars code. 652 653 elsif Is_Private_Type (P_Type) 654 and then Present (Full_View (P_Type)) 655 and then Is_Scalar_Type (Full_View (P_Type)) 656 and then not Comes_From_Source (N) 657 then 658 Set_Etype (N, Implementation_Base_Type (P_Type)); 659 660 -- Array types other than string literal subtypes handled above 661 662 else 663 Check_Array_Type; 664 665 -- We know prefix is an array type, or the name of an array 666 -- object, and that the expression, if present, is static 667 -- and within the range of the dimensions of the type. 668 669 if Is_Array_Type (P_Type) then 670 Index := First_Index (P_Base_Type); 671 672 else pragma Assert (Is_Access_Type (P_Type)); 673 Index := First_Index (Base_Type (Designated_Type (P_Type))); 674 end if; 675 676 if No (E1) then 677 678 -- First dimension assumed 679 680 Set_Etype (N, Base_Type (Etype (Index))); 681 682 else 683 D := UI_To_Int (Intval (E1)); 684 685 for J in 1 .. D - 1 loop 686 Next_Index (Index); 687 end loop; 688 689 Set_Etype (N, Base_Type (Etype (Index))); 690 Set_Etype (E1, Standard_Integer); 691 end if; 692 end if; 693 end Check_Array_Or_Scalar_Type; 694 695 ---------------------- 696 -- Check_Array_Type -- 697 ---------------------- 698 699 procedure Check_Array_Type is 700 D : Int; 701 -- Dimension number for array attributes. 702 703 begin 704 -- If the type is a string literal type, then this must be generated 705 -- internally, and no further check is required on its legality. 706 707 if Ekind (P_Type) = E_String_Literal_Subtype then 708 return; 709 710 -- If the type is a composite, it is an illegal aggregate, no point 711 -- in going on. 712 713 elsif P_Type = Any_Composite then 714 raise Bad_Attribute; 715 end if; 716 717 -- Normal case of array type or subtype 718 719 Check_Either_E0_Or_E1; 720 721 if Is_Array_Type (P_Type) then 722 if not Is_Constrained (P_Type) 723 and then Is_Entity_Name (P) 724 and then Is_Type (Entity (P)) 725 then 726 -- Note: we do not call Error_Attr here, since we prefer to 727 -- continue, using the relevant index type of the array, 728 -- even though it is unconstrained. This gives better error 729 -- recovery behavior. 730 731 Error_Msg_Name_1 := Aname; 732 Error_Msg_N 733 ("prefix for % attribute must be constrained array", P); 734 end if; 735 736 D := Number_Dimensions (P_Type); 737 738 elsif Is_Access_Type (P_Type) 739 and then Is_Array_Type (Designated_Type (P_Type)) 740 then 741 if Is_Entity_Name (P) and then Is_Type (Entity (P)) then 742 Error_Attr ("prefix of % attribute cannot be access type", P); 743 end if; 744 745 D := Number_Dimensions (Designated_Type (P_Type)); 746 747 -- If there is an implicit dereference, then we must freeze 748 -- the designated type of the access type, since the type of 749 -- the referenced array is this type (see AI95-00106). 750 751 Freeze_Before (N, Designated_Type (P_Type)); 752 753 else 754 if Is_Private_Type (P_Type) then 755 Error_Attr 756 ("prefix for % attribute may not be private type", P); 757 758 elsif Attr_Id = Attribute_First 759 or else 760 Attr_Id = Attribute_Last 761 then 762 Error_Attr ("invalid prefix for % attribute", P); 763 764 else 765 Error_Attr ("prefix for % attribute must be array", P); 766 end if; 767 end if; 768 769 if Present (E1) then 770 Resolve (E1, Any_Integer); 771 Set_Etype (E1, Standard_Integer); 772 773 if not Is_Static_Expression (E1) 774 or else Raises_Constraint_Error (E1) 775 then 776 Flag_Non_Static_Expr 777 ("expression for dimension must be static!", E1); 778 Error_Attr; 779 780 elsif UI_To_Int (Expr_Value (E1)) > D 781 or else UI_To_Int (Expr_Value (E1)) < 1 782 then 783 Error_Attr ("invalid dimension number for array type", E1); 784 end if; 785 end if; 786 end Check_Array_Type; 787 788 ------------------------- 789 -- Check_Asm_Attribute -- 790 ------------------------- 791 792 procedure Check_Asm_Attribute is 793 begin 794 Check_Type; 795 Check_E2; 796 797 -- Check first argument is static string expression 798 799 Analyze_And_Resolve (E1, Standard_String); 800 801 if Etype (E1) = Any_Type then 802 return; 803 804 elsif not Is_OK_Static_Expression (E1) then 805 Flag_Non_Static_Expr 806 ("constraint argument must be static string expression!", E1); 807 Error_Attr; 808 end if; 809 810 -- Check second argument is right type 811 812 Analyze_And_Resolve (E2, Entity (P)); 813 814 -- Note: that is all we need to do, we don't need to check 815 -- that it appears in a correct context. The Ada type system 816 -- will do that for us. 817 818 end Check_Asm_Attribute; 819 820 --------------------- 821 -- Check_Component -- 822 --------------------- 823 824 procedure Check_Component is 825 begin 826 Check_E0; 827 828 if Nkind (P) /= N_Selected_Component 829 or else 830 (Ekind (Entity (Selector_Name (P))) /= E_Component 831 and then 832 Ekind (Entity (Selector_Name (P))) /= E_Discriminant) 833 then 834 Error_Attr 835 ("prefix for % attribute must be selected component", P); 836 end if; 837 end Check_Component; 838 839 ------------------------------------ 840 -- Check_Decimal_Fixed_Point_Type -- 841 ------------------------------------ 842 843 procedure Check_Decimal_Fixed_Point_Type is 844 begin 845 Check_Type; 846 847 if not Is_Decimal_Fixed_Point_Type (P_Type) then 848 Error_Attr 849 ("prefix of % attribute must be decimal type", P); 850 end if; 851 end Check_Decimal_Fixed_Point_Type; 852 853 ----------------------- 854 -- Check_Dereference -- 855 ----------------------- 856 857 procedure Check_Dereference is 858 begin 859 if Is_Object_Reference (P) 860 and then Is_Access_Type (P_Type) 861 then 862 Rewrite (P, 863 Make_Explicit_Dereference (Sloc (P), 864 Prefix => Relocate_Node (P))); 865 866 Analyze_And_Resolve (P); 867 P_Type := Etype (P); 868 869 if P_Type = Any_Type then 870 raise Bad_Attribute; 871 end if; 872 873 P_Base_Type := Base_Type (P_Type); 874 end if; 875 end Check_Dereference; 876 877 ------------------------- 878 -- Check_Discrete_Type -- 879 ------------------------- 880 881 procedure Check_Discrete_Type is 882 begin 883 Check_Type; 884 885 if not Is_Discrete_Type (P_Type) then 886 Error_Attr ("prefix of % attribute must be discrete type", P); 887 end if; 888 end Check_Discrete_Type; 889 890 -------------- 891 -- Check_E0 -- 892 -------------- 893 894 procedure Check_E0 is 895 begin 896 if Present (E1) then 897 Unexpected_Argument (E1); 898 end if; 899 end Check_E0; 900 901 -------------- 902 -- Check_E1 -- 903 -------------- 904 905 procedure Check_E1 is 906 begin 907 Check_Either_E0_Or_E1; 908 909 if No (E1) then 910 911 -- Special-case attributes that are functions and that appear as 912 -- the prefix of another attribute. Error is posted on parent. 913 914 if Nkind (Parent (N)) = N_Attribute_Reference 915 and then (Attribute_Name (Parent (N)) = Name_Address 916 or else 917 Attribute_Name (Parent (N)) = Name_Code_Address 918 or else 919 Attribute_Name (Parent (N)) = Name_Access) 920 then 921 Error_Msg_Name_1 := Attribute_Name (Parent (N)); 922 Error_Msg_N ("illegal prefix for % attribute", Parent (N)); 923 Set_Etype (Parent (N), Any_Type); 924 Set_Entity (Parent (N), Any_Type); 925 raise Bad_Attribute; 926 927 else 928 Error_Attr ("missing argument for % attribute", N); 929 end if; 930 end if; 931 end Check_E1; 932 933 -------------- 934 -- Check_E2 -- 935 -------------- 936 937 procedure Check_E2 is 938 begin 939 if No (E1) then 940 Error_Attr ("missing arguments for % attribute (2 required)", N); 941 elsif No (E2) then 942 Error_Attr ("missing argument for % attribute (2 required)", N); 943 end if; 944 end Check_E2; 945 946 --------------------------- 947 -- Check_Either_E0_Or_E1 -- 948 --------------------------- 949 950 procedure Check_Either_E0_Or_E1 is 951 begin 952 if Present (E2) then 953 Unexpected_Argument (E2); 954 end if; 955 end Check_Either_E0_Or_E1; 956 957 ---------------------- 958 -- Check_Enum_Image -- 959 ---------------------- 960 961 procedure Check_Enum_Image is 962 Lit : Entity_Id; 963 964 begin 965 if Is_Enumeration_Type (P_Base_Type) then 966 Lit := First_Literal (P_Base_Type); 967 while Present (Lit) loop 968 Set_Referenced (Lit); 969 Next_Literal (Lit); 970 end loop; 971 end if; 972 end Check_Enum_Image; 973 974 ---------------------------- 975 -- Check_Fixed_Point_Type -- 976 ---------------------------- 977 978 procedure Check_Fixed_Point_Type is 979 begin 980 Check_Type; 981 982 if not Is_Fixed_Point_Type (P_Type) then 983 Error_Attr ("prefix of % attribute must be fixed point type", P); 984 end if; 985 end Check_Fixed_Point_Type; 986 987 ------------------------------ 988 -- Check_Fixed_Point_Type_0 -- 989 ------------------------------ 990 991 procedure Check_Fixed_Point_Type_0 is 992 begin 993 Check_Fixed_Point_Type; 994 Check_E0; 995 end Check_Fixed_Point_Type_0; 996 997 ------------------------------- 998 -- Check_Floating_Point_Type -- 999 ------------------------------- 1000 1001 procedure Check_Floating_Point_Type is 1002 begin 1003 Check_Type; 1004 1005 if not Is_Floating_Point_Type (P_Type) then 1006 Error_Attr ("prefix of % attribute must be float type", P); 1007 end if; 1008 end Check_Floating_Point_Type; 1009 1010 --------------------------------- 1011 -- Check_Floating_Point_Type_0 -- 1012 --------------------------------- 1013 1014 procedure Check_Floating_Point_Type_0 is 1015 begin 1016 Check_Floating_Point_Type; 1017 Check_E0; 1018 end Check_Floating_Point_Type_0; 1019 1020 --------------------------------- 1021 -- Check_Floating_Point_Type_1 -- 1022 --------------------------------- 1023 1024 procedure Check_Floating_Point_Type_1 is 1025 begin 1026 Check_Floating_Point_Type; 1027 Check_E1; 1028 end Check_Floating_Point_Type_1; 1029 1030 --------------------------------- 1031 -- Check_Floating_Point_Type_2 -- 1032 --------------------------------- 1033 1034 procedure Check_Floating_Point_Type_2 is 1035 begin 1036 Check_Floating_Point_Type; 1037 Check_E2; 1038 end Check_Floating_Point_Type_2; 1039 1040 ------------------------ 1041 -- Check_Integer_Type -- 1042 ------------------------ 1043 1044 procedure Check_Integer_Type is 1045 begin 1046 Check_Type; 1047 1048 if not Is_Integer_Type (P_Type) then 1049 Error_Attr ("prefix of % attribute must be integer type", P); 1050 end if; 1051 end Check_Integer_Type; 1052 1053 ------------------------ 1054 -- Check_Library_Unit -- 1055 ------------------------ 1056 1057 procedure Check_Library_Unit is 1058 begin 1059 if not Is_Compilation_Unit (Entity (P)) then 1060 Error_Attr ("prefix of % attribute must be library unit", P); 1061 end if; 1062 end Check_Library_Unit; 1063 1064 ------------------------------- 1065 -- Check_Not_Incomplete_Type -- 1066 ------------------------------- 1067 1068 procedure Check_Not_Incomplete_Type is 1069 begin 1070 if not Is_Entity_Name (P) 1071 or else not Is_Type (Entity (P)) 1072 or else In_Default_Expression 1073 then 1074 return; 1075 1076 else 1077 Check_Fully_Declared (P_Type, P); 1078 end if; 1079 end Check_Not_Incomplete_Type; 1080 1081 ---------------------------- 1082 -- Check_Object_Reference -- 1083 ---------------------------- 1084 1085 procedure Check_Object_Reference (P : Node_Id) is 1086 Rtyp : Entity_Id; 1087 1088 begin 1089 -- If we need an object, and we have a prefix that is the name of 1090 -- a function entity, convert it into a function call. 1091 1092 if Is_Entity_Name (P) 1093 and then Ekind (Entity (P)) = E_Function 1094 then 1095 Rtyp := Etype (Entity (P)); 1096 1097 Rewrite (P, 1098 Make_Function_Call (Sloc (P), 1099 Name => Relocate_Node (P))); 1100 1101 Analyze_And_Resolve (P, Rtyp); 1102 1103 -- Otherwise we must have an object reference 1104 1105 elsif not Is_Object_Reference (P) then 1106 Error_Attr ("prefix of % attribute must be object", P); 1107 end if; 1108 end Check_Object_Reference; 1109 1110 ------------------------ 1111 -- Check_Program_Unit -- 1112 ------------------------ 1113 1114 procedure Check_Program_Unit is 1115 begin 1116 if Is_Entity_Name (P) then 1117 declare 1118 K : constant Entity_Kind := Ekind (Entity (P)); 1119 T : constant Entity_Id := Etype (Entity (P)); 1120 1121 begin 1122 if K in Subprogram_Kind 1123 or else K in Task_Kind 1124 or else K in Protected_Kind 1125 or else K = E_Package 1126 or else K in Generic_Unit_Kind 1127 or else (K = E_Variable 1128 and then 1129 (Is_Task_Type (T) 1130 or else 1131 Is_Protected_Type (T))) 1132 then 1133 return; 1134 end if; 1135 end; 1136 end if; 1137 1138 Error_Attr ("prefix of % attribute must be program unit", P); 1139 end Check_Program_Unit; 1140 1141 --------------------- 1142 -- Check_Real_Type -- 1143 --------------------- 1144 1145 procedure Check_Real_Type is 1146 begin 1147 Check_Type; 1148 1149 if not Is_Real_Type (P_Type) then 1150 Error_Attr ("prefix of % attribute must be real type", P); 1151 end if; 1152 end Check_Real_Type; 1153 1154 ----------------------- 1155 -- Check_Scalar_Type -- 1156 ----------------------- 1157 1158 procedure Check_Scalar_Type is 1159 begin 1160 Check_Type; 1161 1162 if not Is_Scalar_Type (P_Type) then 1163 Error_Attr ("prefix of % attribute must be scalar type", P); 1164 end if; 1165 end Check_Scalar_Type; 1166 1167 --------------------------- 1168 -- Check_Standard_Prefix -- 1169 --------------------------- 1170 1171 procedure Check_Standard_Prefix is 1172 begin 1173 Check_E0; 1174 1175 if Nkind (P) /= N_Identifier 1176 or else Chars (P) /= Name_Standard 1177 then 1178 Error_Attr ("only allowed prefix for % attribute is Standard", P); 1179 end if; 1180 1181 end Check_Standard_Prefix; 1182 1183 ---------------------------- 1184 -- Check_Stream_Attribute -- 1185 ---------------------------- 1186 1187 procedure Check_Stream_Attribute (Nam : TSS_Name_Type) is 1188 Etyp : Entity_Id; 1189 Btyp : Entity_Id; 1190 1191 begin 1192 Validate_Non_Static_Attribute_Function_Call; 1193 1194 -- With the exception of 'Input, Stream attributes are procedures, 1195 -- and can only appear at the position of procedure calls. We check 1196 -- for this here, before they are rewritten, to give a more precise 1197 -- diagnostic. 1198 1199 if Nam = TSS_Stream_Input then 1200 null; 1201 1202 elsif Is_List_Member (N) 1203 and then Nkind (Parent (N)) /= N_Procedure_Call_Statement 1204 and then Nkind (Parent (N)) /= N_Aggregate 1205 then 1206 null; 1207 1208 else 1209 Error_Attr 1210 ("invalid context for attribute%, which is a procedure", N); 1211 end if; 1212 1213 Check_Type; 1214 Btyp := Implementation_Base_Type (P_Type); 1215 1216 -- Stream attributes not allowed on limited types unless the 1217 -- special OK_For_Stream flag is set. 1218 1219 if Is_Limited_Type (P_Type) 1220 and then Comes_From_Source (N) 1221 and then not Present (TSS (Btyp, Nam)) 1222 and then No (Get_Rep_Pragma (Btyp, Name_Stream_Convert)) 1223 then 1224 Error_Msg_Name_1 := Aname; 1225 Error_Msg_NE 1226 ("limited type& has no% attribute", P, Btyp); 1227 Explain_Limited_Type (P_Type, P); 1228 end if; 1229 1230 -- Check for violation of restriction No_Stream_Attributes 1231 1232 if Is_RTE (P_Type, RE_Exception_Id) 1233 or else 1234 Is_RTE (P_Type, RE_Exception_Occurrence) 1235 then 1236 Check_Restriction (No_Exception_Registration, P); 1237 end if; 1238 1239 -- Here we must check that the first argument is an access type 1240 -- that is compatible with Ada.Streams.Root_Stream_Type'Class. 1241 1242 Analyze_And_Resolve (E1); 1243 Etyp := Etype (E1); 1244 1245 -- Note: the double call to Root_Type here is needed because the 1246 -- root type of a class-wide type is the corresponding type (e.g. 1247 -- X for X'Class, and we really want to go to the root. 1248 1249 if not Is_Access_Type (Etyp) 1250 or else Root_Type (Root_Type (Designated_Type (Etyp))) /= 1251 RTE (RE_Root_Stream_Type) 1252 then 1253 Error_Attr 1254 ("expected access to Ada.Streams.Root_Stream_Type''Class", E1); 1255 end if; 1256 1257 -- Check that the second argument is of the right type if there is 1258 -- one (the Input attribute has only one argument so this is skipped) 1259 1260 if Present (E2) then 1261 Analyze (E2); 1262 1263 if Nam = TSS_Stream_Read 1264 and then not Is_OK_Variable_For_Out_Formal (E2) 1265 then 1266 Error_Attr 1267 ("second argument of % attribute must be a variable", E2); 1268 end if; 1269 1270 Resolve (E2, P_Type); 1271 end if; 1272 end Check_Stream_Attribute; 1273 1274 ----------------------- 1275 -- Check_Task_Prefix -- 1276 ----------------------- 1277 1278 procedure Check_Task_Prefix is 1279 begin 1280 Analyze (P); 1281 1282 if Is_Task_Type (Etype (P)) 1283 or else (Is_Access_Type (Etype (P)) 1284 and then Is_Task_Type (Designated_Type (Etype (P)))) 1285 then 1286 Resolve (P); 1287 else 1288 Error_Attr ("prefix of % attribute must be a task", P); 1289 end if; 1290 end Check_Task_Prefix; 1291 1292 ---------------- 1293 -- Check_Type -- 1294 ---------------- 1295 1296 -- The possibilities are an entity name denoting a type, or an 1297 -- attribute reference that denotes a type (Base or Class). If 1298 -- the type is incomplete, replace it with its full view. 1299 1300 procedure Check_Type is 1301 begin 1302 if not Is_Entity_Name (P) 1303 or else not Is_Type (Entity (P)) 1304 then 1305 Error_Attr ("prefix of % attribute must be a type", P); 1306 1307 elsif Ekind (Entity (P)) = E_Incomplete_Type 1308 and then Present (Full_View (Entity (P))) 1309 then 1310 P_Type := Full_View (Entity (P)); 1311 Set_Entity (P, P_Type); 1312 end if; 1313 end Check_Type; 1314 1315 --------------------- 1316 -- Check_Unit_Name -- 1317 --------------------- 1318 1319 procedure Check_Unit_Name (Nod : Node_Id) is 1320 begin 1321 if Nkind (Nod) = N_Identifier then 1322 return; 1323 1324 elsif Nkind (Nod) = N_Selected_Component then 1325 Check_Unit_Name (Prefix (Nod)); 1326 1327 if Nkind (Selector_Name (Nod)) = N_Identifier then 1328 return; 1329 end if; 1330 end if; 1331 1332 Error_Attr ("argument for % attribute must be unit name", P); 1333 end Check_Unit_Name; 1334 1335 ---------------- 1336 -- Error_Attr -- 1337 ---------------- 1338 1339 procedure Error_Attr is 1340 begin 1341 Set_Etype (N, Any_Type); 1342 Set_Entity (N, Any_Type); 1343 raise Bad_Attribute; 1344 end Error_Attr; 1345 1346 procedure Error_Attr (Msg : String; Error_Node : Node_Id) is 1347 begin 1348 Error_Msg_Name_1 := Aname; 1349 Error_Msg_N (Msg, Error_Node); 1350 Error_Attr; 1351 end Error_Attr; 1352 1353 ---------------------------- 1354 -- Legal_Formal_Attribute -- 1355 ---------------------------- 1356 1357 procedure Legal_Formal_Attribute is 1358 begin 1359 Check_E0; 1360 1361 if not Is_Entity_Name (P) 1362 or else not Is_Type (Entity (P)) 1363 then 1364 Error_Attr ("prefix of % attribute must be generic type", N); 1365 1366 elsif Is_Generic_Actual_Type (Entity (P)) 1367 or else In_Instance 1368 or else In_Inlined_Body 1369 then 1370 null; 1371 1372 elsif Is_Generic_Type (Entity (P)) then 1373 if not Is_Indefinite_Subtype (Entity (P)) then 1374 Error_Attr 1375 ("prefix of % attribute must be indefinite generic type", N); 1376 end if; 1377 1378 else 1379 Error_Attr 1380 ("prefix of % attribute must be indefinite generic type", N); 1381 end if; 1382 1383 Set_Etype (N, Standard_Boolean); 1384 end Legal_Formal_Attribute; 1385 1386 ------------------------ 1387 -- Standard_Attribute -- 1388 ------------------------ 1389 1390 procedure Standard_Attribute (Val : Int) is 1391 begin 1392 Check_Standard_Prefix; 1393 1394 -- First a special check (more like a kludge really). For GNAT5 1395 -- on Windows, the alignments in GCC are severely mixed up. In 1396 -- particular, we have a situation where the maximum alignment 1397 -- that GCC thinks is possible is greater than the guaranteed 1398 -- alignment at run-time. That causes many problems. As a partial 1399 -- cure for this situation, we force a value of 4 for the maximum 1400 -- alignment attribute on this target. This still does not solve 1401 -- all problems, but it helps. 1402 1403 -- A further (even more horrible) dimension to this kludge is now 1404 -- installed. There are two uses for Maximum_Alignment, one is to 1405 -- determine the maximum guaranteed alignment, that's the one we 1406 -- want the kludge to yield as 4. The other use is to maximally 1407 -- align objects, we can't use 4 here, since for example, long 1408 -- long integer has an alignment of 8, so we will get errors. 1409 1410 -- It is of course impossible to determine which use the programmer 1411 -- has in mind, but an approximation for now is to disconnect the 1412 -- kludge if the attribute appears in an alignment clause. 1413 1414 -- To be removed if GCC ever gets its act together here ??? 1415 1416 Alignment_Kludge : declare 1417 P : Node_Id; 1418 1419 function On_X86 return Boolean; 1420 -- Determine if target is x86 (ia32), return True if so 1421 1422 ------------ 1423 -- On_X86 -- 1424 ------------ 1425 1426 function On_X86 return Boolean is 1427 T : constant String := Sdefault.Target_Name.all; 1428 1429 begin 1430 -- There is no clean way to check this. That's not surprising, 1431 -- the front end should not be doing this kind of test ???. The 1432 -- way we do it is test for either "86" or "pentium" being in 1433 -- the string for the target name. 1434 1435 for J in T'First .. T'Last - 1 loop 1436 if T (J .. J + 1) = "86" 1437 or else (J <= T'Last - 6 1438 and then T (J .. J + 6) = "pentium") 1439 then 1440 return True; 1441 end if; 1442 end loop; 1443 1444 return False; 1445 end On_X86; 1446 1447 begin 1448 if Aname = Name_Maximum_Alignment and then On_X86 then 1449 P := Parent (N); 1450 1451 while Nkind (P) in N_Subexpr loop 1452 P := Parent (P); 1453 end loop; 1454 1455 if Nkind (P) /= N_Attribute_Definition_Clause 1456 or else Chars (P) /= Name_Alignment 1457 then 1458 Rewrite (N, Make_Integer_Literal (Loc, 4)); 1459 Analyze (N); 1460 return; 1461 end if; 1462 end if; 1463 end Alignment_Kludge; 1464 1465 -- Normally we get the value from gcc ??? 1466 1467 Rewrite (N, Make_Integer_Literal (Loc, Val)); 1468 Analyze (N); 1469 end Standard_Attribute; 1470 1471 ------------------------- 1472 -- Unexpected Argument -- 1473 ------------------------- 1474 1475 procedure Unexpected_Argument (En : Node_Id) is 1476 begin 1477 Error_Attr ("unexpected argument for % attribute", En); 1478 end Unexpected_Argument; 1479 1480 ------------------------------------------------- 1481 -- Validate_Non_Static_Attribute_Function_Call -- 1482 ------------------------------------------------- 1483 1484 -- This function should be moved to Sem_Dist ??? 1485 1486 procedure Validate_Non_Static_Attribute_Function_Call is 1487 begin 1488 if In_Preelaborated_Unit 1489 and then not In_Subprogram_Or_Concurrent_Unit 1490 then 1491 Flag_Non_Static_Expr 1492 ("non-static function call in preelaborated unit!", N); 1493 end if; 1494 end Validate_Non_Static_Attribute_Function_Call; 1495 1496 ----------------------------------------------- 1497 -- Start of Processing for Analyze_Attribute -- 1498 ----------------------------------------------- 1499 1500 begin 1501 -- Immediate return if unrecognized attribute (already diagnosed 1502 -- by parser, so there is nothing more that we need to do) 1503 1504 if not Is_Attribute_Name (Aname) then 1505 raise Bad_Attribute; 1506 end if; 1507 1508 -- Deal with Ada 83 and Features issues 1509 1510 if Comes_From_Source (N) then 1511 if not Attribute_83 (Attr_Id) then 1512 if Ada_83 and then Comes_From_Source (N) then 1513 Error_Msg_Name_1 := Aname; 1514 Error_Msg_N ("(Ada 83) attribute% is not standard?", N); 1515 end if; 1516 1517 if Attribute_Impl_Def (Attr_Id) then 1518 Check_Restriction (No_Implementation_Attributes, N); 1519 end if; 1520 end if; 1521 end if; 1522 1523 -- Remote access to subprogram type access attribute reference needs 1524 -- unanalyzed copy for tree transformation. The analyzed copy is used 1525 -- for its semantic information (whether prefix is a remote subprogram 1526 -- name), the unanalyzed copy is used to construct new subtree rooted 1527 -- with N_aggregate which represents a fat pointer aggregate. 1528 1529 if Aname = Name_Access then 1530 Discard_Node (Copy_Separate_Tree (N)); 1531 end if; 1532 1533 -- Analyze prefix and exit if error in analysis. If the prefix is an 1534 -- incomplete type, use full view if available. A special case is 1535 -- that we never analyze the prefix of an Elab_Body or Elab_Spec 1536 -- or UET_Address attribute. 1537 1538 if Aname /= Name_Elab_Body 1539 and then 1540 Aname /= Name_Elab_Spec 1541 and then 1542 Aname /= Name_UET_Address 1543 then 1544 Analyze (P); 1545 P_Type := Etype (P); 1546 1547 if Is_Entity_Name (P) 1548 and then Present (Entity (P)) 1549 and then Is_Type (Entity (P)) 1550 and then Ekind (Entity (P)) = E_Incomplete_Type 1551 then 1552 P_Type := Get_Full_View (P_Type); 1553 Set_Entity (P, P_Type); 1554 Set_Etype (P, P_Type); 1555 end if; 1556 1557 if P_Type = Any_Type then 1558 raise Bad_Attribute; 1559 end if; 1560 1561 P_Base_Type := Base_Type (P_Type); 1562 end if; 1563 1564 -- Analyze expressions that may be present, exiting if an error occurs 1565 1566 if No (Exprs) then 1567 E1 := Empty; 1568 E2 := Empty; 1569 1570 else 1571 E1 := First (Exprs); 1572 Analyze (E1); 1573 1574 -- Check for missing or bad expression (result of previous error) 1575 1576 if No (E1) or else Etype (E1) = Any_Type then 1577 raise Bad_Attribute; 1578 end if; 1579 1580 E2 := Next (E1); 1581 1582 if Present (E2) then 1583 Analyze (E2); 1584 1585 if Etype (E2) = Any_Type then 1586 raise Bad_Attribute; 1587 end if; 1588 1589 if Present (Next (E2)) then 1590 Unexpected_Argument (Next (E2)); 1591 end if; 1592 end if; 1593 end if; 1594 1595 if Is_Overloaded (P) 1596 and then Aname /= Name_Access 1597 and then Aname /= Name_Address 1598 and then Aname /= Name_Code_Address 1599 and then Aname /= Name_Count 1600 and then Aname /= Name_Unchecked_Access 1601 then 1602 Error_Attr ("ambiguous prefix for % attribute", P); 1603 end if; 1604 1605 -- Remaining processing depends on attribute 1606 1607 case Attr_Id is 1608 1609 ------------------ 1610 -- Abort_Signal -- 1611 ------------------ 1612 1613 when Attribute_Abort_Signal => 1614 Check_Standard_Prefix; 1615 Rewrite (N, 1616 New_Reference_To (Stand.Abort_Signal, Loc)); 1617 Analyze (N); 1618 1619 ------------ 1620 -- Access -- 1621 ------------ 1622 1623 when Attribute_Access => 1624 Analyze_Access_Attribute; 1625 1626 ------------- 1627 -- Address -- 1628 ------------- 1629 1630 when Attribute_Address => 1631 Check_E0; 1632 1633 -- Check for some junk cases, where we have to allow the address 1634 -- attribute but it does not make much sense, so at least for now 1635 -- just replace with Null_Address. 1636 1637 -- We also do this if the prefix is a reference to the AST_Entry 1638 -- attribute. If expansion is active, the attribute will be 1639 -- replaced by a function call, and address will work fine and 1640 -- get the proper value, but if expansion is not active, then 1641 -- the check here allows proper semantic analysis of the reference. 1642 1643 -- An Address attribute created by expansion is legal even when it 1644 -- applies to other entity-denoting expressions. 1645 1646 if Is_Entity_Name (P) then 1647 declare 1648 Ent : constant Entity_Id := Entity (P); 1649 1650 begin 1651 if Is_Subprogram (Ent) then 1652 if not Is_Library_Level_Entity (Ent) then 1653 Check_Restriction (No_Implicit_Dynamic_Code, P); 1654 end if; 1655 1656 Set_Address_Taken (Ent); 1657 1658 elsif Is_Object (Ent) 1659 or else Ekind (Ent) = E_Label 1660 then 1661 Set_Address_Taken (Ent); 1662 1663 -- If we have an address of an object, and the attribute 1664 -- comes from source, then set the object as potentially 1665 -- source modified. We do this because the resulting address 1666 -- can potentially be used to modify the variable and we 1667 -- might not detect this, leading to some junk warnings. 1668 1669 Set_Never_Set_In_Source (Ent, False); 1670 1671 elsif (Is_Concurrent_Type (Etype (Ent)) 1672 and then Etype (Ent) = Base_Type (Ent)) 1673 or else Ekind (Ent) = E_Package 1674 or else Is_Generic_Unit (Ent) 1675 then 1676 Rewrite (N, 1677 New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); 1678 1679 else 1680 Error_Attr ("invalid prefix for % attribute", P); 1681 end if; 1682 end; 1683 1684 elsif Nkind (P) = N_Attribute_Reference 1685 and then Attribute_Name (P) = Name_AST_Entry 1686 then 1687 Rewrite (N, 1688 New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); 1689 1690 elsif Is_Object_Reference (P) then 1691 null; 1692 1693 elsif Nkind (P) = N_Selected_Component 1694 and then Is_Subprogram (Entity (Selector_Name (P))) 1695 then 1696 null; 1697 1698 -- What exactly are we allowing here ??? and is this properly 1699 -- documented in the sinfo documentation for this node ??? 1700 1701 elsif not Comes_From_Source (N) then 1702 null; 1703 1704 else 1705 Error_Attr ("invalid prefix for % attribute", P); 1706 end if; 1707 1708 Set_Etype (N, RTE (RE_Address)); 1709 1710 ------------------ 1711 -- Address_Size -- 1712 ------------------ 1713 1714 when Attribute_Address_Size => 1715 Standard_Attribute (System_Address_Size); 1716 1717 -------------- 1718 -- Adjacent -- 1719 -------------- 1720 1721 when Attribute_Adjacent => 1722 Check_Floating_Point_Type_2; 1723 Set_Etype (N, P_Base_Type); 1724 Resolve (E1, P_Base_Type); 1725 Resolve (E2, P_Base_Type); 1726 1727 --------- 1728 -- Aft -- 1729 --------- 1730 1731 when Attribute_Aft => 1732 Check_Fixed_Point_Type_0; 1733 Set_Etype (N, Universal_Integer); 1734 1735 --------------- 1736 -- Alignment -- 1737 --------------- 1738 1739 when Attribute_Alignment => 1740 1741 -- Don't we need more checking here, cf Size ??? 1742 1743 Check_E0; 1744 Check_Not_Incomplete_Type; 1745 Set_Etype (N, Universal_Integer); 1746 1747 --------------- 1748 -- Asm_Input -- 1749 --------------- 1750 1751 when Attribute_Asm_Input => 1752 Check_Asm_Attribute; 1753 Set_Etype (N, RTE (RE_Asm_Input_Operand)); 1754 1755 ---------------- 1756 -- Asm_Output -- 1757 ---------------- 1758 1759 when Attribute_Asm_Output => 1760 Check_Asm_Attribute; 1761 1762 if Etype (E2) = Any_Type then 1763 return; 1764 1765 elsif Aname = Name_Asm_Output then 1766 if not Is_Variable (E2) then 1767 Error_Attr 1768 ("second argument for Asm_Output is not variable", E2); 1769 end if; 1770 end if; 1771 1772 Note_Possible_Modification (E2); 1773 Set_Etype (N, RTE (RE_Asm_Output_Operand)); 1774 1775 --------------- 1776 -- AST_Entry -- 1777 --------------- 1778 1779 when Attribute_AST_Entry => AST_Entry : declare 1780 Ent : Entity_Id; 1781 Pref : Node_Id; 1782 Ptyp : Entity_Id; 1783 1784 Indexed : Boolean; 1785 -- Indicates if entry family index is present. Note the coding 1786 -- here handles the entry family case, but in fact it cannot be 1787 -- executed currently, because pragma AST_Entry does not permit 1788 -- the specification of an entry family. 1789 1790 procedure Bad_AST_Entry; 1791 -- Signal a bad AST_Entry pragma 1792 1793 function OK_Entry (E : Entity_Id) return Boolean; 1794 -- Checks that E is of an appropriate entity kind for an entry 1795 -- (i.e. E_Entry if Index is False, or E_Entry_Family if Index 1796 -- is set True for the entry family case). In the True case, 1797 -- makes sure that Is_AST_Entry is set on the entry. 1798 1799 procedure Bad_AST_Entry is 1800 begin 1801 Error_Attr ("prefix for % attribute must be task entry", P); 1802 end Bad_AST_Entry; 1803 1804 function OK_Entry (E : Entity_Id) return Boolean is 1805 Result : Boolean; 1806 1807 begin 1808 if Indexed then 1809 Result := (Ekind (E) = E_Entry_Family); 1810 else 1811 Result := (Ekind (E) = E_Entry); 1812 end if; 1813 1814 if Result then 1815 if not Is_AST_Entry (E) then 1816 Error_Msg_Name_2 := Aname; 1817 Error_Attr 1818 ("% attribute requires previous % pragma", P); 1819 end if; 1820 end if; 1821 1822 return Result; 1823 end OK_Entry; 1824 1825 -- Start of processing for AST_Entry 1826 1827 begin 1828 Check_VMS (N); 1829 Check_E0; 1830 1831 -- Deal with entry family case 1832 1833 if Nkind (P) = N_Indexed_Component then 1834 Pref := Prefix (P); 1835 Indexed := True; 1836 else 1837 Pref := P; 1838 Indexed := False; 1839 end if; 1840 1841 Ptyp := Etype (Pref); 1842 1843 if Ptyp = Any_Type or else Error_Posted (Pref) then 1844 return; 1845 end if; 1846 1847 -- If the prefix is a selected component whose prefix is of an 1848 -- access type, then introduce an explicit dereference. 1849 1850 if Nkind (Pref) = N_Selected_Component 1851 and then Is_Access_Type (Ptyp) 1852 then 1853 Rewrite (Pref, 1854 Make_Explicit_Dereference (Sloc (Pref), 1855 Relocate_Node (Pref))); 1856 Analyze_And_Resolve (Pref, Designated_Type (Ptyp)); 1857 end if; 1858 1859 -- Prefix can be of the form a.b, where a is a task object 1860 -- and b is one of the entries of the corresponding task type. 1861 1862 if Nkind (Pref) = N_Selected_Component 1863 and then OK_Entry (Entity (Selector_Name (Pref))) 1864 and then Is_Object_Reference (Prefix (Pref)) 1865 and then Is_Task_Type (Etype (Prefix (Pref))) 1866 then 1867 null; 1868 1869 -- Otherwise the prefix must be an entry of a containing task, 1870 -- or of a variable of the enclosing task type. 1871 1872 else 1873 if Nkind (Pref) = N_Identifier 1874 or else Nkind (Pref) = N_Expanded_Name 1875 then 1876 Ent := Entity (Pref); 1877 1878 if not OK_Entry (Ent) 1879 or else not In_Open_Scopes (Scope (Ent)) 1880 then 1881 Bad_AST_Entry; 1882 end if; 1883 1884 else 1885 Bad_AST_Entry; 1886 end if; 1887 end if; 1888 1889 Set_Etype (N, RTE (RE_AST_Handler)); 1890 end AST_Entry; 1891 1892 ---------- 1893 -- Base -- 1894 ---------- 1895 1896 -- Note: when the base attribute appears in the context of a subtype 1897 -- mark, the analysis is done by Sem_Ch8.Find_Type, rather than by 1898 -- the following circuit. 1899 1900 when Attribute_Base => Base : declare 1901 Typ : Entity_Id; 1902 1903 begin 1904 Check_Either_E0_Or_E1; 1905 Find_Type (P); 1906 Typ := Entity (P); 1907 1908 if Ada_95 1909 and then not Is_Scalar_Type (Typ) 1910 and then not Is_Generic_Type (Typ) 1911 then 1912 Error_Msg_N ("prefix of Base attribute must be scalar type", N); 1913 1914 elsif Sloc (Typ) = Standard_Location 1915 and then Base_Type (Typ) = Typ 1916 and then Warn_On_Redundant_Constructs 1917 then 1918 Error_Msg_NE 1919 ("?redudant attribute, & is its own base type", N, Typ); 1920 end if; 1921 1922 Set_Etype (N, Base_Type (Entity (P))); 1923 1924 -- If we have an expression present, then really this is a conversion 1925 -- and the tree must be reformed. Note that this is one of the cases 1926 -- in which we do a replace rather than a rewrite, because the 1927 -- original tree is junk. 1928 1929 if Present (E1) then 1930 Replace (N, 1931 Make_Type_Conversion (Loc, 1932 Subtype_Mark => 1933 Make_Attribute_Reference (Loc, 1934 Prefix => Prefix (N), 1935 Attribute_Name => Name_Base), 1936 Expression => Relocate_Node (E1))); 1937 1938 -- E1 may be overloaded, and its interpretations preserved. 1939 1940 Save_Interps (E1, Expression (N)); 1941 Analyze (N); 1942 1943 -- For other cases, set the proper type as the entity of the 1944 -- attribute reference, and then rewrite the node to be an 1945 -- occurrence of the referenced base type. This way, no one 1946 -- else in the compiler has to worry about the base attribute. 1947 1948 else 1949 Set_Entity (N, Base_Type (Entity (P))); 1950 Rewrite (N, 1951 New_Reference_To (Entity (N), Loc)); 1952 Analyze (N); 1953 end if; 1954 end Base; 1955 1956 --------- 1957 -- Bit -- 1958 --------- 1959 1960 when Attribute_Bit => Bit : 1961 begin 1962 Check_E0; 1963 1964 if not Is_Object_Reference (P) then 1965 Error_Attr ("prefix for % attribute must be object", P); 1966 1967 -- What about the access object cases ??? 1968 1969 else 1970 null; 1971 end if; 1972 1973 Set_Etype (N, Universal_Integer); 1974 end Bit; 1975 1976 --------------- 1977 -- Bit_Order -- 1978 --------------- 1979 1980 when Attribute_Bit_Order => Bit_Order : 1981 begin 1982 Check_E0; 1983 Check_Type; 1984 1985 if not Is_Record_Type (P_Type) then 1986 Error_Attr ("prefix of % attribute must be record type", P); 1987 end if; 1988 1989 if Bytes_Big_Endian xor Reverse_Bit_Order (P_Type) then 1990 Rewrite (N, 1991 New_Occurrence_Of (RTE (RE_High_Order_First), Loc)); 1992 else 1993 Rewrite (N, 1994 New_Occurrence_Of (RTE (RE_Low_Order_First), Loc)); 1995 end if; 1996 1997 Set_Etype (N, RTE (RE_Bit_Order)); 1998 Resolve (N); 1999 2000 -- Reset incorrect indication of staticness 2001 2002 Set_Is_Static_Expression (N, False); 2003 end Bit_Order; 2004 2005 ------------------ 2006 -- Bit_Position -- 2007 ------------------ 2008 2009 -- Note: in generated code, we can have a Bit_Position attribute 2010 -- applied to a (naked) record component (i.e. the prefix is an 2011 -- identifier that references an E_Component or E_Discriminant 2012 -- entity directly, and this is interpreted as expected by Gigi. 2013 -- The following code will not tolerate such usage, but when the 2014 -- expander creates this special case, it marks it as analyzed 2015 -- immediately and sets an appropriate type. 2016 2017 when Attribute_Bit_Position => 2018 2019 if Comes_From_Source (N) then 2020 Check_Component; 2021 end if; 2022 2023 Set_Etype (N, Universal_Integer); 2024 2025 ------------------ 2026 -- Body_Version -- 2027 ------------------ 2028 2029 when Attribute_Body_Version => 2030 Check_E0; 2031 Check_Program_Unit; 2032 Set_Etype (N, RTE (RE_Version_String)); 2033 2034 -------------- 2035 -- Callable -- 2036 -------------- 2037 2038 when Attribute_Callable => 2039 Check_E0; 2040 Set_Etype (N, Standard_Boolean); 2041 Check_Task_Prefix; 2042 2043 ------------ 2044 -- Caller -- 2045 ------------ 2046 2047 when Attribute_Caller => Caller : declare 2048 Ent : Entity_Id; 2049 S : Entity_Id; 2050 2051 begin 2052 Check_E0; 2053 2054 if Nkind (P) = N_Identifier 2055 or else Nkind (P) = N_Expanded_Name 2056 then 2057 Ent := Entity (P); 2058 2059 if not Is_Entry (Ent) then 2060 Error_Attr ("invalid entry name", N); 2061 end if; 2062 2063 else 2064 Error_Attr ("invalid entry name", N); 2065 return; 2066 end if; 2067 2068 for J in reverse 0 .. Scope_Stack.Last loop 2069 S := Scope_Stack.Table (J).Entity; 2070 2071 if S = Scope (Ent) then 2072 Error_Attr ("Caller must appear in matching accept or body", N); 2073 elsif S = Ent then 2074 exit; 2075 end if; 2076 end loop; 2077 2078 Set_Etype (N, RTE (RO_AT_Task_ID)); 2079 end Caller; 2080 2081 ------------- 2082 -- Ceiling -- 2083 ------------- 2084 2085 when Attribute_Ceiling => 2086 Check_Floating_Point_Type_1; 2087 Set_Etype (N, P_Base_Type); 2088 Resolve (E1, P_Base_Type); 2089 2090 ----------- 2091 -- Class -- 2092 ----------- 2093 2094 when Attribute_Class => Class : declare 2095 begin 2096 Check_Restriction (No_Dispatch, N); 2097 Check_Either_E0_Or_E1; 2098 2099 -- If we have an expression present, then really this is a conversion 2100 -- and the tree must be reformed into a proper conversion. This is a 2101 -- Replace rather than a Rewrite, because the original tree is junk. 2102 -- If expression is overloaded, propagate interpretations to new one. 2103 2104 if Present (E1) then 2105 Replace (N, 2106 Make_Type_Conversion (Loc, 2107 Subtype_Mark => 2108 Make_Attribute_Reference (Loc, 2109 Prefix => Prefix (N), 2110 Attribute_Name => Name_Class), 2111 Expression => Relocate_Node (E1))); 2112 2113 Save_Interps (E1, Expression (N)); 2114 Analyze (N); 2115 2116 -- Otherwise we just need to find the proper type 2117 2118 else 2119 Find_Type (N); 2120 end if; 2121 2122 end Class; 2123 2124 ------------------ 2125 -- Code_Address -- 2126 ------------------ 2127 2128 when Attribute_Code_Address => 2129 Check_E0; 2130 2131 if Nkind (P) = N_Attribute_Reference 2132 and then (Attribute_Name (P) = Name_Elab_Body 2133 or else 2134 Attribute_Name (P) = Name_Elab_Spec) 2135 then 2136 null; 2137 2138 elsif not Is_Entity_Name (P) 2139 or else (Ekind (Entity (P)) /= E_Function 2140 and then 2141 Ekind (Entity (P)) /= E_Procedure) 2142 then 2143 Error_Attr ("invalid prefix for % attribute", P); 2144 Set_Address_Taken (Entity (P)); 2145 end if; 2146 2147 Set_Etype (N, RTE (RE_Address)); 2148 2149 -------------------- 2150 -- Component_Size -- 2151 -------------------- 2152 2153 when Attribute_Component_Size => 2154 Check_E0; 2155 Set_Etype (N, Universal_Integer); 2156 2157 -- Note: unlike other array attributes, unconstrained arrays are OK 2158 2159 if Is_Array_Type (P_Type) and then not Is_Constrained (P_Type) then 2160 null; 2161 else 2162 Check_Array_Type; 2163 end if; 2164 2165 ------------- 2166 -- Compose -- 2167 ------------- 2168 2169 when Attribute_Compose => 2170 Check_Floating_Point_Type_2; 2171 Set_Etype (N, P_Base_Type); 2172 Resolve (E1, P_Base_Type); 2173 Resolve (E2, Any_Integer); 2174 2175 ----------------- 2176 -- Constrained -- 2177 ----------------- 2178 2179 when Attribute_Constrained => 2180 Check_E0; 2181 Set_Etype (N, Standard_Boolean); 2182 2183 -- Case from RM J.4(2) of constrained applied to private type 2184 2185 if Is_Entity_Name (P) and then Is_Type (Entity (P)) then 2186 2187 -- If we are within an instance, the attribute must be legal 2188 -- because it was valid in the generic unit. Ditto if this is 2189 -- an inlining of a function declared in an instance. 2190 2191 if In_Instance 2192 or else In_Inlined_Body 2193 then 2194 return; 2195 2196 -- For sure OK if we have a real private type itself, but must 2197 -- be completed, cannot apply Constrained to incomplete type. 2198 2199 elsif Is_Private_Type (Entity (P)) then 2200 2201 -- Note: this is one of the Annex J features that does not 2202 -- generate a warning from -gnatwj, since in fact it seems 2203 -- very useful, and is used in the GNAT runtime. 2204 2205 Check_Not_Incomplete_Type; 2206 return; 2207 end if; 2208 2209 -- Normal (non-obsolescent case) of application to object of 2210 -- a discriminated type. 2211 2212 else 2213 Check_Object_Reference (P); 2214 2215 -- If N does not come from source, then we allow the 2216 -- the attribute prefix to be of a private type whose 2217 -- full type has discriminants. This occurs in cases 2218 -- involving expanded calls to stream attributes. 2219 2220 if not Comes_From_Source (N) then 2221 P_Type := Underlying_Type (P_Type); 2222 end if; 2223 2224 -- Must have discriminants or be an access type designating 2225 -- a type with discriminants. If it is a classwide type is 2226 -- has unknown discriminants. 2227 2228 if Has_Discriminants (P_Type) 2229 or else Has_Unknown_Discriminants (P_Type) 2230 or else 2231 (Is_Access_Type (P_Type) 2232 and then Has_Discriminants (Designated_Type (P_Type))) 2233 then 2234 return; 2235 2236 -- Also allow an object of a generic type if extensions allowed 2237 -- and allow this for any type at all. 2238 2239 elsif (Is_Generic_Type (P_Type) 2240 or else Is_Generic_Actual_Type (P_Type)) 2241 and then Extensions_Allowed 2242 then 2243 return; 2244 end if; 2245 end if; 2246 2247 -- Fall through if bad prefix 2248 2249 Error_Attr 2250 ("prefix of % attribute must be object of discriminated type", P); 2251 2252 --------------- 2253 -- Copy_Sign -- 2254 --------------- 2255 2256 when Attribute_Copy_Sign => 2257 Check_Floating_Point_Type_2; 2258 Set_Etype (N, P_Base_Type); 2259 Resolve (E1, P_Base_Type); 2260 Resolve (E2, P_Base_Type); 2261 2262 ----------- 2263 -- Count -- 2264 ----------- 2265 2266 when Attribute_Count => Count : 2267 declare 2268 Ent : Entity_Id; 2269 S : Entity_Id; 2270 Tsk : Entity_Id; 2271 2272 begin 2273 Check_E0; 2274 2275 if Nkind (P) = N_Identifier 2276 or else Nkind (P) = N_Expanded_Name 2277 then 2278 Ent := Entity (P); 2279 2280 if Ekind (Ent) /= E_Entry then 2281 Error_Attr ("invalid entry name", N); 2282 end if; 2283 2284 elsif Nkind (P) = N_Indexed_Component then 2285 if not Is_Entity_Name (Prefix (P)) 2286 or else No (Entity (Prefix (P))) 2287 or else Ekind (Entity (Prefix (P))) /= E_Entry_Family 2288 then 2289 if Nkind (Prefix (P)) = N_Selected_Component 2290 and then Present (Entity (Selector_Name (Prefix (P)))) 2291 and then Ekind (Entity (Selector_Name (Prefix (P)))) = 2292 E_Entry_Family 2293 then 2294 Error_Attr 2295 ("attribute % must apply to entry of current task", P); 2296 2297 else 2298 Error_Attr ("invalid entry family name", P); 2299 end if; 2300 return; 2301 2302 else 2303 Ent := Entity (Prefix (P)); 2304 end if; 2305 2306 elsif Nkind (P) = N_Selected_Component 2307 and then Present (Entity (Selector_Name (P))) 2308 and then Ekind (Entity (Selector_Name (P))) = E_Entry 2309 then 2310 Error_Attr 2311 ("attribute % must apply to entry of current task", P); 2312 2313 else 2314 Error_Attr ("invalid entry name", N); 2315 return; 2316 end if; 2317 2318 for J in reverse 0 .. Scope_Stack.Last loop 2319 S := Scope_Stack.Table (J).Entity; 2320 2321 if S = Scope (Ent) then 2322 if Nkind (P) = N_Expanded_Name then 2323 Tsk := Entity (Prefix (P)); 2324 2325 -- The prefix denotes either the task type, or else a 2326 -- single task whose task type is being analyzed. 2327 2328 if (Is_Type (Tsk) 2329 and then Tsk = S) 2330 2331 or else (not Is_Type (Tsk) 2332 and then Etype (Tsk) = S 2333 and then not (Comes_From_Source (S))) 2334 then 2335 null; 2336 else 2337 Error_Attr 2338 ("Attribute % must apply to entry of current task", N); 2339 end if; 2340 end if; 2341 2342 exit; 2343 2344 elsif Ekind (Scope (Ent)) in Task_Kind 2345 and then Ekind (S) /= E_Loop 2346 and then Ekind (S) /= E_Block 2347 and then Ekind (S) /= E_Entry 2348 and then Ekind (S) /= E_Entry_Family 2349 then 2350 Error_Attr ("Attribute % cannot appear in inner unit", N); 2351 2352 elsif Ekind (Scope (Ent)) = E_Protected_Type 2353 and then not Has_Completion (Scope (Ent)) 2354 then 2355 Error_Attr ("attribute % can only be used inside body", N); 2356 end if; 2357 end loop; 2358 2359 if Is_Overloaded (P) then 2360 declare 2361 Index : Interp_Index; 2362 It : Interp; 2363 2364 begin 2365 Get_First_Interp (P, Index, It); 2366 2367 while Present (It.Nam) loop 2368 if It.Nam = Ent then 2369 null; 2370 2371 else 2372 Error_Attr ("ambiguous entry name", N); 2373 end if; 2374 2375 Get_Next_Interp (Index, It); 2376 end loop; 2377 end; 2378 end if; 2379 2380 Set_Etype (N, Universal_Integer); 2381 end Count; 2382 2383 ----------------------- 2384 -- Default_Bit_Order -- 2385 ----------------------- 2386 2387 when Attribute_Default_Bit_Order => Default_Bit_Order : 2388 begin 2389 Check_Standard_Prefix; 2390 Check_E0; 2391 2392 if Bytes_Big_Endian then 2393 Rewrite (N, 2394 Make_Integer_Literal (Loc, False_Value)); 2395 else 2396 Rewrite (N, 2397 Make_Integer_Literal (Loc, True_Value)); 2398 end if; 2399 2400 Set_Etype (N, Universal_Integer); 2401 Set_Is_Static_Expression (N); 2402 end Default_Bit_Order; 2403 2404 -------------- 2405 -- Definite -- 2406 -------------- 2407 2408 when Attribute_Definite => 2409 Legal_Formal_Attribute; 2410 2411 ----------- 2412 -- Delta -- 2413 ----------- 2414 2415 when Attribute_Delta => 2416 Check_Fixed_Point_Type_0; 2417 Set_Etype (N, Universal_Real); 2418 2419 ------------ 2420 -- Denorm -- 2421 ------------ 2422 2423 when Attribute_Denorm => 2424 Check_Floating_Point_Type_0; 2425 Set_Etype (N, Standard_Boolean); 2426 2427 ------------ 2428 -- Digits -- 2429 ------------ 2430 2431 when Attribute_Digits => 2432 Check_E0; 2433 Check_Type; 2434 2435 if not Is_Floating_Point_Type (P_Type) 2436 and then not Is_Decimal_Fixed_Point_Type (P_Type) 2437 then 2438 Error_Attr 2439 ("prefix of % attribute must be float or decimal type", P); 2440 end if; 2441 2442 Set_Etype (N, Universal_Integer); 2443 2444 --------------- 2445 -- Elab_Body -- 2446 --------------- 2447 2448 -- Also handles processing for Elab_Spec 2449 2450 when Attribute_Elab_Body | Attribute_Elab_Spec => 2451 Check_E0; 2452 Check_Unit_Name (P); 2453 Set_Etype (N, Standard_Void_Type); 2454 2455 -- We have to manually call the expander in this case to get 2456 -- the necessary expansion (normally attributes that return 2457 -- entities are not expanded). 2458 2459 Expand (N); 2460 2461 --------------- 2462 -- Elab_Spec -- 2463 --------------- 2464 2465 -- Shares processing with Elab_Body 2466 2467 ---------------- 2468 -- Elaborated -- 2469 ---------------- 2470 2471 when Attribute_Elaborated => 2472 Check_E0; 2473 Check_Library_Unit; 2474 Set_Etype (N, Standard_Boolean); 2475 2476 ---------- 2477 -- Emax -- 2478 ---------- 2479 2480 when Attribute_Emax => 2481 Check_Floating_Point_Type_0; 2482 Set_Etype (N, Universal_Integer); 2483 2484 -------------- 2485 -- Enum_Rep -- 2486 -------------- 2487 2488 when Attribute_Enum_Rep => Enum_Rep : declare 2489 begin 2490 if Present (E1) then 2491 Check_E1; 2492 Check_Discrete_Type; 2493 Resolve (E1, P_Base_Type); 2494 2495 else 2496 if not Is_Entity_Name (P) 2497 or else (not Is_Object (Entity (P)) 2498 and then 2499 Ekind (Entity (P)) /= E_Enumeration_Literal) 2500 then 2501 Error_Attr 2502 ("prefix of %attribute must be " & 2503 "discrete type/object or enum literal", P); 2504 end if; 2505 end if; 2506 2507 Set_Etype (N, Universal_Integer); 2508 end Enum_Rep; 2509 2510 ------------- 2511 -- Epsilon -- 2512 ------------- 2513 2514 when Attribute_Epsilon => 2515 Check_Floating_Point_Type_0; 2516 Set_Etype (N, Universal_Real); 2517 2518 -------------- 2519 -- Exponent -- 2520 -------------- 2521 2522 when Attribute_Exponent => 2523 Check_Floating_Point_Type_1; 2524 Set_Etype (N, Universal_Integer); 2525 Resolve (E1, P_Base_Type); 2526 2527 ------------------ 2528 -- External_Tag -- 2529 ------------------ 2530 2531 when Attribute_External_Tag => 2532 Check_E0; 2533 Check_Type; 2534 2535 Set_Etype (N, Standard_String); 2536 2537 if not Is_Tagged_Type (P_Type) then 2538 Error_Attr ("prefix of % attribute must be tagged", P); 2539 end if; 2540 2541 ----------- 2542 -- First -- 2543 ----------- 2544 2545 when Attribute_First => 2546 Check_Array_Or_Scalar_Type; 2547 2548 --------------- 2549 -- First_Bit -- 2550 --------------- 2551 2552 when Attribute_First_Bit => 2553 Check_Component; 2554 Set_Etype (N, Universal_Integer); 2555 2556 ----------------- 2557 -- Fixed_Value -- 2558 ----------------- 2559 2560 when Attribute_Fixed_Value => 2561 Check_E1; 2562 Check_Fixed_Point_Type; 2563 Resolve (E1, Any_Integer); 2564 Set_Etype (N, P_Base_Type); 2565 2566 ----------- 2567 -- Floor -- 2568 ----------- 2569 2570 when Attribute_Floor => 2571 Check_Floating_Point_Type_1; 2572 Set_Etype (N, P_Base_Type); 2573 Resolve (E1, P_Base_Type); 2574 2575 ---------- 2576 -- Fore -- 2577 ---------- 2578 2579 when Attribute_Fore => 2580 Check_Fixed_Point_Type_0; 2581 Set_Etype (N, Universal_Integer); 2582 2583 -------------- 2584 -- Fraction -- 2585 -------------- 2586 2587 when Attribute_Fraction => 2588 Check_Floating_Point_Type_1; 2589 Set_Etype (N, P_Base_Type); 2590 Resolve (E1, P_Base_Type); 2591 2592 ----------------------- 2593 -- Has_Discriminants -- 2594 ----------------------- 2595 2596 when Attribute_Has_Discriminants => 2597 Legal_Formal_Attribute; 2598 2599 -------------- 2600 -- Identity -- 2601 -------------- 2602 2603 when Attribute_Identity => 2604 Check_E0; 2605 Analyze (P); 2606 2607 if Etype (P) = Standard_Exception_Type then 2608 Set_Etype (N, RTE (RE_Exception_Id)); 2609 2610 elsif Is_Task_Type (Etype (P)) 2611 or else (Is_Access_Type (Etype (P)) 2612 and then Is_Task_Type (Designated_Type (Etype (P)))) 2613 then 2614 Resolve (P); 2615 Set_Etype (N, RTE (RO_AT_Task_ID)); 2616 2617 else 2618 Error_Attr ("prefix of % attribute must be a task or an " 2619 & "exception", P); 2620 end if; 2621 2622 ----------- 2623 -- Image -- 2624 ----------- 2625 2626 when Attribute_Image => Image : 2627 begin 2628 Set_Etype (N, Standard_String); 2629 Check_Scalar_Type; 2630 2631 if Is_Real_Type (P_Type) then 2632 if Ada_83 and then Comes_From_Source (N) then 2633 Error_Msg_Name_1 := Aname; 2634 Error_Msg_N 2635 ("(Ada 83) % attribute not allowed for real types", N); 2636 end if; 2637 end if; 2638 2639 if Is_Enumeration_Type (P_Type) then 2640 Check_Restriction (No_Enumeration_Maps, N); 2641 end if; 2642 2643 Check_E1; 2644 Resolve (E1, P_Base_Type); 2645 Check_Enum_Image; 2646 Validate_Non_Static_Attribute_Function_Call; 2647 end Image; 2648 2649 --------- 2650 -- Img -- 2651 --------- 2652 2653 when Attribute_Img => Img : 2654 begin 2655 Set_Etype (N, Standard_String); 2656 2657 if not Is_Scalar_Type (P_Type) 2658 or else (Is_Entity_Name (P) and then Is_Type (Entity (P))) 2659 then 2660 Error_Attr 2661 ("prefix of % attribute must be scalar object name", N); 2662 end if; 2663 2664 Check_Enum_Image; 2665 end Img; 2666 2667 ----------- 2668 -- Input -- 2669 ----------- 2670 2671 when Attribute_Input => 2672 Check_E1; 2673 Check_Stream_Attribute (TSS_Stream_Input); 2674 Set_Etype (N, P_Base_Type); 2675 2676 ------------------- 2677 -- Integer_Value -- 2678 ------------------- 2679 2680 when Attribute_Integer_Value => 2681 Check_E1; 2682 Check_Integer_Type; 2683 Resolve (E1, Any_Fixed); 2684 Set_Etype (N, P_Base_Type); 2685 2686 ----------- 2687 -- Large -- 2688 ----------- 2689 2690 when Attribute_Large => 2691 Check_E0; 2692 Check_Real_Type; 2693 Set_Etype (N, Universal_Real); 2694 2695 ---------- 2696 -- Last -- 2697 ---------- 2698 2699 when Attribute_Last => 2700 Check_Array_Or_Scalar_Type; 2701 2702 -------------- 2703 -- Last_Bit -- 2704 -------------- 2705 2706 when Attribute_Last_Bit => 2707 Check_Component; 2708 Set_Etype (N, Universal_Integer); 2709 2710 ------------------ 2711 -- Leading_Part -- 2712 ------------------ 2713 2714 when Attribute_Leading_Part => 2715 Check_Floating_Point_Type_2; 2716 Set_Etype (N, P_Base_Type); 2717 Resolve (E1, P_Base_Type); 2718 Resolve (E2, Any_Integer); 2719 2720 ------------ 2721 -- Length -- 2722 ------------ 2723 2724 when Attribute_Length => 2725 Check_Array_Type; 2726 Set_Etype (N, Universal_Integer); 2727 2728 ------------- 2729 -- Machine -- 2730 ------------- 2731 2732 when Attribute_Machine => 2733 Check_Floating_Point_Type_1; 2734 Set_Etype (N, P_Base_Type); 2735 Resolve (E1, P_Base_Type); 2736 2737 ------------------ 2738 -- Machine_Emax -- 2739 ------------------ 2740 2741 when Attribute_Machine_Emax => 2742 Check_Floating_Point_Type_0; 2743 Set_Etype (N, Universal_Integer); 2744 2745 ------------------ 2746 -- Machine_Emin -- 2747 ------------------ 2748 2749 when Attribute_Machine_Emin => 2750 Check_Floating_Point_Type_0; 2751 Set_Etype (N, Universal_Integer); 2752 2753 ---------------------- 2754 -- Machine_Mantissa -- 2755 ---------------------- 2756 2757 when Attribute_Machine_Mantissa => 2758 Check_Floating_Point_Type_0; 2759 Set_Etype (N, Universal_Integer); 2760 2761 ----------------------- 2762 -- Machine_Overflows -- 2763 ----------------------- 2764 2765 when Attribute_Machine_Overflows => 2766 Check_Real_Type; 2767 Check_E0; 2768 Set_Etype (N, Standard_Boolean); 2769 2770 ------------------- 2771 -- Machine_Radix -- 2772 ------------------- 2773 2774 when Attribute_Machine_Radix => 2775 Check_Real_Type; 2776 Check_E0; 2777 Set_Etype (N, Universal_Integer); 2778 2779 -------------------- 2780 -- Machine_Rounds -- 2781 -------------------- 2782 2783 when Attribute_Machine_Rounds => 2784 Check_Real_Type; 2785 Check_E0; 2786 Set_Etype (N, Standard_Boolean); 2787 2788 ------------------ 2789 -- Machine_Size -- 2790 ------------------ 2791 2792 when Attribute_Machine_Size => 2793 Check_E0; 2794 Check_Type; 2795 Check_Not_Incomplete_Type; 2796 Set_Etype (N, Universal_Integer); 2797 2798 -------------- 2799 -- Mantissa -- 2800 -------------- 2801 2802 when Attribute_Mantissa => 2803 Check_E0; 2804 Check_Real_Type; 2805 Set_Etype (N, Universal_Integer); 2806 2807 --------- 2808 -- Max -- 2809 --------- 2810 2811 when Attribute_Max => 2812 Check_E2; 2813 Check_Scalar_Type; 2814 Resolve (E1, P_Base_Type); 2815 Resolve (E2, P_Base_Type); 2816 Set_Etype (N, P_Base_Type); 2817 2818 ---------------------------------- 2819 -- Max_Size_In_Storage_Elements -- 2820 ---------------------------------- 2821 2822 when Attribute_Max_Size_In_Storage_Elements => 2823 Check_E0; 2824 Check_Type; 2825 Check_Not_Incomplete_Type; 2826 Set_Etype (N, Universal_Integer); 2827 2828 ----------------------- 2829 -- Maximum_Alignment -- 2830 ----------------------- 2831 2832 when Attribute_Maximum_Alignment => 2833 Standard_Attribute (Ttypes.Maximum_Alignment); 2834 2835 -------------------- 2836 -- Mechanism_Code -- 2837 -------------------- 2838 2839 when Attribute_Mechanism_Code => 2840 if not Is_Entity_Name (P) 2841 or else not Is_Subprogram (Entity (P)) 2842 then 2843 Error_Attr ("prefix of % attribute must be subprogram", P); 2844 end if; 2845 2846 Check_Either_E0_Or_E1; 2847 2848 if Present (E1) then 2849 Resolve (E1, Any_Integer); 2850 Set_Etype (E1, Standard_Integer); 2851 2852 if not Is_Static_Expression (E1) then 2853 Flag_Non_Static_Expr 2854 ("expression for parameter number must be static!", E1); 2855 Error_Attr; 2856 2857 elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P)) 2858 or else UI_To_Int (Intval (E1)) < 0 2859 then 2860 Error_Attr ("invalid parameter number for %attribute", E1); 2861 end if; 2862 end if; 2863 2864 Set_Etype (N, Universal_Integer); 2865 2866 --------- 2867 -- Min -- 2868 --------- 2869 2870 when Attribute_Min => 2871 Check_E2; 2872 Check_Scalar_Type; 2873 Resolve (E1, P_Base_Type); 2874 Resolve (E2, P_Base_Type); 2875 Set_Etype (N, P_Base_Type); 2876 2877 ----------- 2878 -- Model -- 2879 ----------- 2880 2881 when Attribute_Model => 2882 Check_Floating_Point_Type_1; 2883 Set_Etype (N, P_Base_Type); 2884 Resolve (E1, P_Base_Type); 2885 2886 ---------------- 2887 -- Model_Emin -- 2888 ---------------- 2889 2890 when Attribute_Model_Emin => 2891 Check_Floating_Point_Type_0; 2892 Set_Etype (N, Universal_Integer); 2893 2894 ------------------- 2895 -- Model_Epsilon -- 2896 ------------------- 2897 2898 when Attribute_Model_Epsilon => 2899 Check_Floating_Point_Type_0; 2900 Set_Etype (N, Universal_Real); 2901 2902 -------------------- 2903 -- Model_Mantissa -- 2904 -------------------- 2905 2906 when Attribute_Model_Mantissa => 2907 Check_Floating_Point_Type_0; 2908 Set_Etype (N, Universal_Integer); 2909 2910 ----------------- 2911 -- Model_Small -- 2912 ----------------- 2913 2914 when Attribute_Model_Small => 2915 Check_Floating_Point_Type_0; 2916 Set_Etype (N, Universal_Real); 2917 2918 ------------- 2919 -- Modulus -- 2920 ------------- 2921 2922 when Attribute_Modulus => 2923 Check_E0; 2924 Check_Type; 2925 2926 if not Is_Modular_Integer_Type (P_Type) then 2927 Error_Attr ("prefix of % attribute must be modular type", P); 2928 end if; 2929 2930 Set_Etype (N, Universal_Integer); 2931 2932 -------------------- 2933 -- Null_Parameter -- 2934 -------------------- 2935 2936 when Attribute_Null_Parameter => Null_Parameter : declare 2937 Parnt : constant Node_Id := Parent (N); 2938 GParnt : constant Node_Id := Parent (Parnt); 2939 2940 procedure Bad_Null_Parameter (Msg : String); 2941 -- Used if bad Null parameter attribute node is found. Issues 2942 -- given error message, and also sets the type to Any_Type to 2943 -- avoid blowups later on from dealing with a junk node. 2944 2945 procedure Must_Be_Imported (Proc_Ent : Entity_Id); 2946 -- Called to check that Proc_Ent is imported subprogram 2947 2948 ------------------------ 2949 -- Bad_Null_Parameter -- 2950 ------------------------ 2951 2952 procedure Bad_Null_Parameter (Msg : String) is 2953 begin 2954 Error_Msg_N (Msg, N); 2955 Set_Etype (N, Any_Type); 2956 end Bad_Null_Parameter; 2957 2958 ---------------------- 2959 -- Must_Be_Imported -- 2960 ---------------------- 2961 2962 procedure Must_Be_Imported (Proc_Ent : Entity_Id) is 2963 Pent : Entity_Id := Proc_Ent; 2964 2965 begin 2966 while Present (Alias (Pent)) loop 2967 Pent := Alias (Pent); 2968 end loop; 2969 2970 -- Ignore check if procedure not frozen yet (we will get 2971 -- another chance when the default parameter is reanalyzed) 2972 2973 if not Is_Frozen (Pent) then 2974 return; 2975 2976 elsif not Is_Imported (Pent) then 2977 Bad_Null_Parameter 2978 ("Null_Parameter can only be used with imported subprogram"); 2979 2980 else 2981 return; 2982 end if; 2983 end Must_Be_Imported; 2984 2985 -- Start of processing for Null_Parameter 2986 2987 begin 2988 Check_Type; 2989 Check_E0; 2990 Set_Etype (N, P_Type); 2991 2992 -- Case of attribute used as default expression 2993 2994 if Nkind (Parnt) = N_Parameter_Specification then 2995 Must_Be_Imported (Defining_Entity (GParnt)); 2996 2997 -- Case of attribute used as actual for subprogram (positional) 2998 2999 elsif (Nkind (Parnt) = N_Procedure_Call_Statement 3000 or else 3001 Nkind (Parnt) = N_Function_Call) 3002 and then Is_Entity_Name (Name (Parnt)) 3003 then 3004 Must_Be_Imported (Entity (Name (Parnt))); 3005 3006 -- Case of attribute used as actual for subprogram (named) 3007 3008 elsif Nkind (Parnt) = N_Parameter_Association 3009 and then (Nkind (GParnt) = N_Procedure_Call_Statement 3010 or else 3011 Nkind (GParnt) = N_Function_Call) 3012 and then Is_Entity_Name (Name (GParnt)) 3013 then 3014 Must_Be_Imported (Entity (Name (GParnt))); 3015 3016 -- Not an allowed case 3017 3018 else 3019 Bad_Null_Parameter 3020 ("Null_Parameter must be actual or default parameter"); 3021 end if; 3022 3023 end Null_Parameter; 3024 3025 ----------------- 3026 -- Object_Size -- 3027 ----------------- 3028 3029 when Attribute_Object_Size => 3030 Check_E0; 3031 Check_Type; 3032 Check_Not_Incomplete_Type; 3033 Set_Etype (N, Universal_Integer); 3034 3035 ------------ 3036 -- Output -- 3037 ------------ 3038 3039 when Attribute_Output => 3040 Check_E2; 3041 Check_Stream_Attribute (TSS_Stream_Output); 3042 Set_Etype (N, Standard_Void_Type); 3043 Resolve (N, Standard_Void_Type); 3044 3045 ------------------ 3046 -- Partition_ID -- 3047 ------------------ 3048 3049 when Attribute_Partition_ID => 3050 Check_E0; 3051 3052 if P_Type /= Any_Type then 3053 if not Is_Library_Level_Entity (Entity (P)) then 3054 Error_Attr 3055 ("prefix of % attribute must be library-level entity", P); 3056 3057 -- The defining entity of prefix should not be declared inside 3058 -- a Pure unit. RM E.1(8). 3059 -- The Is_Pure flag has been set during declaration. 3060 3061 elsif Is_Entity_Name (P) 3062 and then Is_Pure (Entity (P)) 3063 then 3064 Error_Attr 3065 ("prefix of % attribute must not be declared pure", P); 3066 end if; 3067 end if; 3068 3069 Set_Etype (N, Universal_Integer); 3070 3071 ------------------------- 3072 -- Passed_By_Reference -- 3073 ------------------------- 3074 3075 when Attribute_Passed_By_Reference => 3076 Check_E0; 3077 Check_Type; 3078 Set_Etype (N, Standard_Boolean); 3079 3080 ------------------ 3081 -- Pool_Address -- 3082 ------------------ 3083 3084 when Attribute_Pool_Address => 3085 Check_E0; 3086 Set_Etype (N, RTE (RE_Address)); 3087 3088 --------- 3089 -- Pos -- 3090 --------- 3091 3092 when Attribute_Pos => 3093 Check_Discrete_Type; 3094 Check_E1; 3095 Resolve (E1, P_Base_Type); 3096 Set_Etype (N, Universal_Integer); 3097 3098 -------------- 3099 -- Position -- 3100 -------------- 3101 3102 when Attribute_Position => 3103 Check_Component; 3104 Set_Etype (N, Universal_Integer); 3105 3106 ---------- 3107 -- Pred -- 3108 ---------- 3109 3110 when Attribute_Pred => 3111 Check_Scalar_Type; 3112 Check_E1; 3113 Resolve (E1, P_Base_Type); 3114 Set_Etype (N, P_Base_Type); 3115 3116 -- Nothing to do for real type case 3117 3118 if Is_Real_Type (P_Type) then 3119 null; 3120 3121 -- If not modular type, test for overflow check required 3122 3123 else 3124 if not Is_Modular_Integer_Type (P_Type) 3125 and then not Range_Checks_Suppressed (P_Base_Type) 3126 then 3127 Enable_Range_Check (E1); 3128 end if; 3129 end if; 3130 3131 ----------- 3132 -- Range -- 3133 ----------- 3134 3135 when Attribute_Range => 3136 Check_Array_Or_Scalar_Type; 3137 3138 if Ada_83 3139 and then Is_Scalar_Type (P_Type) 3140 and then Comes_From_Source (N) 3141 then 3142 Error_Attr 3143 ("(Ada 83) % attribute not allowed for scalar type", P); 3144 end if; 3145 3146 ------------------ 3147 -- Range_Length -- 3148 ------------------ 3149 3150 when Attribute_Range_Length => 3151 Check_Discrete_Type; 3152 Set_Etype (N, Universal_Integer); 3153 3154 ---------- 3155 -- Read -- 3156 ---------- 3157 3158 when Attribute_Read => 3159 Check_E2; 3160 Check_Stream_Attribute (TSS_Stream_Read); 3161 Set_Etype (N, Standard_Void_Type); 3162 Resolve (N, Standard_Void_Type); 3163 Note_Possible_Modification (E2); 3164 3165 --------------- 3166 -- Remainder -- 3167 --------------- 3168 3169 when Attribute_Remainder => 3170 Check_Floating_Point_Type_2; 3171 Set_Etype (N, P_Base_Type); 3172 Resolve (E1, P_Base_Type); 3173 Resolve (E2, P_Base_Type); 3174 3175 ----------- 3176 -- Round -- 3177 ----------- 3178 3179 when Attribute_Round => 3180 Check_E1; 3181 Check_Decimal_Fixed_Point_Type; 3182 Set_Etype (N, P_Base_Type); 3183 3184 -- Because the context is universal_real (3.5.10(12)) it is a legal 3185 -- context for a universal fixed expression. This is the only 3186 -- attribute whose functional description involves U_R. 3187 3188 if Etype (E1) = Universal_Fixed then 3189 declare 3190 Conv : constant Node_Id := Make_Type_Conversion (Loc, 3191 Subtype_Mark => New_Occurrence_Of (Universal_Real, Loc), 3192 Expression => Relocate_Node (E1)); 3193 3194 begin 3195 Rewrite (E1, Conv); 3196 Analyze (E1); 3197 end; 3198 end if; 3199 3200 Resolve (E1, Any_Real); 3201 3202 -------------- 3203 -- Rounding -- 3204 -------------- 3205 3206 when Attribute_Rounding => 3207 Check_Floating_Point_Type_1; 3208 Set_Etype (N, P_Base_Type); 3209 Resolve (E1, P_Base_Type); 3210 3211 --------------- 3212 -- Safe_Emax -- 3213 --------------- 3214 3215 when Attribute_Safe_Emax => 3216 Check_Floating_Point_Type_0; 3217 Set_Etype (N, Universal_Integer); 3218 3219 ---------------- 3220 -- Safe_First -- 3221 ---------------- 3222 3223 when Attribute_Safe_First => 3224 Check_Floating_Point_Type_0; 3225 Set_Etype (N, Universal_Real); 3226 3227 ---------------- 3228 -- Safe_Large -- 3229 ---------------- 3230 3231 when Attribute_Safe_Large => 3232 Check_E0; 3233 Check_Real_Type; 3234 Set_Etype (N, Universal_Real); 3235 3236 --------------- 3237 -- Safe_Last -- 3238 --------------- 3239 3240 when Attribute_Safe_Last => 3241 Check_Floating_Point_Type_0; 3242 Set_Etype (N, Universal_Real); 3243 3244 ---------------- 3245 -- Safe_Small -- 3246 ---------------- 3247 3248 when Attribute_Safe_Small => 3249 Check_E0; 3250 Check_Real_Type; 3251 Set_Etype (N, Universal_Real); 3252 3253 ----------- 3254 -- Scale -- 3255 ----------- 3256 3257 when Attribute_Scale => 3258 Check_E0; 3259 Check_Decimal_Fixed_Point_Type; 3260 Set_Etype (N, Universal_Integer); 3261 3262 ------------- 3263 -- Scaling -- 3264 ------------- 3265 3266 when Attribute_Scaling => 3267 Check_Floating_Point_Type_2; 3268 Set_Etype (N, P_Base_Type); 3269 Resolve (E1, P_Base_Type); 3270 3271 ------------------ 3272 -- Signed_Zeros -- 3273 ------------------ 3274 3275 when Attribute_Signed_Zeros => 3276 Check_Floating_Point_Type_0; 3277 Set_Etype (N, Standard_Boolean); 3278 3279 ---------- 3280 -- Size -- 3281 ---------- 3282 3283 when Attribute_Size | Attribute_VADS_Size => 3284 Check_E0; 3285 3286 if Is_Object_Reference (P) 3287 or else (Is_Entity_Name (P) 3288 and then Ekind (Entity (P)) = E_Function) 3289 then 3290 Check_Object_Reference (P); 3291 3292 elsif Is_Entity_Name (P) 3293 and then Is_Type (Entity (P)) 3294 then 3295 null; 3296 3297 elsif Nkind (P) = N_Type_Conversion 3298 and then not Comes_From_Source (P) 3299 then 3300 null; 3301 3302 else 3303 Error_Attr ("invalid prefix for % attribute", P); 3304 end if; 3305 3306 Check_Not_Incomplete_Type; 3307 Set_Etype (N, Universal_Integer); 3308 3309 ----------- 3310 -- Small -- 3311 ----------- 3312 3313 when Attribute_Small => 3314 Check_E0; 3315 Check_Real_Type; 3316 Set_Etype (N, Universal_Real); 3317 3318 ------------------ 3319 -- Storage_Pool -- 3320 ------------------ 3321 3322 when Attribute_Storage_Pool => 3323 if Is_Access_Type (P_Type) then 3324 Check_E0; 3325 3326 -- Set appropriate entity 3327 3328 if Present (Associated_Storage_Pool (Root_Type (P_Type))) then 3329 Set_Entity (N, Associated_Storage_Pool (Root_Type (P_Type))); 3330 else 3331 Set_Entity (N, RTE (RE_Global_Pool_Object)); 3332 end if; 3333 3334 Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); 3335 3336 -- Validate_Remote_Access_To_Class_Wide_Type for attribute 3337 -- Storage_Pool since this attribute is not defined for such 3338 -- types (RM E.2.3(22)). 3339 3340 Validate_Remote_Access_To_Class_Wide_Type (N); 3341 3342 else 3343 Error_Attr ("prefix of % attribute must be access type", P); 3344 end if; 3345 3346 ------------------ 3347 -- Storage_Size -- 3348 ------------------ 3349 3350 when Attribute_Storage_Size => 3351 3352 if Is_Task_Type (P_Type) then 3353 Check_E0; 3354 Set_Etype (N, Universal_Integer); 3355 3356 elsif Is_Access_Type (P_Type) then 3357 if Is_Entity_Name (P) 3358 and then Is_Type (Entity (P)) 3359 then 3360 Check_E0; 3361 Check_Type; 3362 Set_Etype (N, Universal_Integer); 3363 3364 -- Validate_Remote_Access_To_Class_Wide_Type for attribute 3365 -- Storage_Size since this attribute is not defined for 3366 -- such types (RM E.2.3(22)). 3367 3368 Validate_Remote_Access_To_Class_Wide_Type (N); 3369 3370 -- The prefix is allowed to be an implicit dereference 3371 -- of an access value designating a task. 3372 3373 else 3374 Check_E0; 3375 Check_Task_Prefix; 3376 Set_Etype (N, Universal_Integer); 3377 end if; 3378 3379 else 3380 Error_Attr 3381 ("prefix of % attribute must be access or task type", P); 3382 end if; 3383 3384 ------------------ 3385 -- Storage_Unit -- 3386 ------------------ 3387 3388 when Attribute_Storage_Unit => 3389 Standard_Attribute (Ttypes.System_Storage_Unit); 3390 3391 ---------- 3392 -- Succ -- 3393 ---------- 3394 3395 when Attribute_Succ => 3396 Check_Scalar_Type; 3397 Check_E1; 3398 Resolve (E1, P_Base_Type); 3399 Set_Etype (N, P_Base_Type); 3400 3401 -- Nothing to do for real type case 3402 3403 if Is_Real_Type (P_Type) then 3404 null; 3405 3406 -- If not modular type, test for overflow check required. 3407 3408 else 3409 if not Is_Modular_Integer_Type (P_Type) 3410 and then not Range_Checks_Suppressed (P_Base_Type) 3411 then 3412 Enable_Range_Check (E1); 3413 end if; 3414 end if; 3415 3416 --------- 3417 -- Tag -- 3418 --------- 3419 3420 when Attribute_Tag => 3421 Check_E0; 3422 Check_Dereference; 3423 3424 if not Is_Tagged_Type (P_Type) then 3425 Error_Attr ("prefix of % attribute must be tagged", P); 3426 3427 -- Next test does not apply to generated code 3428 -- why not, and what does the illegal reference mean??? 3429 3430 elsif Is_Object_Reference (P) 3431 and then not Is_Class_Wide_Type (P_Type) 3432 and then Comes_From_Source (N) 3433 then 3434 Error_Attr 3435 ("% attribute can only be applied to objects of class-wide type", 3436 P); 3437 end if; 3438 3439 Set_Etype (N, RTE (RE_Tag)); 3440 3441 ----------------- 3442 -- Target_Name -- 3443 ----------------- 3444 3445 when Attribute_Target_Name => Target_Name : declare 3446 TN : constant String := Sdefault.Target_Name.all; 3447 TL : Integer := TN'Last; 3448 3449 begin 3450 Check_Standard_Prefix; 3451 Check_E0; 3452 Start_String; 3453 3454 if TN (TL) = '/' or else TN (TL) = '\' then 3455 TL := TL - 1; 3456 end if; 3457 3458 Store_String_Chars (TN (TN'First .. TL)); 3459 3460 Rewrite (N, 3461 Make_String_Literal (Loc, 3462 Strval => End_String)); 3463 Analyze_And_Resolve (N, Standard_String); 3464 end Target_Name; 3465 3466 ---------------- 3467 -- Terminated -- 3468 ---------------- 3469 3470 when Attribute_Terminated => 3471 Check_E0; 3472 Set_Etype (N, Standard_Boolean); 3473 Check_Task_Prefix; 3474 3475 ---------------- 3476 -- To_Address -- 3477 ---------------- 3478 3479 when Attribute_To_Address => 3480 Check_E1; 3481 Analyze (P); 3482 3483 if Nkind (P) /= N_Identifier 3484 or else Chars (P) /= Name_System 3485 then 3486 Error_Attr ("prefix of %attribute must be System", P); 3487 end if; 3488 3489 Generate_Reference (RTE (RE_Address), P); 3490 Analyze_And_Resolve (E1, Any_Integer); 3491 Set_Etype (N, RTE (RE_Address)); 3492 3493 ---------------- 3494 -- Truncation -- 3495 ---------------- 3496 3497 when Attribute_Truncation => 3498 Check_Floating_Point_Type_1; 3499 Resolve (E1, P_Base_Type); 3500 Set_Etype (N, P_Base_Type); 3501 3502 ---------------- 3503 -- Type_Class -- 3504 ---------------- 3505 3506 when Attribute_Type_Class => 3507 Check_E0; 3508 Check_Type; 3509 Check_Not_Incomplete_Type; 3510 Set_Etype (N, RTE (RE_Type_Class)); 3511 3512 ----------------- 3513 -- UET_Address -- 3514 ----------------- 3515 3516 when Attribute_UET_Address => 3517 Check_E0; 3518 Check_Unit_Name (P); 3519 Set_Etype (N, RTE (RE_Address)); 3520 3521 ----------------------- 3522 -- Unbiased_Rounding -- 3523 ----------------------- 3524 3525 when Attribute_Unbiased_Rounding => 3526 Check_Floating_Point_Type_1; 3527 Set_Etype (N, P_Base_Type); 3528 Resolve (E1, P_Base_Type); 3529 3530 ---------------------- 3531 -- Unchecked_Access -- 3532 ---------------------- 3533 3534 when Attribute_Unchecked_Access => 3535 if Comes_From_Source (N) then 3536 Check_Restriction (No_Unchecked_Access, N); 3537 end if; 3538 3539 Analyze_Access_Attribute; 3540 3541 ------------------------- 3542 -- Unconstrained_Array -- 3543 ------------------------- 3544 3545 when Attribute_Unconstrained_Array => 3546 Check_E0; 3547 Check_Type; 3548 Check_Not_Incomplete_Type; 3549 Set_Etype (N, Standard_Boolean); 3550 3551 ------------------------------ 3552 -- Universal_Literal_String -- 3553 ------------------------------ 3554 3555 -- This is a GNAT specific attribute whose prefix must be a named 3556 -- number where the expression is either a single numeric literal, 3557 -- or a numeric literal immediately preceded by a minus sign. The 3558 -- result is equivalent to a string literal containing the text of 3559 -- the literal as it appeared in the source program with a possible 3560 -- leading minus sign. 3561 3562 when Attribute_Universal_Literal_String => Universal_Literal_String : 3563 begin 3564 Check_E0; 3565 3566 if not Is_Entity_Name (P) 3567 or else Ekind (Entity (P)) not in Named_Kind 3568 then 3569 Error_Attr ("prefix for % attribute must be named number", P); 3570 3571 else 3572 declare 3573 Expr : Node_Id; 3574 Negative : Boolean; 3575 S : Source_Ptr; 3576 Src : Source_Buffer_Ptr; 3577 3578 begin 3579 Expr := Original_Node (Expression (Parent (Entity (P)))); 3580 3581 if Nkind (Expr) = N_Op_Minus then 3582 Negative := True; 3583 Expr := Original_Node (Right_Opnd (Expr)); 3584 else 3585 Negative := False; 3586 end if; 3587 3588 if Nkind (Expr) /= N_Integer_Literal 3589 and then Nkind (Expr) /= N_Real_Literal 3590 then 3591 Error_Attr 3592 ("named number for % attribute must be simple literal", N); 3593 end if; 3594 3595 -- Build string literal corresponding to source literal text 3596 3597 Start_String; 3598 3599 if Negative then 3600 Store_String_Char (Get_Char_Code ('-')); 3601 end if; 3602 3603 S := Sloc (Expr); 3604 Src := Source_Text (Get_Source_File_Index (S)); 3605 3606 while Src (S) /= ';' and then Src (S) /= ' ' loop 3607 Store_String_Char (Get_Char_Code (Src (S))); 3608 S := S + 1; 3609 end loop; 3610 3611 -- Now we rewrite the attribute with the string literal 3612 3613 Rewrite (N, 3614 Make_String_Literal (Loc, End_String)); 3615 Analyze (N); 3616 end; 3617 end if; 3618 end Universal_Literal_String; 3619 3620 ------------------------- 3621 -- Unrestricted_Access -- 3622 ------------------------- 3623 3624 -- This is a GNAT specific attribute which is like Access except that 3625 -- all scope checks and checks for aliased views are omitted. 3626 3627 when Attribute_Unrestricted_Access => 3628 if Comes_From_Source (N) then 3629 Check_Restriction (No_Unchecked_Access, N); 3630 end if; 3631 3632 if Is_Entity_Name (P) then 3633 Set_Address_Taken (Entity (P)); 3634 end if; 3635 3636 Analyze_Access_Attribute; 3637 3638 --------- 3639 -- Val -- 3640 --------- 3641 3642 when Attribute_Val => Val : declare 3643 begin 3644 Check_E1; 3645 Check_Discrete_Type; 3646 Resolve (E1, Any_Integer); 3647 Set_Etype (N, P_Base_Type); 3648 3649 -- Note, we need a range check in general, but we wait for the 3650 -- Resolve call to do this, since we want to let Eval_Attribute 3651 -- have a chance to find an static illegality first! 3652 end Val; 3653 3654 ----------- 3655 -- Valid -- 3656 ----------- 3657 3658 when Attribute_Valid => 3659 Check_E0; 3660 3661 -- Ignore check for object if we have a 'Valid reference generated 3662 -- by the expanded code, since in some cases valid checks can occur 3663 -- on items that are names, but are not objects (e.g. attributes). 3664 3665 if Comes_From_Source (N) then 3666 Check_Object_Reference (P); 3667 end if; 3668 3669 if not Is_Scalar_Type (P_Type) then 3670 Error_Attr ("object for % attribute must be of scalar type", P); 3671 end if; 3672 3673 Set_Etype (N, Standard_Boolean); 3674 3675 ----------- 3676 -- Value -- 3677 ----------- 3678 3679 when Attribute_Value => Value : 3680 begin 3681 Check_E1; 3682 Check_Scalar_Type; 3683 3684 if Is_Enumeration_Type (P_Type) then 3685 Check_Restriction (No_Enumeration_Maps, N); 3686 end if; 3687 3688 -- Set Etype before resolving expression because expansion of 3689 -- expression may require enclosing type. Note that the type 3690 -- returned by 'Value is the base type of the prefix type. 3691 3692 Set_Etype (N, P_Base_Type); 3693 Validate_Non_Static_Attribute_Function_Call; 3694 end Value; 3695 3696 ---------------- 3697 -- Value_Size -- 3698 ---------------- 3699 3700 when Attribute_Value_Size => 3701 Check_E0; 3702 Check_Type; 3703 Check_Not_Incomplete_Type; 3704 Set_Etype (N, Universal_Integer); 3705 3706 ------------- 3707 -- Version -- 3708 ------------- 3709 3710 when Attribute_Version => 3711 Check_E0; 3712 Check_Program_Unit; 3713 Set_Etype (N, RTE (RE_Version_String)); 3714 3715 ------------------ 3716 -- Wchar_T_Size -- 3717 ------------------ 3718 3719 when Attribute_Wchar_T_Size => 3720 Standard_Attribute (Interfaces_Wchar_T_Size); 3721 3722 ---------------- 3723 -- Wide_Image -- 3724 ---------------- 3725 3726 when Attribute_Wide_Image => Wide_Image : 3727 begin 3728 Check_Scalar_Type; 3729 Set_Etype (N, Standard_Wide_String); 3730 Check_E1; 3731 Resolve (E1, P_Base_Type); 3732 Validate_Non_Static_Attribute_Function_Call; 3733 end Wide_Image; 3734 3735 ---------------- 3736 -- Wide_Value -- 3737 ---------------- 3738 3739 when Attribute_Wide_Value => Wide_Value : 3740 begin 3741 Check_E1; 3742 Check_Scalar_Type; 3743 3744 -- Set Etype before resolving expression because expansion 3745 -- of expression may require enclosing type. 3746 3747 Set_Etype (N, P_Type); 3748 Validate_Non_Static_Attribute_Function_Call; 3749 end Wide_Value; 3750 3751 ---------------- 3752 -- Wide_Width -- 3753 ---------------- 3754 3755 when Attribute_Wide_Width => 3756 Check_E0; 3757 Check_Scalar_Type; 3758 Set_Etype (N, Universal_Integer); 3759 3760 ----------- 3761 -- Width -- 3762 ----------- 3763 3764 when Attribute_Width => 3765 Check_E0; 3766 Check_Scalar_Type; 3767 Set_Etype (N, Universal_Integer); 3768 3769 --------------- 3770 -- Word_Size -- 3771 --------------- 3772 3773 when Attribute_Word_Size => 3774 Standard_Attribute (System_Word_Size); 3775 3776 ----------- 3777 -- Write -- 3778 ----------- 3779 3780 when Attribute_Write => 3781 Check_E2; 3782 Check_Stream_Attribute (TSS_Stream_Write); 3783 Set_Etype (N, Standard_Void_Type); 3784 Resolve (N, Standard_Void_Type); 3785 3786 end case; 3787 3788 -- All errors raise Bad_Attribute, so that we get out before any further 3789 -- damage occurs when an error is detected (for example, if we check for 3790 -- one attribute expression, and the check succeeds, we want to be able 3791 -- to proceed securely assuming that an expression is in fact present. 3792 3793 exception 3794 when Bad_Attribute => 3795 Set_Etype (N, Any_Type); 3796 return; 3797 3798 end Analyze_Attribute; 3799 3800 -------------------- 3801 -- Eval_Attribute -- 3802 -------------------- 3803 3804 procedure Eval_Attribute (N : Node_Id) is 3805 Loc : constant Source_Ptr := Sloc (N); 3806 Aname : constant Name_Id := Attribute_Name (N); 3807 Id : constant Attribute_Id := Get_Attribute_Id (Aname); 3808 P : constant Node_Id := Prefix (N); 3809 3810 C_Type : constant Entity_Id := Etype (N); 3811 -- The type imposed by the context. 3812 3813 E1 : Node_Id; 3814 -- First expression, or Empty if none 3815 3816 E2 : Node_Id; 3817 -- Second expression, or Empty if none 3818 3819 P_Entity : Entity_Id; 3820 -- Entity denoted by prefix 3821 3822 P_Type : Entity_Id; 3823 -- The type of the prefix 3824 3825 P_Base_Type : Entity_Id; 3826 -- The base type of the prefix type 3827 3828 P_Root_Type : Entity_Id; 3829 -- The root type of the prefix type 3830 3831 Static : Boolean; 3832 -- True if the result is Static. This is set by the general processing 3833 -- to true if the prefix is static, and all expressions are static. It 3834 -- can be reset as processing continues for particular attributes 3835 3836 Lo_Bound, Hi_Bound : Node_Id; 3837 -- Expressions for low and high bounds of type or array index referenced 3838 -- by First, Last, or Length attribute for array, set by Set_Bounds. 3839 3840 CE_Node : Node_Id; 3841 -- Constraint error node used if we have an attribute reference has 3842 -- an argument that raises a constraint error. In this case we replace 3843 -- the attribute with a raise constraint_error node. This is important 3844 -- processing, since otherwise gigi might see an attribute which it is 3845 -- unprepared to deal with. 3846 3847 function Aft_Value return Nat; 3848 -- Computes Aft value for current attribute prefix (used by Aft itself 3849 -- and also by Width for computing the Width of a fixed point type). 3850 3851 procedure Check_Expressions; 3852 -- In case where the attribute is not foldable, the expressions, if 3853 -- any, of the attribute, are in a non-static context. This procedure 3854 -- performs the required additional checks. 3855 3856 function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean; 3857 -- Determines if the given type has compile time known bounds. Note 3858 -- that we enter the case statement even in cases where the prefix 3859 -- type does NOT have known bounds, so it is important to guard any 3860 -- attempt to evaluate both bounds with a call to this function. 3861 3862 procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint); 3863 -- This procedure is called when the attribute N has a non-static 3864 -- but compile time known value given by Val. It includes the 3865 -- necessary checks for out of range values. 3866 3867 procedure Float_Attribute_Universal_Integer 3868 (IEEES_Val : Int; 3869 IEEEL_Val : Int; 3870 IEEEX_Val : Int; 3871 VAXFF_Val : Int; 3872 VAXDF_Val : Int; 3873 VAXGF_Val : Int; 3874 AAMPS_Val : Int; 3875 AAMPL_Val : Int); 3876 -- This procedure evaluates a float attribute with no arguments that 3877 -- returns a universal integer result. The parameters give the values 3878 -- for the possible floating-point root types. See ttypef for details. 3879 -- The prefix type is a float type (and is thus not a generic type). 3880 3881 procedure Float_Attribute_Universal_Real 3882 (IEEES_Val : String; 3883 IEEEL_Val : String; 3884 IEEEX_Val : String; 3885 VAXFF_Val : String; 3886 VAXDF_Val : String; 3887 VAXGF_Val : String; 3888 AAMPS_Val : String; 3889 AAMPL_Val : String); 3890 -- This procedure evaluates a float attribute with no arguments that 3891 -- returns a universal real result. The parameters give the values 3892 -- required for the possible floating-point root types in string 3893 -- format as real literals with a possible leading minus sign. 3894 -- The prefix type is a float type (and is thus not a generic type). 3895 3896 function Fore_Value return Nat; 3897 -- Computes the Fore value for the current attribute prefix, which is 3898 -- known to be a static fixed-point type. Used by Fore and Width. 3899 3900 function Mantissa return Uint; 3901 -- Returns the Mantissa value for the prefix type 3902 3903 procedure Set_Bounds; 3904 -- Used for First, Last and Length attributes applied to an array or 3905 -- array subtype. Sets the variables Lo_Bound and Hi_Bound to the low 3906 -- and high bound expressions for the index referenced by the attribute 3907 -- designator (i.e. the first index if no expression is present, and 3908 -- the N'th index if the value N is present as an expression). Also 3909 -- used for First and Last of scalar types. Static is reset to False 3910 -- if the type or index type is not statically constrained. 3911 3912 --------------- 3913 -- Aft_Value -- 3914 --------------- 3915 3916 function Aft_Value return Nat is 3917 Result : Nat; 3918 Delta_Val : Ureal; 3919 3920 begin 3921 Result := 1; 3922 Delta_Val := Delta_Value (P_Type); 3923 3924 while Delta_Val < Ureal_Tenth loop 3925 Delta_Val := Delta_Val * Ureal_10; 3926 Result := Result + 1; 3927 end loop; 3928 3929 return Result; 3930 end Aft_Value; 3931 3932 ----------------------- 3933 -- Check_Expressions -- 3934 ----------------------- 3935 3936 procedure Check_Expressions is 3937 E : Node_Id := E1; 3938 3939 begin 3940 while Present (E) loop 3941 Check_Non_Static_Context (E); 3942 Next (E); 3943 end loop; 3944 end Check_Expressions; 3945 3946 ---------------------------------- 3947 -- Compile_Time_Known_Attribute -- 3948 ---------------------------------- 3949 3950 procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint) is 3951 T : constant Entity_Id := Etype (N); 3952 3953 begin 3954 Fold_Uint (N, Val, False); 3955 3956 -- Check that result is in bounds of the type if it is static 3957 3958 if Is_In_Range (N, T) then 3959 null; 3960 3961 elsif Is_Out_Of_Range (N, T) then 3962 Apply_Compile_Time_Constraint_Error 3963 (N, "value not in range of}?", CE_Range_Check_Failed); 3964 3965 elsif not Range_Checks_Suppressed (T) then 3966 Enable_Range_Check (N); 3967 3968 else 3969 Set_Do_Range_Check (N, False); 3970 end if; 3971 end Compile_Time_Known_Attribute; 3972 3973 ------------------------------- 3974 -- Compile_Time_Known_Bounds -- 3975 ------------------------------- 3976 3977 function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean is 3978 begin 3979 return 3980 Compile_Time_Known_Value (Type_Low_Bound (Typ)) 3981 and then 3982 Compile_Time_Known_Value (Type_High_Bound (Typ)); 3983 end Compile_Time_Known_Bounds; 3984 3985 --------------------------------------- 3986 -- Float_Attribute_Universal_Integer -- 3987 --------------------------------------- 3988 3989 procedure Float_Attribute_Universal_Integer 3990 (IEEES_Val : Int; 3991 IEEEL_Val : Int; 3992 IEEEX_Val : Int; 3993 VAXFF_Val : Int; 3994 VAXDF_Val : Int; 3995 VAXGF_Val : Int; 3996 AAMPS_Val : Int; 3997 AAMPL_Val : Int) 3998 is 3999 Val : Int; 4000 Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type)); 4001 4002 begin 4003 if Vax_Float (P_Base_Type) then 4004 if Digs = VAXFF_Digits then 4005 Val := VAXFF_Val; 4006 elsif Digs = VAXDF_Digits then 4007 Val := VAXDF_Val; 4008 else pragma Assert (Digs = VAXGF_Digits); 4009 Val := VAXGF_Val; 4010 end if; 4011 4012 elsif Is_AAMP_Float (P_Base_Type) then 4013 if Digs = AAMPS_Digits then 4014 Val := AAMPS_Val; 4015 else pragma Assert (Digs = AAMPL_Digits); 4016 Val := AAMPL_Val; 4017 end if; 4018 4019 else 4020 if Digs = IEEES_Digits then 4021 Val := IEEES_Val; 4022 elsif Digs = IEEEL_Digits then 4023 Val := IEEEL_Val; 4024 else pragma Assert (Digs = IEEEX_Digits); 4025 Val := IEEEX_Val; 4026 end if; 4027 end if; 4028 4029 Fold_Uint (N, UI_From_Int (Val), True); 4030 end Float_Attribute_Universal_Integer; 4031 4032 ------------------------------------ 4033 -- Float_Attribute_Universal_Real -- 4034 ------------------------------------ 4035 4036 procedure Float_Attribute_Universal_Real 4037 (IEEES_Val : String; 4038 IEEEL_Val : String; 4039 IEEEX_Val : String; 4040 VAXFF_Val : String; 4041 VAXDF_Val : String; 4042 VAXGF_Val : String; 4043 AAMPS_Val : String; 4044 AAMPL_Val : String) 4045 is 4046 Val : Node_Id; 4047 Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type)); 4048 4049 begin 4050 if Vax_Float (P_Base_Type) then 4051 if Digs = VAXFF_Digits then 4052 Val := Real_Convert (VAXFF_Val); 4053 elsif Digs = VAXDF_Digits then 4054 Val := Real_Convert (VAXDF_Val); 4055 else pragma Assert (Digs = VAXGF_Digits); 4056 Val := Real_Convert (VAXGF_Val); 4057 end if; 4058 4059 elsif Is_AAMP_Float (P_Base_Type) then 4060 if Digs = AAMPS_Digits then 4061 Val := Real_Convert (AAMPS_Val); 4062 else pragma Assert (Digs = AAMPL_Digits); 4063 Val := Real_Convert (AAMPL_Val); 4064 end if; 4065 4066 else 4067 if Digs = IEEES_Digits then 4068 Val := Real_Convert (IEEES_Val); 4069 elsif Digs = IEEEL_Digits then 4070 Val := Real_Convert (IEEEL_Val); 4071 else pragma Assert (Digs = IEEEX_Digits); 4072 Val := Real_Convert (IEEEX_Val); 4073 end if; 4074 end if; 4075 4076 Set_Sloc (Val, Loc); 4077 Rewrite (N, Val); 4078 Set_Is_Static_Expression (N, Static); 4079 Analyze_And_Resolve (N, C_Type); 4080 end Float_Attribute_Universal_Real; 4081 4082 ---------------- 4083 -- Fore_Value -- 4084 ---------------- 4085 4086 -- Note that the Fore calculation is based on the actual values 4087 -- of the bounds, and does not take into account possible rounding. 4088 4089 function Fore_Value return Nat is 4090 Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type)); 4091 Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type)); 4092 Small : constant Ureal := Small_Value (P_Type); 4093 Lo_Real : constant Ureal := Lo * Small; 4094 Hi_Real : constant Ureal := Hi * Small; 4095 T : Ureal; 4096 R : Nat; 4097 4098 begin 4099 -- Bounds are given in terms of small units, so first compute 4100 -- proper values as reals. 4101 4102 T := UR_Max (abs Lo_Real, abs Hi_Real); 4103 R := 2; 4104 4105 -- Loop to compute proper value if more than one digit required 4106 4107 while T >= Ureal_10 loop 4108 R := R + 1; 4109 T := T / Ureal_10; 4110 end loop; 4111 4112 return R; 4113 end Fore_Value; 4114 4115 -------------- 4116 -- Mantissa -- 4117 -------------- 4118 4119 -- Table of mantissa values accessed by function Computed using 4120 -- the relation: 4121 4122 -- T'Mantissa = integer next above (D * log(10)/log(2)) + 1) 4123 4124 -- where D is T'Digits (RM83 3.5.7) 4125 4126 Mantissa_Value : constant array (Nat range 1 .. 40) of Nat := ( 4127 1 => 5, 4128 2 => 8, 4129 3 => 11, 4130 4 => 15, 4131 5 => 18, 4132 6 => 21, 4133 7 => 25, 4134 8 => 28, 4135 9 => 31, 4136 10 => 35, 4137 11 => 38, 4138 12 => 41, 4139 13 => 45, 4140 14 => 48, 4141 15 => 51, 4142 16 => 55, 4143 17 => 58, 4144 18 => 61, 4145 19 => 65, 4146 20 => 68, 4147 21 => 71, 4148 22 => 75, 4149 23 => 78, 4150 24 => 81, 4151 25 => 85, 4152 26 => 88, 4153 27 => 91, 4154 28 => 95, 4155 29 => 98, 4156 30 => 101, 4157 31 => 104, 4158 32 => 108, 4159 33 => 111, 4160 34 => 114, 4161 35 => 118, 4162 36 => 121, 4163 37 => 124, 4164 38 => 128, 4165 39 => 131, 4166 40 => 134); 4167 4168 function Mantissa return Uint is 4169 begin 4170 return 4171 UI_From_Int (Mantissa_Value (UI_To_Int (Digits_Value (P_Type)))); 4172 end Mantissa; 4173 4174 ---------------- 4175 -- Set_Bounds -- 4176 ---------------- 4177 4178 procedure Set_Bounds is 4179 Ndim : Nat; 4180 Indx : Node_Id; 4181 Ityp : Entity_Id; 4182 4183 begin 4184 -- For a string literal subtype, we have to construct the bounds. 4185 -- Valid Ada code never applies attributes to string literals, but 4186 -- it is convenient to allow the expander to generate attribute 4187 -- references of this type (e.g. First and Last applied to a string 4188 -- literal). 4189 4190 -- Note that the whole point of the E_String_Literal_Subtype is to 4191 -- avoid this construction of bounds, but the cases in which we 4192 -- have to materialize them are rare enough that we don't worry! 4193 4194 -- The low bound is simply the low bound of the base type. The 4195 -- high bound is computed from the length of the string and this 4196 -- low bound. 4197 4198 if Ekind (P_Type) = E_String_Literal_Subtype then 4199 Ityp := Etype (First_Index (Base_Type (P_Type))); 4200 Lo_Bound := Type_Low_Bound (Ityp); 4201 4202 Hi_Bound := 4203 Make_Integer_Literal (Sloc (P), 4204 Intval => 4205 Expr_Value (Lo_Bound) + String_Literal_Length (P_Type) - 1); 4206 4207 Set_Parent (Hi_Bound, P); 4208 Analyze_And_Resolve (Hi_Bound, Etype (Lo_Bound)); 4209 return; 4210 4211 -- For non-array case, just get bounds of scalar type 4212 4213 elsif Is_Scalar_Type (P_Type) then 4214 Ityp := P_Type; 4215 4216 -- For a fixed-point type, we must freeze to get the attributes 4217 -- of the fixed-point type set now so we can reference them. 4218 4219 if Is_Fixed_Point_Type (P_Type) 4220 and then not Is_Frozen (Base_Type (P_Type)) 4221 and then Compile_Time_Known_Value (Type_Low_Bound (P_Type)) 4222 and then Compile_Time_Known_Value (Type_High_Bound (P_Type)) 4223 then 4224 Freeze_Fixed_Point_Type (Base_Type (P_Type)); 4225 end if; 4226 4227 -- For array case, get type of proper index 4228 4229 else 4230 if No (E1) then 4231 Ndim := 1; 4232 else 4233 Ndim := UI_To_Int (Expr_Value (E1)); 4234 end if; 4235 4236 Indx := First_Index (P_Type); 4237 for J in 1 .. Ndim - 1 loop 4238 Next_Index (Indx); 4239 end loop; 4240 4241 -- If no index type, get out (some other error occurred, and 4242 -- we don't have enough information to complete the job!) 4243 4244 if No (Indx) then 4245 Lo_Bound := Error; 4246 Hi_Bound := Error; 4247 return; 4248 end if; 4249 4250 Ityp := Etype (Indx); 4251 end if; 4252 4253 -- A discrete range in an index constraint is allowed to be a 4254 -- subtype indication. This is syntactically a pain, but should 4255 -- not propagate to the entity for the corresponding index subtype. 4256 -- After checking that the subtype indication is legal, the range 4257 -- of the subtype indication should be transfered to the entity. 4258 -- The attributes for the bounds should remain the simple retrievals 4259 -- that they are now. 4260 4261 Lo_Bound := Type_Low_Bound (Ityp); 4262 Hi_Bound := Type_High_Bound (Ityp); 4263 4264 if not Is_Static_Subtype (Ityp) then 4265 Static := False; 4266 end if; 4267 end Set_Bounds; 4268 4269 -- Start of processing for Eval_Attribute 4270 4271 begin 4272 -- Acquire first two expressions (at the moment, no attributes 4273 -- take more than two expressions in any case). 4274 4275 if Present (Expressions (N)) then 4276 E1 := First (Expressions (N)); 4277 E2 := Next (E1); 4278 else 4279 E1 := Empty; 4280 E2 := Empty; 4281 end if; 4282 4283 -- Special processing for cases where the prefix is an object. For 4284 -- this purpose, a string literal counts as an object (attributes 4285 -- of string literals can only appear in generated code). 4286 4287 if Is_Object_Reference (P) or else Nkind (P) = N_String_Literal then 4288 4289 -- For Component_Size, the prefix is an array object, and we apply 4290 -- the attribute to the type of the object. This is allowed for 4291 -- both unconstrained and constrained arrays, since the bounds 4292 -- have no influence on the value of this attribute. 4293 4294 if Id = Attribute_Component_Size then 4295 P_Entity := Etype (P); 4296 4297 -- For First and Last, the prefix is an array object, and we apply 4298 -- the attribute to the type of the array, but we need a constrained 4299 -- type for this, so we use the actual subtype if available. 4300 4301 elsif Id = Attribute_First 4302 or else 4303 Id = Attribute_Last 4304 or else 4305 Id = Attribute_Length 4306 then 4307 declare 4308 AS : constant Entity_Id := Get_Actual_Subtype_If_Available (P); 4309 4310 begin 4311 if Present (AS) and then Is_Constrained (AS) then 4312 P_Entity := AS; 4313 4314 -- If we have an unconstrained type, cannot fold 4315 4316 else 4317 Check_Expressions; 4318 return; 4319 end if; 4320 end; 4321 4322 -- For Size, give size of object if available, otherwise we 4323 -- cannot fold Size. 4324 4325 elsif Id = Attribute_Size then 4326 if Is_Entity_Name (P) 4327 and then Known_Esize (Entity (P)) 4328 then 4329 Compile_Time_Known_Attribute (N, Esize (Entity (P))); 4330 return; 4331 4332 else 4333 Check_Expressions; 4334 return; 4335 end if; 4336 4337 -- For Alignment, give size of object if available, otherwise we 4338 -- cannot fold Alignment. 4339 4340 elsif Id = Attribute_Alignment then 4341 if Is_Entity_Name (P) 4342 and then Known_Alignment (Entity (P)) 4343 then 4344 Fold_Uint (N, Alignment (Entity (P)), False); 4345 return; 4346 4347 else 4348 Check_Expressions; 4349 return; 4350 end if; 4351 4352 -- No other attributes for objects are folded 4353 4354 else 4355 Check_Expressions; 4356 return; 4357 end if; 4358 4359 -- Cases where P is not an object. Cannot do anything if P is 4360 -- not the name of an entity. 4361 4362 elsif not Is_Entity_Name (P) then 4363 Check_Expressions; 4364 return; 4365 4366 -- Otherwise get prefix entity 4367 4368 else 4369 P_Entity := Entity (P); 4370 end if; 4371 4372 -- At this stage P_Entity is the entity to which the attribute 4373 -- is to be applied. This is usually simply the entity of the 4374 -- prefix, except in some cases of attributes for objects, where 4375 -- as described above, we apply the attribute to the object type. 4376 4377 -- First foldable possibility is a scalar or array type (RM 4.9(7)) 4378 -- that is not generic (generic types are eliminated by RM 4.9(25)). 4379 -- Note we allow non-static non-generic types at this stage as further 4380 -- described below. 4381 4382 if Is_Type (P_Entity) 4383 and then (Is_Scalar_Type (P_Entity) or Is_Array_Type (P_Entity)) 4384 and then (not Is_Generic_Type (P_Entity)) 4385 then 4386 P_Type := P_Entity; 4387 4388 -- Second foldable possibility is an array object (RM 4.9(8)) 4389 4390 elsif (Ekind (P_Entity) = E_Variable 4391 or else 4392 Ekind (P_Entity) = E_Constant) 4393 and then Is_Array_Type (Etype (P_Entity)) 4394 and then (not Is_Generic_Type (Etype (P_Entity))) 4395 then 4396 P_Type := Etype (P_Entity); 4397 4398 -- If the entity is an array constant with an unconstrained 4399 -- nominal subtype then get the type from the initial value. 4400 -- If the value has been expanded into assignments, the expression 4401 -- is not present and the attribute reference remains dynamic. 4402 -- We could do better here and retrieve the type ??? 4403 4404 if Ekind (P_Entity) = E_Constant 4405 and then not Is_Constrained (P_Type) 4406 then 4407 if No (Constant_Value (P_Entity)) then 4408 return; 4409 else 4410 P_Type := Etype (Constant_Value (P_Entity)); 4411 end if; 4412 end if; 4413 4414 -- Definite must be folded if the prefix is not a generic type, 4415 -- that is to say if we are within an instantiation. Same processing 4416 -- applies to the GNAT attributes Has_Discriminants, Type_Class, 4417 -- and Unconstrained_Array. 4418 4419 elsif (Id = Attribute_Definite 4420 or else 4421 Id = Attribute_Has_Discriminants 4422 or else 4423 Id = Attribute_Type_Class 4424 or else 4425 Id = Attribute_Unconstrained_Array) 4426 and then not Is_Generic_Type (P_Entity) 4427 then 4428 P_Type := P_Entity; 4429 4430 -- We can fold 'Size applied to a type if the size is known 4431 -- (as happens for a size from an attribute definition clause). 4432 -- At this stage, this can happen only for types (e.g. record 4433 -- types) for which the size is always non-static. We exclude 4434 -- generic types from consideration (since they have bogus 4435 -- sizes set within templates). 4436 4437 elsif Id = Attribute_Size 4438 and then Is_Type (P_Entity) 4439 and then (not Is_Generic_Type (P_Entity)) 4440 and then Known_Static_RM_Size (P_Entity) 4441 then 4442 Compile_Time_Known_Attribute (N, RM_Size (P_Entity)); 4443 return; 4444 4445 -- We can fold 'Alignment applied to a type if the alignment is known 4446 -- (as happens for an alignment from an attribute definition clause). 4447 -- At this stage, this can happen only for types (e.g. record 4448 -- types) for which the size is always non-static. We exclude 4449 -- generic types from consideration (since they have bogus 4450 -- sizes set within templates). 4451 4452 elsif Id = Attribute_Alignment 4453 and then Is_Type (P_Entity) 4454 and then (not Is_Generic_Type (P_Entity)) 4455 and then Known_Alignment (P_Entity) 4456 then 4457 Compile_Time_Known_Attribute (N, Alignment (P_Entity)); 4458 return; 4459 4460 -- If this is an access attribute that is known to fail accessibility 4461 -- check, rewrite accordingly. 4462 4463 elsif Attribute_Name (N) = Name_Access 4464 and then Raises_Constraint_Error (N) 4465 then 4466 Rewrite (N, 4467 Make_Raise_Program_Error (Loc, 4468 Reason => PE_Accessibility_Check_Failed)); 4469 Set_Etype (N, C_Type); 4470 return; 4471 4472 -- No other cases are foldable (they certainly aren't static, and at 4473 -- the moment we don't try to fold any cases other than these three). 4474 4475 else 4476 Check_Expressions; 4477 return; 4478 end if; 4479 4480 -- If either attribute or the prefix is Any_Type, then propagate 4481 -- Any_Type to the result and don't do anything else at all. 4482 4483 if P_Type = Any_Type 4484 or else (Present (E1) and then Etype (E1) = Any_Type) 4485 or else (Present (E2) and then Etype (E2) = Any_Type) 4486 then 4487 Set_Etype (N, Any_Type); 4488 return; 4489 end if; 4490 4491 -- Scalar subtype case. We have not yet enforced the static requirement 4492 -- of (RM 4.9(7)) and we don't intend to just yet, since there are cases 4493 -- of non-static attribute references (e.g. S'Digits for a non-static 4494 -- floating-point type, which we can compute at compile time). 4495 4496 -- Note: this folding of non-static attributes is not simply a case of 4497 -- optimization. For many of the attributes affected, Gigi cannot handle 4498 -- the attribute and depends on the front end having folded them away. 4499 4500 -- Note: although we don't require staticness at this stage, we do set 4501 -- the Static variable to record the staticness, for easy reference by 4502 -- those attributes where it matters (e.g. Succ and Pred), and also to 4503 -- be used to ensure that non-static folded things are not marked as 4504 -- being static (a check that is done right at the end). 4505 4506 P_Root_Type := Root_Type (P_Type); 4507 P_Base_Type := Base_Type (P_Type); 4508 4509 -- If the root type or base type is generic, then we cannot fold. This 4510 -- test is needed because subtypes of generic types are not always 4511 -- marked as being generic themselves (which seems odd???) 4512 4513 if Is_Generic_Type (P_Root_Type) 4514 or else Is_Generic_Type (P_Base_Type) 4515 then 4516 return; 4517 end if; 4518 4519 if Is_Scalar_Type (P_Type) then 4520 Static := Is_OK_Static_Subtype (P_Type); 4521 4522 -- Array case. We enforce the constrained requirement of (RM 4.9(7-8)) 4523 -- since we can't do anything with unconstrained arrays. In addition, 4524 -- only the First, Last and Length attributes are possibly static. 4525 -- In addition Component_Size is possibly foldable, even though it 4526 -- can never be static. 4527 4528 -- Definite, Has_Discriminants, Type_Class and Unconstrained_Array are 4529 -- again exceptions, because they apply as well to unconstrained types. 4530 4531 elsif Id = Attribute_Definite 4532 or else 4533 Id = Attribute_Has_Discriminants 4534 or else 4535 Id = Attribute_Type_Class 4536 or else 4537 Id = Attribute_Unconstrained_Array 4538 then 4539 Static := False; 4540 4541 else 4542 if not Is_Constrained (P_Type) 4543 or else (Id /= Attribute_Component_Size and then 4544 Id /= Attribute_First and then 4545 Id /= Attribute_Last and then 4546 Id /= Attribute_Length) 4547 then 4548 Check_Expressions; 4549 return; 4550 end if; 4551 4552 -- The rules in (RM 4.9(7,8)) require a static array, but as in the 4553 -- scalar case, we hold off on enforcing staticness, since there are 4554 -- cases which we can fold at compile time even though they are not 4555 -- static (e.g. 'Length applied to a static index, even though other 4556 -- non-static indexes make the array type non-static). This is only 4557 -- an optimization, but it falls out essentially free, so why not. 4558 -- Again we compute the variable Static for easy reference later 4559 -- (note that no array attributes are static in Ada 83). 4560 4561 Static := Ada_95; 4562 4563 declare 4564 N : Node_Id; 4565 4566 begin 4567 N := First_Index (P_Type); 4568 while Present (N) loop 4569 Static := Static and then Is_Static_Subtype (Etype (N)); 4570 4571 -- If however the index type is generic, attributes cannot 4572 -- be folded. 4573 4574 if Is_Generic_Type (Etype (N)) 4575 and then Id /= Attribute_Component_Size 4576 then 4577 return; 4578 end if; 4579 4580 Next_Index (N); 4581 end loop; 4582 end; 4583 end if; 4584 4585 -- Check any expressions that are present. Note that these expressions, 4586 -- depending on the particular attribute type, are either part of the 4587 -- attribute designator, or they are arguments in a case where the 4588 -- attribute reference returns a function. In the latter case, the 4589 -- rule in (RM 4.9(22)) applies and in particular requires the type 4590 -- of the expressions to be scalar in order for the attribute to be 4591 -- considered to be static. 4592 4593 declare 4594 E : Node_Id; 4595 4596 begin 4597 E := E1; 4598 while Present (E) loop 4599 4600 -- If expression is not static, then the attribute reference 4601 -- result certainly cannot be static. 4602 4603 if not Is_Static_Expression (E) then 4604 Static := False; 4605 end if; 4606 4607 -- If the result is not known at compile time, or is not of 4608 -- a scalar type, then the result is definitely not static, 4609 -- so we can quit now. 4610 4611 if not Compile_Time_Known_Value (E) 4612 or else not Is_Scalar_Type (Etype (E)) 4613 then 4614 -- An odd special case, if this is a Pos attribute, this 4615 -- is where we need to apply a range check since it does 4616 -- not get done anywhere else. 4617 4618 if Id = Attribute_Pos then 4619 if Is_Integer_Type (Etype (E)) then 4620 Apply_Range_Check (E, Etype (N)); 4621 end if; 4622 end if; 4623 4624 Check_Expressions; 4625 return; 4626 4627 -- If the expression raises a constraint error, then so does 4628 -- the attribute reference. We keep going in this case because 4629 -- we are still interested in whether the attribute reference 4630 -- is static even if it is not static. 4631 4632 elsif Raises_Constraint_Error (E) then 4633 Set_Raises_Constraint_Error (N); 4634 end if; 4635 4636 Next (E); 4637 end loop; 4638 4639 if Raises_Constraint_Error (Prefix (N)) then 4640 return; 4641 end if; 4642 end; 4643 4644 -- Deal with the case of a static attribute reference that raises 4645 -- constraint error. The Raises_Constraint_Error flag will already 4646 -- have been set, and the Static flag shows whether the attribute 4647 -- reference is static. In any case we certainly can't fold such an 4648 -- attribute reference. 4649 4650 -- Note that the rewriting of the attribute node with the constraint 4651 -- error node is essential in this case, because otherwise Gigi might 4652 -- blow up on one of the attributes it never expects to see. 4653 4654 -- The constraint_error node must have the type imposed by the context, 4655 -- to avoid spurious errors in the enclosing expression. 4656 4657 if Raises_Constraint_Error (N) then 4658 CE_Node := 4659 Make_Raise_Constraint_Error (Sloc (N), 4660 Reason => CE_Range_Check_Failed); 4661 Set_Etype (CE_Node, Etype (N)); 4662 Set_Raises_Constraint_Error (CE_Node); 4663 Check_Expressions; 4664 Rewrite (N, Relocate_Node (CE_Node)); 4665 Set_Is_Static_Expression (N, Static); 4666 return; 4667 end if; 4668 4669 -- At this point we have a potentially foldable attribute reference. 4670 -- If Static is set, then the attribute reference definitely obeys 4671 -- the requirements in (RM 4.9(7,8,22)), and it definitely can be 4672 -- folded. If Static is not set, then the attribute may or may not 4673 -- be foldable, and the individual attribute processing routines 4674 -- test Static as required in cases where it makes a difference. 4675 4676 -- In the case where Static is not set, we do know that all the 4677 -- expressions present are at least known at compile time (we 4678 -- assumed above that if this was not the case, then there was 4679 -- no hope of static evaluation). However, we did not require 4680 -- that the bounds of the prefix type be compile time known, 4681 -- let alone static). That's because there are many attributes 4682 -- that can be computed at compile time on non-static subtypes, 4683 -- even though such references are not static expressions. 4684 4685 case Id is 4686 4687 -------------- 4688 -- Adjacent -- 4689 -------------- 4690 4691 when Attribute_Adjacent => 4692 Fold_Ureal (N, 4693 Eval_Fat.Adjacent 4694 (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static); 4695 4696 --------- 4697 -- Aft -- 4698 --------- 4699 4700 when Attribute_Aft => 4701 Fold_Uint (N, UI_From_Int (Aft_Value), True); 4702 4703 --------------- 4704 -- Alignment -- 4705 --------------- 4706 4707 when Attribute_Alignment => Alignment_Block : declare 4708 P_TypeA : constant Entity_Id := Underlying_Type (P_Type); 4709 4710 begin 4711 -- Fold if alignment is set and not otherwise 4712 4713 if Known_Alignment (P_TypeA) then 4714 Fold_Uint (N, Alignment (P_TypeA), Is_Discrete_Type (P_TypeA)); 4715 end if; 4716 end Alignment_Block; 4717 4718 --------------- 4719 -- AST_Entry -- 4720 --------------- 4721 4722 -- Can only be folded in No_Ast_Handler case 4723 4724 when Attribute_AST_Entry => 4725 if not Is_AST_Entry (P_Entity) then 4726 Rewrite (N, 4727 New_Occurrence_Of (RTE (RE_No_AST_Handler), Loc)); 4728 else 4729 null; 4730 end if; 4731 4732 --------- 4733 -- Bit -- 4734 --------- 4735 4736 -- Bit can never be folded 4737 4738 when Attribute_Bit => 4739 null; 4740 4741 ------------------ 4742 -- Body_Version -- 4743 ------------------ 4744 4745 -- Body_version can never be static 4746 4747 when Attribute_Body_Version => 4748 null; 4749 4750 ------------- 4751 -- Ceiling -- 4752 ------------- 4753 4754 when Attribute_Ceiling => 4755 Fold_Ureal (N, 4756 Eval_Fat.Ceiling (P_Root_Type, Expr_Value_R (E1)), Static); 4757 4758 -------------------- 4759 -- Component_Size -- 4760 -------------------- 4761 4762 when Attribute_Component_Size => 4763 if Known_Static_Component_Size (P_Type) then 4764 Fold_Uint (N, Component_Size (P_Type), False); 4765 end if; 4766 4767 ------------- 4768 -- Compose -- 4769 ------------- 4770 4771 when Attribute_Compose => 4772 Fold_Ureal (N, 4773 Eval_Fat.Compose 4774 (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)), 4775 Static); 4776 4777 ----------------- 4778 -- Constrained -- 4779 ----------------- 4780 4781 -- Constrained is never folded for now, there may be cases that 4782 -- could be handled at compile time. to be looked at later. 4783 4784 when Attribute_Constrained => 4785 null; 4786 4787 --------------- 4788 -- Copy_Sign -- 4789 --------------- 4790 4791 when Attribute_Copy_Sign => 4792 Fold_Ureal (N, 4793 Eval_Fat.Copy_Sign 4794 (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static); 4795 4796 ----------- 4797 -- Delta -- 4798 ----------- 4799 4800 when Attribute_Delta => 4801 Fold_Ureal (N, Delta_Value (P_Type), True); 4802 4803 -------------- 4804 -- Definite -- 4805 -------------- 4806 4807 when Attribute_Definite => 4808 declare 4809 Result : Node_Id; 4810 4811 begin 4812 if Is_Indefinite_Subtype (P_Entity) then 4813 Result := New_Occurrence_Of (Standard_False, Loc); 4814 else 4815 Result := New_Occurrence_Of (Standard_True, Loc); 4816 end if; 4817 4818 Rewrite (N, Result); 4819 Analyze_And_Resolve (N, Standard_Boolean); 4820 end; 4821 4822 ------------ 4823 -- Denorm -- 4824 ------------ 4825 4826 when Attribute_Denorm => 4827 Fold_Uint 4828 (N, UI_From_Int (Boolean'Pos (Denorm_On_Target)), True); 4829 4830 ------------ 4831 -- Digits -- 4832 ------------ 4833 4834 when Attribute_Digits => 4835 Fold_Uint (N, Digits_Value (P_Type), True); 4836 4837 ---------- 4838 -- Emax -- 4839 ---------- 4840 4841 when Attribute_Emax => 4842 4843 -- Ada 83 attribute is defined as (RM83 3.5.8) 4844 4845 -- T'Emax = 4 * T'Mantissa 4846 4847 Fold_Uint (N, 4 * Mantissa, True); 4848 4849 -------------- 4850 -- Enum_Rep -- 4851 -------------- 4852 4853 when Attribute_Enum_Rep => 4854 4855 -- For an enumeration type with a non-standard representation 4856 -- use the Enumeration_Rep field of the proper constant. Note 4857 -- that this would not work for types Character/Wide_Character, 4858 -- since no real entities are created for the enumeration 4859 -- literals, but that does not matter since these two types 4860 -- do not have non-standard representations anyway. 4861 4862 if Is_Enumeration_Type (P_Type) 4863 and then Has_Non_Standard_Rep (P_Type) 4864 then 4865 Fold_Uint (N, Enumeration_Rep (Expr_Value_E (E1)), Static); 4866 4867 -- For enumeration types with standard representations and all 4868 -- other cases (i.e. all integer and modular types), Enum_Rep 4869 -- is equivalent to Pos. 4870 4871 else 4872 Fold_Uint (N, Expr_Value (E1), Static); 4873 end if; 4874 4875 ------------- 4876 -- Epsilon -- 4877 ------------- 4878 4879 when Attribute_Epsilon => 4880 4881 -- Ada 83 attribute is defined as (RM83 3.5.8) 4882 4883 -- T'Epsilon = 2.0**(1 - T'Mantissa) 4884 4885 Fold_Ureal (N, Ureal_2 ** (1 - Mantissa), True); 4886 4887 -------------- 4888 -- Exponent -- 4889 -------------- 4890 4891 when Attribute_Exponent => 4892 Fold_Uint (N, 4893 Eval_Fat.Exponent (P_Root_Type, Expr_Value_R (E1)), Static); 4894 4895 ----------- 4896 -- First -- 4897 ----------- 4898 4899 when Attribute_First => First_Attr : 4900 begin 4901 Set_Bounds; 4902 4903 if Compile_Time_Known_Value (Lo_Bound) then 4904 if Is_Real_Type (P_Type) then 4905 Fold_Ureal (N, Expr_Value_R (Lo_Bound), Static); 4906 else 4907 Fold_Uint (N, Expr_Value (Lo_Bound), Static); 4908 end if; 4909 end if; 4910 end First_Attr; 4911 4912 ----------------- 4913 -- Fixed_Value -- 4914 ----------------- 4915 4916 when Attribute_Fixed_Value => 4917 null; 4918 4919 ----------- 4920 -- Floor -- 4921 ----------- 4922 4923 when Attribute_Floor => 4924 Fold_Ureal (N, 4925 Eval_Fat.Floor (P_Root_Type, Expr_Value_R (E1)), Static); 4926 4927 ---------- 4928 -- Fore -- 4929 ---------- 4930 4931 when Attribute_Fore => 4932 if Compile_Time_Known_Bounds (P_Type) then 4933 Fold_Uint (N, UI_From_Int (Fore_Value), Static); 4934 end if; 4935 4936 -------------- 4937 -- Fraction -- 4938 -------------- 4939 4940 when Attribute_Fraction => 4941 Fold_Ureal (N, 4942 Eval_Fat.Fraction (P_Root_Type, Expr_Value_R (E1)), Static); 4943 4944 ----------------------- 4945 -- Has_Discriminants -- 4946 ----------------------- 4947 4948 when Attribute_Has_Discriminants => 4949 declare 4950 Result : Node_Id; 4951 4952 begin 4953 if Has_Discriminants (P_Entity) then 4954 Result := New_Occurrence_Of (Standard_True, Loc); 4955 else 4956 Result := New_Occurrence_Of (Standard_False, Loc); 4957 end if; 4958 4959 Rewrite (N, Result); 4960 Analyze_And_Resolve (N, Standard_Boolean); 4961 end; 4962 4963 -------------- 4964 -- Identity -- 4965 -------------- 4966 4967 when Attribute_Identity => 4968 null; 4969 4970 ----------- 4971 -- Image -- 4972 ----------- 4973 4974 -- Image is a scalar attribute, but is never static, because it is 4975 -- not a static function (having a non-scalar argument (RM 4.9(22)) 4976 4977 when Attribute_Image => 4978 null; 4979 4980 --------- 4981 -- Img -- 4982 --------- 4983 4984 -- Img is a scalar attribute, but is never static, because it is 4985 -- not a static function (having a non-scalar argument (RM 4.9(22)) 4986 4987 when Attribute_Img => 4988 null; 4989 4990 ------------------- 4991 -- Integer_Value -- 4992 ------------------- 4993 4994 when Attribute_Integer_Value => 4995 null; 4996 4997 ----------- 4998 -- Large -- 4999 ----------- 5000 5001 when Attribute_Large => 5002 5003 -- For fixed-point, we use the identity: 5004 5005 -- T'Large = (2.0**T'Mantissa - 1.0) * T'Small 5006 5007 if Is_Fixed_Point_Type (P_Type) then 5008 Rewrite (N, 5009 Make_Op_Multiply (Loc, 5010 Left_Opnd => 5011 Make_Op_Subtract (Loc, 5012 Left_Opnd => 5013 Make_Op_Expon (Loc, 5014 Left_Opnd => 5015 Make_Real_Literal (Loc, Ureal_2), 5016 Right_Opnd => 5017 Make_Attribute_Reference (Loc, 5018 Prefix => P, 5019 Attribute_Name => Name_Mantissa)), 5020 Right_Opnd => Make_Real_Literal (Loc, Ureal_1)), 5021 5022 Right_Opnd => 5023 Make_Real_Literal (Loc, Small_Value (Entity (P))))); 5024 5025 Analyze_And_Resolve (N, C_Type); 5026 5027 -- Floating-point (Ada 83 compatibility) 5028 5029 else 5030 -- Ada 83 attribute is defined as (RM83 3.5.8) 5031 5032 -- T'Large = 2.0**T'Emax * (1.0 - 2.0**(-T'Mantissa)) 5033 5034 -- where 5035 5036 -- T'Emax = 4 * T'Mantissa 5037 5038 Fold_Ureal (N, 5039 Ureal_2 ** (4 * Mantissa) * (Ureal_1 - Ureal_2 ** (-Mantissa)), 5040 True); 5041 end if; 5042 5043 ---------- 5044 -- Last -- 5045 ---------- 5046 5047 when Attribute_Last => Last : 5048 begin 5049 Set_Bounds; 5050 5051 if Compile_Time_Known_Value (Hi_Bound) then 5052 if Is_Real_Type (P_Type) then 5053 Fold_Ureal (N, Expr_Value_R (Hi_Bound), Static); 5054 else 5055 Fold_Uint (N, Expr_Value (Hi_Bound), Static); 5056 end if; 5057 end if; 5058 end Last; 5059 5060 ------------------ 5061 -- Leading_Part -- 5062 ------------------ 5063 5064 when Attribute_Leading_Part => 5065 Fold_Ureal (N, 5066 Eval_Fat.Leading_Part 5067 (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)), Static); 5068 5069 ------------ 5070 -- Length -- 5071 ------------ 5072 5073 when Attribute_Length => Length : declare 5074 Ind : Node_Id; 5075 5076 begin 5077 -- In the case of a generic index type, the bounds may 5078 -- appear static but the computation is not meaningful, 5079 -- and may generate a spurious warning. 5080 5081 Ind := First_Index (P_Type); 5082 5083 while Present (Ind) loop 5084 if Is_Generic_Type (Etype (Ind)) then 5085 return; 5086 end if; 5087 5088 Next_Index (Ind); 5089 end loop; 5090 5091 Set_Bounds; 5092 5093 if Compile_Time_Known_Value (Lo_Bound) 5094 and then Compile_Time_Known_Value (Hi_Bound) 5095 then 5096 Fold_Uint (N, 5097 UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))), 5098 True); 5099 end if; 5100 end Length; 5101 5102 ------------- 5103 -- Machine -- 5104 ------------- 5105 5106 when Attribute_Machine => 5107 Fold_Ureal (N, 5108 Eval_Fat.Machine 5109 (P_Root_Type, Expr_Value_R (E1), Eval_Fat.Round, N), 5110 Static); 5111 5112 ------------------ 5113 -- Machine_Emax -- 5114 ------------------ 5115 5116 when Attribute_Machine_Emax => 5117 Float_Attribute_Universal_Integer ( 5118 IEEES_Machine_Emax, 5119 IEEEL_Machine_Emax, 5120 IEEEX_Machine_Emax, 5121 VAXFF_Machine_Emax, 5122 VAXDF_Machine_Emax, 5123 VAXGF_Machine_Emax, 5124 AAMPS_Machine_Emax, 5125 AAMPL_Machine_Emax); 5126 5127 ------------------ 5128 -- Machine_Emin -- 5129 ------------------ 5130 5131 when Attribute_Machine_Emin => 5132 Float_Attribute_Universal_Integer ( 5133 IEEES_Machine_Emin, 5134 IEEEL_Machine_Emin, 5135 IEEEX_Machine_Emin, 5136 VAXFF_Machine_Emin, 5137 VAXDF_Machine_Emin, 5138 VAXGF_Machine_Emin, 5139 AAMPS_Machine_Emin, 5140 AAMPL_Machine_Emin); 5141 5142 ---------------------- 5143 -- Machine_Mantissa -- 5144 ---------------------- 5145 5146 when Attribute_Machine_Mantissa => 5147 Float_Attribute_Universal_Integer ( 5148 IEEES_Machine_Mantissa, 5149 IEEEL_Machine_Mantissa, 5150 IEEEX_Machine_Mantissa, 5151 VAXFF_Machine_Mantissa, 5152 VAXDF_Machine_Mantissa, 5153 VAXGF_Machine_Mantissa, 5154 AAMPS_Machine_Mantissa, 5155 AAMPL_Machine_Mantissa); 5156 5157 ----------------------- 5158 -- Machine_Overflows -- 5159 ----------------------- 5160 5161 when Attribute_Machine_Overflows => 5162 5163 -- Always true for fixed-point 5164 5165 if Is_Fixed_Point_Type (P_Type) then 5166 Fold_Uint (N, True_Value, True); 5167 5168 -- Floating point case 5169 5170 else 5171 Fold_Uint (N, 5172 UI_From_Int (Boolean'Pos (Machine_Overflows_On_Target)), 5173 True); 5174 end if; 5175 5176 ------------------- 5177 -- Machine_Radix -- 5178 ------------------- 5179 5180 when Attribute_Machine_Radix => 5181 if Is_Fixed_Point_Type (P_Type) then 5182 if Is_Decimal_Fixed_Point_Type (P_Type) 5183 and then Machine_Radix_10 (P_Type) 5184 then 5185 Fold_Uint (N, Uint_10, True); 5186 else 5187 Fold_Uint (N, Uint_2, True); 5188 end if; 5189 5190 -- All floating-point type always have radix 2 5191 5192 else 5193 Fold_Uint (N, Uint_2, True); 5194 end if; 5195 5196 -------------------- 5197 -- Machine_Rounds -- 5198 -------------------- 5199 5200 when Attribute_Machine_Rounds => 5201 5202 -- Always False for fixed-point 5203 5204 if Is_Fixed_Point_Type (P_Type) then 5205 Fold_Uint (N, False_Value, True); 5206 5207 -- Else yield proper floating-point result 5208 5209 else 5210 Fold_Uint 5211 (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)), True); 5212 end if; 5213 5214 ------------------ 5215 -- Machine_Size -- 5216 ------------------ 5217 5218 -- Note: Machine_Size is identical to Object_Size 5219 5220 when Attribute_Machine_Size => Machine_Size : declare 5221 P_TypeA : constant Entity_Id := Underlying_Type (P_Type); 5222 5223 begin 5224 if Known_Esize (P_TypeA) then 5225 Fold_Uint (N, Esize (P_TypeA), True); 5226 end if; 5227 end Machine_Size; 5228 5229 -------------- 5230 -- Mantissa -- 5231 -------------- 5232 5233 when Attribute_Mantissa => 5234 5235 -- Fixed-point mantissa 5236 5237 if Is_Fixed_Point_Type (P_Type) then 5238 5239 -- Compile time foldable case 5240 5241 if Compile_Time_Known_Value (Type_Low_Bound (P_Type)) 5242 and then 5243 Compile_Time_Known_Value (Type_High_Bound (P_Type)) 5244 then 5245 -- The calculation of the obsolete Ada 83 attribute Mantissa 5246 -- is annoying, because of AI00143, quoted here: 5247 5248 -- !question 84-01-10 5249 5250 -- Consider the model numbers for F: 5251 5252 -- type F is delta 1.0 range -7.0 .. 8.0; 5253 5254 -- The wording requires that F'MANTISSA be the SMALLEST 5255 -- integer number for which each bound of the specified 5256 -- range is either a model number or lies at most small 5257 -- distant from a model number. This means F'MANTISSA 5258 -- is required to be 3 since the range -7.0 .. 7.0 fits 5259 -- in 3 signed bits, and 8 is "at most" 1.0 from a model 5260 -- number, namely, 7. Is this analysis correct? Note that 5261 -- this implies the upper bound of the range is not 5262 -- represented as a model number. 5263 5264 -- !response 84-03-17 5265 5266 -- The analysis is correct. The upper and lower bounds for 5267 -- a fixed point type can lie outside the range of model 5268 -- numbers. 5269 5270 declare 5271 Siz : Uint; 5272 LBound : Ureal; 5273 UBound : Ureal; 5274 Bound : Ureal; 5275 Max_Man : Uint; 5276 5277 begin 5278 LBound := Expr_Value_R (Type_Low_Bound (P_Type)); 5279 UBound := Expr_Value_R (Type_High_Bound (P_Type)); 5280 Bound := UR_Max (UR_Abs (LBound), UR_Abs (UBound)); 5281 Max_Man := UR_Trunc (Bound / Small_Value (P_Type)); 5282 5283 -- If the Bound is exactly a model number, i.e. a multiple 5284 -- of Small, then we back it off by one to get the integer 5285 -- value that must be representable. 5286 5287 if Small_Value (P_Type) * Max_Man = Bound then 5288 Max_Man := Max_Man - 1; 5289 end if; 5290 5291 -- Now find corresponding size = Mantissa value 5292 5293 Siz := Uint_0; 5294 while 2 ** Siz < Max_Man loop 5295 Siz := Siz + 1; 5296 end loop; 5297 5298 Fold_Uint (N, Siz, True); 5299 end; 5300 5301 else 5302 -- The case of dynamic bounds cannot be evaluated at compile 5303 -- time. Instead we use a runtime routine (see Exp_Attr). 5304 5305 null; 5306 end if; 5307 5308 -- Floating-point Mantissa 5309 5310 else 5311 Fold_Uint (N, Mantissa, True); 5312 end if; 5313 5314 --------- 5315 -- Max -- 5316 --------- 5317 5318 when Attribute_Max => Max : 5319 begin 5320 if Is_Real_Type (P_Type) then 5321 Fold_Ureal 5322 (N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2)), Static); 5323 else 5324 Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2)), Static); 5325 end if; 5326 end Max; 5327 5328 ---------------------------------- 5329 -- Max_Size_In_Storage_Elements -- 5330 ---------------------------------- 5331 5332 -- Max_Size_In_Storage_Elements is simply the Size rounded up to a 5333 -- Storage_Unit boundary. We can fold any cases for which the size 5334 -- is known by the front end. 5335 5336 when Attribute_Max_Size_In_Storage_Elements => 5337 if Known_Esize (P_Type) then 5338 Fold_Uint (N, 5339 (Esize (P_Type) + System_Storage_Unit - 1) / 5340 System_Storage_Unit, 5341 Static); 5342 end if; 5343 5344 -------------------- 5345 -- Mechanism_Code -- 5346 -------------------- 5347 5348 when Attribute_Mechanism_Code => 5349 declare 5350 Val : Int; 5351 Formal : Entity_Id; 5352 Mech : Mechanism_Type; 5353 5354 begin 5355 if No (E1) then 5356 Mech := Mechanism (P_Entity); 5357 5358 else 5359 Val := UI_To_Int (Expr_Value (E1)); 5360 5361 Formal := First_Formal (P_Entity); 5362 for J in 1 .. Val - 1 loop 5363 Next_Formal (Formal); 5364 end loop; 5365 Mech := Mechanism (Formal); 5366 end if; 5367 5368 if Mech < 0 then 5369 Fold_Uint (N, UI_From_Int (Int (-Mech)), True); 5370 end if; 5371 end; 5372 5373 --------- 5374 -- Min -- 5375 --------- 5376 5377 when Attribute_Min => Min : 5378 begin 5379 if Is_Real_Type (P_Type) then 5380 Fold_Ureal 5381 (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)), Static); 5382 else 5383 Fold_Uint (N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static); 5384 end if; 5385 end Min; 5386 5387 ----------- 5388 -- Model -- 5389 ----------- 5390 5391 when Attribute_Model => 5392 Fold_Ureal (N, 5393 Eval_Fat.Model (P_Root_Type, Expr_Value_R (E1)), Static); 5394 5395 ---------------- 5396 -- Model_Emin -- 5397 ---------------- 5398 5399 when Attribute_Model_Emin => 5400 Float_Attribute_Universal_Integer ( 5401 IEEES_Model_Emin, 5402 IEEEL_Model_Emin, 5403 IEEEX_Model_Emin, 5404 VAXFF_Model_Emin, 5405 VAXDF_Model_Emin, 5406 VAXGF_Model_Emin, 5407 AAMPS_Model_Emin, 5408 AAMPL_Model_Emin); 5409 5410 ------------------- 5411 -- Model_Epsilon -- 5412 ------------------- 5413 5414 when Attribute_Model_Epsilon => 5415 Float_Attribute_Universal_Real ( 5416 IEEES_Model_Epsilon'Universal_Literal_String, 5417 IEEEL_Model_Epsilon'Universal_Literal_String, 5418 IEEEX_Model_Epsilon'Universal_Literal_String, 5419 VAXFF_Model_Epsilon'Universal_Literal_String, 5420 VAXDF_Model_Epsilon'Universal_Literal_String, 5421 VAXGF_Model_Epsilon'Universal_Literal_String, 5422 AAMPS_Model_Epsilon'Universal_Literal_String, 5423 AAMPL_Model_Epsilon'Universal_Literal_String); 5424 5425 -------------------- 5426 -- Model_Mantissa -- 5427 -------------------- 5428 5429 when Attribute_Model_Mantissa => 5430 Float_Attribute_Universal_Integer ( 5431 IEEES_Model_Mantissa, 5432 IEEEL_Model_Mantissa, 5433 IEEEX_Model_Mantissa, 5434 VAXFF_Model_Mantissa, 5435 VAXDF_Model_Mantissa, 5436 VAXGF_Model_Mantissa, 5437 AAMPS_Model_Mantissa, 5438 AAMPL_Model_Mantissa); 5439 5440 ----------------- 5441 -- Model_Small -- 5442 ----------------- 5443 5444 when Attribute_Model_Small => 5445 Float_Attribute_Universal_Real ( 5446 IEEES_Model_Small'Universal_Literal_String, 5447 IEEEL_Model_Small'Universal_Literal_String, 5448 IEEEX_Model_Small'Universal_Literal_String, 5449 VAXFF_Model_Small'Universal_Literal_String, 5450 VAXDF_Model_Small'Universal_Literal_String, 5451 VAXGF_Model_Small'Universal_Literal_String, 5452 AAMPS_Model_Small'Universal_Literal_String, 5453 AAMPL_Model_Small'Universal_Literal_String); 5454 5455 ------------- 5456 -- Modulus -- 5457 ------------- 5458 5459 when Attribute_Modulus => 5460 Fold_Uint (N, Modulus (P_Type), True); 5461 5462 -------------------- 5463 -- Null_Parameter -- 5464 -------------------- 5465 5466 -- Cannot fold, we know the value sort of, but the whole point is 5467 -- that there is no way to talk about this imaginary value except 5468 -- by using the attribute, so we leave it the way it is. 5469 5470 when Attribute_Null_Parameter => 5471 null; 5472 5473 ----------------- 5474 -- Object_Size -- 5475 ----------------- 5476 5477 -- The Object_Size attribute for a type returns the Esize of the 5478 -- type and can be folded if this value is known. 5479 5480 when Attribute_Object_Size => Object_Size : declare 5481 P_TypeA : constant Entity_Id := Underlying_Type (P_Type); 5482 5483 begin 5484 if Known_Esize (P_TypeA) then 5485 Fold_Uint (N, Esize (P_TypeA), True); 5486 end if; 5487 end Object_Size; 5488 5489 ------------------------- 5490 -- Passed_By_Reference -- 5491 ------------------------- 5492 5493 -- Scalar types are never passed by reference 5494 5495 when Attribute_Passed_By_Reference => 5496 Fold_Uint (N, False_Value, True); 5497 5498 --------- 5499 -- Pos -- 5500 --------- 5501 5502 when Attribute_Pos => 5503 Fold_Uint (N, Expr_Value (E1), True); 5504 5505 ---------- 5506 -- Pred -- 5507 ---------- 5508 5509 when Attribute_Pred => Pred : 5510 begin 5511 -- Floating-point case 5512 5513 if Is_Floating_Point_Type (P_Type) then 5514 Fold_Ureal (N, 5515 Eval_Fat.Pred (P_Root_Type, Expr_Value_R (E1)), Static); 5516 5517 -- Fixed-point case 5518 5519 elsif Is_Fixed_Point_Type (P_Type) then 5520 Fold_Ureal (N, 5521 Expr_Value_R (E1) - Small_Value (P_Type), True); 5522 5523 -- Modular integer case (wraps) 5524 5525 elsif Is_Modular_Integer_Type (P_Type) then 5526 Fold_Uint (N, (Expr_Value (E1) - 1) mod Modulus (P_Type), Static); 5527 5528 -- Other scalar cases 5529 5530 else 5531 pragma Assert (Is_Scalar_Type (P_Type)); 5532 5533 if Is_Enumeration_Type (P_Type) 5534 and then Expr_Value (E1) = 5535 Expr_Value (Type_Low_Bound (P_Base_Type)) 5536 then 5537 Apply_Compile_Time_Constraint_Error 5538 (N, "Pred of `&''First`", 5539 CE_Overflow_Check_Failed, 5540 Ent => P_Base_Type, 5541 Warn => not Static); 5542 5543 Check_Expressions; 5544 return; 5545 end if; 5546 5547 Fold_Uint (N, Expr_Value (E1) - 1, Static); 5548 end if; 5549 end Pred; 5550 5551 ----------- 5552 -- Range -- 5553 ----------- 5554 5555 -- No processing required, because by this stage, Range has been 5556 -- replaced by First .. Last, so this branch can never be taken. 5557 5558 when Attribute_Range => 5559 raise Program_Error; 5560 5561 ------------------ 5562 -- Range_Length -- 5563 ------------------ 5564 5565 when Attribute_Range_Length => 5566 Set_Bounds; 5567 5568 if Compile_Time_Known_Value (Hi_Bound) 5569 and then Compile_Time_Known_Value (Lo_Bound) 5570 then 5571 Fold_Uint (N, 5572 UI_Max 5573 (0, Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound) + 1), 5574 Static); 5575 end if; 5576 5577 --------------- 5578 -- Remainder -- 5579 --------------- 5580 5581 when Attribute_Remainder => 5582 Fold_Ureal (N, 5583 Eval_Fat.Remainder 5584 (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), 5585 Static); 5586 5587 ----------- 5588 -- Round -- 5589 ----------- 5590 5591 when Attribute_Round => Round : 5592 declare 5593 Sr : Ureal; 5594 Si : Uint; 5595 5596 begin 5597 -- First we get the (exact result) in units of small 5598 5599 Sr := Expr_Value_R (E1) / Small_Value (C_Type); 5600 5601 -- Now round that exactly to an integer 5602 5603 Si := UR_To_Uint (Sr); 5604 5605 -- Finally the result is obtained by converting back to real 5606 5607 Fold_Ureal (N, Si * Small_Value (C_Type), Static); 5608 end Round; 5609 5610 -------------- 5611 -- Rounding -- 5612 -------------- 5613 5614 when Attribute_Rounding => 5615 Fold_Ureal (N, 5616 Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)), Static); 5617 5618 --------------- 5619 -- Safe_Emax -- 5620 --------------- 5621 5622 when Attribute_Safe_Emax => 5623 Float_Attribute_Universal_Integer ( 5624 IEEES_Safe_Emax, 5625 IEEEL_Safe_Emax, 5626 IEEEX_Safe_Emax, 5627 VAXFF_Safe_Emax, 5628 VAXDF_Safe_Emax, 5629 VAXGF_Safe_Emax, 5630 AAMPS_Safe_Emax, 5631 AAMPL_Safe_Emax); 5632 5633 ---------------- 5634 -- Safe_First -- 5635 ---------------- 5636 5637 when Attribute_Safe_First => 5638 Float_Attribute_Universal_Real ( 5639 IEEES_Safe_First'Universal_Literal_String, 5640 IEEEL_Safe_First'Universal_Literal_String, 5641 IEEEX_Safe_First'Universal_Literal_String, 5642 VAXFF_Safe_First'Universal_Literal_String, 5643 VAXDF_Safe_First'Universal_Literal_String, 5644 VAXGF_Safe_First'Universal_Literal_String, 5645 AAMPS_Safe_First'Universal_Literal_String, 5646 AAMPL_Safe_First'Universal_Literal_String); 5647 5648 ---------------- 5649 -- Safe_Large -- 5650 ---------------- 5651 5652 when Attribute_Safe_Large => 5653 if Is_Fixed_Point_Type (P_Type) then 5654 Fold_Ureal 5655 (N, Expr_Value_R (Type_High_Bound (P_Base_Type)), Static); 5656 else 5657 Float_Attribute_Universal_Real ( 5658 IEEES_Safe_Large'Universal_Literal_String, 5659 IEEEL_Safe_Large'Universal_Literal_String, 5660 IEEEX_Safe_Large'Universal_Literal_String, 5661 VAXFF_Safe_Large'Universal_Literal_String, 5662 VAXDF_Safe_Large'Universal_Literal_String, 5663 VAXGF_Safe_Large'Universal_Literal_String, 5664 AAMPS_Safe_Large'Universal_Literal_String, 5665 AAMPL_Safe_Large'Universal_Literal_String); 5666 end if; 5667 5668 --------------- 5669 -- Safe_Last -- 5670 --------------- 5671 5672 when Attribute_Safe_Last => 5673 Float_Attribute_Universal_Real ( 5674 IEEES_Safe_Last'Universal_Literal_String, 5675 IEEEL_Safe_Last'Universal_Literal_String, 5676 IEEEX_Safe_Last'Universal_Literal_String, 5677 VAXFF_Safe_Last'Universal_Literal_String, 5678 VAXDF_Safe_Last'Universal_Literal_String, 5679 VAXGF_Safe_Last'Universal_Literal_String, 5680 AAMPS_Safe_Last'Universal_Literal_String, 5681 AAMPL_Safe_Last'Universal_Literal_String); 5682 5683 ---------------- 5684 -- Safe_Small -- 5685 ---------------- 5686 5687 when Attribute_Safe_Small => 5688 5689 -- In Ada 95, the old Ada 83 attribute Safe_Small is redundant 5690 -- for fixed-point, since is the same as Small, but we implement 5691 -- it for backwards compatibility. 5692 5693 if Is_Fixed_Point_Type (P_Type) then 5694 Fold_Ureal (N, Small_Value (P_Type), Static); 5695 5696 -- Ada 83 Safe_Small for floating-point cases 5697 5698 else 5699 Float_Attribute_Universal_Real ( 5700 IEEES_Safe_Small'Universal_Literal_String, 5701 IEEEL_Safe_Small'Universal_Literal_String, 5702 IEEEX_Safe_Small'Universal_Literal_String, 5703 VAXFF_Safe_Small'Universal_Literal_String, 5704 VAXDF_Safe_Small'Universal_Literal_String, 5705 VAXGF_Safe_Small'Universal_Literal_String, 5706 AAMPS_Safe_Small'Universal_Literal_String, 5707 AAMPL_Safe_Small'Universal_Literal_String); 5708 end if; 5709 5710 ----------- 5711 -- Scale -- 5712 ----------- 5713 5714 when Attribute_Scale => 5715 Fold_Uint (N, Scale_Value (P_Type), True); 5716 5717 ------------- 5718 -- Scaling -- 5719 ------------- 5720 5721 when Attribute_Scaling => 5722 Fold_Ureal (N, 5723 Eval_Fat.Scaling 5724 (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)), Static); 5725 5726 ------------------ 5727 -- Signed_Zeros -- 5728 ------------------ 5729 5730 when Attribute_Signed_Zeros => 5731 Fold_Uint 5732 (N, UI_From_Int (Boolean'Pos (Signed_Zeros_On_Target)), Static); 5733 5734 ---------- 5735 -- Size -- 5736 ---------- 5737 5738 -- Size attribute returns the RM size. All scalar types can be folded, 5739 -- as well as any types for which the size is known by the front end, 5740 -- including any type for which a size attribute is specified. 5741 5742 when Attribute_Size | Attribute_VADS_Size => Size : declare 5743 P_TypeA : constant Entity_Id := Underlying_Type (P_Type); 5744 5745 begin 5746 if RM_Size (P_TypeA) /= Uint_0 then 5747 5748 -- VADS_Size case 5749 5750 if Id = Attribute_VADS_Size or else Use_VADS_Size then 5751 declare 5752 S : constant Node_Id := Size_Clause (P_TypeA); 5753 5754 begin 5755 -- If a size clause applies, then use the size from it. 5756 -- This is one of the rare cases where we can use the 5757 -- Size_Clause field for a subtype when Has_Size_Clause 5758 -- is False. Consider: 5759 5760 -- type x is range 1 .. 64; g 5761 -- for x'size use 12; 5762 -- subtype y is x range 0 .. 3; 5763 5764 -- Here y has a size clause inherited from x, but normally 5765 -- it does not apply, and y'size is 2. However, y'VADS_Size 5766 -- is indeed 12 and not 2. 5767 5768 if Present (S) 5769 and then Is_OK_Static_Expression (Expression (S)) 5770 then 5771 Fold_Uint (N, Expr_Value (Expression (S)), True); 5772 5773 -- If no size is specified, then we simply use the object 5774 -- size in the VADS_Size case (e.g. Natural'Size is equal 5775 -- to Integer'Size, not one less). 5776 5777 else 5778 Fold_Uint (N, Esize (P_TypeA), True); 5779 end if; 5780 end; 5781 5782 -- Normal case (Size) in which case we want the RM_Size 5783 5784 else 5785 Fold_Uint (N, 5786 RM_Size (P_TypeA), 5787 Static and then Is_Discrete_Type (P_TypeA)); 5788 end if; 5789 end if; 5790 end Size; 5791 5792 ----------- 5793 -- Small -- 5794 ----------- 5795 5796 when Attribute_Small => 5797 5798 -- The floating-point case is present only for Ada 83 compatability. 5799 -- Note that strictly this is an illegal addition, since we are 5800 -- extending an Ada 95 defined attribute, but we anticipate an 5801 -- ARG ruling that will permit this. 5802 5803 if Is_Floating_Point_Type (P_Type) then 5804 5805 -- Ada 83 attribute is defined as (RM83 3.5.8) 5806 5807 -- T'Small = 2.0**(-T'Emax - 1) 5808 5809 -- where 5810 5811 -- T'Emax = 4 * T'Mantissa 5812 5813 Fold_Ureal (N, Ureal_2 ** ((-(4 * Mantissa)) - 1), Static); 5814 5815 -- Normal Ada 95 fixed-point case 5816 5817 else 5818 Fold_Ureal (N, Small_Value (P_Type), True); 5819 end if; 5820 5821 ---------- 5822 -- Succ -- 5823 ---------- 5824 5825 when Attribute_Succ => Succ : 5826 begin 5827 -- Floating-point case 5828 5829 if Is_Floating_Point_Type (P_Type) then 5830 Fold_Ureal (N, 5831 Eval_Fat.Succ (P_Root_Type, Expr_Value_R (E1)), Static); 5832 5833 -- Fixed-point case 5834 5835 elsif Is_Fixed_Point_Type (P_Type) then 5836 Fold_Ureal (N, 5837 Expr_Value_R (E1) + Small_Value (P_Type), Static); 5838 5839 -- Modular integer case (wraps) 5840 5841 elsif Is_Modular_Integer_Type (P_Type) then 5842 Fold_Uint (N, (Expr_Value (E1) + 1) mod Modulus (P_Type), Static); 5843 5844 -- Other scalar cases 5845 5846 else 5847 pragma Assert (Is_Scalar_Type (P_Type)); 5848 5849 if Is_Enumeration_Type (P_Type) 5850 and then Expr_Value (E1) = 5851 Expr_Value (Type_High_Bound (P_Base_Type)) 5852 then 5853 Apply_Compile_Time_Constraint_Error 5854 (N, "Succ of `&''Last`", 5855 CE_Overflow_Check_Failed, 5856 Ent => P_Base_Type, 5857 Warn => not Static); 5858 5859 Check_Expressions; 5860 return; 5861 else 5862 Fold_Uint (N, Expr_Value (E1) + 1, Static); 5863 end if; 5864 end if; 5865 end Succ; 5866 5867 ---------------- 5868 -- Truncation -- 5869 ---------------- 5870 5871 when Attribute_Truncation => 5872 Fold_Ureal (N, 5873 Eval_Fat.Truncation (P_Root_Type, Expr_Value_R (E1)), Static); 5874 5875 ---------------- 5876 -- Type_Class -- 5877 ---------------- 5878 5879 when Attribute_Type_Class => Type_Class : declare 5880 Typ : constant Entity_Id := Underlying_Type (P_Base_Type); 5881 Id : RE_Id; 5882 5883 begin 5884 if Is_RTE (P_Root_Type, RE_Address) then 5885 Id := RE_Type_Class_Address; 5886 5887 elsif Is_Enumeration_Type (Typ) then 5888 Id := RE_Type_Class_Enumeration; 5889 5890 elsif Is_Integer_Type (Typ) then 5891 Id := RE_Type_Class_Integer; 5892 5893 elsif Is_Fixed_Point_Type (Typ) then 5894 Id := RE_Type_Class_Fixed_Point; 5895 5896 elsif Is_Floating_Point_Type (Typ) then 5897 Id := RE_Type_Class_Floating_Point; 5898 5899 elsif Is_Array_Type (Typ) then 5900 Id := RE_Type_Class_Array; 5901 5902 elsif Is_Record_Type (Typ) then 5903 Id := RE_Type_Class_Record; 5904 5905 elsif Is_Access_Type (Typ) then 5906 Id := RE_Type_Class_Access; 5907 5908 elsif Is_Enumeration_Type (Typ) then 5909 Id := RE_Type_Class_Enumeration; 5910 5911 elsif Is_Task_Type (Typ) then 5912 Id := RE_Type_Class_Task; 5913 5914 -- We treat protected types like task types. It would make more 5915 -- sense to have another enumeration value, but after all the 5916 -- whole point of this feature is to be exactly DEC compatible, 5917 -- and changing the type Type_Clas would not meet this requirement. 5918 5919 elsif Is_Protected_Type (Typ) then 5920 Id := RE_Type_Class_Task; 5921 5922 -- Not clear if there are any other possibilities, but if there 5923 -- are, then we will treat them as the address case. 5924 5925 else 5926 Id := RE_Type_Class_Address; 5927 end if; 5928 5929 Rewrite (N, New_Occurrence_Of (RTE (Id), Loc)); 5930 5931 end Type_Class; 5932 5933 ----------------------- 5934 -- Unbiased_Rounding -- 5935 ----------------------- 5936 5937 when Attribute_Unbiased_Rounding => 5938 Fold_Ureal (N, 5939 Eval_Fat.Unbiased_Rounding (P_Root_Type, Expr_Value_R (E1)), 5940 Static); 5941 5942 ------------------------- 5943 -- Unconstrained_Array -- 5944 ------------------------- 5945 5946 when Attribute_Unconstrained_Array => Unconstrained_Array : declare 5947 Typ : constant Entity_Id := Underlying_Type (P_Type); 5948 5949 begin 5950 if Is_Array_Type (P_Type) 5951 and then not Is_Constrained (Typ) 5952 then 5953 Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); 5954 else 5955 Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); 5956 end if; 5957 5958 -- Analyze and resolve as boolean, note that this attribute is 5959 -- a static attribute in GNAT. 5960 5961 Analyze_And_Resolve (N, Standard_Boolean); 5962 Static := True; 5963 end Unconstrained_Array; 5964 5965 --------------- 5966 -- VADS_Size -- 5967 --------------- 5968 5969 -- Processing is shared with Size 5970 5971 --------- 5972 -- Val -- 5973 --------- 5974 5975 when Attribute_Val => Val : 5976 begin 5977 if Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Base_Type)) 5978 or else 5979 Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type)) 5980 then 5981 Apply_Compile_Time_Constraint_Error 5982 (N, "Val expression out of range", 5983 CE_Range_Check_Failed, 5984 Warn => not Static); 5985 5986 Check_Expressions; 5987 return; 5988 5989 else 5990 Fold_Uint (N, Expr_Value (E1), Static); 5991 end if; 5992 end Val; 5993 5994 ---------------- 5995 -- Value_Size -- 5996 ---------------- 5997 5998 -- The Value_Size attribute for a type returns the RM size of the 5999 -- type. This an always be folded for scalar types, and can also 6000 -- be folded for non-scalar types if the size is set. 6001 6002 when Attribute_Value_Size => Value_Size : declare 6003 P_TypeA : constant Entity_Id := Underlying_Type (P_Type); 6004 6005 begin 6006 if RM_Size (P_TypeA) /= Uint_0 then 6007 Fold_Uint (N, RM_Size (P_TypeA), True); 6008 end if; 6009 6010 end Value_Size; 6011 6012 ------------- 6013 -- Version -- 6014 ------------- 6015 6016 -- Version can never be static 6017 6018 when Attribute_Version => 6019 null; 6020 6021 ---------------- 6022 -- Wide_Image -- 6023 ---------------- 6024 6025 -- Wide_Image is a scalar attribute, but is never static, because it 6026 -- is not a static function (having a non-scalar argument (RM 4.9(22)) 6027 6028 when Attribute_Wide_Image => 6029 null; 6030 6031 ---------------- 6032 -- Wide_Width -- 6033 ---------------- 6034 6035 -- Processing for Wide_Width is combined with Width 6036 6037 ----------- 6038 -- Width -- 6039 ----------- 6040 6041 -- This processing also handles the case of Wide_Width 6042 6043 when Attribute_Width | Attribute_Wide_Width => Width : 6044 begin 6045 if Compile_Time_Known_Bounds (P_Type) then 6046 6047 -- Floating-point types 6048 6049 if Is_Floating_Point_Type (P_Type) then 6050 6051 -- Width is zero for a null range (RM 3.5 (38)) 6052 6053 if Expr_Value_R (Type_High_Bound (P_Type)) < 6054 Expr_Value_R (Type_Low_Bound (P_Type)) 6055 then 6056 Fold_Uint (N, Uint_0, True); 6057 6058 else 6059 -- For floating-point, we have +N.dddE+nnn where length 6060 -- of ddd is determined by type'Digits - 1, but is one 6061 -- if Digits is one (RM 3.5 (33)). 6062 6063 -- nnn is set to 2 for Short_Float and Float (32 bit 6064 -- floats), and 3 for Long_Float and Long_Long_Float. 6065 -- This is not quite right, but is good enough. 6066 6067 declare 6068 Len : Int := 6069 Int'Max (2, UI_To_Int (Digits_Value (P_Type))); 6070 6071 begin 6072 if Esize (P_Type) <= 32 then 6073 Len := Len + 6; 6074 else 6075 Len := Len + 7; 6076 end if; 6077 6078 Fold_Uint (N, UI_From_Int (Len), True); 6079 end; 6080 end if; 6081 6082 -- Fixed-point types 6083 6084 elsif Is_Fixed_Point_Type (P_Type) then 6085 6086 -- Width is zero for a null range (RM 3.5 (38)) 6087 6088 if Expr_Value (Type_High_Bound (P_Type)) < 6089 Expr_Value (Type_Low_Bound (P_Type)) 6090 then 6091 Fold_Uint (N, Uint_0, True); 6092 6093 -- The non-null case depends on the specific real type 6094 6095 else 6096 -- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34)) 6097 6098 Fold_Uint 6099 (N, UI_From_Int (Fore_Value + 1 + Aft_Value), True); 6100 end if; 6101 6102 -- Discrete types 6103 6104 else 6105 declare 6106 R : constant Entity_Id := Root_Type (P_Type); 6107 Lo : constant Uint := 6108 Expr_Value (Type_Low_Bound (P_Type)); 6109 Hi : constant Uint := 6110 Expr_Value (Type_High_Bound (P_Type)); 6111 W : Nat; 6112 Wt : Nat; 6113 T : Uint; 6114 L : Node_Id; 6115 C : Character; 6116 6117 begin 6118 -- Empty ranges 6119 6120 if Lo > Hi then 6121 W := 0; 6122 6123 -- Width for types derived from Standard.Character 6124 -- and Standard.Wide_Character. 6125 6126 elsif R = Standard_Character 6127 or else R = Standard_Wide_Character 6128 then 6129 W := 0; 6130 6131 -- Set W larger if needed 6132 6133 for J in UI_To_Int (Lo) .. UI_To_Int (Hi) loop 6134 6135 -- Assume all wide-character escape sequences are 6136 -- same length, so we can quit when we reach one. 6137 6138 if J > 255 then 6139 if Id = Attribute_Wide_Width then 6140 W := Int'Max (W, 3); 6141 exit; 6142 else 6143 W := Int'Max (W, Length_Wide); 6144 exit; 6145 end if; 6146 6147 else 6148 C := Character'Val (J); 6149 6150 -- Test for all cases where Character'Image 6151 -- yields an image that is longer than three 6152 -- characters. First the cases of Reserved_xxx 6153 -- names (length = 12). 6154 6155 case C is 6156 when Reserved_128 | Reserved_129 | 6157 Reserved_132 | Reserved_153 6158 6159 => Wt := 12; 6160 6161 when BS | HT | LF | VT | FF | CR | 6162 SO | SI | EM | FS | GS | RS | 6163 US | RI | MW | ST | PM 6164 6165 => Wt := 2; 6166 6167 when NUL | SOH | STX | ETX | EOT | 6168 ENQ | ACK | BEL | DLE | DC1 | 6169 DC2 | DC3 | DC4 | NAK | SYN | 6170 ETB | CAN | SUB | ESC | DEL | 6171 BPH | NBH | NEL | SSA | ESA | 6172 HTS | HTJ | VTS | PLD | PLU | 6173 SS2 | SS3 | DCS | PU1 | PU2 | 6174 STS | CCH | SPA | EPA | SOS | 6175 SCI | CSI | OSC | APC 6176 6177 => Wt := 3; 6178 6179 when Space .. Tilde | 6180 No_Break_Space .. LC_Y_Diaeresis 6181 6182 => Wt := 3; 6183 end case; 6184 6185 W := Int'Max (W, Wt); 6186 end if; 6187 end loop; 6188 6189 -- Width for types derived from Standard.Boolean 6190 6191 elsif R = Standard_Boolean then 6192 if Lo = 0 then 6193 W := 5; -- FALSE 6194 else 6195 W := 4; -- TRUE 6196 end if; 6197 6198 -- Width for integer types 6199 6200 elsif Is_Integer_Type (P_Type) then 6201 T := UI_Max (abs Lo, abs Hi); 6202 6203 W := 2; 6204 while T >= 10 loop 6205 W := W + 1; 6206 T := T / 10; 6207 end loop; 6208 6209 -- Only remaining possibility is user declared enum type 6210 6211 else 6212 pragma Assert (Is_Enumeration_Type (P_Type)); 6213 6214 W := 0; 6215 L := First_Literal (P_Type); 6216 6217 while Present (L) loop 6218 6219 -- Only pay attention to in range characters 6220 6221 if Lo <= Enumeration_Pos (L) 6222 and then Enumeration_Pos (L) <= Hi 6223 then 6224 -- For Width case, use decoded name 6225 6226 if Id = Attribute_Width then 6227 Get_Decoded_Name_String (Chars (L)); 6228 Wt := Nat (Name_Len); 6229 6230 -- For Wide_Width, use encoded name, and then 6231 -- adjust for the encoding. 6232 6233 else 6234 Get_Name_String (Chars (L)); 6235 6236 -- Character literals are always of length 3 6237 6238 if Name_Buffer (1) = 'Q' then 6239 Wt := 3; 6240 6241 -- Otherwise loop to adjust for upper/wide chars 6242 6243 else 6244 Wt := Nat (Name_Len); 6245 6246 for J in 1 .. Name_Len loop 6247 if Name_Buffer (J) = 'U' then 6248 Wt := Wt - 2; 6249 elsif Name_Buffer (J) = 'W' then 6250 Wt := Wt - 4; 6251 end if; 6252 end loop; 6253 end if; 6254 end if; 6255 6256 W := Int'Max (W, Wt); 6257 end if; 6258 6259 Next_Literal (L); 6260 end loop; 6261 end if; 6262 6263 Fold_Uint (N, UI_From_Int (W), True); 6264 end; 6265 end if; 6266 end if; 6267 end Width; 6268 6269 -- The following attributes can never be folded, and furthermore we 6270 -- should not even have entered the case statement for any of these. 6271 -- Note that in some cases, the values have already been folded as 6272 -- a result of the processing in Analyze_Attribute. 6273 6274 when Attribute_Abort_Signal | 6275 Attribute_Access | 6276 Attribute_Address | 6277 Attribute_Address_Size | 6278 Attribute_Asm_Input | 6279 Attribute_Asm_Output | 6280 Attribute_Base | 6281 Attribute_Bit_Order | 6282 Attribute_Bit_Position | 6283 Attribute_Callable | 6284 Attribute_Caller | 6285 Attribute_Class | 6286 Attribute_Code_Address | 6287 Attribute_Count | 6288 Attribute_Default_Bit_Order | 6289 Attribute_Elaborated | 6290 Attribute_Elab_Body | 6291 Attribute_Elab_Spec | 6292 Attribute_External_Tag | 6293 Attribute_First_Bit | 6294 Attribute_Input | 6295 Attribute_Last_Bit | 6296 Attribute_Maximum_Alignment | 6297 Attribute_Output | 6298 Attribute_Partition_ID | 6299 Attribute_Pool_Address | 6300 Attribute_Position | 6301 Attribute_Read | 6302 Attribute_Storage_Pool | 6303 Attribute_Storage_Size | 6304 Attribute_Storage_Unit | 6305 Attribute_Tag | 6306 Attribute_Target_Name | 6307 Attribute_Terminated | 6308 Attribute_To_Address | 6309 Attribute_UET_Address | 6310 Attribute_Unchecked_Access | 6311 Attribute_Universal_Literal_String | 6312 Attribute_Unrestricted_Access | 6313 Attribute_Valid | 6314 Attribute_Value | 6315 Attribute_Wchar_T_Size | 6316 Attribute_Wide_Value | 6317 Attribute_Word_Size | 6318 Attribute_Write => 6319 6320 raise Program_Error; 6321 6322 end case; 6323 6324 -- At the end of the case, one more check. If we did a static evaluation 6325 -- so that the result is now a literal, then set Is_Static_Expression 6326 -- in the constant only if the prefix type is a static subtype. For 6327 -- non-static subtypes, the folding is still OK, but not static. 6328 6329 -- An exception is the GNAT attribute Constrained_Array which is 6330 -- defined to be a static attribute in all cases. 6331 6332 if Nkind (N) = N_Integer_Literal 6333 or else Nkind (N) = N_Real_Literal 6334 or else Nkind (N) = N_Character_Literal 6335 or else Nkind (N) = N_String_Literal 6336 or else (Is_Entity_Name (N) 6337 and then Ekind (Entity (N)) = E_Enumeration_Literal) 6338 then 6339 Set_Is_Static_Expression (N, Static); 6340 6341 -- If this is still an attribute reference, then it has not been folded 6342 -- and that means that its expressions are in a non-static context. 6343 6344 elsif Nkind (N) = N_Attribute_Reference then 6345 Check_Expressions; 6346 6347 -- Note: the else case not covered here are odd cases where the 6348 -- processing has transformed the attribute into something other 6349 -- than a constant. Nothing more to do in such cases. 6350 6351 else 6352 null; 6353 end if; 6354 6355 end Eval_Attribute; 6356 6357 ------------------------------ 6358 -- Is_Anonymous_Tagged_Base -- 6359 ------------------------------ 6360 6361 function Is_Anonymous_Tagged_Base 6362 (Anon : Entity_Id; 6363 Typ : Entity_Id) 6364 return Boolean 6365 is 6366 begin 6367 return 6368 Anon = Current_Scope 6369 and then Is_Itype (Anon) 6370 and then Associated_Node_For_Itype (Anon) = Parent (Typ); 6371 end Is_Anonymous_Tagged_Base; 6372 6373 ----------------------- 6374 -- Resolve_Attribute -- 6375 ----------------------- 6376 6377 procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id) is 6378 Loc : constant Source_Ptr := Sloc (N); 6379 P : constant Node_Id := Prefix (N); 6380 Aname : constant Name_Id := Attribute_Name (N); 6381 Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname); 6382 Btyp : constant Entity_Id := Base_Type (Typ); 6383 Index : Interp_Index; 6384 It : Interp; 6385 Nom_Subt : Entity_Id; 6386 6387 begin 6388 -- If error during analysis, no point in continuing, except for 6389 -- array types, where we get better recovery by using unconstrained 6390 -- indices than nothing at all (see Check_Array_Type). 6391 6392 if Error_Posted (N) 6393 and then Attr_Id /= Attribute_First 6394 and then Attr_Id /= Attribute_Last 6395 and then Attr_Id /= Attribute_Length 6396 and then Attr_Id /= Attribute_Range 6397 then 6398 return; 6399 end if; 6400 6401 -- If attribute was universal type, reset to actual type 6402 6403 if Etype (N) = Universal_Integer 6404 or else Etype (N) = Universal_Real 6405 then 6406 Set_Etype (N, Typ); 6407 end if; 6408 6409 -- Remaining processing depends on attribute 6410 6411 case Attr_Id is 6412 6413 ------------ 6414 -- Access -- 6415 ------------ 6416 6417 -- For access attributes, if the prefix denotes an entity, it is 6418 -- interpreted as a name, never as a call. It may be overloaded, 6419 -- in which case resolution uses the profile of the context type. 6420 -- Otherwise prefix must be resolved. 6421 6422 when Attribute_Access 6423 | Attribute_Unchecked_Access 6424 | Attribute_Unrestricted_Access => 6425 6426 if Is_Variable (P) then 6427 Note_Possible_Modification (P); 6428 end if; 6429 6430 if Is_Entity_Name (P) then 6431 if Is_Overloaded (P) then 6432 Get_First_Interp (P, Index, It); 6433 6434 while Present (It.Nam) loop 6435 6436 if Type_Conformant (Designated_Type (Typ), It.Nam) then 6437 Set_Entity (P, It.Nam); 6438 6439 -- The prefix is definitely NOT overloaded anymore 6440 -- at this point, so we reset the Is_Overloaded 6441 -- flag to avoid any confusion when reanalyzing 6442 -- the node. 6443 6444 Set_Is_Overloaded (P, False); 6445 Generate_Reference (Entity (P), P); 6446 exit; 6447 end if; 6448 6449 Get_Next_Interp (Index, It); 6450 end loop; 6451 6452 -- If it is a subprogram name or a type, there is nothing 6453 -- to resolve. 6454 6455 elsif not Is_Overloadable (Entity (P)) 6456 and then not Is_Type (Entity (P)) 6457 then 6458 Resolve (P); 6459 end if; 6460 6461 Error_Msg_Name_1 := Aname; 6462 6463 if not Is_Entity_Name (P) then 6464 null; 6465 6466 elsif Is_Abstract (Entity (P)) 6467 and then Is_Overloadable (Entity (P)) 6468 then 6469 Error_Msg_N ("prefix of % attribute cannot be abstract", P); 6470 Set_Etype (N, Any_Type); 6471 6472 elsif Convention (Entity (P)) = Convention_Intrinsic then 6473 if Ekind (Entity (P)) = E_Enumeration_Literal then 6474 Error_Msg_N 6475 ("prefix of % attribute cannot be enumeration literal", 6476 P); 6477 else 6478 Error_Msg_N 6479 ("prefix of % attribute cannot be intrinsic", P); 6480 end if; 6481 6482 Set_Etype (N, Any_Type); 6483 6484 elsif Is_Thread_Body (Entity (P)) then 6485 Error_Msg_N 6486 ("prefix of % attribute cannot be a thread body", P); 6487 end if; 6488 6489 -- Assignments, return statements, components of aggregates, 6490 -- generic instantiations will require convention checks if 6491 -- the type is an access to subprogram. Given that there will 6492 -- also be accessibility checks on those, this is where the 6493 -- checks can eventually be centralized ??? 6494 6495 if Ekind (Btyp) = E_Access_Subprogram_Type then 6496 if Convention (Btyp) /= Convention (Entity (P)) then 6497 Error_Msg_N 6498 ("subprogram has invalid convention for context", P); 6499 6500 else 6501 Check_Subtype_Conformant 6502 (New_Id => Entity (P), 6503 Old_Id => Designated_Type (Btyp), 6504 Err_Loc => P); 6505 end if; 6506 6507 if Attr_Id = Attribute_Unchecked_Access then 6508 Error_Msg_Name_1 := Aname; 6509 Error_Msg_N 6510 ("attribute% cannot be applied to a subprogram", P); 6511 6512 elsif Aname = Name_Unrestricted_Access then 6513 null; -- Nothing to check 6514 6515 -- Check the static accessibility rule of 3.10.2(32) 6516 -- In an instance body, if subprogram and type are both 6517 -- local, other rules prevent dangling references, and no 6518 -- warning is needed. 6519 6520 elsif Attr_Id = Attribute_Access 6521 and then Subprogram_Access_Level (Entity (P)) 6522 > Type_Access_Level (Btyp) 6523 then 6524 if not In_Instance_Body then 6525 Error_Msg_N 6526 ("subprogram must not be deeper than access type", 6527 P); 6528 6529 elsif Scope (Entity (P)) /= Scope (Btyp) then 6530 Error_Msg_N 6531 ("subprogram must not be deeper than access type?", 6532 P); 6533 Error_Msg_N 6534 ("Constraint_Error will be raised ?", P); 6535 Set_Raises_Constraint_Error (N); 6536 end if; 6537 6538 -- Check the restriction of 3.10.2(32) that disallows 6539 -- the type of the access attribute to be declared 6540 -- outside a generic body when the subprogram is declared 6541 -- within that generic body. 6542 6543 elsif Enclosing_Generic_Body (Entity (P)) 6544 /= Enclosing_Generic_Body (Btyp) 6545 then 6546 Error_Msg_N 6547 ("access type must not be outside generic body", P); 6548 end if; 6549 end if; 6550 6551 -- if this is a renaming, an inherited operation, or a 6552 -- subprogram instance, use the original entity. 6553 6554 if Is_Entity_Name (P) 6555 and then Is_Overloadable (Entity (P)) 6556 and then Present (Alias (Entity (P))) 6557 then 6558 Rewrite (P, 6559 New_Occurrence_Of (Alias (Entity (P)), Sloc (P))); 6560 end if; 6561 6562 elsif Nkind (P) = N_Selected_Component 6563 and then Is_Overloadable (Entity (Selector_Name (P))) 6564 then 6565 -- Protected operation. If operation is overloaded, must 6566 -- disambiguate. Prefix that denotes protected object itself 6567 -- is resolved with its own type. 6568 6569 if Attr_Id = Attribute_Unchecked_Access then 6570 Error_Msg_Name_1 := Aname; 6571 Error_Msg_N 6572 ("attribute% cannot be applied to protected operation", P); 6573 end if; 6574 6575 Resolve (Prefix (P)); 6576 Generate_Reference (Entity (Selector_Name (P)), P); 6577 6578 elsif Is_Overloaded (P) then 6579 6580 -- Use the designated type of the context to disambiguate. 6581 declare 6582 Index : Interp_Index; 6583 It : Interp; 6584 begin 6585 Get_First_Interp (P, Index, It); 6586 6587 while Present (It.Typ) loop 6588 if Covers (Designated_Type (Typ), It.Typ) then 6589 Resolve (P, It.Typ); 6590 exit; 6591 end if; 6592 6593 Get_Next_Interp (Index, It); 6594 end loop; 6595 end; 6596 else 6597 Resolve (P); 6598 end if; 6599 6600 -- X'Access is illegal if X denotes a constant and the access 6601 -- type is access-to-variable. Same for 'Unchecked_Access. 6602 -- The rule does not apply to 'Unrestricted_Access. 6603 6604 if not (Ekind (Btyp) = E_Access_Subprogram_Type 6605 or else (Is_Record_Type (Btyp) and then 6606 Present (Corresponding_Remote_Type (Btyp))) 6607 or else Ekind (Btyp) = E_Access_Protected_Subprogram_Type 6608 or else Is_Access_Constant (Btyp) 6609 or else Is_Variable (P) 6610 or else Attr_Id = Attribute_Unrestricted_Access) 6611 then 6612 if Comes_From_Source (N) then 6613 Error_Msg_N ("access-to-variable designates constant", P); 6614 end if; 6615 end if; 6616 6617 if (Attr_Id = Attribute_Access 6618 or else 6619 Attr_Id = Attribute_Unchecked_Access) 6620 and then (Ekind (Btyp) = E_General_Access_Type 6621 or else Ekind (Btyp) = E_Anonymous_Access_Type) 6622 then 6623 if Is_Dependent_Component_Of_Mutable_Object (P) then 6624 Error_Msg_N 6625 ("illegal attribute for discriminant-dependent component", 6626 P); 6627 end if; 6628 6629 -- Check the static matching rule of 3.10.2(27). The 6630 -- nominal subtype of the prefix must statically 6631 -- match the designated type. 6632 6633 Nom_Subt := Etype (P); 6634 6635 if Is_Constr_Subt_For_U_Nominal (Nom_Subt) then 6636 Nom_Subt := Etype (Nom_Subt); 6637 end if; 6638 6639 if Is_Tagged_Type (Designated_Type (Typ)) then 6640 6641 -- If the attribute is in the context of an access 6642 -- parameter, then the prefix is allowed to be of 6643 -- the class-wide type (by AI-127). 6644 6645 if Ekind (Typ) = E_Anonymous_Access_Type then 6646 if not Covers (Designated_Type (Typ), Nom_Subt) 6647 and then not Covers (Nom_Subt, Designated_Type (Typ)) 6648 then 6649 declare 6650 Desig : Entity_Id; 6651 6652 begin 6653 Desig := Designated_Type (Typ); 6654 6655 if Is_Class_Wide_Type (Desig) then 6656 Desig := Etype (Desig); 6657 end if; 6658 6659 if Is_Anonymous_Tagged_Base (Nom_Subt, Desig) then 6660 null; 6661 6662 else 6663 Error_Msg_NE 6664 ("type of prefix: & not compatible", 6665 P, Nom_Subt); 6666 Error_Msg_NE 6667 ("\with &, the expected designated type", 6668 P, Designated_Type (Typ)); 6669 end if; 6670 end; 6671 end if; 6672 6673 elsif not Covers (Designated_Type (Typ), Nom_Subt) 6674 or else 6675 (not Is_Class_Wide_Type (Designated_Type (Typ)) 6676 and then Is_Class_Wide_Type (Nom_Subt)) 6677 then 6678 Error_Msg_NE 6679 ("type of prefix: & is not covered", P, Nom_Subt); 6680 Error_Msg_NE 6681 ("\by &, the expected designated type" & 6682 " ('R'M 3.10.2 (27))", P, Designated_Type (Typ)); 6683 end if; 6684 6685 if Is_Class_Wide_Type (Designated_Type (Typ)) 6686 and then Has_Discriminants (Etype (Designated_Type (Typ))) 6687 and then Is_Constrained (Etype (Designated_Type (Typ))) 6688 and then Designated_Type (Typ) /= Nom_Subt 6689 then 6690 Apply_Discriminant_Check 6691 (N, Etype (Designated_Type (Typ))); 6692 end if; 6693 6694 elsif not Subtypes_Statically_Match 6695 (Designated_Type (Base_Type (Typ)), Nom_Subt) 6696 and then 6697 not (Has_Discriminants (Designated_Type (Typ)) 6698 and then 6699 not Is_Constrained 6700 (Designated_Type (Base_Type (Typ)))) 6701 then 6702 Error_Msg_N 6703 ("object subtype must statically match " 6704 & "designated subtype", P); 6705 6706 if Is_Entity_Name (P) 6707 and then Is_Array_Type (Designated_Type (Typ)) 6708 then 6709 6710 declare 6711 D : constant Node_Id := Declaration_Node (Entity (P)); 6712 6713 begin 6714 Error_Msg_N ("aliased object has explicit bounds?", 6715 D); 6716 Error_Msg_N ("\declare without bounds" 6717 & " (and with explicit initialization)?", D); 6718 Error_Msg_N ("\for use with unconstrained access?", D); 6719 end; 6720 end if; 6721 end if; 6722 6723 -- Check the static accessibility rule of 3.10.2(28). 6724 -- Note that this check is not performed for the 6725 -- case of an anonymous access type, since the access 6726 -- attribute is always legal in such a context. 6727 6728 if Attr_Id /= Attribute_Unchecked_Access 6729 and then Object_Access_Level (P) > Type_Access_Level (Btyp) 6730 and then Ekind (Btyp) = E_General_Access_Type 6731 then 6732 -- In an instance, this is a runtime check, but one we 6733 -- know will fail, so generate an appropriate warning. 6734 6735 if In_Instance_Body then 6736 Error_Msg_N 6737 ("?non-local pointer cannot point to local object", P); 6738 Error_Msg_N 6739 ("?Program_Error will be raised at run time", P); 6740 Rewrite (N, 6741 Make_Raise_Program_Error (Loc, 6742 Reason => PE_Accessibility_Check_Failed)); 6743 Set_Etype (N, Typ); 6744 return; 6745 6746 else 6747 Error_Msg_N 6748 ("non-local pointer cannot point to local object", P); 6749 6750 if Is_Record_Type (Current_Scope) 6751 and then (Nkind (Parent (N)) = 6752 N_Discriminant_Association 6753 or else 6754 Nkind (Parent (N)) = 6755 N_Index_Or_Discriminant_Constraint) 6756 then 6757 declare 6758 Indic : Node_Id := Parent (Parent (N)); 6759 6760 begin 6761 while Present (Indic) 6762 and then Nkind (Indic) /= N_Subtype_Indication 6763 loop 6764 Indic := Parent (Indic); 6765 end loop; 6766 6767 if Present (Indic) then 6768 Error_Msg_NE 6769 ("\use an access definition for" & 6770 " the access discriminant of&", N, 6771 Entity (Subtype_Mark (Indic))); 6772 end if; 6773 end; 6774 end if; 6775 end if; 6776 end if; 6777 end if; 6778 6779 if Ekind (Btyp) = E_Access_Protected_Subprogram_Type 6780 and then Is_Entity_Name (P) 6781 and then not Is_Protected_Type (Scope (Entity (P))) 6782 then 6783 Error_Msg_N ("context requires a protected subprogram", P); 6784 6785 elsif Ekind (Btyp) = E_Access_Subprogram_Type 6786 and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type 6787 then 6788 Error_Msg_N ("context requires a non-protected subprogram", P); 6789 end if; 6790 6791 -- The context cannot be a pool-specific type, but this is a 6792 -- legality rule, not a resolution rule, so it must be checked 6793 -- separately, after possibly disambiguation (see AI-245). 6794 6795 if Ekind (Btyp) = E_Access_Type 6796 and then Attr_Id /= Attribute_Unrestricted_Access 6797 then 6798 Wrong_Type (N, Typ); 6799 end if; 6800 6801 Set_Etype (N, Typ); 6802 6803 -- Check for incorrect atomic/volatile reference (RM C.6(12)) 6804 6805 if Attr_Id /= Attribute_Unrestricted_Access then 6806 if Is_Atomic_Object (P) 6807 and then not Is_Atomic (Designated_Type (Typ)) 6808 then 6809 Error_Msg_N 6810 ("access to atomic object cannot yield access-to-" & 6811 "non-atomic type", P); 6812 6813 elsif Is_Volatile_Object (P) 6814 and then not Is_Volatile (Designated_Type (Typ)) 6815 then 6816 Error_Msg_N 6817 ("access to volatile object cannot yield access-to-" & 6818 "non-volatile type", P); 6819 end if; 6820 end if; 6821 6822 ------------- 6823 -- Address -- 6824 ------------- 6825 6826 -- Deal with resolving the type for Address attribute, overloading 6827 -- is not permitted here, since there is no context to resolve it. 6828 6829 when Attribute_Address | Attribute_Code_Address => 6830 6831 -- To be safe, assume that if the address of a variable is taken, 6832 -- it may be modified via this address, so note modification. 6833 6834 if Is_Variable (P) then 6835 Note_Possible_Modification (P); 6836 end if; 6837 6838 if Nkind (P) in N_Subexpr 6839 and then Is_Overloaded (P) 6840 then 6841 Get_First_Interp (P, Index, It); 6842 Get_Next_Interp (Index, It); 6843 6844 if Present (It.Nam) then 6845 Error_Msg_Name_1 := Aname; 6846 Error_Msg_N 6847 ("prefix of % attribute cannot be overloaded", N); 6848 return; 6849 end if; 6850 end if; 6851 6852 if not Is_Entity_Name (P) 6853 or else not Is_Overloadable (Entity (P)) 6854 then 6855 if not Is_Task_Type (Etype (P)) 6856 or else Nkind (P) = N_Explicit_Dereference 6857 then 6858 Resolve (P); 6859 end if; 6860 end if; 6861 6862 -- If this is the name of a derived subprogram, or that of a 6863 -- generic actual, the address is that of the original entity. 6864 6865 if Is_Entity_Name (P) 6866 and then Is_Overloadable (Entity (P)) 6867 and then Present (Alias (Entity (P))) 6868 then 6869 Rewrite (P, 6870 New_Occurrence_Of (Alias (Entity (P)), Sloc (P))); 6871 end if; 6872 6873 --------------- 6874 -- AST_Entry -- 6875 --------------- 6876 6877 -- Prefix of the AST_Entry attribute is an entry name which must 6878 -- not be resolved, since this is definitely not an entry call. 6879 6880 when Attribute_AST_Entry => 6881 null; 6882 6883 ------------------ 6884 -- Body_Version -- 6885 ------------------ 6886 6887 -- Prefix of Body_Version attribute can be a subprogram name which 6888 -- must not be resolved, since this is not a call. 6889 6890 when Attribute_Body_Version => 6891 null; 6892 6893 ------------ 6894 -- Caller -- 6895 ------------ 6896 6897 -- Prefix of Caller attribute is an entry name which must not 6898 -- be resolved, since this is definitely not an entry call. 6899 6900 when Attribute_Caller => 6901 null; 6902 6903 ------------------ 6904 -- Code_Address -- 6905 ------------------ 6906 6907 -- Shares processing with Address attribute 6908 6909 ----------- 6910 -- Count -- 6911 ----------- 6912 6913 -- If the prefix of the Count attribute is an entry name it must not 6914 -- be resolved, since this is definitely not an entry call. However, 6915 -- if it is an element of an entry family, the index itself may 6916 -- have to be resolved because it can be a general expression. 6917 6918 when Attribute_Count => 6919 if Nkind (P) = N_Indexed_Component 6920 and then Is_Entity_Name (Prefix (P)) 6921 then 6922 declare 6923 Indx : constant Node_Id := First (Expressions (P)); 6924 Fam : constant Entity_Id := Entity (Prefix (P)); 6925 begin 6926 Resolve (Indx, Entry_Index_Type (Fam)); 6927 Apply_Range_Check (Indx, Entry_Index_Type (Fam)); 6928 end; 6929 end if; 6930 6931 ---------------- 6932 -- Elaborated -- 6933 ---------------- 6934 6935 -- Prefix of the Elaborated attribute is a subprogram name which 6936 -- must not be resolved, since this is definitely not a call. Note 6937 -- that it is a library unit, so it cannot be overloaded here. 6938 6939 when Attribute_Elaborated => 6940 null; 6941 6942 -------------------- 6943 -- Mechanism_Code -- 6944 -------------------- 6945 6946 -- Prefix of the Mechanism_Code attribute is a function name 6947 -- which must not be resolved. Should we check for overloaded ??? 6948 6949 when Attribute_Mechanism_Code => 6950 null; 6951 6952 ------------------ 6953 -- Partition_ID -- 6954 ------------------ 6955 6956 -- Most processing is done in sem_dist, after determining the 6957 -- context type. Node is rewritten as a conversion to a runtime call. 6958 6959 when Attribute_Partition_ID => 6960 Process_Partition_Id (N); 6961 return; 6962 6963 when Attribute_Pool_Address => 6964 Resolve (P); 6965 6966 ----------- 6967 -- Range -- 6968 ----------- 6969 6970 -- We replace the Range attribute node with a range expression 6971 -- whose bounds are the 'First and 'Last attributes applied to the 6972 -- same prefix. The reason that we do this transformation here 6973 -- instead of in the expander is that it simplifies other parts of 6974 -- the semantic analysis which assume that the Range has been 6975 -- replaced; thus it must be done even when in semantic-only mode 6976 -- (note that the RM specifically mentions this equivalence, we 6977 -- take care that the prefix is only evaluated once). 6978 6979 when Attribute_Range => Range_Attribute : 6980 declare 6981 LB : Node_Id; 6982 HB : Node_Id; 6983 6984 function Check_Discriminated_Prival 6985 (N : Node_Id) 6986 return Node_Id; 6987 -- The range of a private component constrained by a 6988 -- discriminant is rewritten to make the discriminant 6989 -- explicit. This solves some complex visibility problems 6990 -- related to the use of privals. 6991 6992 -------------------------------- 6993 -- Check_Discriminated_Prival -- 6994 -------------------------------- 6995 6996 function Check_Discriminated_Prival 6997 (N : Node_Id) 6998 return Node_Id 6999 is 7000 begin 7001 if Is_Entity_Name (N) 7002 and then Ekind (Entity (N)) = E_In_Parameter 7003 and then not Within_Init_Proc 7004 then 7005 return Make_Identifier (Sloc (N), Chars (Entity (N))); 7006 else 7007 return Duplicate_Subexpr (N); 7008 end if; 7009 end Check_Discriminated_Prival; 7010 7011 -- Start of processing for Range_Attribute 7012 7013 begin 7014 if not Is_Entity_Name (P) 7015 or else not Is_Type (Entity (P)) 7016 then 7017 Resolve (P); 7018 end if; 7019 7020 -- Check whether prefix is (renaming of) private component 7021 -- of protected type. 7022 7023 if Is_Entity_Name (P) 7024 and then Comes_From_Source (N) 7025 and then Is_Array_Type (Etype (P)) 7026 and then Number_Dimensions (Etype (P)) = 1 7027 and then (Ekind (Scope (Entity (P))) = E_Protected_Type 7028 or else 7029 Ekind (Scope (Scope (Entity (P)))) = 7030 E_Protected_Type) 7031 then 7032 LB := 7033 Check_Discriminated_Prival 7034 (Type_Low_Bound (Etype (First_Index (Etype (P))))); 7035 7036 HB := 7037 Check_Discriminated_Prival 7038 (Type_High_Bound (Etype (First_Index (Etype (P))))); 7039 7040 else 7041 HB := 7042 Make_Attribute_Reference (Loc, 7043 Prefix => Duplicate_Subexpr (P), 7044 Attribute_Name => Name_Last, 7045 Expressions => Expressions (N)); 7046 7047 LB := 7048 Make_Attribute_Reference (Loc, 7049 Prefix => P, 7050 Attribute_Name => Name_First, 7051 Expressions => Expressions (N)); 7052 end if; 7053 7054 -- If the original was marked as Must_Not_Freeze (see code 7055 -- in Sem_Ch3.Make_Index), then make sure the rewriting 7056 -- does not freeze either. 7057 7058 if Must_Not_Freeze (N) then 7059 Set_Must_Not_Freeze (HB); 7060 Set_Must_Not_Freeze (LB); 7061 Set_Must_Not_Freeze (Prefix (HB)); 7062 Set_Must_Not_Freeze (Prefix (LB)); 7063 end if; 7064 7065 if Raises_Constraint_Error (Prefix (N)) then 7066 7067 -- Preserve Sloc of prefix in the new bounds, so that 7068 -- the posted warning can be removed if we are within 7069 -- unreachable code. 7070 7071 Set_Sloc (LB, Sloc (Prefix (N))); 7072 Set_Sloc (HB, Sloc (Prefix (N))); 7073 end if; 7074 7075 Rewrite (N, Make_Range (Loc, LB, HB)); 7076 Analyze_And_Resolve (N, Typ); 7077 7078 -- Normally after resolving attribute nodes, Eval_Attribute 7079 -- is called to do any possible static evaluation of the node. 7080 -- However, here since the Range attribute has just been 7081 -- transformed into a range expression it is no longer an 7082 -- attribute node and therefore the call needs to be avoided 7083 -- and is accomplished by simply returning from the procedure. 7084 7085 return; 7086 end Range_Attribute; 7087 7088 ----------------- 7089 -- UET_Address -- 7090 ----------------- 7091 7092 -- Prefix must not be resolved in this case, since it is not a 7093 -- real entity reference. No action of any kind is require! 7094 7095 when Attribute_UET_Address => 7096 return; 7097 7098 ---------------------- 7099 -- Unchecked_Access -- 7100 ---------------------- 7101 7102 -- Processing is shared with Access 7103 7104 ------------------------- 7105 -- Unrestricted_Access -- 7106 ------------------------- 7107 7108 -- Processing is shared with Access 7109 7110 --------- 7111 -- Val -- 7112 --------- 7113 7114 -- Apply range check. Note that we did not do this during the 7115 -- analysis phase, since we wanted Eval_Attribute to have a 7116 -- chance at finding an illegal out of range value. 7117 7118 when Attribute_Val => 7119 7120 -- Note that we do our own Eval_Attribute call here rather than 7121 -- use the common one, because we need to do processing after 7122 -- the call, as per above comment. 7123 7124 Eval_Attribute (N); 7125 7126 -- Eval_Attribute may replace the node with a raise CE, or 7127 -- fold it to a constant. Obviously we only apply a scalar 7128 -- range check if this did not happen! 7129 7130 if Nkind (N) = N_Attribute_Reference 7131 and then Attribute_Name (N) = Name_Val 7132 then 7133 Apply_Scalar_Range_Check (First (Expressions (N)), Btyp); 7134 end if; 7135 7136 return; 7137 7138 ------------- 7139 -- Version -- 7140 ------------- 7141 7142 -- Prefix of Version attribute can be a subprogram name which 7143 -- must not be resolved, since this is not a call. 7144 7145 when Attribute_Version => 7146 null; 7147 7148 ---------------------- 7149 -- Other Attributes -- 7150 ---------------------- 7151 7152 -- For other attributes, resolve prefix unless it is a type. If 7153 -- the attribute reference itself is a type name ('Base and 'Class) 7154 -- then this is only legal within a task or protected record. 7155 7156 when others => 7157 if not Is_Entity_Name (P) 7158 or else not Is_Type (Entity (P)) 7159 then 7160 Resolve (P); 7161 end if; 7162 7163 -- If the attribute reference itself is a type name ('Base, 7164 -- 'Class) then this is only legal within a task or protected 7165 -- record. What is this all about ??? 7166 7167 if Is_Entity_Name (N) 7168 and then Is_Type (Entity (N)) 7169 then 7170 if Is_Concurrent_Type (Entity (N)) 7171 and then In_Open_Scopes (Entity (P)) 7172 then 7173 null; 7174 else 7175 Error_Msg_N 7176 ("invalid use of subtype name in expression or call", N); 7177 end if; 7178 end if; 7179 7180 -- For attributes whose argument may be a string, complete 7181 -- resolution of argument now. This avoids premature expansion 7182 -- (and the creation of transient scopes) before the attribute 7183 -- reference is resolved. 7184 7185 case Attr_Id is 7186 when Attribute_Value => 7187 Resolve (First (Expressions (N)), Standard_String); 7188 7189 when Attribute_Wide_Value => 7190 Resolve (First (Expressions (N)), Standard_Wide_String); 7191 7192 when others => null; 7193 end case; 7194 end case; 7195 7196 -- Normally the Freezing is done by Resolve but sometimes the Prefix 7197 -- is not resolved, in which case the freezing must be done now. 7198 7199 Freeze_Expression (P); 7200 7201 -- Finally perform static evaluation on the attribute reference 7202 7203 Eval_Attribute (N); 7204 7205 end Resolve_Attribute; 7206 7207end Sem_Attr; 7208