1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ A T T R -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Checks; use Checks; 28with Einfo; use Einfo; 29with Elists; use Elists; 30with Exp_Atag; use Exp_Atag; 31with Exp_Ch2; use Exp_Ch2; 32with Exp_Ch3; use Exp_Ch3; 33with Exp_Ch6; use Exp_Ch6; 34with Exp_Ch9; use Exp_Ch9; 35with Exp_Dist; use Exp_Dist; 36with Exp_Imgv; use Exp_Imgv; 37with Exp_Pakd; use Exp_Pakd; 38with Exp_Strm; use Exp_Strm; 39with Exp_Tss; use Exp_Tss; 40with Exp_Util; use Exp_Util; 41with Exp_VFpt; use Exp_VFpt; 42with Fname; use Fname; 43with Freeze; use Freeze; 44with Gnatvsn; use Gnatvsn; 45with Itypes; use Itypes; 46with Lib; use Lib; 47with Namet; use Namet; 48with Nmake; use Nmake; 49with Nlists; use Nlists; 50with Opt; use Opt; 51with Restrict; use Restrict; 52with Rident; use Rident; 53with Rtsfind; use Rtsfind; 54with Sem; use Sem; 55with Sem_Aux; use Sem_Aux; 56with Sem_Ch6; use Sem_Ch6; 57with Sem_Ch7; use Sem_Ch7; 58with Sem_Ch8; use Sem_Ch8; 59with Sem_Eval; use Sem_Eval; 60with Sem_Res; use Sem_Res; 61with Sem_Util; use Sem_Util; 62with Sinfo; use Sinfo; 63with Snames; use Snames; 64with Stand; use Stand; 65with Stringt; use Stringt; 66with Targparm; use Targparm; 67with Tbuild; use Tbuild; 68with Ttypes; use Ttypes; 69with Uintp; use Uintp; 70with Uname; use Uname; 71with Validsw; use Validsw; 72 73package body Exp_Attr is 74 75 ----------------------- 76 -- Local Subprograms -- 77 ----------------------- 78 79 function Build_Array_VS_Func 80 (A_Type : Entity_Id; 81 Nod : Node_Id) return Entity_Id; 82 -- Build function to test Valid_Scalars for array type A_Type. Nod is the 83 -- Valid_Scalars attribute node, used to insert the function body, and the 84 -- value returned is the entity of the constructed function body. We do not 85 -- bother to generate a separate spec for this subprogram. 86 87 procedure Compile_Stream_Body_In_Scope 88 (N : Node_Id; 89 Decl : Node_Id; 90 Arr : Entity_Id; 91 Check : Boolean); 92 -- The body for a stream subprogram may be generated outside of the scope 93 -- of the type. If the type is fully private, it may depend on the full 94 -- view of other types (e.g. indexes) that are currently private as well. 95 -- We install the declarations of the package in which the type is declared 96 -- before compiling the body in what is its proper environment. The Check 97 -- parameter indicates if checks are to be suppressed for the stream body. 98 -- We suppress checks for array/record reads, since the rule is that these 99 -- are like assignments, out of range values due to uninitialized storage, 100 -- or other invalid values do NOT cause a Constraint_Error to be raised. 101 102 procedure Expand_Access_To_Protected_Op 103 (N : Node_Id; 104 Pref : Node_Id; 105 Typ : Entity_Id); 106 -- An attribute reference to a protected subprogram is transformed into 107 -- a pair of pointers: one to the object, and one to the operations. 108 -- This expansion is performed for 'Access and for 'Unrestricted_Access. 109 110 procedure Expand_Fpt_Attribute 111 (N : Node_Id; 112 Pkg : RE_Id; 113 Nam : Name_Id; 114 Args : List_Id); 115 -- This procedure expands a call to a floating-point attribute function. 116 -- N is the attribute reference node, and Args is a list of arguments to 117 -- be passed to the function call. Pkg identifies the package containing 118 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args 119 -- have already been converted to the floating-point type for which Pkg was 120 -- instantiated. The Nam argument is the relevant attribute processing 121 -- routine to be called. This is the same as the attribute name, except in 122 -- the Unaligned_Valid case. 123 124 procedure Expand_Fpt_Attribute_R (N : Node_Id); 125 -- This procedure expands a call to a floating-point attribute function 126 -- that takes a single floating-point argument. The function to be called 127 -- is always the same as the attribute name. 128 129 procedure Expand_Fpt_Attribute_RI (N : Node_Id); 130 -- This procedure expands a call to a floating-point attribute function 131 -- that takes one floating-point argument and one integer argument. The 132 -- function to be called is always the same as the attribute name. 133 134 procedure Expand_Fpt_Attribute_RR (N : Node_Id); 135 -- This procedure expands a call to a floating-point attribute function 136 -- that takes two floating-point arguments. The function to be called 137 -- is always the same as the attribute name. 138 139 procedure Expand_Loop_Entry_Attribute (N : Node_Id); 140 -- Handle the expansion of attribute 'Loop_Entry. As a result, the related 141 -- loop may be converted into a conditional block. See body for details. 142 143 procedure Expand_Min_Max_Attribute (N : Node_Id); 144 -- Handle the expansion of attributes 'Max and 'Min, including expanding 145 -- then out if we are in Modify_Tree_For_C mode. 146 147 procedure Expand_Pred_Succ_Attribute (N : Node_Id); 148 -- Handles expansion of Pred or Succ attributes for case of non-real 149 -- operand with overflow checking required. 150 151 procedure Expand_Update_Attribute (N : Node_Id); 152 -- Handle the expansion of attribute Update 153 154 function Get_Index_Subtype (N : Node_Id) return Entity_Id; 155 -- Used for Last, Last, and Length, when the prefix is an array type. 156 -- Obtains the corresponding index subtype. 157 158 procedure Find_Fat_Info 159 (T : Entity_Id; 160 Fat_Type : out Entity_Id; 161 Fat_Pkg : out RE_Id); 162 -- Given a floating-point type T, identifies the package containing the 163 -- attributes for this type (returned in Fat_Pkg), and the corresponding 164 -- type for which this package was instantiated from Fat_Gen. Error if T 165 -- is not a floating-point type. 166 167 function Find_Stream_Subprogram 168 (Typ : Entity_Id; 169 Nam : TSS_Name_Type) return Entity_Id; 170 -- Returns the stream-oriented subprogram attribute for Typ. For tagged 171 -- types, the corresponding primitive operation is looked up, else the 172 -- appropriate TSS from the type itself, or from its closest ancestor 173 -- defining it, is returned. In both cases, inheritance of representation 174 -- aspects is thus taken into account. 175 176 function Full_Base (T : Entity_Id) return Entity_Id; 177 -- The stream functions need to examine the underlying representation of 178 -- composite types. In some cases T may be non-private but its base type 179 -- is, in which case the function returns the corresponding full view. 180 181 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id; 182 -- Given a type, find a corresponding stream convert pragma that applies to 183 -- the implementation base type of this type (Typ). If found, return the 184 -- pragma node, otherwise return Empty if no pragma is found. 185 186 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean; 187 -- Utility for array attributes, returns true on packed constrained 188 -- arrays, and on access to same. 189 190 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean; 191 -- Returns true iff the given node refers to an attribute call that 192 -- can be expanded directly by the back end and does not need front end 193 -- expansion. Typically used for rounding and truncation attributes that 194 -- appear directly inside a conversion to integer. 195 196 ------------------------- 197 -- Build_Array_VS_Func -- 198 ------------------------- 199 200 function Build_Array_VS_Func 201 (A_Type : Entity_Id; 202 Nod : Node_Id) return Entity_Id 203 is 204 Loc : constant Source_Ptr := Sloc (Nod); 205 Comp_Type : constant Entity_Id := Component_Type (A_Type); 206 Body_Stmts : List_Id; 207 Index_List : List_Id; 208 Func_Id : Entity_Id; 209 Formals : List_Id; 210 211 function Test_Component return List_Id; 212 -- Create one statement to test validity of one component designated by 213 -- a full set of indexes. Returns statement list containing test. 214 215 function Test_One_Dimension (N : Int) return List_Id; 216 -- Create loop to test one dimension of the array. The single statement 217 -- in the loop body tests the inner dimensions if any, or else the 218 -- single component. Note that this procedure is called recursively, 219 -- with N being the dimension to be initialized. A call with N greater 220 -- than the number of dimensions simply generates the component test, 221 -- terminating the recursion. Returns statement list containing tests. 222 223 -------------------- 224 -- Test_Component -- 225 -------------------- 226 227 function Test_Component return List_Id is 228 Comp : Node_Id; 229 Anam : Name_Id; 230 231 begin 232 Comp := 233 Make_Indexed_Component (Loc, 234 Prefix => Make_Identifier (Loc, Name_uA), 235 Expressions => Index_List); 236 237 if Is_Scalar_Type (Comp_Type) then 238 Anam := Name_Valid; 239 else 240 Anam := Name_Valid_Scalars; 241 end if; 242 243 return New_List ( 244 Make_If_Statement (Loc, 245 Condition => 246 Make_Op_Not (Loc, 247 Right_Opnd => 248 Make_Attribute_Reference (Loc, 249 Attribute_Name => Anam, 250 Prefix => Comp)), 251 Then_Statements => New_List ( 252 Make_Simple_Return_Statement (Loc, 253 Expression => New_Occurrence_Of (Standard_False, Loc))))); 254 end Test_Component; 255 256 ------------------------ 257 -- Test_One_Dimension -- 258 ------------------------ 259 260 function Test_One_Dimension (N : Int) return List_Id is 261 Index : Entity_Id; 262 263 begin 264 -- If all dimensions dealt with, we simply test the component 265 266 if N > Number_Dimensions (A_Type) then 267 return Test_Component; 268 269 -- Here we generate the required loop 270 271 else 272 Index := 273 Make_Defining_Identifier (Loc, New_External_Name ('J', N)); 274 275 Append (New_Occurrence_Of (Index, Loc), Index_List); 276 277 return New_List ( 278 Make_Implicit_Loop_Statement (Nod, 279 Identifier => Empty, 280 Iteration_Scheme => 281 Make_Iteration_Scheme (Loc, 282 Loop_Parameter_Specification => 283 Make_Loop_Parameter_Specification (Loc, 284 Defining_Identifier => Index, 285 Discrete_Subtype_Definition => 286 Make_Attribute_Reference (Loc, 287 Prefix => Make_Identifier (Loc, Name_uA), 288 Attribute_Name => Name_Range, 289 Expressions => New_List ( 290 Make_Integer_Literal (Loc, N))))), 291 Statements => Test_One_Dimension (N + 1)), 292 Make_Simple_Return_Statement (Loc, 293 Expression => New_Occurrence_Of (Standard_True, Loc))); 294 end if; 295 end Test_One_Dimension; 296 297 -- Start of processing for Build_Array_VS_Func 298 299 begin 300 Index_List := New_List; 301 Func_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('V')); 302 303 Body_Stmts := Test_One_Dimension (1); 304 305 -- Parameter is always (A : A_Typ) 306 307 Formals := New_List ( 308 Make_Parameter_Specification (Loc, 309 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uA), 310 In_Present => True, 311 Out_Present => False, 312 Parameter_Type => New_Occurrence_Of (A_Type, Loc))); 313 314 -- Build body 315 316 Set_Ekind (Func_Id, E_Function); 317 Set_Is_Internal (Func_Id); 318 319 Insert_Action (Nod, 320 Make_Subprogram_Body (Loc, 321 Specification => 322 Make_Function_Specification (Loc, 323 Defining_Unit_Name => Func_Id, 324 Parameter_Specifications => Formals, 325 Result_Definition => 326 New_Occurrence_Of (Standard_Boolean, Loc)), 327 Declarations => New_List, 328 Handled_Statement_Sequence => 329 Make_Handled_Sequence_Of_Statements (Loc, 330 Statements => Body_Stmts))); 331 332 if not Debug_Generated_Code then 333 Set_Debug_Info_Off (Func_Id); 334 end if; 335 336 return Func_Id; 337 end Build_Array_VS_Func; 338 339 ---------------------------------- 340 -- Compile_Stream_Body_In_Scope -- 341 ---------------------------------- 342 343 procedure Compile_Stream_Body_In_Scope 344 (N : Node_Id; 345 Decl : Node_Id; 346 Arr : Entity_Id; 347 Check : Boolean) 348 is 349 Installed : Boolean := False; 350 Scop : constant Entity_Id := Scope (Arr); 351 Curr : constant Entity_Id := Current_Scope; 352 353 begin 354 if Is_Hidden (Arr) 355 and then not In_Open_Scopes (Scop) 356 and then Ekind (Scop) = E_Package 357 then 358 Push_Scope (Scop); 359 Install_Visible_Declarations (Scop); 360 Install_Private_Declarations (Scop); 361 Installed := True; 362 363 -- The entities in the package are now visible, but the generated 364 -- stream entity must appear in the current scope (usually an 365 -- enclosing stream function) so that itypes all have their proper 366 -- scopes. 367 368 Push_Scope (Curr); 369 end if; 370 371 if Check then 372 Insert_Action (N, Decl); 373 else 374 Insert_Action (N, Decl, Suppress => All_Checks); 375 end if; 376 377 if Installed then 378 379 -- Remove extra copy of current scope, and package itself 380 381 Pop_Scope; 382 End_Package_Scope (Scop); 383 end if; 384 end Compile_Stream_Body_In_Scope; 385 386 ----------------------------------- 387 -- Expand_Access_To_Protected_Op -- 388 ----------------------------------- 389 390 procedure Expand_Access_To_Protected_Op 391 (N : Node_Id; 392 Pref : Node_Id; 393 Typ : Entity_Id) 394 is 395 -- The value of the attribute_reference is a record containing two 396 -- fields: an access to the protected object, and an access to the 397 -- subprogram itself. The prefix is a selected component. 398 399 Loc : constant Source_Ptr := Sloc (N); 400 Agg : Node_Id; 401 Btyp : constant Entity_Id := Base_Type (Typ); 402 Sub : Entity_Id; 403 Sub_Ref : Node_Id; 404 E_T : constant Entity_Id := Equivalent_Type (Btyp); 405 Acc : constant Entity_Id := 406 Etype (Next_Component (First_Component (E_T))); 407 Obj_Ref : Node_Id; 408 Curr : Entity_Id; 409 410 function May_Be_External_Call return Boolean; 411 -- If the 'Access is to a local operation, but appears in a context 412 -- where it may lead to a call from outside the object, we must treat 413 -- this as an external call. Clearly we cannot tell without full 414 -- flow analysis, and a subsequent call that uses this 'Access may 415 -- lead to a bounded error (trying to seize locks twice, e.g.). For 416 -- now we treat 'Access as a potential external call if it is an actual 417 -- in a call to an outside subprogram. 418 419 -------------------------- 420 -- May_Be_External_Call -- 421 -------------------------- 422 423 function May_Be_External_Call return Boolean is 424 Subp : Entity_Id; 425 Par : Node_Id := Parent (N); 426 427 begin 428 -- Account for the case where the Access attribute is part of a 429 -- named parameter association. 430 431 if Nkind (Par) = N_Parameter_Association then 432 Par := Parent (Par); 433 end if; 434 435 if Nkind (Par) in N_Subprogram_Call 436 and then Is_Entity_Name (Name (Par)) 437 then 438 Subp := Entity (Name (Par)); 439 return not In_Open_Scopes (Scope (Subp)); 440 else 441 return False; 442 end if; 443 end May_Be_External_Call; 444 445 -- Start of processing for Expand_Access_To_Protected_Op 446 447 begin 448 -- Within the body of the protected type, the prefix designates a local 449 -- operation, and the object is the first parameter of the corresponding 450 -- protected body of the current enclosing operation. 451 452 if Is_Entity_Name (Pref) then 453 if May_Be_External_Call then 454 Sub := 455 New_Occurrence_Of (External_Subprogram (Entity (Pref)), Loc); 456 else 457 Sub := 458 New_Occurrence_Of 459 (Protected_Body_Subprogram (Entity (Pref)), Loc); 460 end if; 461 462 -- Don't traverse the scopes when the attribute occurs within an init 463 -- proc, because we directly use the _init formal of the init proc in 464 -- that case. 465 466 Curr := Current_Scope; 467 if not Is_Init_Proc (Curr) then 468 pragma Assert (In_Open_Scopes (Scope (Entity (Pref)))); 469 470 while Scope (Curr) /= Scope (Entity (Pref)) loop 471 Curr := Scope (Curr); 472 end loop; 473 end if; 474 475 -- In case of protected entries the first formal of its Protected_ 476 -- Body_Subprogram is the address of the object. 477 478 if Ekind (Curr) = E_Entry then 479 Obj_Ref := 480 New_Occurrence_Of 481 (First_Formal 482 (Protected_Body_Subprogram (Curr)), Loc); 483 484 -- If the current scope is an init proc, then use the address of the 485 -- _init formal as the object reference. 486 487 elsif Is_Init_Proc (Curr) then 488 Obj_Ref := 489 Make_Attribute_Reference (Loc, 490 Prefix => New_Occurrence_Of (First_Formal (Curr), Loc), 491 Attribute_Name => Name_Address); 492 493 -- In case of protected subprograms the first formal of its 494 -- Protected_Body_Subprogram is the object and we get its address. 495 496 else 497 Obj_Ref := 498 Make_Attribute_Reference (Loc, 499 Prefix => 500 New_Occurrence_Of 501 (First_Formal 502 (Protected_Body_Subprogram (Curr)), Loc), 503 Attribute_Name => Name_Address); 504 end if; 505 506 -- Case where the prefix is not an entity name. Find the 507 -- version of the protected operation to be called from 508 -- outside the protected object. 509 510 else 511 Sub := 512 New_Occurrence_Of 513 (External_Subprogram 514 (Entity (Selector_Name (Pref))), Loc); 515 516 Obj_Ref := 517 Make_Attribute_Reference (Loc, 518 Prefix => Relocate_Node (Prefix (Pref)), 519 Attribute_Name => Name_Address); 520 end if; 521 522 Sub_Ref := 523 Make_Attribute_Reference (Loc, 524 Prefix => Sub, 525 Attribute_Name => Name_Access); 526 527 -- We set the type of the access reference to the already generated 528 -- access_to_subprogram type, and declare the reference analyzed, to 529 -- prevent further expansion when the enclosing aggregate is analyzed. 530 531 Set_Etype (Sub_Ref, Acc); 532 Set_Analyzed (Sub_Ref); 533 534 Agg := 535 Make_Aggregate (Loc, 536 Expressions => New_List (Obj_Ref, Sub_Ref)); 537 538 -- Sub_Ref has been marked as analyzed, but we still need to make sure 539 -- Sub is correctly frozen. 540 541 Freeze_Before (N, Entity (Sub)); 542 543 Rewrite (N, Agg); 544 Analyze_And_Resolve (N, E_T); 545 546 -- For subsequent analysis, the node must retain its type. The backend 547 -- will replace it with the equivalent type where needed. 548 549 Set_Etype (N, Typ); 550 end Expand_Access_To_Protected_Op; 551 552 -------------------------- 553 -- Expand_Fpt_Attribute -- 554 -------------------------- 555 556 procedure Expand_Fpt_Attribute 557 (N : Node_Id; 558 Pkg : RE_Id; 559 Nam : Name_Id; 560 Args : List_Id) 561 is 562 Loc : constant Source_Ptr := Sloc (N); 563 Typ : constant Entity_Id := Etype (N); 564 Fnm : Node_Id; 565 566 begin 567 -- The function name is the selected component Attr_xxx.yyy where 568 -- Attr_xxx is the package name, and yyy is the argument Nam. 569 570 -- Note: it would be more usual to have separate RE entries for each 571 -- of the entities in the Fat packages, but first they have identical 572 -- names (so we would have to have lots of renaming declarations to 573 -- meet the normal RE rule of separate names for all runtime entities), 574 -- and second there would be an awful lot of them. 575 576 Fnm := 577 Make_Selected_Component (Loc, 578 Prefix => New_Occurrence_Of (RTE (Pkg), Loc), 579 Selector_Name => Make_Identifier (Loc, Nam)); 580 581 -- The generated call is given the provided set of parameters, and then 582 -- wrapped in a conversion which converts the result to the target type 583 -- We use the base type as the target because a range check may be 584 -- required. 585 586 Rewrite (N, 587 Unchecked_Convert_To (Base_Type (Etype (N)), 588 Make_Function_Call (Loc, 589 Name => Fnm, 590 Parameter_Associations => Args))); 591 592 Analyze_And_Resolve (N, Typ); 593 end Expand_Fpt_Attribute; 594 595 ---------------------------- 596 -- Expand_Fpt_Attribute_R -- 597 ---------------------------- 598 599 -- The single argument is converted to its root type to call the 600 -- appropriate runtime function, with the actual call being built 601 -- by Expand_Fpt_Attribute 602 603 procedure Expand_Fpt_Attribute_R (N : Node_Id) is 604 E1 : constant Node_Id := First (Expressions (N)); 605 Ftp : Entity_Id; 606 Pkg : RE_Id; 607 begin 608 Find_Fat_Info (Etype (E1), Ftp, Pkg); 609 Expand_Fpt_Attribute 610 (N, Pkg, Attribute_Name (N), 611 New_List (Unchecked_Convert_To (Ftp, Relocate_Node (E1)))); 612 end Expand_Fpt_Attribute_R; 613 614 ----------------------------- 615 -- Expand_Fpt_Attribute_RI -- 616 ----------------------------- 617 618 -- The first argument is converted to its root type and the second 619 -- argument is converted to standard long long integer to call the 620 -- appropriate runtime function, with the actual call being built 621 -- by Expand_Fpt_Attribute 622 623 procedure Expand_Fpt_Attribute_RI (N : Node_Id) is 624 E1 : constant Node_Id := First (Expressions (N)); 625 Ftp : Entity_Id; 626 Pkg : RE_Id; 627 E2 : constant Node_Id := Next (E1); 628 begin 629 Find_Fat_Info (Etype (E1), Ftp, Pkg); 630 Expand_Fpt_Attribute 631 (N, Pkg, Attribute_Name (N), 632 New_List ( 633 Unchecked_Convert_To (Ftp, Relocate_Node (E1)), 634 Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2)))); 635 end Expand_Fpt_Attribute_RI; 636 637 ----------------------------- 638 -- Expand_Fpt_Attribute_RR -- 639 ----------------------------- 640 641 -- The two arguments are converted to their root types to call the 642 -- appropriate runtime function, with the actual call being built 643 -- by Expand_Fpt_Attribute 644 645 procedure Expand_Fpt_Attribute_RR (N : Node_Id) is 646 E1 : constant Node_Id := First (Expressions (N)); 647 E2 : constant Node_Id := Next (E1); 648 Ftp : Entity_Id; 649 Pkg : RE_Id; 650 651 begin 652 Find_Fat_Info (Etype (E1), Ftp, Pkg); 653 Expand_Fpt_Attribute 654 (N, Pkg, Attribute_Name (N), 655 New_List ( 656 Unchecked_Convert_To (Ftp, Relocate_Node (E1)), 657 Unchecked_Convert_To (Ftp, Relocate_Node (E2)))); 658 end Expand_Fpt_Attribute_RR; 659 660 --------------------------------- 661 -- Expand_Loop_Entry_Attribute -- 662 --------------------------------- 663 664 procedure Expand_Loop_Entry_Attribute (N : Node_Id) is 665 procedure Build_Conditional_Block 666 (Loc : Source_Ptr; 667 Cond : Node_Id; 668 Loop_Stmt : Node_Id; 669 If_Stmt : out Node_Id; 670 Blk_Stmt : out Node_Id); 671 -- Create a block Blk_Stmt with an empty declarative list and a single 672 -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with 673 -- condition Cond. If_Stmt is Empty when there is no condition provided. 674 675 function Is_Array_Iteration (N : Node_Id) return Boolean; 676 -- Determine whether loop statement N denotes an Ada 2012 iteration over 677 -- an array object. 678 679 ----------------------------- 680 -- Build_Conditional_Block -- 681 ----------------------------- 682 683 procedure Build_Conditional_Block 684 (Loc : Source_Ptr; 685 Cond : Node_Id; 686 Loop_Stmt : Node_Id; 687 If_Stmt : out Node_Id; 688 Blk_Stmt : out Node_Id) 689 is 690 begin 691 -- Do not reanalyze the original loop statement because it is simply 692 -- being relocated. 693 694 Set_Analyzed (Loop_Stmt); 695 696 Blk_Stmt := 697 Make_Block_Statement (Loc, 698 Declarations => New_List, 699 Handled_Statement_Sequence => 700 Make_Handled_Sequence_Of_Statements (Loc, 701 Statements => New_List (Loop_Stmt))); 702 703 if Present (Cond) then 704 If_Stmt := 705 Make_If_Statement (Loc, 706 Condition => Cond, 707 Then_Statements => New_List (Blk_Stmt)); 708 else 709 If_Stmt := Empty; 710 end if; 711 end Build_Conditional_Block; 712 713 ------------------------ 714 -- Is_Array_Iteration -- 715 ------------------------ 716 717 function Is_Array_Iteration (N : Node_Id) return Boolean is 718 Stmt : constant Node_Id := Original_Node (N); 719 Iter : Node_Id; 720 721 begin 722 if Nkind (Stmt) = N_Loop_Statement 723 and then Present (Iteration_Scheme (Stmt)) 724 and then Present (Iterator_Specification (Iteration_Scheme (Stmt))) 725 then 726 Iter := Iterator_Specification (Iteration_Scheme (Stmt)); 727 728 return 729 Of_Present (Iter) and then Is_Array_Type (Etype (Name (Iter))); 730 end if; 731 732 return False; 733 end Is_Array_Iteration; 734 735 -- Local variables 736 737 Exprs : constant List_Id := Expressions (N); 738 Pref : constant Node_Id := Prefix (N); 739 Typ : constant Entity_Id := Etype (Pref); 740 Blk : Node_Id; 741 Decls : List_Id; 742 Installed : Boolean; 743 Loc : Source_Ptr; 744 Loop_Id : Entity_Id; 745 Loop_Stmt : Node_Id; 746 Result : Node_Id; 747 Scheme : Node_Id; 748 Temp_Decl : Node_Id; 749 Temp_Id : Entity_Id; 750 751 -- Start of processing for Expand_Loop_Entry_Attribute 752 753 begin 754 -- Step 1: Find the related loop 755 756 -- The loop label variant of attribute 'Loop_Entry already has all the 757 -- information in its expression. 758 759 if Present (Exprs) then 760 Loop_Id := Entity (First (Exprs)); 761 Loop_Stmt := Label_Construct (Parent (Loop_Id)); 762 763 -- Climb the parent chain to find the nearest enclosing loop. Skip all 764 -- internally generated loops for quantified expressions. 765 766 else 767 Loop_Stmt := N; 768 while Present (Loop_Stmt) loop 769 if Nkind (Loop_Stmt) = N_Loop_Statement 770 and then Present (Identifier (Loop_Stmt)) 771 then 772 exit; 773 end if; 774 775 Loop_Stmt := Parent (Loop_Stmt); 776 end loop; 777 778 Loop_Id := Entity (Identifier (Loop_Stmt)); 779 end if; 780 781 Loc := Sloc (Loop_Stmt); 782 783 -- Step 2: Transform the loop 784 785 -- The loop has already been transformed during the expansion of a prior 786 -- 'Loop_Entry attribute. Retrieve the declarative list of the block. 787 788 if Has_Loop_Entry_Attributes (Loop_Id) then 789 790 -- When the related loop name appears as the argument of attribute 791 -- Loop_Entry, the corresponding label construct is the generated 792 -- block statement. This is because the expander reuses the label. 793 794 if Nkind (Loop_Stmt) = N_Block_Statement then 795 Decls := Declarations (Loop_Stmt); 796 797 -- In all other cases, the loop must appear in the handled sequence 798 -- of statements of the generated block. 799 800 else 801 pragma Assert 802 (Nkind (Parent (Loop_Stmt)) = N_Handled_Sequence_Of_Statements 803 and then Nkind (Parent (Parent (Loop_Stmt))) = 804 N_Block_Statement); 805 806 Decls := Declarations (Parent (Parent (Loop_Stmt))); 807 end if; 808 809 Result := Empty; 810 811 -- Transform the loop into a conditional block 812 813 else 814 Set_Has_Loop_Entry_Attributes (Loop_Id); 815 Scheme := Iteration_Scheme (Loop_Stmt); 816 817 -- Infinite loops are transformed into: 818 819 -- declare 820 -- Temp1 : constant <type of Pref1> := <Pref1>; 821 -- . . . 822 -- TempN : constant <type of PrefN> := <PrefN>; 823 -- begin 824 -- loop 825 -- <original source statements with attribute rewrites> 826 -- end loop; 827 -- end; 828 829 if No (Scheme) then 830 Build_Conditional_Block (Loc, 831 Cond => Empty, 832 Loop_Stmt => Relocate_Node (Loop_Stmt), 833 If_Stmt => Result, 834 Blk_Stmt => Blk); 835 836 Result := Blk; 837 838 -- While loops are transformed into: 839 840 -- if <Condition> then 841 -- declare 842 -- Temp1 : constant <type of Pref1> := <Pref1>; 843 -- . . . 844 -- TempN : constant <type of PrefN> := <PrefN>; 845 -- begin 846 -- loop 847 -- <original source statements with attribute rewrites> 848 -- exit when not <Condition>; 849 -- end loop; 850 -- end; 851 -- end if; 852 853 -- Note that loops over iterators and containers are already 854 -- converted into while loops. 855 856 elsif Present (Condition (Scheme)) then 857 declare 858 Cond : constant Node_Id := Condition (Scheme); 859 860 begin 861 -- Transform the original while loop into an infinite loop 862 -- where the last statement checks the negated condition. This 863 -- placement ensures that the condition will not be evaluated 864 -- twice on the first iteration. 865 866 -- Generate: 867 -- exit when not <Cond>: 868 869 Append_To (Statements (Loop_Stmt), 870 Make_Exit_Statement (Loc, 871 Condition => Make_Op_Not (Loc, New_Copy_Tree (Cond)))); 872 873 Build_Conditional_Block (Loc, 874 Cond => Relocate_Node (Cond), 875 Loop_Stmt => Relocate_Node (Loop_Stmt), 876 If_Stmt => Result, 877 Blk_Stmt => Blk); 878 end; 879 880 -- Ada 2012 iteration over an array is transformed into: 881 882 -- if <Array_Nam>'Length (1) > 0 883 -- and then <Array_Nam>'Length (N) > 0 884 -- then 885 -- declare 886 -- Temp1 : constant <type of Pref1> := <Pref1>; 887 -- . . . 888 -- TempN : constant <type of PrefN> := <PrefN>; 889 -- begin 890 -- for X in ... loop -- multiple loops depending on dims 891 -- <original source statements with attribute rewrites> 892 -- end loop; 893 -- end; 894 -- end if; 895 896 elsif Is_Array_Iteration (Loop_Stmt) then 897 declare 898 Array_Nam : constant Entity_Id := 899 Entity (Name (Iterator_Specification 900 (Iteration_Scheme (Original_Node (Loop_Stmt))))); 901 Num_Dims : constant Pos := 902 Number_Dimensions (Etype (Array_Nam)); 903 Cond : Node_Id := Empty; 904 Check : Node_Id; 905 906 begin 907 -- Generate a check which determines whether all dimensions of 908 -- the array are non-null. 909 910 for Dim in 1 .. Num_Dims loop 911 Check := 912 Make_Op_Gt (Loc, 913 Left_Opnd => 914 Make_Attribute_Reference (Loc, 915 Prefix => New_Occurrence_Of (Array_Nam, Loc), 916 Attribute_Name => Name_Length, 917 Expressions => New_List ( 918 Make_Integer_Literal (Loc, Dim))), 919 Right_Opnd => 920 Make_Integer_Literal (Loc, 0)); 921 922 if No (Cond) then 923 Cond := Check; 924 else 925 Cond := 926 Make_And_Then (Loc, 927 Left_Opnd => Cond, 928 Right_Opnd => Check); 929 end if; 930 end loop; 931 932 Build_Conditional_Block (Loc, 933 Cond => Cond, 934 Loop_Stmt => Relocate_Node (Loop_Stmt), 935 If_Stmt => Result, 936 Blk_Stmt => Blk); 937 end; 938 939 -- For loops are transformed into: 940 941 -- if <Low> <= <High> then 942 -- declare 943 -- Temp1 : constant <type of Pref1> := <Pref1>; 944 -- . . . 945 -- TempN : constant <type of PrefN> := <PrefN>; 946 -- begin 947 -- for <Def_Id> in <Low> .. <High> loop 948 -- <original source statements with attribute rewrites> 949 -- end loop; 950 -- end; 951 -- end if; 952 953 elsif Present (Loop_Parameter_Specification (Scheme)) then 954 declare 955 Loop_Spec : constant Node_Id := 956 Loop_Parameter_Specification (Scheme); 957 Cond : Node_Id; 958 Subt_Def : Node_Id; 959 960 begin 961 Subt_Def := Discrete_Subtype_Definition (Loop_Spec); 962 963 -- When the loop iterates over a subtype indication with a 964 -- range, use the low and high bounds of the subtype itself. 965 966 if Nkind (Subt_Def) = N_Subtype_Indication then 967 Subt_Def := Scalar_Range (Etype (Subt_Def)); 968 end if; 969 970 pragma Assert (Nkind (Subt_Def) = N_Range); 971 972 -- Generate 973 -- Low <= High 974 975 Cond := 976 Make_Op_Le (Loc, 977 Left_Opnd => New_Copy_Tree (Low_Bound (Subt_Def)), 978 Right_Opnd => New_Copy_Tree (High_Bound (Subt_Def))); 979 980 Build_Conditional_Block (Loc, 981 Cond => Cond, 982 Loop_Stmt => Relocate_Node (Loop_Stmt), 983 If_Stmt => Result, 984 Blk_Stmt => Blk); 985 end; 986 end if; 987 988 Decls := Declarations (Blk); 989 end if; 990 991 -- Step 3: Create a constant to capture the value of the prefix at the 992 -- entry point into the loop. 993 994 -- Generate: 995 -- Temp : constant <type of Pref> := <Pref>; 996 997 Temp_Id := Make_Temporary (Loc, 'P'); 998 999 Temp_Decl := 1000 Make_Object_Declaration (Loc, 1001 Defining_Identifier => Temp_Id, 1002 Constant_Present => True, 1003 Object_Definition => New_Occurrence_Of (Typ, Loc), 1004 Expression => Relocate_Node (Pref)); 1005 Append_To (Decls, Temp_Decl); 1006 1007 -- Step 4: Analyze all bits 1008 1009 Rewrite (N, New_Occurrence_Of (Temp_Id, Loc)); 1010 1011 Installed := Current_Scope = Scope (Loop_Id); 1012 1013 -- Depending on the pracement of attribute 'Loop_Entry relative to the 1014 -- associated loop, ensure the proper visibility for analysis. 1015 1016 if not Installed then 1017 Push_Scope (Scope (Loop_Id)); 1018 end if; 1019 1020 -- The analysis of the conditional block takes care of the constant 1021 -- declaration. 1022 1023 if Present (Result) then 1024 Rewrite (Loop_Stmt, Result); 1025 Analyze (Loop_Stmt); 1026 1027 -- The conditional block was analyzed when a previous 'Loop_Entry was 1028 -- expanded. There is no point in reanalyzing the block, simply analyze 1029 -- the declaration of the constant. 1030 1031 else 1032 Analyze (Temp_Decl); 1033 end if; 1034 1035 Analyze (N); 1036 1037 if not Installed then 1038 Pop_Scope; 1039 end if; 1040 end Expand_Loop_Entry_Attribute; 1041 1042 ------------------------------ 1043 -- Expand_Min_Max_Attribute -- 1044 ------------------------------ 1045 1046 procedure Expand_Min_Max_Attribute (N : Node_Id) is 1047 begin 1048 -- Min and Max are handled by the back end (except that static cases 1049 -- have already been evaluated during semantic processing, although the 1050 -- back end should not count on this). The one bit of special processing 1051 -- required in the normal case is that these two attributes typically 1052 -- generate conditionals in the code, so check the relevant restriction. 1053 1054 Check_Restriction (No_Implicit_Conditionals, N); 1055 1056 -- In Modify_Tree_For_C mode, we rewrite as an if expression 1057 1058 if Modify_Tree_For_C then 1059 declare 1060 Loc : constant Source_Ptr := Sloc (N); 1061 Typ : constant Entity_Id := Etype (N); 1062 Expr : constant Node_Id := First (Expressions (N)); 1063 Left : constant Node_Id := Relocate_Node (Expr); 1064 Right : constant Node_Id := Relocate_Node (Next (Expr)); 1065 1066 function Make_Compare (Left, Right : Node_Id) return Node_Id; 1067 -- Returns Left >= Right for Max, Left <= Right for Min 1068 1069 ------------------ 1070 -- Make_Compare -- 1071 ------------------ 1072 1073 function Make_Compare (Left, Right : Node_Id) return Node_Id is 1074 begin 1075 if Attribute_Name (N) = Name_Max then 1076 return 1077 Make_Op_Ge (Loc, 1078 Left_Opnd => Left, 1079 Right_Opnd => Right); 1080 else 1081 return 1082 Make_Op_Le (Loc, 1083 Left_Opnd => Left, 1084 Right_Opnd => Right); 1085 end if; 1086 end Make_Compare; 1087 1088 -- Start of processing for Min_Max 1089 1090 begin 1091 -- If both Left and Right are side effect free, then we can just 1092 -- use Duplicate_Expr to duplicate the references and return 1093 1094 -- (if Left >=|<= Right then Left else Right) 1095 1096 if Side_Effect_Free (Left) and then Side_Effect_Free (Right) then 1097 Rewrite (N, 1098 Make_If_Expression (Loc, 1099 Expressions => New_List ( 1100 Make_Compare (Left, Right), 1101 Duplicate_Subexpr_No_Checks (Left), 1102 Duplicate_Subexpr_No_Checks (Right)))); 1103 1104 -- Otherwise we generate declarations to capture the values. We 1105 -- can't put these declarations inside the if expression, since 1106 -- we could end up with an N_Expression_With_Actions which has 1107 -- declarations in the actions, forbidden for Modify_Tree_For_C. 1108 1109 -- The translation is 1110 1111 -- T1 : styp; -- inserted high up in tree 1112 -- T2 : styp; -- inserted high up in tree 1113 1114 -- do 1115 -- T1 := styp!(Left); 1116 -- T2 := styp!(Right); 1117 -- in 1118 -- (if T1 >=|<= T2 then typ!(T1) else typ!(T2)) 1119 -- end; 1120 1121 -- We insert the T1,T2 declarations with Insert_Declaration which 1122 -- inserts these declarations high up in the tree unconditionally. 1123 -- This is safe since no code is associated with the declarations. 1124 -- Here styp is a standard type whose Esize matches the size of 1125 -- our type. We do this because the actual type may be a result of 1126 -- some local declaration which would not be visible at the point 1127 -- where we insert the declarations of T1 and T2. 1128 1129 else 1130 declare 1131 T1 : constant Entity_Id := Make_Temporary (Loc, 'T', Left); 1132 T2 : constant Entity_Id := Make_Temporary (Loc, 'T', Left); 1133 Styp : constant Entity_Id := Matching_Standard_Type (Typ); 1134 1135 begin 1136 Insert_Declaration (N, 1137 Make_Object_Declaration (Loc, 1138 Defining_Identifier => T1, 1139 Object_Definition => New_Occurrence_Of (Styp, Loc))); 1140 1141 Insert_Declaration (N, 1142 Make_Object_Declaration (Loc, 1143 Defining_Identifier => T2, 1144 Object_Definition => New_Occurrence_Of (Styp, Loc))); 1145 1146 Rewrite (N, 1147 Make_Expression_With_Actions (Loc, 1148 Actions => New_List ( 1149 Make_Assignment_Statement (Loc, 1150 Name => New_Occurrence_Of (T1, Loc), 1151 Expression => Unchecked_Convert_To (Styp, Left)), 1152 Make_Assignment_Statement (Loc, 1153 Name => New_Occurrence_Of (T2, Loc), 1154 Expression => Unchecked_Convert_To (Styp, Right))), 1155 1156 Expression => 1157 Make_If_Expression (Loc, 1158 Expressions => New_List ( 1159 Make_Compare 1160 (New_Occurrence_Of (T1, Loc), 1161 New_Occurrence_Of (T2, Loc)), 1162 Unchecked_Convert_To (Typ, 1163 New_Occurrence_Of (T1, Loc)), 1164 Unchecked_Convert_To (Typ, 1165 New_Occurrence_Of (T2, Loc)))))); 1166 end; 1167 end if; 1168 1169 Analyze_And_Resolve (N, Typ); 1170 end; 1171 end if; 1172 end Expand_Min_Max_Attribute; 1173 1174 ---------------------------------- 1175 -- Expand_N_Attribute_Reference -- 1176 ---------------------------------- 1177 1178 procedure Expand_N_Attribute_Reference (N : Node_Id) is 1179 Loc : constant Source_Ptr := Sloc (N); 1180 Typ : constant Entity_Id := Etype (N); 1181 Btyp : constant Entity_Id := Base_Type (Typ); 1182 Pref : constant Node_Id := Prefix (N); 1183 Ptyp : constant Entity_Id := Etype (Pref); 1184 Exprs : constant List_Id := Expressions (N); 1185 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); 1186 1187 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id); 1188 -- Rewrites a stream attribute for Read, Write or Output with the 1189 -- procedure call. Pname is the entity for the procedure to call. 1190 1191 ------------------------------ 1192 -- Rewrite_Stream_Proc_Call -- 1193 ------------------------------ 1194 1195 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is 1196 Item : constant Node_Id := Next (First (Exprs)); 1197 Formal : constant Entity_Id := Next_Formal (First_Formal (Pname)); 1198 Formal_Typ : constant Entity_Id := Etype (Formal); 1199 Is_Written : constant Boolean := (Ekind (Formal) /= E_In_Parameter); 1200 1201 begin 1202 -- The expansion depends on Item, the second actual, which is 1203 -- the object being streamed in or out. 1204 1205 -- If the item is a component of a packed array type, and 1206 -- a conversion is needed on exit, we introduce a temporary to 1207 -- hold the value, because otherwise the packed reference will 1208 -- not be properly expanded. 1209 1210 if Nkind (Item) = N_Indexed_Component 1211 and then Is_Packed (Base_Type (Etype (Prefix (Item)))) 1212 and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ) 1213 and then Is_Written 1214 then 1215 declare 1216 Temp : constant Entity_Id := Make_Temporary (Loc, 'V'); 1217 Decl : Node_Id; 1218 Assn : Node_Id; 1219 1220 begin 1221 Decl := 1222 Make_Object_Declaration (Loc, 1223 Defining_Identifier => Temp, 1224 Object_Definition => 1225 New_Occurrence_Of (Formal_Typ, Loc)); 1226 Set_Etype (Temp, Formal_Typ); 1227 1228 Assn := 1229 Make_Assignment_Statement (Loc, 1230 Name => New_Copy_Tree (Item), 1231 Expression => 1232 Unchecked_Convert_To 1233 (Etype (Item), New_Occurrence_Of (Temp, Loc))); 1234 1235 Rewrite (Item, New_Occurrence_Of (Temp, Loc)); 1236 Insert_Actions (N, 1237 New_List ( 1238 Decl, 1239 Make_Procedure_Call_Statement (Loc, 1240 Name => New_Occurrence_Of (Pname, Loc), 1241 Parameter_Associations => Exprs), 1242 Assn)); 1243 1244 Rewrite (N, Make_Null_Statement (Loc)); 1245 return; 1246 end; 1247 end if; 1248 1249 -- For the class-wide dispatching cases, and for cases in which 1250 -- the base type of the second argument matches the base type of 1251 -- the corresponding formal parameter (that is to say the stream 1252 -- operation is not inherited), we are all set, and can use the 1253 -- argument unchanged. 1254 1255 -- For all other cases we do an unchecked conversion of the second 1256 -- parameter to the type of the formal of the procedure we are 1257 -- calling. This deals with the private type cases, and with going 1258 -- to the root type as required in elementary type case. 1259 1260 if not Is_Class_Wide_Type (Entity (Pref)) 1261 and then not Is_Class_Wide_Type (Etype (Item)) 1262 and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ) 1263 then 1264 Rewrite (Item, 1265 Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item))); 1266 1267 -- For untagged derived types set Assignment_OK, to prevent 1268 -- copies from being created when the unchecked conversion 1269 -- is expanded (which would happen in Remove_Side_Effects 1270 -- if Expand_N_Unchecked_Conversion were allowed to call 1271 -- Force_Evaluation). The copy could violate Ada semantics in 1272 -- cases such as an actual that is an out parameter. Note that 1273 -- this approach is also used in exp_ch7 for calls to controlled 1274 -- type operations to prevent problems with actuals wrapped in 1275 -- unchecked conversions. 1276 1277 if Is_Untagged_Derivation (Etype (Expression (Item))) then 1278 Set_Assignment_OK (Item); 1279 end if; 1280 end if; 1281 1282 -- The stream operation to call may be a renaming created by an 1283 -- attribute definition clause, and may not be frozen yet. Ensure 1284 -- that it has the necessary extra formals. 1285 1286 if not Is_Frozen (Pname) then 1287 Create_Extra_Formals (Pname); 1288 end if; 1289 1290 -- And now rewrite the call 1291 1292 Rewrite (N, 1293 Make_Procedure_Call_Statement (Loc, 1294 Name => New_Occurrence_Of (Pname, Loc), 1295 Parameter_Associations => Exprs)); 1296 1297 Analyze (N); 1298 end Rewrite_Stream_Proc_Call; 1299 1300 -- Start of processing for Expand_N_Attribute_Reference 1301 1302 begin 1303 -- Do required validity checking, if enabled. Do not apply check to 1304 -- output parameters of an Asm instruction, since the value of this 1305 -- is not set till after the attribute has been elaborated, and do 1306 -- not apply the check to the arguments of a 'Read or 'Input attribute 1307 -- reference since the scalar argument is an OUT scalar. 1308 1309 if Validity_Checks_On and then Validity_Check_Operands 1310 and then Id /= Attribute_Asm_Output 1311 and then Id /= Attribute_Read 1312 and then Id /= Attribute_Input 1313 then 1314 declare 1315 Expr : Node_Id; 1316 begin 1317 Expr := First (Expressions (N)); 1318 while Present (Expr) loop 1319 Ensure_Valid (Expr); 1320 Next (Expr); 1321 end loop; 1322 end; 1323 end if; 1324 1325 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in- 1326 -- place function, then a temporary return object needs to be created 1327 -- and access to it must be passed to the function. Currently we limit 1328 -- such functions to those with inherently limited result subtypes, but 1329 -- eventually we plan to expand the functions that are treated as 1330 -- build-in-place to include other composite result types. 1331 1332 if Ada_Version >= Ada_2005 1333 and then Is_Build_In_Place_Function_Call (Pref) 1334 then 1335 Make_Build_In_Place_Call_In_Anonymous_Context (Pref); 1336 end if; 1337 1338 -- If prefix is a protected type name, this is a reference to the 1339 -- current instance of the type. For a component definition, nothing 1340 -- to do (expansion will occur in the init proc). In other contexts, 1341 -- rewrite into reference to current instance. 1342 1343 if Is_Protected_Self_Reference (Pref) 1344 and then not 1345 (Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint, 1346 N_Discriminant_Association) 1347 and then Nkind (Parent (Parent (Parent (Parent (N))))) = 1348 N_Component_Definition) 1349 1350 -- No action needed for these attributes since the current instance 1351 -- will be rewritten to be the name of the _object parameter 1352 -- associated with the enclosing protected subprogram (see below). 1353 1354 and then Id /= Attribute_Access 1355 and then Id /= Attribute_Unchecked_Access 1356 and then Id /= Attribute_Unrestricted_Access 1357 then 1358 Rewrite (Pref, Concurrent_Ref (Pref)); 1359 Analyze (Pref); 1360 end if; 1361 1362 -- Remaining processing depends on specific attribute 1363 1364 -- Note: individual sections of the following case statement are 1365 -- allowed to assume there is no code after the case statement, and 1366 -- are legitimately allowed to execute return statements if they have 1367 -- nothing more to do. 1368 1369 case Id is 1370 1371 -- Attributes related to Ada 2012 iterators 1372 1373 when Attribute_Constant_Indexing | 1374 Attribute_Default_Iterator | 1375 Attribute_Implicit_Dereference | 1376 Attribute_Iterable | 1377 Attribute_Iterator_Element | 1378 Attribute_Variable_Indexing => 1379 null; 1380 1381 -- Internal attributes used to deal with Ada 2012 delayed aspects. These 1382 -- were already rejected by the parser. Thus they shouldn't appear here. 1383 1384 when Internal_Attribute_Id => 1385 raise Program_Error; 1386 1387 ------------ 1388 -- Access -- 1389 ------------ 1390 1391 when Attribute_Access | 1392 Attribute_Unchecked_Access | 1393 Attribute_Unrestricted_Access => 1394 1395 Access_Cases : declare 1396 Ref_Object : constant Node_Id := Get_Referenced_Object (Pref); 1397 Btyp_DDT : Entity_Id; 1398 1399 function Enclosing_Object (N : Node_Id) return Node_Id; 1400 -- If N denotes a compound name (selected component, indexed 1401 -- component, or slice), returns the name of the outermost such 1402 -- enclosing object. Otherwise returns N. If the object is a 1403 -- renaming, then the renamed object is returned. 1404 1405 ---------------------- 1406 -- Enclosing_Object -- 1407 ---------------------- 1408 1409 function Enclosing_Object (N : Node_Id) return Node_Id is 1410 Obj_Name : Node_Id; 1411 1412 begin 1413 Obj_Name := N; 1414 while Nkind_In (Obj_Name, N_Selected_Component, 1415 N_Indexed_Component, 1416 N_Slice) 1417 loop 1418 Obj_Name := Prefix (Obj_Name); 1419 end loop; 1420 1421 return Get_Referenced_Object (Obj_Name); 1422 end Enclosing_Object; 1423 1424 -- Local declarations 1425 1426 Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object); 1427 1428 -- Start of processing for Access_Cases 1429 1430 begin 1431 Btyp_DDT := Designated_Type (Btyp); 1432 1433 -- Handle designated types that come from the limited view 1434 1435 if Ekind (Btyp_DDT) = E_Incomplete_Type 1436 and then From_Limited_With (Btyp_DDT) 1437 and then Present (Non_Limited_View (Btyp_DDT)) 1438 then 1439 Btyp_DDT := Non_Limited_View (Btyp_DDT); 1440 1441 elsif Is_Class_Wide_Type (Btyp_DDT) 1442 and then Ekind (Etype (Btyp_DDT)) = E_Incomplete_Type 1443 and then From_Limited_With (Etype (Btyp_DDT)) 1444 and then Present (Non_Limited_View (Etype (Btyp_DDT))) 1445 and then Present (Class_Wide_Type 1446 (Non_Limited_View (Etype (Btyp_DDT)))) 1447 then 1448 Btyp_DDT := 1449 Class_Wide_Type (Non_Limited_View (Etype (Btyp_DDT))); 1450 end if; 1451 1452 -- In order to improve the text of error messages, the designated 1453 -- type of access-to-subprogram itypes is set by the semantics as 1454 -- the associated subprogram entity (see sem_attr). Now we replace 1455 -- such node with the proper E_Subprogram_Type itype. 1456 1457 if Id = Attribute_Unrestricted_Access 1458 and then Is_Subprogram (Directly_Designated_Type (Typ)) 1459 then 1460 -- The following conditions ensure that this special management 1461 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes. 1462 -- At this stage other cases in which the designated type is 1463 -- still a subprogram (instead of an E_Subprogram_Type) are 1464 -- wrong because the semantics must have overridden the type of 1465 -- the node with the type imposed by the context. 1466 1467 if Nkind (Parent (N)) = N_Unchecked_Type_Conversion 1468 and then Etype (Parent (N)) = RTE (RE_Prim_Ptr) 1469 then 1470 Set_Etype (N, RTE (RE_Prim_Ptr)); 1471 1472 else 1473 declare 1474 Subp : constant Entity_Id := 1475 Directly_Designated_Type (Typ); 1476 Etyp : Entity_Id; 1477 Extra : Entity_Id := Empty; 1478 New_Formal : Entity_Id; 1479 Old_Formal : Entity_Id := First_Formal (Subp); 1480 Subp_Typ : Entity_Id; 1481 1482 begin 1483 Subp_Typ := Create_Itype (E_Subprogram_Type, N); 1484 Set_Etype (Subp_Typ, Etype (Subp)); 1485 Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp)); 1486 1487 if Present (Old_Formal) then 1488 New_Formal := New_Copy (Old_Formal); 1489 Set_First_Entity (Subp_Typ, New_Formal); 1490 1491 loop 1492 Set_Scope (New_Formal, Subp_Typ); 1493 Etyp := Etype (New_Formal); 1494 1495 -- Handle itypes. There is no need to duplicate 1496 -- here the itypes associated with record types 1497 -- (i.e the implicit full view of private types). 1498 1499 if Is_Itype (Etyp) 1500 and then Ekind (Base_Type (Etyp)) /= E_Record_Type 1501 then 1502 Extra := New_Copy (Etyp); 1503 Set_Parent (Extra, New_Formal); 1504 Set_Etype (New_Formal, Extra); 1505 Set_Scope (Extra, Subp_Typ); 1506 end if; 1507 1508 Extra := New_Formal; 1509 Next_Formal (Old_Formal); 1510 exit when No (Old_Formal); 1511 1512 Set_Next_Entity (New_Formal, 1513 New_Copy (Old_Formal)); 1514 Next_Entity (New_Formal); 1515 end loop; 1516 1517 Set_Next_Entity (New_Formal, Empty); 1518 Set_Last_Entity (Subp_Typ, Extra); 1519 end if; 1520 1521 -- Now that the explicit formals have been duplicated, 1522 -- any extra formals needed by the subprogram must be 1523 -- created. 1524 1525 if Present (Extra) then 1526 Set_Extra_Formal (Extra, Empty); 1527 end if; 1528 1529 Create_Extra_Formals (Subp_Typ); 1530 Set_Directly_Designated_Type (Typ, Subp_Typ); 1531 end; 1532 end if; 1533 end if; 1534 1535 if Is_Access_Protected_Subprogram_Type (Btyp) then 1536 Expand_Access_To_Protected_Op (N, Pref, Typ); 1537 1538 -- If prefix is a type name, this is a reference to the current 1539 -- instance of the type, within its initialization procedure. 1540 1541 elsif Is_Entity_Name (Pref) 1542 and then Is_Type (Entity (Pref)) 1543 then 1544 declare 1545 Par : Node_Id; 1546 Formal : Entity_Id; 1547 1548 begin 1549 -- If the current instance name denotes a task type, then 1550 -- the access attribute is rewritten to be the name of the 1551 -- "_task" parameter associated with the task type's task 1552 -- procedure. An unchecked conversion is applied to ensure 1553 -- a type match in cases of expander-generated calls (e.g. 1554 -- init procs). 1555 1556 if Is_Task_Type (Entity (Pref)) then 1557 Formal := 1558 First_Entity (Get_Task_Body_Procedure (Entity (Pref))); 1559 while Present (Formal) loop 1560 exit when Chars (Formal) = Name_uTask; 1561 Next_Entity (Formal); 1562 end loop; 1563 1564 pragma Assert (Present (Formal)); 1565 1566 Rewrite (N, 1567 Unchecked_Convert_To (Typ, 1568 New_Occurrence_Of (Formal, Loc))); 1569 Set_Etype (N, Typ); 1570 1571 elsif Is_Protected_Type (Entity (Pref)) then 1572 1573 -- No action needed for current instance located in a 1574 -- component definition (expansion will occur in the 1575 -- init proc) 1576 1577 if Is_Protected_Type (Current_Scope) then 1578 null; 1579 1580 -- If the current instance reference is located in a 1581 -- protected subprogram or entry then rewrite the access 1582 -- attribute to be the name of the "_object" parameter. 1583 -- An unchecked conversion is applied to ensure a type 1584 -- match in cases of expander-generated calls (e.g. init 1585 -- procs). 1586 1587 -- The code may be nested in a block, so find enclosing 1588 -- scope that is a protected operation. 1589 1590 else 1591 declare 1592 Subp : Entity_Id; 1593 1594 begin 1595 Subp := Current_Scope; 1596 while Ekind_In (Subp, E_Loop, E_Block) loop 1597 Subp := Scope (Subp); 1598 end loop; 1599 1600 Formal := 1601 First_Entity 1602 (Protected_Body_Subprogram (Subp)); 1603 1604 -- For a protected subprogram the _Object parameter 1605 -- is the protected record, so we create an access 1606 -- to it. The _Object parameter of an entry is an 1607 -- address. 1608 1609 if Ekind (Subp) = E_Entry then 1610 Rewrite (N, 1611 Unchecked_Convert_To (Typ, 1612 New_Occurrence_Of (Formal, Loc))); 1613 Set_Etype (N, Typ); 1614 1615 else 1616 Rewrite (N, 1617 Unchecked_Convert_To (Typ, 1618 Make_Attribute_Reference (Loc, 1619 Attribute_Name => Name_Unrestricted_Access, 1620 Prefix => 1621 New_Occurrence_Of (Formal, Loc)))); 1622 Analyze_And_Resolve (N); 1623 end if; 1624 end; 1625 end if; 1626 1627 -- The expression must appear in a default expression, 1628 -- (which in the initialization procedure is the right-hand 1629 -- side of an assignment), and not in a discriminant 1630 -- constraint. 1631 1632 else 1633 Par := Parent (N); 1634 while Present (Par) loop 1635 exit when Nkind (Par) = N_Assignment_Statement; 1636 1637 if Nkind (Par) = N_Component_Declaration then 1638 return; 1639 end if; 1640 1641 Par := Parent (Par); 1642 end loop; 1643 1644 if Present (Par) then 1645 Rewrite (N, 1646 Make_Attribute_Reference (Loc, 1647 Prefix => Make_Identifier (Loc, Name_uInit), 1648 Attribute_Name => Attribute_Name (N))); 1649 1650 Analyze_And_Resolve (N, Typ); 1651 end if; 1652 end if; 1653 end; 1654 1655 -- If the prefix of an Access attribute is a dereference of an 1656 -- access parameter (or a renaming of such a dereference, or a 1657 -- subcomponent of such a dereference) and the context is a 1658 -- general access type (including the type of an object or 1659 -- component with an access_definition, but not the anonymous 1660 -- type of an access parameter or access discriminant), then 1661 -- apply an accessibility check to the access parameter. We used 1662 -- to rewrite the access parameter as a type conversion, but that 1663 -- could only be done if the immediate prefix of the Access 1664 -- attribute was the dereference, and didn't handle cases where 1665 -- the attribute is applied to a subcomponent of the dereference, 1666 -- since there's generally no available, appropriate access type 1667 -- to convert to in that case. The attribute is passed as the 1668 -- point to insert the check, because the access parameter may 1669 -- come from a renaming, possibly in a different scope, and the 1670 -- check must be associated with the attribute itself. 1671 1672 elsif Id = Attribute_Access 1673 and then Nkind (Enc_Object) = N_Explicit_Dereference 1674 and then Is_Entity_Name (Prefix (Enc_Object)) 1675 and then (Ekind (Btyp) = E_General_Access_Type 1676 or else Is_Local_Anonymous_Access (Btyp)) 1677 and then Ekind (Entity (Prefix (Enc_Object))) in Formal_Kind 1678 and then Ekind (Etype (Entity (Prefix (Enc_Object)))) 1679 = E_Anonymous_Access_Type 1680 and then Present (Extra_Accessibility 1681 (Entity (Prefix (Enc_Object)))) 1682 then 1683 Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N); 1684 1685 -- Ada 2005 (AI-251): If the designated type is an interface we 1686 -- add an implicit conversion to force the displacement of the 1687 -- pointer to reference the secondary dispatch table. 1688 1689 elsif Is_Interface (Btyp_DDT) 1690 and then (Comes_From_Source (N) 1691 or else Comes_From_Source (Ref_Object) 1692 or else (Nkind (Ref_Object) in N_Has_Chars 1693 and then Chars (Ref_Object) = Name_uInit)) 1694 then 1695 if Nkind (Ref_Object) /= N_Explicit_Dereference then 1696 1697 -- No implicit conversion required if types match, or if 1698 -- the prefix is the class_wide_type of the interface. In 1699 -- either case passing an object of the interface type has 1700 -- already set the pointer correctly. 1701 1702 if Btyp_DDT = Etype (Ref_Object) 1703 or else (Is_Class_Wide_Type (Etype (Ref_Object)) 1704 and then 1705 Class_Wide_Type (Btyp_DDT) = Etype (Ref_Object)) 1706 then 1707 null; 1708 1709 else 1710 Rewrite (Prefix (N), 1711 Convert_To (Btyp_DDT, 1712 New_Copy_Tree (Prefix (N)))); 1713 1714 Analyze_And_Resolve (Prefix (N), Btyp_DDT); 1715 end if; 1716 1717 -- When the object is an explicit dereference, convert the 1718 -- dereference's prefix. 1719 1720 else 1721 declare 1722 Obj_DDT : constant Entity_Id := 1723 Base_Type 1724 (Directly_Designated_Type 1725 (Etype (Prefix (Ref_Object)))); 1726 begin 1727 -- No implicit conversion required if designated types 1728 -- match, or if we have an unrestricted access. 1729 1730 if Obj_DDT /= Btyp_DDT 1731 and then Id /= Attribute_Unrestricted_Access 1732 and then not (Is_Class_Wide_Type (Obj_DDT) 1733 and then Etype (Obj_DDT) = Btyp_DDT) 1734 then 1735 Rewrite (N, 1736 Convert_To (Typ, 1737 New_Copy_Tree (Prefix (Ref_Object)))); 1738 Analyze_And_Resolve (N, Typ); 1739 end if; 1740 end; 1741 end if; 1742 end if; 1743 end Access_Cases; 1744 1745 -------------- 1746 -- Adjacent -- 1747 -------------- 1748 1749 -- Transforms 'Adjacent into a call to the floating-point attribute 1750 -- function Adjacent in Fat_xxx (where xxx is the root type) 1751 1752 when Attribute_Adjacent => 1753 Expand_Fpt_Attribute_RR (N); 1754 1755 ------------- 1756 -- Address -- 1757 ------------- 1758 1759 when Attribute_Address => Address : declare 1760 Task_Proc : Entity_Id; 1761 1762 begin 1763 -- If the prefix is a task or a task type, the useful address is that 1764 -- of the procedure for the task body, i.e. the actual program unit. 1765 -- We replace the original entity with that of the procedure. 1766 1767 if Is_Entity_Name (Pref) 1768 and then Is_Task_Type (Entity (Pref)) 1769 then 1770 Task_Proc := Next_Entity (Root_Type (Ptyp)); 1771 1772 while Present (Task_Proc) loop 1773 exit when Ekind (Task_Proc) = E_Procedure 1774 and then Etype (First_Formal (Task_Proc)) = 1775 Corresponding_Record_Type (Ptyp); 1776 Next_Entity (Task_Proc); 1777 end loop; 1778 1779 if Present (Task_Proc) then 1780 Set_Entity (Pref, Task_Proc); 1781 Set_Etype (Pref, Etype (Task_Proc)); 1782 end if; 1783 1784 -- Similarly, the address of a protected operation is the address 1785 -- of the corresponding protected body, regardless of the protected 1786 -- object from which it is selected. 1787 1788 elsif Nkind (Pref) = N_Selected_Component 1789 and then Is_Subprogram (Entity (Selector_Name (Pref))) 1790 and then Is_Protected_Type (Scope (Entity (Selector_Name (Pref)))) 1791 then 1792 Rewrite (Pref, 1793 New_Occurrence_Of ( 1794 External_Subprogram (Entity (Selector_Name (Pref))), Loc)); 1795 1796 elsif Nkind (Pref) = N_Explicit_Dereference 1797 and then Ekind (Ptyp) = E_Subprogram_Type 1798 and then Convention (Ptyp) = Convention_Protected 1799 then 1800 -- The prefix is be a dereference of an access_to_protected_ 1801 -- subprogram. The desired address is the second component of 1802 -- the record that represents the access. 1803 1804 declare 1805 Addr : constant Entity_Id := Etype (N); 1806 Ptr : constant Node_Id := Prefix (Pref); 1807 T : constant Entity_Id := 1808 Equivalent_Type (Base_Type (Etype (Ptr))); 1809 1810 begin 1811 Rewrite (N, 1812 Unchecked_Convert_To (Addr, 1813 Make_Selected_Component (Loc, 1814 Prefix => Unchecked_Convert_To (T, Ptr), 1815 Selector_Name => New_Occurrence_Of ( 1816 Next_Entity (First_Entity (T)), Loc)))); 1817 1818 Analyze_And_Resolve (N, Addr); 1819 end; 1820 1821 -- Ada 2005 (AI-251): Class-wide interface objects are always 1822 -- "displaced" to reference the tag associated with the interface 1823 -- type. In order to obtain the real address of such objects we 1824 -- generate a call to a run-time subprogram that returns the base 1825 -- address of the object. 1826 1827 -- This processing is not needed in the VM case, where dispatching 1828 -- issues are taken care of by the virtual machine. 1829 1830 elsif Is_Class_Wide_Type (Ptyp) 1831 and then Is_Interface (Ptyp) 1832 and then Tagged_Type_Expansion 1833 and then not (Nkind (Pref) in N_Has_Entity 1834 and then Is_Subprogram (Entity (Pref))) 1835 then 1836 Rewrite (N, 1837 Make_Function_Call (Loc, 1838 Name => New_Occurrence_Of (RTE (RE_Base_Address), Loc), 1839 Parameter_Associations => New_List ( 1840 Relocate_Node (N)))); 1841 Analyze (N); 1842 return; 1843 end if; 1844 1845 -- Deal with packed array reference, other cases are handled by 1846 -- the back end. 1847 1848 if Involves_Packed_Array_Reference (Pref) then 1849 Expand_Packed_Address_Reference (N); 1850 end if; 1851 end Address; 1852 1853 --------------- 1854 -- Alignment -- 1855 --------------- 1856 1857 when Attribute_Alignment => Alignment : declare 1858 New_Node : Node_Id; 1859 1860 begin 1861 -- For class-wide types, X'Class'Alignment is transformed into a 1862 -- direct reference to the Alignment of the class type, so that the 1863 -- back end does not have to deal with the X'Class'Alignment 1864 -- reference. 1865 1866 if Is_Entity_Name (Pref) 1867 and then Is_Class_Wide_Type (Entity (Pref)) 1868 then 1869 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc)); 1870 return; 1871 1872 -- For x'Alignment applied to an object of a class wide type, 1873 -- transform X'Alignment into a call to the predefined primitive 1874 -- operation _Alignment applied to X. 1875 1876 elsif Is_Class_Wide_Type (Ptyp) then 1877 New_Node := 1878 Make_Attribute_Reference (Loc, 1879 Prefix => Pref, 1880 Attribute_Name => Name_Tag); 1881 1882 if VM_Target = No_VM then 1883 New_Node := Build_Get_Alignment (Loc, New_Node); 1884 else 1885 New_Node := 1886 Make_Function_Call (Loc, 1887 Name => New_Occurrence_Of (RTE (RE_Get_Alignment), Loc), 1888 Parameter_Associations => New_List (New_Node)); 1889 end if; 1890 1891 -- Case where the context is a specific integer type with which 1892 -- the original attribute was compatible. The function has a 1893 -- specific type as well, so to preserve the compatibility we 1894 -- must convert explicitly. 1895 1896 if Typ /= Standard_Integer then 1897 New_Node := Convert_To (Typ, New_Node); 1898 end if; 1899 1900 Rewrite (N, New_Node); 1901 Analyze_And_Resolve (N, Typ); 1902 return; 1903 1904 -- For all other cases, we just have to deal with the case of 1905 -- the fact that the result can be universal. 1906 1907 else 1908 Apply_Universal_Integer_Attribute_Checks (N); 1909 end if; 1910 end Alignment; 1911 1912 --------------- 1913 -- AST_Entry -- 1914 --------------- 1915 1916 when Attribute_AST_Entry => AST_Entry : declare 1917 Ttyp : Entity_Id; 1918 T_Id : Node_Id; 1919 Eent : Entity_Id; 1920 1921 Entry_Ref : Node_Id; 1922 -- The reference to the entry or entry family 1923 1924 Index : Node_Id; 1925 -- The index expression for an entry family reference, or 1926 -- the Empty if Entry_Ref references a simple entry. 1927 1928 begin 1929 if Nkind (Pref) = N_Indexed_Component then 1930 Entry_Ref := Prefix (Pref); 1931 Index := First (Expressions (Pref)); 1932 else 1933 Entry_Ref := Pref; 1934 Index := Empty; 1935 end if; 1936 1937 -- Get expression for Task_Id and the entry entity 1938 1939 if Nkind (Entry_Ref) = N_Selected_Component then 1940 T_Id := 1941 Make_Attribute_Reference (Loc, 1942 Attribute_Name => Name_Identity, 1943 Prefix => Prefix (Entry_Ref)); 1944 1945 Ttyp := Etype (Prefix (Entry_Ref)); 1946 Eent := Entity (Selector_Name (Entry_Ref)); 1947 1948 else 1949 T_Id := 1950 Make_Function_Call (Loc, 1951 Name => New_Occurrence_Of (RTE (RE_Current_Task), Loc)); 1952 1953 Eent := Entity (Entry_Ref); 1954 1955 -- We have to find the enclosing task to get the task type 1956 -- There must be one, since we already validated this earlier 1957 1958 Ttyp := Current_Scope; 1959 while not Is_Task_Type (Ttyp) loop 1960 Ttyp := Scope (Ttyp); 1961 end loop; 1962 end if; 1963 1964 -- Now rewrite the attribute with a call to Create_AST_Handler 1965 1966 Rewrite (N, 1967 Make_Function_Call (Loc, 1968 Name => New_Occurrence_Of (RTE (RE_Create_AST_Handler), Loc), 1969 Parameter_Associations => New_List ( 1970 T_Id, 1971 Entry_Index_Expression (Loc, Eent, Index, Ttyp)))); 1972 1973 Analyze_And_Resolve (N, RTE (RE_AST_Handler)); 1974 end AST_Entry; 1975 1976 --------- 1977 -- Bit -- 1978 --------- 1979 1980 -- We compute this if a packed array reference was present, otherwise we 1981 -- leave the computation up to the back end. 1982 1983 when Attribute_Bit => 1984 if Involves_Packed_Array_Reference (Pref) then 1985 Expand_Packed_Bit_Reference (N); 1986 else 1987 Apply_Universal_Integer_Attribute_Checks (N); 1988 end if; 1989 1990 ------------------ 1991 -- Bit_Position -- 1992 ------------------ 1993 1994 -- We compute this if a component clause was present, otherwise we leave 1995 -- the computation up to the back end, since we don't know what layout 1996 -- will be chosen. 1997 1998 -- Note that the attribute can apply to a naked record component 1999 -- in generated code (i.e. the prefix is an identifier that 2000 -- references the component or discriminant entity). 2001 2002 when Attribute_Bit_Position => Bit_Position : declare 2003 CE : Entity_Id; 2004 2005 begin 2006 if Nkind (Pref) = N_Identifier then 2007 CE := Entity (Pref); 2008 else 2009 CE := Entity (Selector_Name (Pref)); 2010 end if; 2011 2012 if Known_Static_Component_Bit_Offset (CE) then 2013 Rewrite (N, 2014 Make_Integer_Literal (Loc, 2015 Intval => Component_Bit_Offset (CE))); 2016 Analyze_And_Resolve (N, Typ); 2017 2018 else 2019 Apply_Universal_Integer_Attribute_Checks (N); 2020 end if; 2021 end Bit_Position; 2022 2023 ------------------ 2024 -- Body_Version -- 2025 ------------------ 2026 2027 -- A reference to P'Body_Version or P'Version is expanded to 2028 2029 -- Vnn : Unsigned; 2030 -- pragma Import (C, Vnn, "uuuuT"); 2031 -- ... 2032 -- Get_Version_String (Vnn) 2033 2034 -- where uuuu is the unit name (dots replaced by double underscore) 2035 -- and T is B for the cases of Body_Version, or Version applied to a 2036 -- subprogram acting as its own spec, and S for Version applied to a 2037 -- subprogram spec or package. This sequence of code references the 2038 -- unsigned constant created in the main program by the binder. 2039 2040 -- A special exception occurs for Standard, where the string returned 2041 -- is a copy of the library string in gnatvsn.ads. 2042 2043 when Attribute_Body_Version | Attribute_Version => Version : declare 2044 E : constant Entity_Id := Make_Temporary (Loc, 'V'); 2045 Pent : Entity_Id; 2046 S : String_Id; 2047 2048 begin 2049 -- If not library unit, get to containing library unit 2050 2051 Pent := Entity (Pref); 2052 while Pent /= Standard_Standard 2053 and then Scope (Pent) /= Standard_Standard 2054 and then not Is_Child_Unit (Pent) 2055 loop 2056 Pent := Scope (Pent); 2057 end loop; 2058 2059 -- Special case Standard and Standard.ASCII 2060 2061 if Pent = Standard_Standard or else Pent = Standard_ASCII then 2062 Rewrite (N, 2063 Make_String_Literal (Loc, 2064 Strval => Verbose_Library_Version)); 2065 2066 -- All other cases 2067 2068 else 2069 -- Build required string constant 2070 2071 Get_Name_String (Get_Unit_Name (Pent)); 2072 2073 Start_String; 2074 for J in 1 .. Name_Len - 2 loop 2075 if Name_Buffer (J) = '.' then 2076 Store_String_Chars ("__"); 2077 else 2078 Store_String_Char (Get_Char_Code (Name_Buffer (J))); 2079 end if; 2080 end loop; 2081 2082 -- Case of subprogram acting as its own spec, always use body 2083 2084 if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification 2085 and then Nkind (Parent (Declaration_Node (Pent))) = 2086 N_Subprogram_Body 2087 and then Acts_As_Spec (Parent (Declaration_Node (Pent))) 2088 then 2089 Store_String_Chars ("B"); 2090 2091 -- Case of no body present, always use spec 2092 2093 elsif not Unit_Requires_Body (Pent) then 2094 Store_String_Chars ("S"); 2095 2096 -- Otherwise use B for Body_Version, S for spec 2097 2098 elsif Id = Attribute_Body_Version then 2099 Store_String_Chars ("B"); 2100 else 2101 Store_String_Chars ("S"); 2102 end if; 2103 2104 S := End_String; 2105 Lib.Version_Referenced (S); 2106 2107 -- Insert the object declaration 2108 2109 Insert_Actions (N, New_List ( 2110 Make_Object_Declaration (Loc, 2111 Defining_Identifier => E, 2112 Object_Definition => 2113 New_Occurrence_Of (RTE (RE_Unsigned), Loc)))); 2114 2115 -- Set entity as imported with correct external name 2116 2117 Set_Is_Imported (E); 2118 Set_Interface_Name (E, Make_String_Literal (Loc, S)); 2119 2120 -- Set entity as internal to ensure proper Sprint output of its 2121 -- implicit importation. 2122 2123 Set_Is_Internal (E); 2124 2125 -- And now rewrite original reference 2126 2127 Rewrite (N, 2128 Make_Function_Call (Loc, 2129 Name => New_Occurrence_Of (RTE (RE_Get_Version_String), Loc), 2130 Parameter_Associations => New_List ( 2131 New_Occurrence_Of (E, Loc)))); 2132 end if; 2133 2134 Analyze_And_Resolve (N, RTE (RE_Version_String)); 2135 end Version; 2136 2137 ------------- 2138 -- Ceiling -- 2139 ------------- 2140 2141 -- Transforms 'Ceiling into a call to the floating-point attribute 2142 -- function Ceiling in Fat_xxx (where xxx is the root type) 2143 2144 when Attribute_Ceiling => 2145 Expand_Fpt_Attribute_R (N); 2146 2147 -------------- 2148 -- Callable -- 2149 -------------- 2150 2151 -- Transforms 'Callable attribute into a call to the Callable function 2152 2153 when Attribute_Callable => Callable : 2154 begin 2155 -- We have an object of a task interface class-wide type as a prefix 2156 -- to Callable. Generate: 2157 -- callable (Task_Id (Pref._disp_get_task_id)); 2158 2159 if Ada_Version >= Ada_2005 2160 and then Ekind (Ptyp) = E_Class_Wide_Type 2161 and then Is_Interface (Ptyp) 2162 and then Is_Task_Interface (Ptyp) 2163 then 2164 Rewrite (N, 2165 Make_Function_Call (Loc, 2166 Name => 2167 New_Occurrence_Of (RTE (RE_Callable), Loc), 2168 Parameter_Associations => New_List ( 2169 Make_Unchecked_Type_Conversion (Loc, 2170 Subtype_Mark => 2171 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), 2172 Expression => 2173 Make_Selected_Component (Loc, 2174 Prefix => 2175 New_Copy_Tree (Pref), 2176 Selector_Name => 2177 Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))))); 2178 2179 else 2180 Rewrite (N, 2181 Build_Call_With_Task (Pref, RTE (RE_Callable))); 2182 end if; 2183 2184 Analyze_And_Resolve (N, Standard_Boolean); 2185 end Callable; 2186 2187 ------------ 2188 -- Caller -- 2189 ------------ 2190 2191 -- Transforms 'Caller attribute into a call to either the 2192 -- Task_Entry_Caller or the Protected_Entry_Caller function. 2193 2194 when Attribute_Caller => Caller : declare 2195 Id_Kind : constant Entity_Id := RTE (RO_AT_Task_Id); 2196 Ent : constant Entity_Id := Entity (Pref); 2197 Conctype : constant Entity_Id := Scope (Ent); 2198 Nest_Depth : Integer := 0; 2199 Name : Node_Id; 2200 S : Entity_Id; 2201 2202 begin 2203 -- Protected case 2204 2205 if Is_Protected_Type (Conctype) then 2206 case Corresponding_Runtime_Package (Conctype) is 2207 when System_Tasking_Protected_Objects_Entries => 2208 Name := 2209 New_Occurrence_Of 2210 (RTE (RE_Protected_Entry_Caller), Loc); 2211 2212 when System_Tasking_Protected_Objects_Single_Entry => 2213 Name := 2214 New_Occurrence_Of 2215 (RTE (RE_Protected_Single_Entry_Caller), Loc); 2216 2217 when others => 2218 raise Program_Error; 2219 end case; 2220 2221 Rewrite (N, 2222 Unchecked_Convert_To (Id_Kind, 2223 Make_Function_Call (Loc, 2224 Name => Name, 2225 Parameter_Associations => New_List ( 2226 New_Occurrence_Of 2227 (Find_Protection_Object (Current_Scope), Loc))))); 2228 2229 -- Task case 2230 2231 else 2232 -- Determine the nesting depth of the E'Caller attribute, that 2233 -- is, how many accept statements are nested within the accept 2234 -- statement for E at the point of E'Caller. The runtime uses 2235 -- this depth to find the specified entry call. 2236 2237 for J in reverse 0 .. Scope_Stack.Last loop 2238 S := Scope_Stack.Table (J).Entity; 2239 2240 -- We should not reach the scope of the entry, as it should 2241 -- already have been checked in Sem_Attr that this attribute 2242 -- reference is within a matching accept statement. 2243 2244 pragma Assert (S /= Conctype); 2245 2246 if S = Ent then 2247 exit; 2248 2249 elsif Is_Entry (S) then 2250 Nest_Depth := Nest_Depth + 1; 2251 end if; 2252 end loop; 2253 2254 Rewrite (N, 2255 Unchecked_Convert_To (Id_Kind, 2256 Make_Function_Call (Loc, 2257 Name => 2258 New_Occurrence_Of (RTE (RE_Task_Entry_Caller), Loc), 2259 Parameter_Associations => New_List ( 2260 Make_Integer_Literal (Loc, 2261 Intval => Int (Nest_Depth)))))); 2262 end if; 2263 2264 Analyze_And_Resolve (N, Id_Kind); 2265 end Caller; 2266 2267 ------------- 2268 -- Compose -- 2269 ------------- 2270 2271 -- Transforms 'Compose into a call to the floating-point attribute 2272 -- function Compose in Fat_xxx (where xxx is the root type) 2273 2274 -- Note: we strictly should have special code here to deal with the 2275 -- case of absurdly negative arguments (less than Integer'First) 2276 -- which will return a (signed) zero value, but it hardly seems 2277 -- worth the effort. Absurdly large positive arguments will raise 2278 -- constraint error which is fine. 2279 2280 when Attribute_Compose => 2281 Expand_Fpt_Attribute_RI (N); 2282 2283 ----------------- 2284 -- Constrained -- 2285 ----------------- 2286 2287 when Attribute_Constrained => Constrained : declare 2288 Formal_Ent : constant Entity_Id := Param_Entity (Pref); 2289 2290 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean; 2291 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a 2292 -- view of an aliased object whose subtype is constrained. 2293 2294 --------------------------------- 2295 -- Is_Constrained_Aliased_View -- 2296 --------------------------------- 2297 2298 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is 2299 E : Entity_Id; 2300 2301 begin 2302 if Is_Entity_Name (Obj) then 2303 E := Entity (Obj); 2304 2305 if Present (Renamed_Object (E)) then 2306 return Is_Constrained_Aliased_View (Renamed_Object (E)); 2307 else 2308 return Is_Aliased (E) and then Is_Constrained (Etype (E)); 2309 end if; 2310 2311 else 2312 return Is_Aliased_View (Obj) 2313 and then 2314 (Is_Constrained (Etype (Obj)) 2315 or else 2316 (Nkind (Obj) = N_Explicit_Dereference 2317 and then 2318 not Object_Type_Has_Constrained_Partial_View 2319 (Typ => Base_Type (Etype (Obj)), 2320 Scop => Current_Scope))); 2321 end if; 2322 end Is_Constrained_Aliased_View; 2323 2324 -- Start of processing for Constrained 2325 2326 begin 2327 -- Reference to a parameter where the value is passed as an extra 2328 -- actual, corresponding to the extra formal referenced by the 2329 -- Extra_Constrained field of the corresponding formal. If this 2330 -- is an entry in-parameter, it is replaced by a constant renaming 2331 -- for which Extra_Constrained is never created. 2332 2333 if Present (Formal_Ent) 2334 and then Ekind (Formal_Ent) /= E_Constant 2335 and then Present (Extra_Constrained (Formal_Ent)) 2336 then 2337 Rewrite (N, 2338 New_Occurrence_Of 2339 (Extra_Constrained (Formal_Ent), Sloc (N))); 2340 2341 -- For variables with a Extra_Constrained field, we use the 2342 -- corresponding entity. 2343 2344 elsif Nkind (Pref) = N_Identifier 2345 and then Ekind (Entity (Pref)) = E_Variable 2346 and then Present (Extra_Constrained (Entity (Pref))) 2347 then 2348 Rewrite (N, 2349 New_Occurrence_Of 2350 (Extra_Constrained (Entity (Pref)), Sloc (N))); 2351 2352 -- For all other entity names, we can tell at compile time 2353 2354 elsif Is_Entity_Name (Pref) then 2355 declare 2356 Ent : constant Entity_Id := Entity (Pref); 2357 Res : Boolean; 2358 2359 begin 2360 -- (RM J.4) obsolescent cases 2361 2362 if Is_Type (Ent) then 2363 2364 -- Private type 2365 2366 if Is_Private_Type (Ent) then 2367 Res := not Has_Discriminants (Ent) 2368 or else Is_Constrained (Ent); 2369 2370 -- It not a private type, must be a generic actual type 2371 -- that corresponded to a private type. We know that this 2372 -- correspondence holds, since otherwise the reference 2373 -- within the generic template would have been illegal. 2374 2375 else 2376 if Is_Composite_Type (Underlying_Type (Ent)) then 2377 Res := Is_Constrained (Ent); 2378 else 2379 Res := True; 2380 end if; 2381 end if; 2382 2383 -- If the prefix is not a variable or is aliased, then 2384 -- definitely true; if it's a formal parameter without an 2385 -- associated extra formal, then treat it as constrained. 2386 2387 -- Ada 2005 (AI-363): An aliased prefix must be known to be 2388 -- constrained in order to set the attribute to True. 2389 2390 elsif not Is_Variable (Pref) 2391 or else Present (Formal_Ent) 2392 or else (Ada_Version < Ada_2005 2393 and then Is_Aliased_View (Pref)) 2394 or else (Ada_Version >= Ada_2005 2395 and then Is_Constrained_Aliased_View (Pref)) 2396 then 2397 Res := True; 2398 2399 -- Variable case, look at type to see if it is constrained. 2400 -- Note that the one case where this is not accurate (the 2401 -- procedure formal case), has been handled above. 2402 2403 -- We use the Underlying_Type here (and below) in case the 2404 -- type is private without discriminants, but the full type 2405 -- has discriminants. This case is illegal, but we generate it 2406 -- internally for passing to the Extra_Constrained parameter. 2407 2408 else 2409 -- In Ada 2012, test for case of a limited tagged type, in 2410 -- which case the attribute is always required to return 2411 -- True. The underlying type is tested, to make sure we also 2412 -- return True for cases where there is an unconstrained 2413 -- object with an untagged limited partial view which has 2414 -- defaulted discriminants (such objects always produce a 2415 -- False in earlier versions of Ada). (Ada 2012: AI05-0214) 2416 2417 Res := Is_Constrained (Underlying_Type (Etype (Ent))) 2418 or else 2419 (Ada_Version >= Ada_2012 2420 and then Is_Tagged_Type (Underlying_Type (Ptyp)) 2421 and then Is_Limited_Type (Ptyp)); 2422 end if; 2423 2424 Rewrite (N, New_Occurrence_Of (Boolean_Literals (Res), Loc)); 2425 end; 2426 2427 -- Prefix is not an entity name. These are also cases where we can 2428 -- always tell at compile time by looking at the form and type of the 2429 -- prefix. If an explicit dereference of an object with constrained 2430 -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the 2431 -- underlying type is a limited tagged type, then Constrained is 2432 -- required to always return True (Ada 2012: AI05-0214). 2433 2434 else 2435 Rewrite (N, 2436 New_Occurrence_Of ( 2437 Boolean_Literals ( 2438 not Is_Variable (Pref) 2439 or else 2440 (Nkind (Pref) = N_Explicit_Dereference 2441 and then 2442 not Object_Type_Has_Constrained_Partial_View 2443 (Typ => Base_Type (Ptyp), 2444 Scop => Current_Scope)) 2445 or else Is_Constrained (Underlying_Type (Ptyp)) 2446 or else (Ada_Version >= Ada_2012 2447 and then Is_Tagged_Type (Underlying_Type (Ptyp)) 2448 and then Is_Limited_Type (Ptyp))), 2449 Loc)); 2450 end if; 2451 2452 Analyze_And_Resolve (N, Standard_Boolean); 2453 end Constrained; 2454 2455 --------------- 2456 -- Copy_Sign -- 2457 --------------- 2458 2459 -- Transforms 'Copy_Sign into a call to the floating-point attribute 2460 -- function Copy_Sign in Fat_xxx (where xxx is the root type) 2461 2462 when Attribute_Copy_Sign => 2463 Expand_Fpt_Attribute_RR (N); 2464 2465 ----------- 2466 -- Count -- 2467 ----------- 2468 2469 -- Transforms 'Count attribute into a call to the Count function 2470 2471 when Attribute_Count => Count : declare 2472 Call : Node_Id; 2473 Conctyp : Entity_Id; 2474 Entnam : Node_Id; 2475 Entry_Id : Entity_Id; 2476 Index : Node_Id; 2477 Name : Node_Id; 2478 2479 begin 2480 -- If the prefix is a member of an entry family, retrieve both 2481 -- entry name and index. For a simple entry there is no index. 2482 2483 if Nkind (Pref) = N_Indexed_Component then 2484 Entnam := Prefix (Pref); 2485 Index := First (Expressions (Pref)); 2486 else 2487 Entnam := Pref; 2488 Index := Empty; 2489 end if; 2490 2491 Entry_Id := Entity (Entnam); 2492 2493 -- Find the concurrent type in which this attribute is referenced 2494 -- (there had better be one). 2495 2496 Conctyp := Current_Scope; 2497 while not Is_Concurrent_Type (Conctyp) loop 2498 Conctyp := Scope (Conctyp); 2499 end loop; 2500 2501 -- Protected case 2502 2503 if Is_Protected_Type (Conctyp) then 2504 case Corresponding_Runtime_Package (Conctyp) is 2505 when System_Tasking_Protected_Objects_Entries => 2506 Name := New_Occurrence_Of (RTE (RE_Protected_Count), Loc); 2507 2508 Call := 2509 Make_Function_Call (Loc, 2510 Name => Name, 2511 Parameter_Associations => New_List ( 2512 New_Occurrence_Of 2513 (Find_Protection_Object (Current_Scope), Loc), 2514 Entry_Index_Expression 2515 (Loc, Entry_Id, Index, Scope (Entry_Id)))); 2516 2517 when System_Tasking_Protected_Objects_Single_Entry => 2518 Name := 2519 New_Occurrence_Of (RTE (RE_Protected_Count_Entry), Loc); 2520 2521 Call := 2522 Make_Function_Call (Loc, 2523 Name => Name, 2524 Parameter_Associations => New_List ( 2525 New_Occurrence_Of 2526 (Find_Protection_Object (Current_Scope), Loc))); 2527 2528 when others => 2529 raise Program_Error; 2530 end case; 2531 2532 -- Task case 2533 2534 else 2535 Call := 2536 Make_Function_Call (Loc, 2537 Name => New_Occurrence_Of (RTE (RE_Task_Count), Loc), 2538 Parameter_Associations => New_List ( 2539 Entry_Index_Expression (Loc, 2540 Entry_Id, Index, Scope (Entry_Id)))); 2541 end if; 2542 2543 -- The call returns type Natural but the context is universal integer 2544 -- so any integer type is allowed. The attribute was already resolved 2545 -- so its Etype is the required result type. If the base type of the 2546 -- context type is other than Standard.Integer we put in a conversion 2547 -- to the required type. This can be a normal typed conversion since 2548 -- both input and output types of the conversion are integer types 2549 2550 if Base_Type (Typ) /= Base_Type (Standard_Integer) then 2551 Rewrite (N, Convert_To (Typ, Call)); 2552 else 2553 Rewrite (N, Call); 2554 end if; 2555 2556 Analyze_And_Resolve (N, Typ); 2557 end Count; 2558 2559 --------------------- 2560 -- Descriptor_Size -- 2561 --------------------- 2562 2563 when Attribute_Descriptor_Size => 2564 2565 -- Attribute Descriptor_Size is handled by the back end when applied 2566 -- to an unconstrained array type. 2567 2568 if Is_Array_Type (Ptyp) 2569 and then not Is_Constrained (Ptyp) 2570 then 2571 Apply_Universal_Integer_Attribute_Checks (N); 2572 2573 -- For any other type, the descriptor size is 0 because there is no 2574 -- actual descriptor, but the result is not formally static. 2575 2576 else 2577 Rewrite (N, Make_Integer_Literal (Loc, 0)); 2578 Analyze (N); 2579 Set_Is_Static_Expression (N, False); 2580 end if; 2581 2582 --------------- 2583 -- Elab_Body -- 2584 --------------- 2585 2586 -- This processing is shared by Elab_Spec 2587 2588 -- What we do is to insert the following declarations 2589 2590 -- procedure tnn; 2591 -- pragma Import (C, enn, "name___elabb/s"); 2592 2593 -- and then the Elab_Body/Spec attribute is replaced by a reference 2594 -- to this defining identifier. 2595 2596 when Attribute_Elab_Body | 2597 Attribute_Elab_Spec => 2598 2599 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil 2600 -- back-end knows how to handle these attributes directly. 2601 2602 if CodePeer_Mode then 2603 return; 2604 end if; 2605 2606 Elab_Body : declare 2607 Ent : constant Entity_Id := Make_Temporary (Loc, 'E'); 2608 Str : String_Id; 2609 Lang : Node_Id; 2610 2611 procedure Make_Elab_String (Nod : Node_Id); 2612 -- Given Nod, an identifier, or a selected component, put the 2613 -- image into the current string literal, with double underline 2614 -- between components. 2615 2616 ---------------------- 2617 -- Make_Elab_String -- 2618 ---------------------- 2619 2620 procedure Make_Elab_String (Nod : Node_Id) is 2621 begin 2622 if Nkind (Nod) = N_Selected_Component then 2623 Make_Elab_String (Prefix (Nod)); 2624 2625 case VM_Target is 2626 when JVM_Target => 2627 Store_String_Char ('$'); 2628 when CLI_Target => 2629 Store_String_Char ('.'); 2630 when No_VM => 2631 Store_String_Char ('_'); 2632 Store_String_Char ('_'); 2633 end case; 2634 2635 Get_Name_String (Chars (Selector_Name (Nod))); 2636 2637 else 2638 pragma Assert (Nkind (Nod) = N_Identifier); 2639 Get_Name_String (Chars (Nod)); 2640 end if; 2641 2642 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 2643 end Make_Elab_String; 2644 2645 -- Start of processing for Elab_Body/Elab_Spec 2646 2647 begin 2648 -- First we need to prepare the string literal for the name of 2649 -- the elaboration routine to be referenced. 2650 2651 Start_String; 2652 Make_Elab_String (Pref); 2653 2654 if VM_Target = No_VM then 2655 Store_String_Chars ("___elab"); 2656 Lang := Make_Identifier (Loc, Name_C); 2657 else 2658 Store_String_Chars ("._elab"); 2659 Lang := Make_Identifier (Loc, Name_Ada); 2660 end if; 2661 2662 if Id = Attribute_Elab_Body then 2663 Store_String_Char ('b'); 2664 else 2665 Store_String_Char ('s'); 2666 end if; 2667 2668 Str := End_String; 2669 2670 Insert_Actions (N, New_List ( 2671 Make_Subprogram_Declaration (Loc, 2672 Specification => 2673 Make_Procedure_Specification (Loc, 2674 Defining_Unit_Name => Ent)), 2675 2676 Make_Pragma (Loc, 2677 Chars => Name_Import, 2678 Pragma_Argument_Associations => New_List ( 2679 Make_Pragma_Argument_Association (Loc, Expression => Lang), 2680 2681 Make_Pragma_Argument_Association (Loc, 2682 Expression => Make_Identifier (Loc, Chars (Ent))), 2683 2684 Make_Pragma_Argument_Association (Loc, 2685 Expression => Make_String_Literal (Loc, Str)))))); 2686 2687 Set_Entity (N, Ent); 2688 Rewrite (N, New_Occurrence_Of (Ent, Loc)); 2689 end Elab_Body; 2690 2691 -------------------- 2692 -- Elab_Subp_Body -- 2693 -------------------- 2694 2695 -- Always ignored. In CodePeer mode, gnat2scil knows how to handle 2696 -- this attribute directly, and if we are not in CodePeer mode it is 2697 -- entirely ignored ??? 2698 2699 when Attribute_Elab_Subp_Body => 2700 return; 2701 2702 ---------------- 2703 -- Elaborated -- 2704 ---------------- 2705 2706 -- Elaborated is always True for preelaborated units, predefined units, 2707 -- pure units and units which have Elaborate_Body pragmas. These units 2708 -- have no elaboration entity. 2709 2710 -- Note: The Elaborated attribute is never passed to the back end 2711 2712 when Attribute_Elaborated => Elaborated : declare 2713 Ent : constant Entity_Id := Entity (Pref); 2714 2715 begin 2716 if Present (Elaboration_Entity (Ent)) then 2717 Rewrite (N, 2718 Make_Op_Ne (Loc, 2719 Left_Opnd => 2720 New_Occurrence_Of (Elaboration_Entity (Ent), Loc), 2721 Right_Opnd => 2722 Make_Integer_Literal (Loc, Uint_0))); 2723 Analyze_And_Resolve (N, Typ); 2724 else 2725 Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); 2726 end if; 2727 end Elaborated; 2728 2729 -------------- 2730 -- Enum_Rep -- 2731 -------------- 2732 2733 when Attribute_Enum_Rep => Enum_Rep : 2734 begin 2735 -- X'Enum_Rep (Y) expands to 2736 2737 -- target-type (Y) 2738 2739 -- This is simply a direct conversion from the enumeration type to 2740 -- the target integer type, which is treated by the back end as a 2741 -- normal integer conversion, treating the enumeration type as an 2742 -- integer, which is exactly what we want. We set Conversion_OK to 2743 -- make sure that the analyzer does not complain about what otherwise 2744 -- might be an illegal conversion. 2745 2746 if Is_Non_Empty_List (Exprs) then 2747 Rewrite (N, 2748 OK_Convert_To (Typ, Relocate_Node (First (Exprs)))); 2749 2750 -- X'Enum_Rep where X is an enumeration literal is replaced by 2751 -- the literal value. 2752 2753 elsif Ekind (Entity (Pref)) = E_Enumeration_Literal then 2754 Rewrite (N, 2755 Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Pref)))); 2756 2757 -- If this is a renaming of a literal, recover the representation 2758 -- of the original. 2759 2760 elsif Ekind (Entity (Pref)) = E_Constant 2761 and then Present (Renamed_Object (Entity (Pref))) 2762 and then 2763 Ekind (Entity (Renamed_Object (Entity (Pref)))) 2764 = E_Enumeration_Literal 2765 then 2766 Rewrite (N, 2767 Make_Integer_Literal (Loc, 2768 Enumeration_Rep (Entity (Renamed_Object (Entity (Pref)))))); 2769 2770 -- X'Enum_Rep where X is an object does a direct unchecked conversion 2771 -- of the object value, as described for the type case above. 2772 2773 else 2774 Rewrite (N, 2775 OK_Convert_To (Typ, Relocate_Node (Pref))); 2776 end if; 2777 2778 Set_Etype (N, Typ); 2779 Analyze_And_Resolve (N, Typ); 2780 end Enum_Rep; 2781 2782 -------------- 2783 -- Enum_Val -- 2784 -------------- 2785 2786 when Attribute_Enum_Val => Enum_Val : declare 2787 Expr : Node_Id; 2788 Btyp : constant Entity_Id := Base_Type (Ptyp); 2789 2790 begin 2791 -- X'Enum_Val (Y) expands to 2792 2793 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg] 2794 -- X!(Y); 2795 2796 Expr := Unchecked_Convert_To (Ptyp, First (Exprs)); 2797 2798 Insert_Action (N, 2799 Make_Raise_Constraint_Error (Loc, 2800 Condition => 2801 Make_Op_Eq (Loc, 2802 Left_Opnd => 2803 Make_Function_Call (Loc, 2804 Name => 2805 New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc), 2806 Parameter_Associations => New_List ( 2807 Relocate_Node (Duplicate_Subexpr (Expr)), 2808 New_Occurrence_Of (Standard_False, Loc))), 2809 2810 Right_Opnd => Make_Integer_Literal (Loc, -1)), 2811 Reason => CE_Range_Check_Failed)); 2812 2813 Rewrite (N, Expr); 2814 Analyze_And_Resolve (N, Ptyp); 2815 end Enum_Val; 2816 2817 -------------- 2818 -- Exponent -- 2819 -------------- 2820 2821 -- Transforms 'Exponent into a call to the floating-point attribute 2822 -- function Exponent in Fat_xxx (where xxx is the root type) 2823 2824 when Attribute_Exponent => 2825 Expand_Fpt_Attribute_R (N); 2826 2827 ------------------ 2828 -- External_Tag -- 2829 ------------------ 2830 2831 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag) 2832 2833 when Attribute_External_Tag => External_Tag : 2834 begin 2835 Rewrite (N, 2836 Make_Function_Call (Loc, 2837 Name => New_Occurrence_Of (RTE (RE_External_Tag), Loc), 2838 Parameter_Associations => New_List ( 2839 Make_Attribute_Reference (Loc, 2840 Attribute_Name => Name_Tag, 2841 Prefix => Prefix (N))))); 2842 2843 Analyze_And_Resolve (N, Standard_String); 2844 end External_Tag; 2845 2846 ----------- 2847 -- First -- 2848 ----------- 2849 2850 when Attribute_First => 2851 2852 -- If the prefix type is a constrained packed array type which 2853 -- already has a Packed_Array_Type representation defined, then 2854 -- replace this attribute with a direct reference to 'First of the 2855 -- appropriate index subtype (since otherwise the back end will try 2856 -- to give us the value of 'First for this implementation type). 2857 2858 if Is_Constrained_Packed_Array (Ptyp) then 2859 Rewrite (N, 2860 Make_Attribute_Reference (Loc, 2861 Attribute_Name => Name_First, 2862 Prefix => New_Occurrence_Of (Get_Index_Subtype (N), Loc))); 2863 Analyze_And_Resolve (N, Typ); 2864 2865 elsif Is_Access_Type (Ptyp) then 2866 Apply_Access_Check (N); 2867 end if; 2868 2869 --------------- 2870 -- First_Bit -- 2871 --------------- 2872 2873 -- Compute this if component clause was present, otherwise we leave the 2874 -- computation to be completed in the back-end, since we don't know what 2875 -- layout will be chosen. 2876 2877 when Attribute_First_Bit => First_Bit_Attr : declare 2878 CE : constant Entity_Id := Entity (Selector_Name (Pref)); 2879 2880 begin 2881 -- In Ada 2005 (or later) if we have the non-default bit order, then 2882 -- we return the original value as given in the component clause 2883 -- (RM 2005 13.5.2(3/2)). 2884 2885 if Present (Component_Clause (CE)) 2886 and then Ada_Version >= Ada_2005 2887 and then Reverse_Bit_Order (Scope (CE)) 2888 then 2889 Rewrite (N, 2890 Make_Integer_Literal (Loc, 2891 Intval => Expr_Value (First_Bit (Component_Clause (CE))))); 2892 Analyze_And_Resolve (N, Typ); 2893 2894 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order), 2895 -- rewrite with normalized value if we know it statically. 2896 2897 elsif Known_Static_Component_Bit_Offset (CE) then 2898 Rewrite (N, 2899 Make_Integer_Literal (Loc, 2900 Component_Bit_Offset (CE) mod System_Storage_Unit)); 2901 Analyze_And_Resolve (N, Typ); 2902 2903 -- Otherwise left to back end, just do universal integer checks 2904 2905 else 2906 Apply_Universal_Integer_Attribute_Checks (N); 2907 end if; 2908 end First_Bit_Attr; 2909 2910 ----------------- 2911 -- Fixed_Value -- 2912 ----------------- 2913 2914 -- We transform: 2915 2916 -- fixtype'Fixed_Value (integer-value) 2917 2918 -- into 2919 2920 -- fixtype(integer-value) 2921 2922 -- We do all the required analysis of the conversion here, because we do 2923 -- not want this to go through the fixed-point conversion circuits. Note 2924 -- that the back end always treats fixed-point as equivalent to the 2925 -- corresponding integer type anyway. 2926 2927 when Attribute_Fixed_Value => Fixed_Value : 2928 begin 2929 Rewrite (N, 2930 Make_Type_Conversion (Loc, 2931 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc), 2932 Expression => Relocate_Node (First (Exprs)))); 2933 Set_Etype (N, Entity (Pref)); 2934 Set_Analyzed (N); 2935 2936 -- Note: it might appear that a properly analyzed unchecked conversion 2937 -- would be just fine here, but that's not the case, since the full 2938 -- range checks performed by the following call are critical. 2939 2940 Apply_Type_Conversion_Checks (N); 2941 end Fixed_Value; 2942 2943 ----------- 2944 -- Floor -- 2945 ----------- 2946 2947 -- Transforms 'Floor into a call to the floating-point attribute 2948 -- function Floor in Fat_xxx (where xxx is the root type) 2949 2950 when Attribute_Floor => 2951 Expand_Fpt_Attribute_R (N); 2952 2953 ---------- 2954 -- Fore -- 2955 ---------- 2956 2957 -- For the fixed-point type Typ: 2958 2959 -- Typ'Fore 2960 2961 -- expands into 2962 2963 -- Result_Type (System.Fore (Universal_Real (Type'First)), 2964 -- Universal_Real (Type'Last)) 2965 2966 -- Note that we know that the type is a non-static subtype, or Fore 2967 -- would have itself been computed dynamically in Eval_Attribute. 2968 2969 when Attribute_Fore => Fore : begin 2970 Rewrite (N, 2971 Convert_To (Typ, 2972 Make_Function_Call (Loc, 2973 Name => New_Occurrence_Of (RTE (RE_Fore), Loc), 2974 2975 Parameter_Associations => New_List ( 2976 Convert_To (Universal_Real, 2977 Make_Attribute_Reference (Loc, 2978 Prefix => New_Occurrence_Of (Ptyp, Loc), 2979 Attribute_Name => Name_First)), 2980 2981 Convert_To (Universal_Real, 2982 Make_Attribute_Reference (Loc, 2983 Prefix => New_Occurrence_Of (Ptyp, Loc), 2984 Attribute_Name => Name_Last)))))); 2985 2986 Analyze_And_Resolve (N, Typ); 2987 end Fore; 2988 2989 -------------- 2990 -- Fraction -- 2991 -------------- 2992 2993 -- Transforms 'Fraction into a call to the floating-point attribute 2994 -- function Fraction in Fat_xxx (where xxx is the root type) 2995 2996 when Attribute_Fraction => 2997 Expand_Fpt_Attribute_R (N); 2998 2999 -------------- 3000 -- From_Any -- 3001 -------------- 3002 3003 when Attribute_From_Any => From_Any : declare 3004 P_Type : constant Entity_Id := Etype (Pref); 3005 Decls : constant List_Id := New_List; 3006 begin 3007 Rewrite (N, 3008 Build_From_Any_Call (P_Type, 3009 Relocate_Node (First (Exprs)), 3010 Decls)); 3011 Insert_Actions (N, Decls); 3012 Analyze_And_Resolve (N, P_Type); 3013 end From_Any; 3014 3015 -------------- 3016 -- Identity -- 3017 -------------- 3018 3019 -- For an exception returns a reference to the exception data: 3020 -- Exception_Id!(Prefix'Reference) 3021 3022 -- For a task it returns a reference to the _task_id component of 3023 -- corresponding record: 3024 3025 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined 3026 3027 -- in Ada.Task_Identification 3028 3029 when Attribute_Identity => Identity : declare 3030 Id_Kind : Entity_Id; 3031 3032 begin 3033 if Ptyp = Standard_Exception_Type then 3034 Id_Kind := RTE (RE_Exception_Id); 3035 3036 if Present (Renamed_Object (Entity (Pref))) then 3037 Set_Entity (Pref, Renamed_Object (Entity (Pref))); 3038 end if; 3039 3040 Rewrite (N, 3041 Unchecked_Convert_To (Id_Kind, Make_Reference (Loc, Pref))); 3042 else 3043 Id_Kind := RTE (RO_AT_Task_Id); 3044 3045 -- If the prefix is a task interface, the Task_Id is obtained 3046 -- dynamically through a dispatching call, as for other task 3047 -- attributes applied to interfaces. 3048 3049 if Ada_Version >= Ada_2005 3050 and then Ekind (Ptyp) = E_Class_Wide_Type 3051 and then Is_Interface (Ptyp) 3052 and then Is_Task_Interface (Ptyp) 3053 then 3054 Rewrite (N, 3055 Unchecked_Convert_To (Id_Kind, 3056 Make_Selected_Component (Loc, 3057 Prefix => 3058 New_Copy_Tree (Pref), 3059 Selector_Name => 3060 Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))); 3061 3062 else 3063 Rewrite (N, 3064 Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref))); 3065 end if; 3066 end if; 3067 3068 Analyze_And_Resolve (N, Id_Kind); 3069 end Identity; 3070 3071 ----------- 3072 -- Image -- 3073 ----------- 3074 3075 -- Image attribute is handled in separate unit Exp_Imgv 3076 3077 when Attribute_Image => 3078 Exp_Imgv.Expand_Image_Attribute (N); 3079 3080 --------- 3081 -- Img -- 3082 --------- 3083 3084 -- X'Img is expanded to typ'Image (X), where typ is the type of X 3085 3086 when Attribute_Img => Img : 3087 begin 3088 Rewrite (N, 3089 Make_Attribute_Reference (Loc, 3090 Prefix => New_Occurrence_Of (Ptyp, Loc), 3091 Attribute_Name => Name_Image, 3092 Expressions => New_List (Relocate_Node (Pref)))); 3093 3094 Analyze_And_Resolve (N, Standard_String); 3095 end Img; 3096 3097 ----------- 3098 -- Input -- 3099 ----------- 3100 3101 when Attribute_Input => Input : declare 3102 P_Type : constant Entity_Id := Entity (Pref); 3103 B_Type : constant Entity_Id := Base_Type (P_Type); 3104 U_Type : constant Entity_Id := Underlying_Type (P_Type); 3105 Strm : constant Node_Id := First (Exprs); 3106 Fname : Entity_Id; 3107 Decl : Node_Id; 3108 Call : Node_Id; 3109 Prag : Node_Id; 3110 Arg2 : Node_Id; 3111 Rfunc : Node_Id; 3112 3113 Cntrl : Node_Id := Empty; 3114 -- Value for controlling argument in call. Always Empty except in 3115 -- the dispatching (class-wide type) case, where it is a reference 3116 -- to the dummy object initialized to the right internal tag. 3117 3118 procedure Freeze_Stream_Subprogram (F : Entity_Id); 3119 -- The expansion of the attribute reference may generate a call to 3120 -- a user-defined stream subprogram that is frozen by the call. This 3121 -- can lead to access-before-elaboration problem if the reference 3122 -- appears in an object declaration and the subprogram body has not 3123 -- been seen. The freezing of the subprogram requires special code 3124 -- because it appears in an expanded context where expressions do 3125 -- not freeze their constituents. 3126 3127 ------------------------------ 3128 -- Freeze_Stream_Subprogram -- 3129 ------------------------------ 3130 3131 procedure Freeze_Stream_Subprogram (F : Entity_Id) is 3132 Decl : constant Node_Id := Unit_Declaration_Node (F); 3133 Bod : Node_Id; 3134 3135 begin 3136 -- If this is user-defined subprogram, the corresponding 3137 -- stream function appears as a renaming-as-body, and the 3138 -- user subprogram must be retrieved by tree traversal. 3139 3140 if Present (Decl) 3141 and then Nkind (Decl) = N_Subprogram_Declaration 3142 and then Present (Corresponding_Body (Decl)) 3143 then 3144 Bod := Corresponding_Body (Decl); 3145 3146 if Nkind (Unit_Declaration_Node (Bod)) = 3147 N_Subprogram_Renaming_Declaration 3148 then 3149 Set_Is_Frozen (Entity (Name (Unit_Declaration_Node (Bod)))); 3150 end if; 3151 end if; 3152 end Freeze_Stream_Subprogram; 3153 3154 -- Start of processing for Input 3155 3156 begin 3157 -- If no underlying type, we have an error that will be diagnosed 3158 -- elsewhere, so here we just completely ignore the expansion. 3159 3160 if No (U_Type) then 3161 return; 3162 end if; 3163 3164 -- If there is a TSS for Input, just call it 3165 3166 Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input); 3167 3168 if Present (Fname) then 3169 null; 3170 3171 else 3172 -- If there is a Stream_Convert pragma, use it, we rewrite 3173 3174 -- sourcetyp'Input (stream) 3175 3176 -- as 3177 3178 -- sourcetyp (streamread (strmtyp'Input (stream))); 3179 3180 -- where streamread is the given Read function that converts an 3181 -- argument of type strmtyp to type sourcetyp or a type from which 3182 -- it is derived (extra conversion required for the derived case). 3183 3184 Prag := Get_Stream_Convert_Pragma (P_Type); 3185 3186 if Present (Prag) then 3187 Arg2 := Next (First (Pragma_Argument_Associations (Prag))); 3188 Rfunc := Entity (Expression (Arg2)); 3189 3190 Rewrite (N, 3191 Convert_To (B_Type, 3192 Make_Function_Call (Loc, 3193 Name => New_Occurrence_Of (Rfunc, Loc), 3194 Parameter_Associations => New_List ( 3195 Make_Attribute_Reference (Loc, 3196 Prefix => 3197 New_Occurrence_Of 3198 (Etype (First_Formal (Rfunc)), Loc), 3199 Attribute_Name => Name_Input, 3200 Expressions => Exprs))))); 3201 3202 Analyze_And_Resolve (N, B_Type); 3203 return; 3204 3205 -- Elementary types 3206 3207 elsif Is_Elementary_Type (U_Type) then 3208 3209 -- A special case arises if we have a defined _Read routine, 3210 -- since in this case we are required to call this routine. 3211 3212 if Present (TSS (Base_Type (U_Type), TSS_Stream_Read)) then 3213 Build_Record_Or_Elementary_Input_Function 3214 (Loc, U_Type, Decl, Fname); 3215 Insert_Action (N, Decl); 3216 3217 -- For normal cases, we call the I_xxx routine directly 3218 3219 else 3220 Rewrite (N, Build_Elementary_Input_Call (N)); 3221 Analyze_And_Resolve (N, P_Type); 3222 return; 3223 end if; 3224 3225 -- Array type case 3226 3227 elsif Is_Array_Type (U_Type) then 3228 Build_Array_Input_Function (Loc, U_Type, Decl, Fname); 3229 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False); 3230 3231 -- Dispatching case with class-wide type 3232 3233 elsif Is_Class_Wide_Type (P_Type) then 3234 3235 -- No need to do anything else compiling under restriction 3236 -- No_Dispatching_Calls. During the semantic analysis we 3237 -- already notified such violation. 3238 3239 if Restriction_Active (No_Dispatching_Calls) then 3240 return; 3241 end if; 3242 3243 declare 3244 Rtyp : constant Entity_Id := Root_Type (P_Type); 3245 Dnn : Entity_Id; 3246 Decl : Node_Id; 3247 Expr : Node_Id; 3248 3249 begin 3250 -- Read the internal tag (RM 13.13.2(34)) and use it to 3251 -- initialize a dummy tag object: 3252 3253 -- Dnn : Ada.Tags.Tag := 3254 -- Descendant_Tag (String'Input (Strm), P_Type); 3255 3256 -- This dummy object is used only to provide a controlling 3257 -- argument for the eventual _Input call. Descendant_Tag is 3258 -- called rather than Internal_Tag to ensure that we have a 3259 -- tag for a type that is descended from the prefix type and 3260 -- declared at the same accessibility level (the exception 3261 -- Tag_Error will be raised otherwise). The level check is 3262 -- required for Ada 2005 because tagged types can be 3263 -- extended in nested scopes (AI-344). 3264 3265 Expr := 3266 Make_Function_Call (Loc, 3267 Name => 3268 New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc), 3269 Parameter_Associations => New_List ( 3270 Make_Attribute_Reference (Loc, 3271 Prefix => New_Occurrence_Of (Standard_String, Loc), 3272 Attribute_Name => Name_Input, 3273 Expressions => New_List ( 3274 Relocate_Node (Duplicate_Subexpr (Strm)))), 3275 Make_Attribute_Reference (Loc, 3276 Prefix => New_Occurrence_Of (P_Type, Loc), 3277 Attribute_Name => Name_Tag))); 3278 3279 Dnn := Make_Temporary (Loc, 'D', Expr); 3280 3281 Decl := 3282 Make_Object_Declaration (Loc, 3283 Defining_Identifier => Dnn, 3284 Object_Definition => 3285 New_Occurrence_Of (RTE (RE_Tag), Loc), 3286 Expression => Expr); 3287 3288 Insert_Action (N, Decl); 3289 3290 -- Now we need to get the entity for the call, and construct 3291 -- a function call node, where we preset a reference to Dnn 3292 -- as the controlling argument (doing an unchecked convert 3293 -- to the class-wide tagged type to make it look like a real 3294 -- tagged object). 3295 3296 Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input); 3297 Cntrl := 3298 Unchecked_Convert_To (P_Type, 3299 New_Occurrence_Of (Dnn, Loc)); 3300 Set_Etype (Cntrl, P_Type); 3301 Set_Parent (Cntrl, N); 3302 end; 3303 3304 -- For tagged types, use the primitive Input function 3305 3306 elsif Is_Tagged_Type (U_Type) then 3307 Fname := Find_Prim_Op (U_Type, TSS_Stream_Input); 3308 3309 -- All other record type cases, including protected records. The 3310 -- latter only arise for expander generated code for handling 3311 -- shared passive partition access. 3312 3313 else 3314 pragma Assert 3315 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); 3316 3317 -- Ada 2005 (AI-216): Program_Error is raised executing default 3318 -- implementation of the Input attribute of an unchecked union 3319 -- type if the type lacks default discriminant values. 3320 3321 if Is_Unchecked_Union (Base_Type (U_Type)) 3322 and then No (Discriminant_Constraint (U_Type)) 3323 then 3324 Insert_Action (N, 3325 Make_Raise_Program_Error (Loc, 3326 Reason => PE_Unchecked_Union_Restriction)); 3327 3328 return; 3329 end if; 3330 3331 -- Build the type's Input function, passing the subtype rather 3332 -- than its base type, because checks are needed in the case of 3333 -- constrained discriminants (see Ada 2012 AI05-0192). 3334 3335 Build_Record_Or_Elementary_Input_Function 3336 (Loc, U_Type, Decl, Fname); 3337 Insert_Action (N, Decl); 3338 3339 if Nkind (Parent (N)) = N_Object_Declaration 3340 and then Is_Record_Type (U_Type) 3341 then 3342 -- The stream function may contain calls to user-defined 3343 -- Read procedures for individual components. 3344 3345 declare 3346 Comp : Entity_Id; 3347 Func : Entity_Id; 3348 3349 begin 3350 Comp := First_Component (U_Type); 3351 while Present (Comp) loop 3352 Func := 3353 Find_Stream_Subprogram 3354 (Etype (Comp), TSS_Stream_Read); 3355 3356 if Present (Func) then 3357 Freeze_Stream_Subprogram (Func); 3358 end if; 3359 3360 Next_Component (Comp); 3361 end loop; 3362 end; 3363 end if; 3364 end if; 3365 end if; 3366 3367 -- If we fall through, Fname is the function to be called. The result 3368 -- is obtained by calling the appropriate function, then converting 3369 -- the result. The conversion does a subtype check. 3370 3371 Call := 3372 Make_Function_Call (Loc, 3373 Name => New_Occurrence_Of (Fname, Loc), 3374 Parameter_Associations => New_List ( 3375 Relocate_Node (Strm))); 3376 3377 Set_Controlling_Argument (Call, Cntrl); 3378 Rewrite (N, Unchecked_Convert_To (P_Type, Call)); 3379 Analyze_And_Resolve (N, P_Type); 3380 3381 if Nkind (Parent (N)) = N_Object_Declaration then 3382 Freeze_Stream_Subprogram (Fname); 3383 end if; 3384 end Input; 3385 3386 ------------------- 3387 -- Integer_Value -- 3388 ------------------- 3389 3390 -- We transform 3391 3392 -- inttype'Fixed_Value (fixed-value) 3393 3394 -- into 3395 3396 -- inttype(integer-value)) 3397 3398 -- we do all the required analysis of the conversion here, because we do 3399 -- not want this to go through the fixed-point conversion circuits. Note 3400 -- that the back end always treats fixed-point as equivalent to the 3401 -- corresponding integer type anyway. 3402 3403 when Attribute_Integer_Value => Integer_Value : 3404 begin 3405 Rewrite (N, 3406 Make_Type_Conversion (Loc, 3407 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc), 3408 Expression => Relocate_Node (First (Exprs)))); 3409 Set_Etype (N, Entity (Pref)); 3410 Set_Analyzed (N); 3411 3412 -- Note: it might appear that a properly analyzed unchecked conversion 3413 -- would be just fine here, but that's not the case, since the full 3414 -- range checks performed by the following call are critical. 3415 3416 Apply_Type_Conversion_Checks (N); 3417 end Integer_Value; 3418 3419 ------------------- 3420 -- Invalid_Value -- 3421 ------------------- 3422 3423 when Attribute_Invalid_Value => 3424 Rewrite (N, Get_Simple_Init_Val (Ptyp, N)); 3425 3426 ---------- 3427 -- Last -- 3428 ---------- 3429 3430 when Attribute_Last => 3431 3432 -- If the prefix type is a constrained packed array type which 3433 -- already has a Packed_Array_Type representation defined, then 3434 -- replace this attribute with a direct reference to 'Last of the 3435 -- appropriate index subtype (since otherwise the back end will try 3436 -- to give us the value of 'Last for this implementation type). 3437 3438 if Is_Constrained_Packed_Array (Ptyp) then 3439 Rewrite (N, 3440 Make_Attribute_Reference (Loc, 3441 Attribute_Name => Name_Last, 3442 Prefix => New_Occurrence_Of (Get_Index_Subtype (N), Loc))); 3443 Analyze_And_Resolve (N, Typ); 3444 3445 elsif Is_Access_Type (Ptyp) then 3446 Apply_Access_Check (N); 3447 end if; 3448 3449 -------------- 3450 -- Last_Bit -- 3451 -------------- 3452 3453 -- We compute this if a component clause was present, otherwise we leave 3454 -- the computation up to the back end, since we don't know what layout 3455 -- will be chosen. 3456 3457 when Attribute_Last_Bit => Last_Bit_Attr : declare 3458 CE : constant Entity_Id := Entity (Selector_Name (Pref)); 3459 3460 begin 3461 -- In Ada 2005 (or later) if we have the non-default bit order, then 3462 -- we return the original value as given in the component clause 3463 -- (RM 2005 13.5.2(3/2)). 3464 3465 if Present (Component_Clause (CE)) 3466 and then Ada_Version >= Ada_2005 3467 and then Reverse_Bit_Order (Scope (CE)) 3468 then 3469 Rewrite (N, 3470 Make_Integer_Literal (Loc, 3471 Intval => Expr_Value (Last_Bit (Component_Clause (CE))))); 3472 Analyze_And_Resolve (N, Typ); 3473 3474 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order), 3475 -- rewrite with normalized value if we know it statically. 3476 3477 elsif Known_Static_Component_Bit_Offset (CE) 3478 and then Known_Static_Esize (CE) 3479 then 3480 Rewrite (N, 3481 Make_Integer_Literal (Loc, 3482 Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit) 3483 + Esize (CE) - 1)); 3484 Analyze_And_Resolve (N, Typ); 3485 3486 -- Otherwise leave to back end, just apply universal integer checks 3487 3488 else 3489 Apply_Universal_Integer_Attribute_Checks (N); 3490 end if; 3491 end Last_Bit_Attr; 3492 3493 ------------------ 3494 -- Leading_Part -- 3495 ------------------ 3496 3497 -- Transforms 'Leading_Part into a call to the floating-point attribute 3498 -- function Leading_Part in Fat_xxx (where xxx is the root type) 3499 3500 -- Note: strictly, we should generate special case code to deal with 3501 -- absurdly large positive arguments (greater than Integer'Last), which 3502 -- result in returning the first argument unchanged, but it hardly seems 3503 -- worth the effort. We raise constraint error for absurdly negative 3504 -- arguments which is fine. 3505 3506 when Attribute_Leading_Part => 3507 Expand_Fpt_Attribute_RI (N); 3508 3509 ------------ 3510 -- Length -- 3511 ------------ 3512 3513 when Attribute_Length => Length : declare 3514 Ityp : Entity_Id; 3515 Xnum : Uint; 3516 3517 begin 3518 -- Processing for packed array types 3519 3520 if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then 3521 Ityp := Get_Index_Subtype (N); 3522 3523 -- If the index type, Ityp, is an enumeration type with holes, 3524 -- then we calculate X'Length explicitly using 3525 3526 -- Typ'Max 3527 -- (0, Ityp'Pos (X'Last (N)) - 3528 -- Ityp'Pos (X'First (N)) + 1); 3529 3530 -- Since the bounds in the template are the representation values 3531 -- and the back end would get the wrong value. 3532 3533 if Is_Enumeration_Type (Ityp) 3534 and then Present (Enum_Pos_To_Rep (Base_Type (Ityp))) 3535 then 3536 if No (Exprs) then 3537 Xnum := Uint_1; 3538 else 3539 Xnum := Expr_Value (First (Expressions (N))); 3540 end if; 3541 3542 Rewrite (N, 3543 Make_Attribute_Reference (Loc, 3544 Prefix => New_Occurrence_Of (Typ, Loc), 3545 Attribute_Name => Name_Max, 3546 Expressions => New_List 3547 (Make_Integer_Literal (Loc, 0), 3548 3549 Make_Op_Add (Loc, 3550 Left_Opnd => 3551 Make_Op_Subtract (Loc, 3552 Left_Opnd => 3553 Make_Attribute_Reference (Loc, 3554 Prefix => New_Occurrence_Of (Ityp, Loc), 3555 Attribute_Name => Name_Pos, 3556 3557 Expressions => New_List ( 3558 Make_Attribute_Reference (Loc, 3559 Prefix => Duplicate_Subexpr (Pref), 3560 Attribute_Name => Name_Last, 3561 Expressions => New_List ( 3562 Make_Integer_Literal (Loc, Xnum))))), 3563 3564 Right_Opnd => 3565 Make_Attribute_Reference (Loc, 3566 Prefix => New_Occurrence_Of (Ityp, Loc), 3567 Attribute_Name => Name_Pos, 3568 3569 Expressions => New_List ( 3570 Make_Attribute_Reference (Loc, 3571 Prefix => 3572 Duplicate_Subexpr_No_Checks (Pref), 3573 Attribute_Name => Name_First, 3574 Expressions => New_List ( 3575 Make_Integer_Literal (Loc, Xnum)))))), 3576 3577 Right_Opnd => Make_Integer_Literal (Loc, 1))))); 3578 3579 Analyze_And_Resolve (N, Typ, Suppress => All_Checks); 3580 return; 3581 3582 -- If the prefix type is a constrained packed array type which 3583 -- already has a Packed_Array_Type representation defined, then 3584 -- replace this attribute with a direct reference to 'Range_Length 3585 -- of the appropriate index subtype (since otherwise the back end 3586 -- will try to give us the value of 'Length for this 3587 -- implementation type). 3588 3589 elsif Is_Constrained (Ptyp) then 3590 Rewrite (N, 3591 Make_Attribute_Reference (Loc, 3592 Attribute_Name => Name_Range_Length, 3593 Prefix => New_Occurrence_Of (Ityp, Loc))); 3594 Analyze_And_Resolve (N, Typ); 3595 end if; 3596 3597 -- Access type case 3598 3599 elsif Is_Access_Type (Ptyp) then 3600 Apply_Access_Check (N); 3601 3602 -- If the designated type is a packed array type, then we convert 3603 -- the reference to: 3604 3605 -- typ'Max (0, 1 + 3606 -- xtyp'Pos (Pref'Last (Expr)) - 3607 -- xtyp'Pos (Pref'First (Expr))); 3608 3609 -- This is a bit complex, but it is the easiest thing to do that 3610 -- works in all cases including enum types with holes xtyp here 3611 -- is the appropriate index type. 3612 3613 declare 3614 Dtyp : constant Entity_Id := Designated_Type (Ptyp); 3615 Xtyp : Entity_Id; 3616 3617 begin 3618 if Is_Array_Type (Dtyp) and then Is_Packed (Dtyp) then 3619 Xtyp := Get_Index_Subtype (N); 3620 3621 Rewrite (N, 3622 Make_Attribute_Reference (Loc, 3623 Prefix => New_Occurrence_Of (Typ, Loc), 3624 Attribute_Name => Name_Max, 3625 Expressions => New_List ( 3626 Make_Integer_Literal (Loc, 0), 3627 3628 Make_Op_Add (Loc, 3629 Make_Integer_Literal (Loc, 1), 3630 Make_Op_Subtract (Loc, 3631 Left_Opnd => 3632 Make_Attribute_Reference (Loc, 3633 Prefix => New_Occurrence_Of (Xtyp, Loc), 3634 Attribute_Name => Name_Pos, 3635 Expressions => New_List ( 3636 Make_Attribute_Reference (Loc, 3637 Prefix => Duplicate_Subexpr (Pref), 3638 Attribute_Name => Name_Last, 3639 Expressions => 3640 New_Copy_List (Exprs)))), 3641 3642 Right_Opnd => 3643 Make_Attribute_Reference (Loc, 3644 Prefix => New_Occurrence_Of (Xtyp, Loc), 3645 Attribute_Name => Name_Pos, 3646 Expressions => New_List ( 3647 Make_Attribute_Reference (Loc, 3648 Prefix => 3649 Duplicate_Subexpr_No_Checks (Pref), 3650 Attribute_Name => Name_First, 3651 Expressions => 3652 New_Copy_List (Exprs))))))))); 3653 3654 Analyze_And_Resolve (N, Typ); 3655 end if; 3656 end; 3657 3658 -- Otherwise leave it to the back end 3659 3660 else 3661 Apply_Universal_Integer_Attribute_Checks (N); 3662 end if; 3663 end Length; 3664 3665 -- Attribute Loop_Entry is replaced with a reference to a constant value 3666 -- which captures the prefix at the entry point of the related loop. The 3667 -- loop itself may be transformed into a conditional block. 3668 3669 when Attribute_Loop_Entry => 3670 Expand_Loop_Entry_Attribute (N); 3671 3672 ------------- 3673 -- Machine -- 3674 ------------- 3675 3676 -- Transforms 'Machine into a call to the floating-point attribute 3677 -- function Machine in Fat_xxx (where xxx is the root type) 3678 3679 when Attribute_Machine => 3680 Expand_Fpt_Attribute_R (N); 3681 3682 ---------------------- 3683 -- Machine_Rounding -- 3684 ---------------------- 3685 3686 -- Transforms 'Machine_Rounding into a call to the floating-point 3687 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root 3688 -- type). Expansion is avoided for cases the back end can handle 3689 -- directly. 3690 3691 when Attribute_Machine_Rounding => 3692 if not Is_Inline_Floating_Point_Attribute (N) then 3693 Expand_Fpt_Attribute_R (N); 3694 end if; 3695 3696 ------------------ 3697 -- Machine_Size -- 3698 ------------------ 3699 3700 -- Machine_Size is equivalent to Object_Size, so transform it into 3701 -- Object_Size and that way the back end never sees Machine_Size. 3702 3703 when Attribute_Machine_Size => 3704 Rewrite (N, 3705 Make_Attribute_Reference (Loc, 3706 Prefix => Prefix (N), 3707 Attribute_Name => Name_Object_Size)); 3708 3709 Analyze_And_Resolve (N, Typ); 3710 3711 -------------- 3712 -- Mantissa -- 3713 -------------- 3714 3715 -- The only case that can get this far is the dynamic case of the old 3716 -- Ada 83 Mantissa attribute for the fixed-point case. For this case, 3717 -- we expand: 3718 3719 -- typ'Mantissa 3720 3721 -- into 3722 3723 -- ityp (System.Mantissa.Mantissa_Value 3724 -- (Integer'Integer_Value (typ'First), 3725 -- Integer'Integer_Value (typ'Last))); 3726 3727 when Attribute_Mantissa => Mantissa : begin 3728 Rewrite (N, 3729 Convert_To (Typ, 3730 Make_Function_Call (Loc, 3731 Name => New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc), 3732 3733 Parameter_Associations => New_List ( 3734 3735 Make_Attribute_Reference (Loc, 3736 Prefix => New_Occurrence_Of (Standard_Integer, Loc), 3737 Attribute_Name => Name_Integer_Value, 3738 Expressions => New_List ( 3739 3740 Make_Attribute_Reference (Loc, 3741 Prefix => New_Occurrence_Of (Ptyp, Loc), 3742 Attribute_Name => Name_First))), 3743 3744 Make_Attribute_Reference (Loc, 3745 Prefix => New_Occurrence_Of (Standard_Integer, Loc), 3746 Attribute_Name => Name_Integer_Value, 3747 Expressions => New_List ( 3748 3749 Make_Attribute_Reference (Loc, 3750 Prefix => New_Occurrence_Of (Ptyp, Loc), 3751 Attribute_Name => Name_Last))))))); 3752 3753 Analyze_And_Resolve (N, Typ); 3754 end Mantissa; 3755 3756 --------- 3757 -- Max -- 3758 --------- 3759 3760 when Attribute_Max => 3761 Expand_Min_Max_Attribute (N); 3762 3763 ---------------------------------- 3764 -- Max_Size_In_Storage_Elements -- 3765 ---------------------------------- 3766 3767 when Attribute_Max_Size_In_Storage_Elements => declare 3768 Typ : constant Entity_Id := Etype (N); 3769 Attr : Node_Id; 3770 3771 Conversion_Added : Boolean := False; 3772 -- A flag which tracks whether the original attribute has been 3773 -- wrapped inside a type conversion. 3774 3775 begin 3776 Apply_Universal_Integer_Attribute_Checks (N); 3777 3778 -- The universal integer check may sometimes add a type conversion, 3779 -- retrieve the original attribute reference from the expression. 3780 3781 Attr := N; 3782 if Nkind (Attr) = N_Type_Conversion then 3783 Attr := Expression (Attr); 3784 Conversion_Added := True; 3785 end if; 3786 3787 -- Heap-allocated controlled objects contain two extra pointers which 3788 -- are not part of the actual type. Transform the attribute reference 3789 -- into a runtime expression to add the size of the hidden header. 3790 3791 -- Do not perform this expansion on .NET/JVM targets because the 3792 -- two pointers are already present in the type. 3793 3794 if VM_Target = No_VM 3795 and then Nkind (Attr) = N_Attribute_Reference 3796 and then Needs_Finalization (Ptyp) 3797 and then not Header_Size_Added (Attr) 3798 then 3799 Set_Header_Size_Added (Attr); 3800 3801 -- Generate: 3802 -- P'Max_Size_In_Storage_Elements + 3803 -- Universal_Integer 3804 -- (Header_Size_With_Padding (Ptyp'Alignment)) 3805 3806 Rewrite (Attr, 3807 Make_Op_Add (Loc, 3808 Left_Opnd => Relocate_Node (Attr), 3809 Right_Opnd => 3810 Convert_To (Universal_Integer, 3811 Make_Function_Call (Loc, 3812 Name => 3813 New_Occurrence_Of 3814 (RTE (RE_Header_Size_With_Padding), Loc), 3815 3816 Parameter_Associations => New_List ( 3817 Make_Attribute_Reference (Loc, 3818 Prefix => 3819 New_Occurrence_Of (Ptyp, Loc), 3820 Attribute_Name => Name_Alignment)))))); 3821 3822 -- Add a conversion to the target type 3823 3824 if not Conversion_Added then 3825 Rewrite (Attr, 3826 Make_Type_Conversion (Loc, 3827 Subtype_Mark => New_Occurrence_Of (Typ, Loc), 3828 Expression => Relocate_Node (Attr))); 3829 end if; 3830 3831 Analyze (Attr); 3832 return; 3833 end if; 3834 end; 3835 3836 -------------------- 3837 -- Mechanism_Code -- 3838 -------------------- 3839 3840 when Attribute_Mechanism_Code => 3841 3842 -- We must replace the prefix i the renamed case 3843 3844 if Is_Entity_Name (Pref) 3845 and then Present (Alias (Entity (Pref))) 3846 then 3847 Set_Renamed_Subprogram (Pref, Alias (Entity (Pref))); 3848 end if; 3849 3850 --------- 3851 -- Min -- 3852 --------- 3853 3854 when Attribute_Min => 3855 Expand_Min_Max_Attribute (N); 3856 3857 --------- 3858 -- Mod -- 3859 --------- 3860 3861 when Attribute_Mod => Mod_Case : declare 3862 Arg : constant Node_Id := Relocate_Node (First (Exprs)); 3863 Hi : constant Node_Id := Type_High_Bound (Etype (Arg)); 3864 Modv : constant Uint := Modulus (Btyp); 3865 3866 begin 3867 3868 -- This is not so simple. The issue is what type to use for the 3869 -- computation of the modular value. 3870 3871 -- The easy case is when the modulus value is within the bounds 3872 -- of the signed integer type of the argument. In this case we can 3873 -- just do the computation in that signed integer type, and then 3874 -- do an ordinary conversion to the target type. 3875 3876 if Modv <= Expr_Value (Hi) then 3877 Rewrite (N, 3878 Convert_To (Btyp, 3879 Make_Op_Mod (Loc, 3880 Left_Opnd => Arg, 3881 Right_Opnd => Make_Integer_Literal (Loc, Modv)))); 3882 3883 -- Here we know that the modulus is larger than type'Last of the 3884 -- integer type. There are two cases to consider: 3885 3886 -- a) The integer value is non-negative. In this case, it is 3887 -- returned as the result (since it is less than the modulus). 3888 3889 -- b) The integer value is negative. In this case, we know that the 3890 -- result is modulus + value, where the value might be as small as 3891 -- -modulus. The trouble is what type do we use to do the subtract. 3892 -- No type will do, since modulus can be as big as 2**64, and no 3893 -- integer type accommodates this value. Let's do bit of algebra 3894 3895 -- modulus + value 3896 -- = modulus - (-value) 3897 -- = (modulus - 1) - (-value - 1) 3898 3899 -- Now modulus - 1 is certainly in range of the modular type. 3900 -- -value is in the range 1 .. modulus, so -value -1 is in the 3901 -- range 0 .. modulus-1 which is in range of the modular type. 3902 -- Furthermore, (-value - 1) can be expressed as -(value + 1) 3903 -- which we can compute using the integer base type. 3904 3905 -- Once this is done we analyze the if expression without range 3906 -- checks, because we know everything is in range, and we want 3907 -- to prevent spurious warnings on either branch. 3908 3909 else 3910 Rewrite (N, 3911 Make_If_Expression (Loc, 3912 Expressions => New_List ( 3913 Make_Op_Ge (Loc, 3914 Left_Opnd => Duplicate_Subexpr (Arg), 3915 Right_Opnd => Make_Integer_Literal (Loc, 0)), 3916 3917 Convert_To (Btyp, 3918 Duplicate_Subexpr_No_Checks (Arg)), 3919 3920 Make_Op_Subtract (Loc, 3921 Left_Opnd => 3922 Make_Integer_Literal (Loc, 3923 Intval => Modv - 1), 3924 Right_Opnd => 3925 Convert_To (Btyp, 3926 Make_Op_Minus (Loc, 3927 Right_Opnd => 3928 Make_Op_Add (Loc, 3929 Left_Opnd => Duplicate_Subexpr_No_Checks (Arg), 3930 Right_Opnd => 3931 Make_Integer_Literal (Loc, 3932 Intval => 1)))))))); 3933 3934 end if; 3935 3936 Analyze_And_Resolve (N, Btyp, Suppress => All_Checks); 3937 end Mod_Case; 3938 3939 ----------- 3940 -- Model -- 3941 ----------- 3942 3943 -- Transforms 'Model into a call to the floating-point attribute 3944 -- function Model in Fat_xxx (where xxx is the root type) 3945 3946 when Attribute_Model => 3947 Expand_Fpt_Attribute_R (N); 3948 3949 ----------------- 3950 -- Object_Size -- 3951 ----------------- 3952 3953 -- The processing for Object_Size shares the processing for Size 3954 3955 --------- 3956 -- Old -- 3957 --------- 3958 3959 when Attribute_Old => Old : declare 3960 Asn_Stm : Node_Id; 3961 Subp : Node_Id; 3962 Temp : Entity_Id; 3963 3964 begin 3965 -- If assertions are disabled, no need to create the declaration 3966 -- that preserves the value. 3967 3968 if not Assertions_Enabled then 3969 return; 3970 end if; 3971 3972 Temp := Make_Temporary (Loc, 'T', Pref); 3973 3974 -- Climb the parent chain looking for subprogram _Postconditions 3975 3976 Subp := N; 3977 while Present (Subp) loop 3978 exit when Nkind (Subp) = N_Subprogram_Body 3979 and then Chars (Defining_Entity (Subp)) = Name_uPostconditions; 3980 3981 Subp := Parent (Subp); 3982 end loop; 3983 3984 -- 'Old can only appear in a postcondition, the generated body of 3985 -- _Postconditions must be in the tree. 3986 3987 pragma Assert (Present (Subp)); 3988 3989 -- Generate: 3990 -- Temp : constant <Pref type> := <Pref>; 3991 3992 Asn_Stm := 3993 Make_Object_Declaration (Loc, 3994 Defining_Identifier => Temp, 3995 Constant_Present => True, 3996 Object_Definition => New_Occurrence_Of (Etype (N), Loc), 3997 Expression => Pref); 3998 3999 -- Push the scope of the related subprogram where _Postcondition 4000 -- resides as this ensures that the object will be analyzed in the 4001 -- proper context. 4002 4003 Push_Scope (Scope (Defining_Entity (Subp))); 4004 4005 -- The object declaration is inserted before the body of subprogram 4006 -- _Postconditions. This ensures that any precondition-like actions 4007 -- are still executed before any parameter values are captured and 4008 -- the multiple 'Old occurrences appear in order of declaration. 4009 4010 Insert_Before_And_Analyze (Subp, Asn_Stm); 4011 Pop_Scope; 4012 4013 -- Ensure that the prefix of attribute 'Old is valid. The check must 4014 -- be inserted after the expansion of the attribute has taken place 4015 -- to reflect the new placement of the prefix. 4016 4017 if Validity_Checks_On and then Validity_Check_Operands then 4018 Ensure_Valid (Pref); 4019 end if; 4020 4021 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 4022 end Old; 4023 4024 ---------------------- 4025 -- Overlaps_Storage -- 4026 ---------------------- 4027 4028 when Attribute_Overlaps_Storage => Overlaps_Storage : declare 4029 Loc : constant Source_Ptr := Sloc (N); 4030 4031 X : constant Node_Id := Prefix (N); 4032 Y : constant Node_Id := First (Expressions (N)); 4033 -- The argumens 4034 4035 X_Addr, Y_Addr : Node_Id; 4036 -- the expressions for their integer addresses 4037 4038 X_Size, Y_Size : Node_Id; 4039 -- the expressions for their sizes 4040 4041 Cond : Node_Id; 4042 4043 begin 4044 -- Attribute expands into: 4045 4046 -- if X'Address < Y'address then 4047 -- (X'address + X'Size - 1) >= Y'address 4048 -- else 4049 -- (Y'address + Y'size - 1) >= X'Address 4050 -- end if; 4051 4052 -- with the proper address operations. We convert addresses to 4053 -- integer addresses to use predefined arithmetic. The size is 4054 -- expressed in storage units. 4055 4056 X_Addr := 4057 Unchecked_Convert_To (RTE (RE_Integer_Address), 4058 Make_Attribute_Reference (Loc, 4059 Attribute_Name => Name_Address, 4060 Prefix => New_Copy_Tree (X))); 4061 4062 Y_Addr := 4063 Unchecked_Convert_To (RTE (RE_Integer_Address), 4064 Make_Attribute_Reference (Loc, 4065 Attribute_Name => Name_Address, 4066 Prefix => New_Copy_Tree (Y))); 4067 4068 X_Size := 4069 Make_Op_Divide (Loc, 4070 Left_Opnd => 4071 Make_Attribute_Reference (Loc, 4072 Attribute_Name => Name_Size, 4073 Prefix => New_Copy_Tree (X)), 4074 Right_Opnd => 4075 Make_Integer_Literal (Loc, System_Storage_Unit)); 4076 4077 Y_Size := 4078 Make_Op_Divide (Loc, 4079 Left_Opnd => 4080 Make_Attribute_Reference (Loc, 4081 Attribute_Name => Name_Size, 4082 Prefix => New_Copy_Tree (Y)), 4083 Right_Opnd => 4084 Make_Integer_Literal (Loc, System_Storage_Unit)); 4085 4086 Cond := 4087 Make_Op_Le (Loc, 4088 Left_Opnd => X_Addr, 4089 Right_Opnd => Y_Addr); 4090 4091 Rewrite (N, 4092 Make_If_Expression (Loc, 4093 New_List ( 4094 Cond, 4095 4096 Make_Op_Ge (Loc, 4097 Left_Opnd => 4098 Make_Op_Add (Loc, 4099 Left_Opnd => X_Addr, 4100 Right_Opnd => 4101 Make_Op_Subtract (Loc, 4102 Left_Opnd => X_Size, 4103 Right_Opnd => Make_Integer_Literal (Loc, 1))), 4104 Right_Opnd => Y_Addr), 4105 4106 Make_Op_Ge (Loc, 4107 Make_Op_Add (Loc, 4108 Left_Opnd => Y_Addr, 4109 Right_Opnd => 4110 Make_Op_Subtract (Loc, 4111 Left_Opnd => Y_Size, 4112 Right_Opnd => Make_Integer_Literal (Loc, 1))), 4113 Right_Opnd => X_Addr)))); 4114 4115 Analyze_And_Resolve (N, Standard_Boolean); 4116 end Overlaps_Storage; 4117 4118 ------------ 4119 -- Output -- 4120 ------------ 4121 4122 when Attribute_Output => Output : declare 4123 P_Type : constant Entity_Id := Entity (Pref); 4124 U_Type : constant Entity_Id := Underlying_Type (P_Type); 4125 Pname : Entity_Id; 4126 Decl : Node_Id; 4127 Prag : Node_Id; 4128 Arg3 : Node_Id; 4129 Wfunc : Node_Id; 4130 4131 begin 4132 -- If no underlying type, we have an error that will be diagnosed 4133 -- elsewhere, so here we just completely ignore the expansion. 4134 4135 if No (U_Type) then 4136 return; 4137 end if; 4138 4139 -- If TSS for Output is present, just call it 4140 4141 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output); 4142 4143 if Present (Pname) then 4144 null; 4145 4146 else 4147 -- If there is a Stream_Convert pragma, use it, we rewrite 4148 4149 -- sourcetyp'Output (stream, Item) 4150 4151 -- as 4152 4153 -- strmtyp'Output (Stream, strmwrite (acttyp (Item))); 4154 4155 -- where strmwrite is the given Write function that converts an 4156 -- argument of type sourcetyp or a type acctyp, from which it is 4157 -- derived to type strmtyp. The conversion to acttyp is required 4158 -- for the derived case. 4159 4160 Prag := Get_Stream_Convert_Pragma (P_Type); 4161 4162 if Present (Prag) then 4163 Arg3 := 4164 Next (Next (First (Pragma_Argument_Associations (Prag)))); 4165 Wfunc := Entity (Expression (Arg3)); 4166 4167 Rewrite (N, 4168 Make_Attribute_Reference (Loc, 4169 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc), 4170 Attribute_Name => Name_Output, 4171 Expressions => New_List ( 4172 Relocate_Node (First (Exprs)), 4173 Make_Function_Call (Loc, 4174 Name => New_Occurrence_Of (Wfunc, Loc), 4175 Parameter_Associations => New_List ( 4176 OK_Convert_To (Etype (First_Formal (Wfunc)), 4177 Relocate_Node (Next (First (Exprs))))))))); 4178 4179 Analyze (N); 4180 return; 4181 4182 -- For elementary types, we call the W_xxx routine directly. 4183 -- Note that the effect of Write and Output is identical for 4184 -- the case of an elementary type, since there are no 4185 -- discriminants or bounds. 4186 4187 elsif Is_Elementary_Type (U_Type) then 4188 4189 -- A special case arises if we have a defined _Write routine, 4190 -- since in this case we are required to call this routine. 4191 4192 if Present (TSS (Base_Type (U_Type), TSS_Stream_Write)) then 4193 Build_Record_Or_Elementary_Output_Procedure 4194 (Loc, U_Type, Decl, Pname); 4195 Insert_Action (N, Decl); 4196 4197 -- For normal cases, we call the W_xxx routine directly 4198 4199 else 4200 Rewrite (N, Build_Elementary_Write_Call (N)); 4201 Analyze (N); 4202 return; 4203 end if; 4204 4205 -- Array type case 4206 4207 elsif Is_Array_Type (U_Type) then 4208 Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname); 4209 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False); 4210 4211 -- Class-wide case, first output external tag, then dispatch 4212 -- to the appropriate primitive Output function (RM 13.13.2(31)). 4213 4214 elsif Is_Class_Wide_Type (P_Type) then 4215 4216 -- No need to do anything else compiling under restriction 4217 -- No_Dispatching_Calls. During the semantic analysis we 4218 -- already notified such violation. 4219 4220 if Restriction_Active (No_Dispatching_Calls) then 4221 return; 4222 end if; 4223 4224 Tag_Write : declare 4225 Strm : constant Node_Id := First (Exprs); 4226 Item : constant Node_Id := Next (Strm); 4227 4228 begin 4229 -- Ada 2005 (AI-344): Check that the accessibility level 4230 -- of the type of the output object is not deeper than 4231 -- that of the attribute's prefix type. 4232 4233 -- if Get_Access_Level (Item'Tag) 4234 -- /= Get_Access_Level (P_Type'Tag) 4235 -- then 4236 -- raise Tag_Error; 4237 -- end if; 4238 4239 -- String'Output (Strm, External_Tag (Item'Tag)); 4240 4241 -- We cannot figure out a practical way to implement this 4242 -- accessibility check on virtual machines, so we omit it. 4243 4244 if Ada_Version >= Ada_2005 4245 and then Tagged_Type_Expansion 4246 then 4247 Insert_Action (N, 4248 Make_Implicit_If_Statement (N, 4249 Condition => 4250 Make_Op_Ne (Loc, 4251 Left_Opnd => 4252 Build_Get_Access_Level (Loc, 4253 Make_Attribute_Reference (Loc, 4254 Prefix => 4255 Relocate_Node ( 4256 Duplicate_Subexpr (Item, 4257 Name_Req => True)), 4258 Attribute_Name => Name_Tag)), 4259 4260 Right_Opnd => 4261 Make_Integer_Literal (Loc, 4262 Type_Access_Level (P_Type))), 4263 4264 Then_Statements => 4265 New_List (Make_Raise_Statement (Loc, 4266 New_Occurrence_Of ( 4267 RTE (RE_Tag_Error), Loc))))); 4268 end if; 4269 4270 Insert_Action (N, 4271 Make_Attribute_Reference (Loc, 4272 Prefix => New_Occurrence_Of (Standard_String, Loc), 4273 Attribute_Name => Name_Output, 4274 Expressions => New_List ( 4275 Relocate_Node (Duplicate_Subexpr (Strm)), 4276 Make_Function_Call (Loc, 4277 Name => 4278 New_Occurrence_Of (RTE (RE_External_Tag), Loc), 4279 Parameter_Associations => New_List ( 4280 Make_Attribute_Reference (Loc, 4281 Prefix => 4282 Relocate_Node 4283 (Duplicate_Subexpr (Item, Name_Req => True)), 4284 Attribute_Name => Name_Tag)))))); 4285 end Tag_Write; 4286 4287 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output); 4288 4289 -- Tagged type case, use the primitive Output function 4290 4291 elsif Is_Tagged_Type (U_Type) then 4292 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output); 4293 4294 -- All other record type cases, including protected records. 4295 -- The latter only arise for expander generated code for 4296 -- handling shared passive partition access. 4297 4298 else 4299 pragma Assert 4300 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); 4301 4302 -- Ada 2005 (AI-216): Program_Error is raised when executing 4303 -- the default implementation of the Output attribute of an 4304 -- unchecked union type if the type lacks default discriminant 4305 -- values. 4306 4307 if Is_Unchecked_Union (Base_Type (U_Type)) 4308 and then No (Discriminant_Constraint (U_Type)) 4309 then 4310 Insert_Action (N, 4311 Make_Raise_Program_Error (Loc, 4312 Reason => PE_Unchecked_Union_Restriction)); 4313 4314 return; 4315 end if; 4316 4317 Build_Record_Or_Elementary_Output_Procedure 4318 (Loc, Base_Type (U_Type), Decl, Pname); 4319 Insert_Action (N, Decl); 4320 end if; 4321 end if; 4322 4323 -- If we fall through, Pname is the name of the procedure to call 4324 4325 Rewrite_Stream_Proc_Call (Pname); 4326 end Output; 4327 4328 --------- 4329 -- Pos -- 4330 --------- 4331 4332 -- For enumeration types with a standard representation, Pos is 4333 -- handled by the back end. 4334 4335 -- For enumeration types, with a non-standard representation we generate 4336 -- a call to the _Rep_To_Pos function created when the type was frozen. 4337 -- The call has the form 4338 4339 -- _rep_to_pos (expr, flag) 4340 4341 -- The parameter flag is True if range checks are enabled, causing 4342 -- Program_Error to be raised if the expression has an invalid 4343 -- representation, and False if range checks are suppressed. 4344 4345 -- For integer types, Pos is equivalent to a simple integer 4346 -- conversion and we rewrite it as such 4347 4348 when Attribute_Pos => Pos : 4349 declare 4350 Etyp : Entity_Id := Base_Type (Entity (Pref)); 4351 4352 begin 4353 -- Deal with zero/non-zero boolean values 4354 4355 if Is_Boolean_Type (Etyp) then 4356 Adjust_Condition (First (Exprs)); 4357 Etyp := Standard_Boolean; 4358 Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc)); 4359 end if; 4360 4361 -- Case of enumeration type 4362 4363 if Is_Enumeration_Type (Etyp) then 4364 4365 -- Non-standard enumeration type (generate call) 4366 4367 if Present (Enum_Pos_To_Rep (Etyp)) then 4368 Append_To (Exprs, Rep_To_Pos_Flag (Etyp, Loc)); 4369 Rewrite (N, 4370 Convert_To (Typ, 4371 Make_Function_Call (Loc, 4372 Name => 4373 New_Occurrence_Of (TSS (Etyp, TSS_Rep_To_Pos), Loc), 4374 Parameter_Associations => Exprs))); 4375 4376 Analyze_And_Resolve (N, Typ); 4377 4378 -- Standard enumeration type (do universal integer check) 4379 4380 else 4381 Apply_Universal_Integer_Attribute_Checks (N); 4382 end if; 4383 4384 -- Deal with integer types (replace by conversion) 4385 4386 elsif Is_Integer_Type (Etyp) then 4387 Rewrite (N, Convert_To (Typ, First (Exprs))); 4388 Analyze_And_Resolve (N, Typ); 4389 end if; 4390 4391 end Pos; 4392 4393 -------------- 4394 -- Position -- 4395 -------------- 4396 4397 -- We compute this if a component clause was present, otherwise we leave 4398 -- the computation up to the back end, since we don't know what layout 4399 -- will be chosen. 4400 4401 when Attribute_Position => Position_Attr : 4402 declare 4403 CE : constant Entity_Id := Entity (Selector_Name (Pref)); 4404 4405 begin 4406 if Present (Component_Clause (CE)) then 4407 4408 -- In Ada 2005 (or later) if we have the non-default bit order, 4409 -- then we return the original value as given in the component 4410 -- clause (RM 2005 13.5.2(2/2)). 4411 4412 if Ada_Version >= Ada_2005 4413 and then Reverse_Bit_Order (Scope (CE)) 4414 then 4415 Rewrite (N, 4416 Make_Integer_Literal (Loc, 4417 Intval => Expr_Value (Position (Component_Clause (CE))))); 4418 4419 -- Otherwise (Ada 83 or 95, or default bit order specified in 4420 -- later Ada version), return the normalized value. 4421 4422 else 4423 Rewrite (N, 4424 Make_Integer_Literal (Loc, 4425 Intval => Component_Bit_Offset (CE) / System_Storage_Unit)); 4426 end if; 4427 4428 Analyze_And_Resolve (N, Typ); 4429 4430 -- If back end is doing things, just apply universal integer checks 4431 4432 else 4433 Apply_Universal_Integer_Attribute_Checks (N); 4434 end if; 4435 end Position_Attr; 4436 4437 ---------- 4438 -- Pred -- 4439 ---------- 4440 4441 -- 1. Deal with enumeration types with holes 4442 -- 2. For floating-point, generate call to attribute function 4443 -- 3. For other cases, deal with constraint checking 4444 4445 when Attribute_Pred => Pred : 4446 declare 4447 Etyp : constant Entity_Id := Base_Type (Ptyp); 4448 4449 begin 4450 4451 -- For enumeration types with non-standard representations, we 4452 -- expand typ'Pred (x) into 4453 4454 -- Pos_To_Rep (Rep_To_Pos (x) - 1) 4455 4456 -- If the representation is contiguous, we compute instead 4457 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations. 4458 -- The conversion function Enum_Pos_To_Rep is defined on the 4459 -- base type, not the subtype, so we have to use the base type 4460 -- explicitly for this and other enumeration attributes. 4461 4462 if Is_Enumeration_Type (Ptyp) 4463 and then Present (Enum_Pos_To_Rep (Etyp)) 4464 then 4465 if Has_Contiguous_Rep (Etyp) then 4466 Rewrite (N, 4467 Unchecked_Convert_To (Ptyp, 4468 Make_Op_Add (Loc, 4469 Left_Opnd => 4470 Make_Integer_Literal (Loc, 4471 Enumeration_Rep (First_Literal (Ptyp))), 4472 Right_Opnd => 4473 Make_Function_Call (Loc, 4474 Name => 4475 New_Occurrence_Of 4476 (TSS (Etyp, TSS_Rep_To_Pos), Loc), 4477 4478 Parameter_Associations => 4479 New_List ( 4480 Unchecked_Convert_To (Ptyp, 4481 Make_Op_Subtract (Loc, 4482 Left_Opnd => 4483 Unchecked_Convert_To (Standard_Integer, 4484 Relocate_Node (First (Exprs))), 4485 Right_Opnd => 4486 Make_Integer_Literal (Loc, 1))), 4487 Rep_To_Pos_Flag (Ptyp, Loc)))))); 4488 4489 else 4490 -- Add Boolean parameter True, to request program errror if 4491 -- we have a bad representation on our hands. If checks are 4492 -- suppressed, then add False instead 4493 4494 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc)); 4495 Rewrite (N, 4496 Make_Indexed_Component (Loc, 4497 Prefix => 4498 New_Occurrence_Of 4499 (Enum_Pos_To_Rep (Etyp), Loc), 4500 Expressions => New_List ( 4501 Make_Op_Subtract (Loc, 4502 Left_Opnd => 4503 Make_Function_Call (Loc, 4504 Name => 4505 New_Occurrence_Of 4506 (TSS (Etyp, TSS_Rep_To_Pos), Loc), 4507 Parameter_Associations => Exprs), 4508 Right_Opnd => Make_Integer_Literal (Loc, 1))))); 4509 end if; 4510 4511 Analyze_And_Resolve (N, Typ); 4512 4513 -- For floating-point, we transform 'Pred into a call to the Pred 4514 -- floating-point attribute function in Fat_xxx (xxx is root type) 4515 4516 elsif Is_Floating_Point_Type (Ptyp) then 4517 Expand_Fpt_Attribute_R (N); 4518 Analyze_And_Resolve (N, Typ); 4519 4520 -- For modular types, nothing to do (no overflow, since wraps) 4521 4522 elsif Is_Modular_Integer_Type (Ptyp) then 4523 null; 4524 4525 -- For other types, if argument is marked as needing a range check or 4526 -- overflow checking is enabled, we must generate a check. 4527 4528 elsif not Overflow_Checks_Suppressed (Ptyp) 4529 or else Do_Range_Check (First (Exprs)) 4530 then 4531 Set_Do_Range_Check (First (Exprs), False); 4532 Expand_Pred_Succ_Attribute (N); 4533 end if; 4534 end Pred; 4535 4536 -------------- 4537 -- Priority -- 4538 -------------- 4539 4540 -- Ada 2005 (AI-327): Dynamic ceiling priorities 4541 4542 -- We rewrite X'Priority as the following run-time call: 4543 4544 -- Get_Ceiling (X._Object) 4545 4546 -- Note that although X'Priority is notionally an object, it is quite 4547 -- deliberately not defined as an aliased object in the RM. This means 4548 -- that it works fine to rewrite it as a call, without having to worry 4549 -- about complications that would other arise from X'Priority'Access, 4550 -- which is illegal, because of the lack of aliasing. 4551 4552 when Attribute_Priority => 4553 declare 4554 Call : Node_Id; 4555 Conctyp : Entity_Id; 4556 Object_Parm : Node_Id; 4557 Subprg : Entity_Id; 4558 RT_Subprg_Name : Node_Id; 4559 4560 begin 4561 -- Look for the enclosing concurrent type 4562 4563 Conctyp := Current_Scope; 4564 while not Is_Concurrent_Type (Conctyp) loop 4565 Conctyp := Scope (Conctyp); 4566 end loop; 4567 4568 pragma Assert (Is_Protected_Type (Conctyp)); 4569 4570 -- Generate the actual of the call 4571 4572 Subprg := Current_Scope; 4573 while not Present (Protected_Body_Subprogram (Subprg)) loop 4574 Subprg := Scope (Subprg); 4575 end loop; 4576 4577 -- Use of 'Priority inside protected entries and barriers (in 4578 -- both cases the type of the first formal of their expanded 4579 -- subprogram is Address) 4580 4581 if Etype (First_Entity (Protected_Body_Subprogram (Subprg))) 4582 = RTE (RE_Address) 4583 then 4584 declare 4585 New_Itype : Entity_Id; 4586 4587 begin 4588 -- In the expansion of protected entries the type of the 4589 -- first formal of the Protected_Body_Subprogram is an 4590 -- Address. In order to reference the _object component 4591 -- we generate: 4592 4593 -- type T is access p__ptTV; 4594 -- freeze T [] 4595 4596 New_Itype := Create_Itype (E_Access_Type, N); 4597 Set_Etype (New_Itype, New_Itype); 4598 Set_Directly_Designated_Type (New_Itype, 4599 Corresponding_Record_Type (Conctyp)); 4600 Freeze_Itype (New_Itype, N); 4601 4602 -- Generate: 4603 -- T!(O)._object'unchecked_access 4604 4605 Object_Parm := 4606 Make_Attribute_Reference (Loc, 4607 Prefix => 4608 Make_Selected_Component (Loc, 4609 Prefix => 4610 Unchecked_Convert_To (New_Itype, 4611 New_Occurrence_Of 4612 (First_Entity 4613 (Protected_Body_Subprogram (Subprg)), 4614 Loc)), 4615 Selector_Name => 4616 Make_Identifier (Loc, Name_uObject)), 4617 Attribute_Name => Name_Unchecked_Access); 4618 end; 4619 4620 -- Use of 'Priority inside a protected subprogram 4621 4622 else 4623 Object_Parm := 4624 Make_Attribute_Reference (Loc, 4625 Prefix => 4626 Make_Selected_Component (Loc, 4627 Prefix => New_Occurrence_Of 4628 (First_Entity 4629 (Protected_Body_Subprogram (Subprg)), 4630 Loc), 4631 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4632 Attribute_Name => Name_Unchecked_Access); 4633 end if; 4634 4635 -- Select the appropriate run-time subprogram 4636 4637 if Number_Entries (Conctyp) = 0 then 4638 RT_Subprg_Name := 4639 New_Occurrence_Of (RTE (RE_Get_Ceiling), Loc); 4640 else 4641 RT_Subprg_Name := 4642 New_Occurrence_Of (RTE (RO_PE_Get_Ceiling), Loc); 4643 end if; 4644 4645 Call := 4646 Make_Function_Call (Loc, 4647 Name => RT_Subprg_Name, 4648 Parameter_Associations => New_List (Object_Parm)); 4649 4650 Rewrite (N, Call); 4651 4652 -- Avoid the generation of extra checks on the pointer to the 4653 -- protected object. 4654 4655 Analyze_And_Resolve (N, Typ, Suppress => Access_Check); 4656 end; 4657 4658 ------------------ 4659 -- Range_Length -- 4660 ------------------ 4661 4662 when Attribute_Range_Length => Range_Length : begin 4663 4664 -- The only special processing required is for the case where 4665 -- Range_Length is applied to an enumeration type with holes. 4666 -- In this case we transform 4667 4668 -- X'Range_Length 4669 4670 -- to 4671 4672 -- X'Pos (X'Last) - X'Pos (X'First) + 1 4673 4674 -- So that the result reflects the proper Pos values instead 4675 -- of the underlying representations. 4676 4677 if Is_Enumeration_Type (Ptyp) 4678 and then Has_Non_Standard_Rep (Ptyp) 4679 then 4680 Rewrite (N, 4681 Make_Op_Add (Loc, 4682 Left_Opnd => 4683 Make_Op_Subtract (Loc, 4684 Left_Opnd => 4685 Make_Attribute_Reference (Loc, 4686 Attribute_Name => Name_Pos, 4687 Prefix => New_Occurrence_Of (Ptyp, Loc), 4688 Expressions => New_List ( 4689 Make_Attribute_Reference (Loc, 4690 Attribute_Name => Name_Last, 4691 Prefix => New_Occurrence_Of (Ptyp, Loc)))), 4692 4693 Right_Opnd => 4694 Make_Attribute_Reference (Loc, 4695 Attribute_Name => Name_Pos, 4696 Prefix => New_Occurrence_Of (Ptyp, Loc), 4697 Expressions => New_List ( 4698 Make_Attribute_Reference (Loc, 4699 Attribute_Name => Name_First, 4700 Prefix => New_Occurrence_Of (Ptyp, Loc))))), 4701 4702 Right_Opnd => Make_Integer_Literal (Loc, 1))); 4703 4704 Analyze_And_Resolve (N, Typ); 4705 4706 -- For all other cases, the attribute is handled by the back end, but 4707 -- we need to deal with the case of the range check on a universal 4708 -- integer. 4709 4710 else 4711 Apply_Universal_Integer_Attribute_Checks (N); 4712 end if; 4713 end Range_Length; 4714 4715 ---------- 4716 -- Read -- 4717 ---------- 4718 4719 when Attribute_Read => Read : declare 4720 P_Type : constant Entity_Id := Entity (Pref); 4721 B_Type : constant Entity_Id := Base_Type (P_Type); 4722 U_Type : constant Entity_Id := Underlying_Type (P_Type); 4723 Pname : Entity_Id; 4724 Decl : Node_Id; 4725 Prag : Node_Id; 4726 Arg2 : Node_Id; 4727 Rfunc : Node_Id; 4728 Lhs : Node_Id; 4729 Rhs : Node_Id; 4730 4731 begin 4732 -- If no underlying type, we have an error that will be diagnosed 4733 -- elsewhere, so here we just completely ignore the expansion. 4734 4735 if No (U_Type) then 4736 return; 4737 end if; 4738 4739 -- The simple case, if there is a TSS for Read, just call it 4740 4741 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read); 4742 4743 if Present (Pname) then 4744 null; 4745 4746 else 4747 -- If there is a Stream_Convert pragma, use it, we rewrite 4748 4749 -- sourcetyp'Read (stream, Item) 4750 4751 -- as 4752 4753 -- Item := sourcetyp (strmread (strmtyp'Input (Stream))); 4754 4755 -- where strmread is the given Read function that converts an 4756 -- argument of type strmtyp to type sourcetyp or a type from which 4757 -- it is derived. The conversion to sourcetyp is required in the 4758 -- latter case. 4759 4760 -- A special case arises if Item is a type conversion in which 4761 -- case, we have to expand to: 4762 4763 -- Itemx := typex (strmread (strmtyp'Input (Stream))); 4764 4765 -- where Itemx is the expression of the type conversion (i.e. 4766 -- the actual object), and typex is the type of Itemx. 4767 4768 Prag := Get_Stream_Convert_Pragma (P_Type); 4769 4770 if Present (Prag) then 4771 Arg2 := Next (First (Pragma_Argument_Associations (Prag))); 4772 Rfunc := Entity (Expression (Arg2)); 4773 Lhs := Relocate_Node (Next (First (Exprs))); 4774 Rhs := 4775 OK_Convert_To (B_Type, 4776 Make_Function_Call (Loc, 4777 Name => New_Occurrence_Of (Rfunc, Loc), 4778 Parameter_Associations => New_List ( 4779 Make_Attribute_Reference (Loc, 4780 Prefix => 4781 New_Occurrence_Of 4782 (Etype (First_Formal (Rfunc)), Loc), 4783 Attribute_Name => Name_Input, 4784 Expressions => New_List ( 4785 Relocate_Node (First (Exprs))))))); 4786 4787 if Nkind (Lhs) = N_Type_Conversion then 4788 Lhs := Expression (Lhs); 4789 Rhs := Convert_To (Etype (Lhs), Rhs); 4790 end if; 4791 4792 Rewrite (N, 4793 Make_Assignment_Statement (Loc, 4794 Name => Lhs, 4795 Expression => Rhs)); 4796 Set_Assignment_OK (Lhs); 4797 Analyze (N); 4798 return; 4799 4800 -- For elementary types, we call the I_xxx routine using the first 4801 -- parameter and then assign the result into the second parameter. 4802 -- We set Assignment_OK to deal with the conversion case. 4803 4804 elsif Is_Elementary_Type (U_Type) then 4805 declare 4806 Lhs : Node_Id; 4807 Rhs : Node_Id; 4808 4809 begin 4810 Lhs := Relocate_Node (Next (First (Exprs))); 4811 Rhs := Build_Elementary_Input_Call (N); 4812 4813 if Nkind (Lhs) = N_Type_Conversion then 4814 Lhs := Expression (Lhs); 4815 Rhs := Convert_To (Etype (Lhs), Rhs); 4816 end if; 4817 4818 Set_Assignment_OK (Lhs); 4819 4820 Rewrite (N, 4821 Make_Assignment_Statement (Loc, 4822 Name => Lhs, 4823 Expression => Rhs)); 4824 4825 Analyze (N); 4826 return; 4827 end; 4828 4829 -- Array type case 4830 4831 elsif Is_Array_Type (U_Type) then 4832 Build_Array_Read_Procedure (N, U_Type, Decl, Pname); 4833 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False); 4834 4835 -- Tagged type case, use the primitive Read function. Note that 4836 -- this will dispatch in the class-wide case which is what we want 4837 4838 elsif Is_Tagged_Type (U_Type) then 4839 Pname := Find_Prim_Op (U_Type, TSS_Stream_Read); 4840 4841 -- All other record type cases, including protected records. The 4842 -- latter only arise for expander generated code for handling 4843 -- shared passive partition access. 4844 4845 else 4846 pragma Assert 4847 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); 4848 4849 -- Ada 2005 (AI-216): Program_Error is raised when executing 4850 -- the default implementation of the Read attribute of an 4851 -- Unchecked_Union type. 4852 4853 if Is_Unchecked_Union (Base_Type (U_Type)) then 4854 Insert_Action (N, 4855 Make_Raise_Program_Error (Loc, 4856 Reason => PE_Unchecked_Union_Restriction)); 4857 end if; 4858 4859 if Has_Discriminants (U_Type) 4860 and then Present 4861 (Discriminant_Default_Value (First_Discriminant (U_Type))) 4862 then 4863 Build_Mutable_Record_Read_Procedure 4864 (Loc, Full_Base (U_Type), Decl, Pname); 4865 else 4866 Build_Record_Read_Procedure 4867 (Loc, Full_Base (U_Type), Decl, Pname); 4868 end if; 4869 4870 -- Suppress checks, uninitialized or otherwise invalid 4871 -- data does not cause constraint errors to be raised for 4872 -- a complete record read. 4873 4874 Insert_Action (N, Decl, All_Checks); 4875 end if; 4876 end if; 4877 4878 Rewrite_Stream_Proc_Call (Pname); 4879 end Read; 4880 4881 --------- 4882 -- Ref -- 4883 --------- 4884 4885 -- Ref is identical to To_Address, see To_Address for processing 4886 4887 --------------- 4888 -- Remainder -- 4889 --------------- 4890 4891 -- Transforms 'Remainder into a call to the floating-point attribute 4892 -- function Remainder in Fat_xxx (where xxx is the root type) 4893 4894 when Attribute_Remainder => 4895 Expand_Fpt_Attribute_RR (N); 4896 4897 ------------ 4898 -- Result -- 4899 ------------ 4900 4901 -- Transform 'Result into reference to _Result formal. At the point 4902 -- where a legal 'Result attribute is expanded, we know that we are in 4903 -- the context of a _Postcondition function with a _Result parameter. 4904 4905 when Attribute_Result => 4906 Rewrite (N, Make_Identifier (Loc, Chars => Name_uResult)); 4907 Analyze_And_Resolve (N, Typ); 4908 4909 ----------- 4910 -- Round -- 4911 ----------- 4912 4913 -- The handling of the Round attribute is quite delicate. The processing 4914 -- in Sem_Attr introduced a conversion to universal real, reflecting the 4915 -- semantics of Round, but we do not want anything to do with universal 4916 -- real at runtime, since this corresponds to using floating-point 4917 -- arithmetic. 4918 4919 -- What we have now is that the Etype of the Round attribute correctly 4920 -- indicates the final result type. The operand of the Round is the 4921 -- conversion to universal real, described above, and the operand of 4922 -- this conversion is the actual operand of Round, which may be the 4923 -- special case of a fixed point multiplication or division (Etype = 4924 -- universal fixed) 4925 4926 -- The exapander will expand first the operand of the conversion, then 4927 -- the conversion, and finally the round attribute itself, since we 4928 -- always work inside out. But we cannot simply process naively in this 4929 -- order. In the semantic world where universal fixed and real really 4930 -- exist and have infinite precision, there is no problem, but in the 4931 -- implementation world, where universal real is a floating-point type, 4932 -- we would get the wrong result. 4933 4934 -- So the approach is as follows. First, when expanding a multiply or 4935 -- divide whose type is universal fixed, we do nothing at all, instead 4936 -- deferring the operation till later. 4937 4938 -- The actual processing is done in Expand_N_Type_Conversion which 4939 -- handles the special case of Round by looking at its parent to see if 4940 -- it is a Round attribute, and if it is, handling the conversion (or 4941 -- its fixed multiply/divide child) in an appropriate manner. 4942 4943 -- This means that by the time we get to expanding the Round attribute 4944 -- itself, the Round is nothing more than a type conversion (and will 4945 -- often be a null type conversion), so we just replace it with the 4946 -- appropriate conversion operation. 4947 4948 when Attribute_Round => 4949 Rewrite (N, 4950 Convert_To (Etype (N), Relocate_Node (First (Exprs)))); 4951 Analyze_And_Resolve (N); 4952 4953 -------------- 4954 -- Rounding -- 4955 -------------- 4956 4957 -- Transforms 'Rounding into a call to the floating-point attribute 4958 -- function Rounding in Fat_xxx (where xxx is the root type) 4959 4960 when Attribute_Rounding => 4961 Expand_Fpt_Attribute_R (N); 4962 4963 ------------------ 4964 -- Same_Storage -- 4965 ------------------ 4966 4967 when Attribute_Same_Storage => Same_Storage : declare 4968 Loc : constant Source_Ptr := Sloc (N); 4969 4970 X : constant Node_Id := Prefix (N); 4971 Y : constant Node_Id := First (Expressions (N)); 4972 -- The arguments 4973 4974 X_Addr, Y_Addr : Node_Id; 4975 -- Rhe expressions for their addresses 4976 4977 X_Size, Y_Size : Node_Id; 4978 -- Rhe expressions for their sizes 4979 4980 begin 4981 -- The attribute is expanded as: 4982 4983 -- (X'address = Y'address) 4984 -- and then (X'Size = Y'Size) 4985 4986 -- If both arguments have the same Etype the second conjunct can be 4987 -- omitted. 4988 4989 X_Addr := 4990 Make_Attribute_Reference (Loc, 4991 Attribute_Name => Name_Address, 4992 Prefix => New_Copy_Tree (X)); 4993 4994 Y_Addr := 4995 Make_Attribute_Reference (Loc, 4996 Attribute_Name => Name_Address, 4997 Prefix => New_Copy_Tree (Y)); 4998 4999 X_Size := 5000 Make_Attribute_Reference (Loc, 5001 Attribute_Name => Name_Size, 5002 Prefix => New_Copy_Tree (X)); 5003 5004 Y_Size := 5005 Make_Attribute_Reference (Loc, 5006 Attribute_Name => Name_Size, 5007 Prefix => New_Copy_Tree (Y)); 5008 5009 if Etype (X) = Etype (Y) then 5010 Rewrite (N, 5011 (Make_Op_Eq (Loc, 5012 Left_Opnd => X_Addr, 5013 Right_Opnd => Y_Addr))); 5014 else 5015 Rewrite (N, 5016 Make_Op_And (Loc, 5017 Left_Opnd => 5018 Make_Op_Eq (Loc, 5019 Left_Opnd => X_Addr, 5020 Right_Opnd => Y_Addr), 5021 Right_Opnd => 5022 Make_Op_Eq (Loc, 5023 Left_Opnd => X_Size, 5024 Right_Opnd => Y_Size))); 5025 end if; 5026 5027 Analyze_And_Resolve (N, Standard_Boolean); 5028 end Same_Storage; 5029 5030 ------------- 5031 -- Scaling -- 5032 ------------- 5033 5034 -- Transforms 'Scaling into a call to the floating-point attribute 5035 -- function Scaling in Fat_xxx (where xxx is the root type) 5036 5037 when Attribute_Scaling => 5038 Expand_Fpt_Attribute_RI (N); 5039 5040 ------------------------- 5041 -- Simple_Storage_Pool -- 5042 ------------------------- 5043 5044 when Attribute_Simple_Storage_Pool => 5045 Rewrite (N, 5046 Make_Type_Conversion (Loc, 5047 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc), 5048 Expression => New_Occurrence_Of (Entity (N), Loc))); 5049 Analyze_And_Resolve (N, Typ); 5050 5051 ---------- 5052 -- Size -- 5053 ---------- 5054 5055 when Attribute_Size | 5056 Attribute_Object_Size | 5057 Attribute_Value_Size | 5058 Attribute_VADS_Size => Size : 5059 5060 declare 5061 Siz : Uint; 5062 New_Node : Node_Id; 5063 5064 begin 5065 -- Processing for VADS_Size case. Note that this processing removes 5066 -- all traces of VADS_Size from the tree, and completes all required 5067 -- processing for VADS_Size by translating the attribute reference 5068 -- to an appropriate Size or Object_Size reference. 5069 5070 if Id = Attribute_VADS_Size 5071 or else (Use_VADS_Size and then Id = Attribute_Size) 5072 then 5073 -- If the size is specified, then we simply use the specified 5074 -- size. This applies to both types and objects. The size of an 5075 -- object can be specified in the following ways: 5076 5077 -- An explicit size object is given for an object 5078 -- A component size is specified for an indexed component 5079 -- A component clause is specified for a selected component 5080 -- The object is a component of a packed composite object 5081 5082 -- If the size is specified, then VADS_Size of an object 5083 5084 if (Is_Entity_Name (Pref) 5085 and then Present (Size_Clause (Entity (Pref)))) 5086 or else 5087 (Nkind (Pref) = N_Component_Clause 5088 and then (Present (Component_Clause 5089 (Entity (Selector_Name (Pref)))) 5090 or else Is_Packed (Etype (Prefix (Pref))))) 5091 or else 5092 (Nkind (Pref) = N_Indexed_Component 5093 and then (Component_Size (Etype (Prefix (Pref))) /= 0 5094 or else Is_Packed (Etype (Prefix (Pref))))) 5095 then 5096 Set_Attribute_Name (N, Name_Size); 5097 5098 -- Otherwise if we have an object rather than a type, then the 5099 -- VADS_Size attribute applies to the type of the object, rather 5100 -- than the object itself. This is one of the respects in which 5101 -- VADS_Size differs from Size. 5102 5103 else 5104 if (not Is_Entity_Name (Pref) 5105 or else not Is_Type (Entity (Pref))) 5106 and then (Is_Scalar_Type (Ptyp) or else Is_Constrained (Ptyp)) 5107 then 5108 Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc)); 5109 end if; 5110 5111 -- For a scalar type for which no size was explicitly given, 5112 -- VADS_Size means Object_Size. This is the other respect in 5113 -- which VADS_Size differs from Size. 5114 5115 if Is_Scalar_Type (Ptyp) and then No (Size_Clause (Ptyp)) then 5116 Set_Attribute_Name (N, Name_Object_Size); 5117 5118 -- In all other cases, Size and VADS_Size are the sane 5119 5120 else 5121 Set_Attribute_Name (N, Name_Size); 5122 end if; 5123 end if; 5124 end if; 5125 5126 -- For class-wide types, X'Class'Size is transformed into a direct 5127 -- reference to the Size of the class type, so that the back end does 5128 -- not have to deal with the X'Class'Size reference. 5129 5130 if Is_Entity_Name (Pref) 5131 and then Is_Class_Wide_Type (Entity (Pref)) 5132 then 5133 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc)); 5134 return; 5135 5136 -- For X'Size applied to an object of a class-wide type, transform 5137 -- X'Size into a call to the primitive operation _Size applied to X. 5138 5139 elsif Is_Class_Wide_Type (Ptyp) 5140 or else (Id = Attribute_Size 5141 and then Is_Tagged_Type (Ptyp) 5142 and then Has_Unknown_Discriminants (Ptyp)) 5143 then 5144 -- No need to do anything else compiling under restriction 5145 -- No_Dispatching_Calls. During the semantic analysis we 5146 -- already notified such violation. 5147 5148 if Restriction_Active (No_Dispatching_Calls) then 5149 return; 5150 end if; 5151 5152 New_Node := 5153 Make_Function_Call (Loc, 5154 Name => New_Occurrence_Of 5155 (Find_Prim_Op (Ptyp, Name_uSize), Loc), 5156 Parameter_Associations => New_List (Pref)); 5157 5158 if Typ /= Standard_Long_Long_Integer then 5159 5160 -- The context is a specific integer type with which the 5161 -- original attribute was compatible. The function has a 5162 -- specific type as well, so to preserve the compatibility 5163 -- we must convert explicitly. 5164 5165 New_Node := Convert_To (Typ, New_Node); 5166 end if; 5167 5168 Rewrite (N, New_Node); 5169 Analyze_And_Resolve (N, Typ); 5170 return; 5171 5172 -- Case of known RM_Size of a type 5173 5174 elsif (Id = Attribute_Size or else Id = Attribute_Value_Size) 5175 and then Is_Entity_Name (Pref) 5176 and then Is_Type (Entity (Pref)) 5177 and then Known_Static_RM_Size (Entity (Pref)) 5178 then 5179 Siz := RM_Size (Entity (Pref)); 5180 5181 -- Case of known Esize of a type 5182 5183 elsif Id = Attribute_Object_Size 5184 and then Is_Entity_Name (Pref) 5185 and then Is_Type (Entity (Pref)) 5186 and then Known_Static_Esize (Entity (Pref)) 5187 then 5188 Siz := Esize (Entity (Pref)); 5189 5190 -- Case of known size of object 5191 5192 elsif Id = Attribute_Size 5193 and then Is_Entity_Name (Pref) 5194 and then Is_Object (Entity (Pref)) 5195 and then Known_Esize (Entity (Pref)) 5196 and then Known_Static_Esize (Entity (Pref)) 5197 then 5198 Siz := Esize (Entity (Pref)); 5199 5200 -- For an array component, we can do Size in the front end 5201 -- if the component_size of the array is set. 5202 5203 elsif Nkind (Pref) = N_Indexed_Component then 5204 Siz := Component_Size (Etype (Prefix (Pref))); 5205 5206 -- For a record component, we can do Size in the front end if there 5207 -- is a component clause, or if the record is packed and the 5208 -- component's size is known at compile time. 5209 5210 elsif Nkind (Pref) = N_Selected_Component then 5211 declare 5212 Rec : constant Entity_Id := Etype (Prefix (Pref)); 5213 Comp : constant Entity_Id := Entity (Selector_Name (Pref)); 5214 5215 begin 5216 if Present (Component_Clause (Comp)) then 5217 Siz := Esize (Comp); 5218 5219 elsif Is_Packed (Rec) then 5220 Siz := RM_Size (Ptyp); 5221 5222 else 5223 Apply_Universal_Integer_Attribute_Checks (N); 5224 return; 5225 end if; 5226 end; 5227 5228 -- All other cases are handled by the back end 5229 5230 else 5231 Apply_Universal_Integer_Attribute_Checks (N); 5232 5233 -- If Size is applied to a formal parameter that is of a packed 5234 -- array subtype, then apply Size to the actual subtype. 5235 5236 if Is_Entity_Name (Pref) 5237 and then Is_Formal (Entity (Pref)) 5238 and then Is_Array_Type (Ptyp) 5239 and then Is_Packed (Ptyp) 5240 then 5241 Rewrite (N, 5242 Make_Attribute_Reference (Loc, 5243 Prefix => 5244 New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc), 5245 Attribute_Name => Name_Size)); 5246 Analyze_And_Resolve (N, Typ); 5247 end if; 5248 5249 -- If Size applies to a dereference of an access to unconstrained 5250 -- packed array, the back end needs to see its unconstrained 5251 -- nominal type, but also a hint to the actual constrained type. 5252 5253 if Nkind (Pref) = N_Explicit_Dereference 5254 and then Is_Array_Type (Ptyp) 5255 and then not Is_Constrained (Ptyp) 5256 and then Is_Packed (Ptyp) 5257 then 5258 Set_Actual_Designated_Subtype (Pref, 5259 Get_Actual_Subtype (Pref)); 5260 end if; 5261 5262 return; 5263 end if; 5264 5265 -- Common processing for record and array component case 5266 5267 if Siz /= No_Uint and then Siz /= 0 then 5268 declare 5269 CS : constant Boolean := Comes_From_Source (N); 5270 5271 begin 5272 Rewrite (N, Make_Integer_Literal (Loc, Siz)); 5273 5274 -- This integer literal is not a static expression. We do not 5275 -- call Analyze_And_Resolve here, because this would activate 5276 -- the circuit for deciding that a static value was out of 5277 -- range, and we don't want that. 5278 5279 -- So just manually set the type, mark the expression as non- 5280 -- static, and then ensure that the result is checked properly 5281 -- if the attribute comes from source (if it was internally 5282 -- generated, we never need a constraint check). 5283 5284 Set_Etype (N, Typ); 5285 Set_Is_Static_Expression (N, False); 5286 5287 if CS then 5288 Apply_Constraint_Check (N, Typ); 5289 end if; 5290 end; 5291 end if; 5292 end Size; 5293 5294 ------------------ 5295 -- Storage_Pool -- 5296 ------------------ 5297 5298 when Attribute_Storage_Pool => 5299 Rewrite (N, 5300 Make_Type_Conversion (Loc, 5301 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc), 5302 Expression => New_Occurrence_Of (Entity (N), Loc))); 5303 Analyze_And_Resolve (N, Typ); 5304 5305 ------------------ 5306 -- Storage_Size -- 5307 ------------------ 5308 5309 when Attribute_Storage_Size => Storage_Size : declare 5310 Alloc_Op : Entity_Id := Empty; 5311 5312 begin 5313 5314 -- Access type case, always go to the root type 5315 5316 -- The case of access types results in a value of zero for the case 5317 -- where no storage size attribute clause has been given. If a 5318 -- storage size has been given, then the attribute is converted 5319 -- to a reference to the variable used to hold this value. 5320 5321 if Is_Access_Type (Ptyp) then 5322 if Present (Storage_Size_Variable (Root_Type (Ptyp))) then 5323 Rewrite (N, 5324 Make_Attribute_Reference (Loc, 5325 Prefix => New_Occurrence_Of (Typ, Loc), 5326 Attribute_Name => Name_Max, 5327 Expressions => New_List ( 5328 Make_Integer_Literal (Loc, 0), 5329 Convert_To (Typ, 5330 New_Occurrence_Of 5331 (Storage_Size_Variable (Root_Type (Ptyp)), Loc))))); 5332 5333 elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then 5334 5335 -- If the access type is associated with a simple storage pool 5336 -- object, then attempt to locate the optional Storage_Size 5337 -- function of the simple storage pool type. If not found, 5338 -- then the result will default to zero. 5339 5340 if Present (Get_Rep_Pragma (Root_Type (Ptyp), 5341 Name_Simple_Storage_Pool_Type)) 5342 then 5343 declare 5344 Pool_Type : constant Entity_Id := 5345 Base_Type (Etype (Entity (N))); 5346 5347 begin 5348 Alloc_Op := Get_Name_Entity_Id (Name_Storage_Size); 5349 while Present (Alloc_Op) loop 5350 if Scope (Alloc_Op) = Scope (Pool_Type) 5351 and then Present (First_Formal (Alloc_Op)) 5352 and then Etype (First_Formal (Alloc_Op)) = Pool_Type 5353 then 5354 exit; 5355 end if; 5356 5357 Alloc_Op := Homonym (Alloc_Op); 5358 end loop; 5359 end; 5360 5361 -- In the normal Storage_Pool case, retrieve the primitive 5362 -- function associated with the pool type. 5363 5364 else 5365 Alloc_Op := 5366 Find_Prim_Op 5367 (Etype (Associated_Storage_Pool (Root_Type (Ptyp))), 5368 Attribute_Name (N)); 5369 end if; 5370 5371 -- If Storage_Size wasn't found (can only occur in the simple 5372 -- storage pool case), then simply use zero for the result. 5373 5374 if not Present (Alloc_Op) then 5375 Rewrite (N, Make_Integer_Literal (Loc, 0)); 5376 5377 -- Otherwise, rewrite the allocator as a call to pool type's 5378 -- Storage_Size function. 5379 5380 else 5381 Rewrite (N, 5382 OK_Convert_To (Typ, 5383 Make_Function_Call (Loc, 5384 Name => 5385 New_Occurrence_Of (Alloc_Op, Loc), 5386 5387 Parameter_Associations => New_List ( 5388 New_Occurrence_Of 5389 (Associated_Storage_Pool 5390 (Root_Type (Ptyp)), Loc))))); 5391 end if; 5392 5393 else 5394 Rewrite (N, Make_Integer_Literal (Loc, 0)); 5395 end if; 5396 5397 Analyze_And_Resolve (N, Typ); 5398 5399 -- For tasks, we retrieve the size directly from the TCB. The 5400 -- size may depend on a discriminant of the type, and therefore 5401 -- can be a per-object expression, so type-level information is 5402 -- not sufficient in general. There are four cases to consider: 5403 5404 -- a) If the attribute appears within a task body, the designated 5405 -- TCB is obtained by a call to Self. 5406 5407 -- b) If the prefix of the attribute is the name of a task object, 5408 -- the designated TCB is the one stored in the corresponding record. 5409 5410 -- c) If the prefix is a task type, the size is obtained from the 5411 -- size variable created for each task type 5412 5413 -- d) If no storage_size was specified for the type , there is no 5414 -- size variable, and the value is a system-specific default. 5415 5416 else 5417 if In_Open_Scopes (Ptyp) then 5418 5419 -- Storage_Size (Self) 5420 5421 Rewrite (N, 5422 Convert_To (Typ, 5423 Make_Function_Call (Loc, 5424 Name => 5425 New_Occurrence_Of (RTE (RE_Storage_Size), Loc), 5426 Parameter_Associations => 5427 New_List ( 5428 Make_Function_Call (Loc, 5429 Name => 5430 New_Occurrence_Of (RTE (RE_Self), Loc)))))); 5431 5432 elsif not Is_Entity_Name (Pref) 5433 or else not Is_Type (Entity (Pref)) 5434 then 5435 -- Storage_Size (Rec (Obj).Size) 5436 5437 Rewrite (N, 5438 Convert_To (Typ, 5439 Make_Function_Call (Loc, 5440 Name => 5441 New_Occurrence_Of (RTE (RE_Storage_Size), Loc), 5442 Parameter_Associations => 5443 New_List ( 5444 Make_Selected_Component (Loc, 5445 Prefix => 5446 Unchecked_Convert_To ( 5447 Corresponding_Record_Type (Ptyp), 5448 New_Copy_Tree (Pref)), 5449 Selector_Name => 5450 Make_Identifier (Loc, Name_uTask_Id)))))); 5451 5452 elsif Present (Storage_Size_Variable (Ptyp)) then 5453 5454 -- Static storage size pragma given for type: retrieve value 5455 -- from its allocated storage variable. 5456 5457 Rewrite (N, 5458 Convert_To (Typ, 5459 Make_Function_Call (Loc, 5460 Name => New_Occurrence_Of ( 5461 RTE (RE_Adjust_Storage_Size), Loc), 5462 Parameter_Associations => 5463 New_List ( 5464 New_Occurrence_Of ( 5465 Storage_Size_Variable (Ptyp), Loc))))); 5466 else 5467 -- Get system default 5468 5469 Rewrite (N, 5470 Convert_To (Typ, 5471 Make_Function_Call (Loc, 5472 Name => 5473 New_Occurrence_Of ( 5474 RTE (RE_Default_Stack_Size), Loc)))); 5475 end if; 5476 5477 Analyze_And_Resolve (N, Typ); 5478 end if; 5479 end Storage_Size; 5480 5481 ----------------- 5482 -- Stream_Size -- 5483 ----------------- 5484 5485 when Attribute_Stream_Size => 5486 Rewrite (N, 5487 Make_Integer_Literal (Loc, Intval => Get_Stream_Size (Ptyp))); 5488 Analyze_And_Resolve (N, Typ); 5489 5490 ---------- 5491 -- Succ -- 5492 ---------- 5493 5494 -- 1. Deal with enumeration types with holes 5495 -- 2. For floating-point, generate call to attribute function 5496 -- 3. For other cases, deal with constraint checking 5497 5498 when Attribute_Succ => Succ : declare 5499 Etyp : constant Entity_Id := Base_Type (Ptyp); 5500 5501 begin 5502 5503 -- For enumeration types with non-standard representations, we 5504 -- expand typ'Succ (x) into 5505 5506 -- Pos_To_Rep (Rep_To_Pos (x) + 1) 5507 5508 -- If the representation is contiguous, we compute instead 5509 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations. 5510 5511 if Is_Enumeration_Type (Ptyp) 5512 and then Present (Enum_Pos_To_Rep (Etyp)) 5513 then 5514 if Has_Contiguous_Rep (Etyp) then 5515 Rewrite (N, 5516 Unchecked_Convert_To (Ptyp, 5517 Make_Op_Add (Loc, 5518 Left_Opnd => 5519 Make_Integer_Literal (Loc, 5520 Enumeration_Rep (First_Literal (Ptyp))), 5521 Right_Opnd => 5522 Make_Function_Call (Loc, 5523 Name => 5524 New_Occurrence_Of 5525 (TSS (Etyp, TSS_Rep_To_Pos), Loc), 5526 5527 Parameter_Associations => 5528 New_List ( 5529 Unchecked_Convert_To (Ptyp, 5530 Make_Op_Add (Loc, 5531 Left_Opnd => 5532 Unchecked_Convert_To (Standard_Integer, 5533 Relocate_Node (First (Exprs))), 5534 Right_Opnd => 5535 Make_Integer_Literal (Loc, 1))), 5536 Rep_To_Pos_Flag (Ptyp, Loc)))))); 5537 else 5538 -- Add Boolean parameter True, to request program errror if 5539 -- we have a bad representation on our hands. Add False if 5540 -- checks are suppressed. 5541 5542 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc)); 5543 Rewrite (N, 5544 Make_Indexed_Component (Loc, 5545 Prefix => 5546 New_Occurrence_Of 5547 (Enum_Pos_To_Rep (Etyp), Loc), 5548 Expressions => New_List ( 5549 Make_Op_Add (Loc, 5550 Left_Opnd => 5551 Make_Function_Call (Loc, 5552 Name => 5553 New_Occurrence_Of 5554 (TSS (Etyp, TSS_Rep_To_Pos), Loc), 5555 Parameter_Associations => Exprs), 5556 Right_Opnd => Make_Integer_Literal (Loc, 1))))); 5557 end if; 5558 5559 Analyze_And_Resolve (N, Typ); 5560 5561 -- For floating-point, we transform 'Succ into a call to the Succ 5562 -- floating-point attribute function in Fat_xxx (xxx is root type) 5563 5564 elsif Is_Floating_Point_Type (Ptyp) then 5565 Expand_Fpt_Attribute_R (N); 5566 Analyze_And_Resolve (N, Typ); 5567 5568 -- For modular types, nothing to do (no overflow, since wraps) 5569 5570 elsif Is_Modular_Integer_Type (Ptyp) then 5571 null; 5572 5573 -- For other types, if argument is marked as needing a range check or 5574 -- overflow checking is enabled, we must generate a check. 5575 5576 elsif not Overflow_Checks_Suppressed (Ptyp) 5577 or else Do_Range_Check (First (Exprs)) 5578 then 5579 Set_Do_Range_Check (First (Exprs), False); 5580 Expand_Pred_Succ_Attribute (N); 5581 end if; 5582 end Succ; 5583 5584 --------- 5585 -- Tag -- 5586 --------- 5587 5588 -- Transforms X'Tag into a direct reference to the tag of X 5589 5590 when Attribute_Tag => Tag : declare 5591 Ttyp : Entity_Id; 5592 Prefix_Is_Type : Boolean; 5593 5594 begin 5595 if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then 5596 Ttyp := Entity (Pref); 5597 Prefix_Is_Type := True; 5598 else 5599 Ttyp := Ptyp; 5600 Prefix_Is_Type := False; 5601 end if; 5602 5603 if Is_Class_Wide_Type (Ttyp) then 5604 Ttyp := Root_Type (Ttyp); 5605 end if; 5606 5607 Ttyp := Underlying_Type (Ttyp); 5608 5609 -- Ada 2005: The type may be a synchronized tagged type, in which 5610 -- case the tag information is stored in the corresponding record. 5611 5612 if Is_Concurrent_Type (Ttyp) then 5613 Ttyp := Corresponding_Record_Type (Ttyp); 5614 end if; 5615 5616 if Prefix_Is_Type then 5617 5618 -- For VMs we leave the type attribute unexpanded because 5619 -- there's not a dispatching table to reference. 5620 5621 if Tagged_Type_Expansion then 5622 Rewrite (N, 5623 Unchecked_Convert_To (RTE (RE_Tag), 5624 New_Occurrence_Of 5625 (Node (First_Elmt (Access_Disp_Table (Ttyp))), Loc))); 5626 Analyze_And_Resolve (N, RTE (RE_Tag)); 5627 end if; 5628 5629 -- Ada 2005 (AI-251): The use of 'Tag in the sources always 5630 -- references the primary tag of the actual object. If 'Tag is 5631 -- applied to class-wide interface objects we generate code that 5632 -- displaces "this" to reference the base of the object. 5633 5634 elsif Comes_From_Source (N) 5635 and then Is_Class_Wide_Type (Etype (Prefix (N))) 5636 and then Is_Interface (Etype (Prefix (N))) 5637 then 5638 -- Generate: 5639 -- (To_Tag_Ptr (Prefix'Address)).all 5640 5641 -- Note that Prefix'Address is recursively expanded into a call 5642 -- to Base_Address (Obj.Tag) 5643 5644 -- Not needed for VM targets, since all handled by the VM 5645 5646 if Tagged_Type_Expansion then 5647 Rewrite (N, 5648 Make_Explicit_Dereference (Loc, 5649 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 5650 Make_Attribute_Reference (Loc, 5651 Prefix => Relocate_Node (Pref), 5652 Attribute_Name => Name_Address)))); 5653 Analyze_And_Resolve (N, RTE (RE_Tag)); 5654 end if; 5655 5656 else 5657 Rewrite (N, 5658 Make_Selected_Component (Loc, 5659 Prefix => Relocate_Node (Pref), 5660 Selector_Name => 5661 New_Occurrence_Of (First_Tag_Component (Ttyp), Loc))); 5662 Analyze_And_Resolve (N, RTE (RE_Tag)); 5663 end if; 5664 end Tag; 5665 5666 ---------------- 5667 -- Terminated -- 5668 ---------------- 5669 5670 -- Transforms 'Terminated attribute into a call to Terminated function 5671 5672 when Attribute_Terminated => Terminated : 5673 begin 5674 -- The prefix of Terminated is of a task interface class-wide type. 5675 -- Generate: 5676 -- terminated (Task_Id (Pref._disp_get_task_id)); 5677 5678 if Ada_Version >= Ada_2005 5679 and then Ekind (Ptyp) = E_Class_Wide_Type 5680 and then Is_Interface (Ptyp) 5681 and then Is_Task_Interface (Ptyp) 5682 then 5683 Rewrite (N, 5684 Make_Function_Call (Loc, 5685 Name => 5686 New_Occurrence_Of (RTE (RE_Terminated), Loc), 5687 Parameter_Associations => New_List ( 5688 Make_Unchecked_Type_Conversion (Loc, 5689 Subtype_Mark => 5690 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), 5691 Expression => 5692 Make_Selected_Component (Loc, 5693 Prefix => 5694 New_Copy_Tree (Pref), 5695 Selector_Name => 5696 Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))))); 5697 5698 elsif Restricted_Profile then 5699 Rewrite (N, 5700 Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated))); 5701 5702 else 5703 Rewrite (N, 5704 Build_Call_With_Task (Pref, RTE (RE_Terminated))); 5705 end if; 5706 5707 Analyze_And_Resolve (N, Standard_Boolean); 5708 end Terminated; 5709 5710 ---------------- 5711 -- To_Address -- 5712 ---------------- 5713 5714 -- Transforms System'To_Address (X) and System.Address'Ref (X) into 5715 -- unchecked conversion from (integral) type of X to type address. 5716 5717 when Attribute_To_Address | Attribute_Ref => 5718 Rewrite (N, 5719 Unchecked_Convert_To (RTE (RE_Address), 5720 Relocate_Node (First (Exprs)))); 5721 Analyze_And_Resolve (N, RTE (RE_Address)); 5722 5723 ------------ 5724 -- To_Any -- 5725 ------------ 5726 5727 when Attribute_To_Any => To_Any : declare 5728 P_Type : constant Entity_Id := Etype (Pref); 5729 Decls : constant List_Id := New_List; 5730 begin 5731 Rewrite (N, 5732 Build_To_Any_Call 5733 (Loc, 5734 Convert_To (P_Type, 5735 Relocate_Node (First (Exprs))), Decls)); 5736 Insert_Actions (N, Decls); 5737 Analyze_And_Resolve (N, RTE (RE_Any)); 5738 end To_Any; 5739 5740 ---------------- 5741 -- Truncation -- 5742 ---------------- 5743 5744 -- Transforms 'Truncation into a call to the floating-point attribute 5745 -- function Truncation in Fat_xxx (where xxx is the root type). 5746 -- Expansion is avoided for cases the back end can handle directly. 5747 5748 when Attribute_Truncation => 5749 if not Is_Inline_Floating_Point_Attribute (N) then 5750 Expand_Fpt_Attribute_R (N); 5751 end if; 5752 5753 -------------- 5754 -- TypeCode -- 5755 -------------- 5756 5757 when Attribute_TypeCode => TypeCode : declare 5758 P_Type : constant Entity_Id := Etype (Pref); 5759 Decls : constant List_Id := New_List; 5760 begin 5761 Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls)); 5762 Insert_Actions (N, Decls); 5763 Analyze_And_Resolve (N, RTE (RE_TypeCode)); 5764 end TypeCode; 5765 5766 ----------------------- 5767 -- Unbiased_Rounding -- 5768 ----------------------- 5769 5770 -- Transforms 'Unbiased_Rounding into a call to the floating-point 5771 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the 5772 -- root type). Expansion is avoided for cases the back end can handle 5773 -- directly. 5774 5775 when Attribute_Unbiased_Rounding => 5776 if not Is_Inline_Floating_Point_Attribute (N) then 5777 Expand_Fpt_Attribute_R (N); 5778 end if; 5779 5780 ----------------- 5781 -- UET_Address -- 5782 ----------------- 5783 5784 when Attribute_UET_Address => UET_Address : declare 5785 Ent : constant Entity_Id := Make_Temporary (Loc, 'T'); 5786 5787 begin 5788 Insert_Action (N, 5789 Make_Object_Declaration (Loc, 5790 Defining_Identifier => Ent, 5791 Aliased_Present => True, 5792 Object_Definition => 5793 New_Occurrence_Of (RTE (RE_Address), Loc))); 5794 5795 -- Construct name __gnat_xxx__SDP, where xxx is the unit name 5796 -- in normal external form. 5797 5798 Get_External_Unit_Name_String (Get_Unit_Name (Pref)); 5799 Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len); 5800 Name_Len := Name_Len + 7; 5801 Name_Buffer (1 .. 7) := "__gnat_"; 5802 Name_Buffer (Name_Len + 1 .. Name_Len + 5) := "__SDP"; 5803 Name_Len := Name_Len + 5; 5804 5805 Set_Is_Imported (Ent); 5806 Set_Interface_Name (Ent, 5807 Make_String_Literal (Loc, 5808 Strval => String_From_Name_Buffer)); 5809 5810 -- Set entity as internal to ensure proper Sprint output of its 5811 -- implicit importation. 5812 5813 Set_Is_Internal (Ent); 5814 5815 Rewrite (N, 5816 Make_Attribute_Reference (Loc, 5817 Prefix => New_Occurrence_Of (Ent, Loc), 5818 Attribute_Name => Name_Address)); 5819 5820 Analyze_And_Resolve (N, Typ); 5821 end UET_Address; 5822 5823 ------------ 5824 -- Update -- 5825 ------------ 5826 5827 when Attribute_Update => 5828 Expand_Update_Attribute (N); 5829 5830 --------------- 5831 -- VADS_Size -- 5832 --------------- 5833 5834 -- The processing for VADS_Size is shared with Size 5835 5836 --------- 5837 -- Val -- 5838 --------- 5839 5840 -- For enumeration types with a standard representation, and for all 5841 -- other types, Val is handled by the back end. For enumeration types 5842 -- with a non-standard representation we use the _Pos_To_Rep array that 5843 -- was created when the type was frozen. 5844 5845 when Attribute_Val => Val : declare 5846 Etyp : constant Entity_Id := Base_Type (Entity (Pref)); 5847 5848 begin 5849 if Is_Enumeration_Type (Etyp) 5850 and then Present (Enum_Pos_To_Rep (Etyp)) 5851 then 5852 if Has_Contiguous_Rep (Etyp) then 5853 declare 5854 Rep_Node : constant Node_Id := 5855 Unchecked_Convert_To (Etyp, 5856 Make_Op_Add (Loc, 5857 Left_Opnd => 5858 Make_Integer_Literal (Loc, 5859 Enumeration_Rep (First_Literal (Etyp))), 5860 Right_Opnd => 5861 (Convert_To (Standard_Integer, 5862 Relocate_Node (First (Exprs)))))); 5863 5864 begin 5865 Rewrite (N, 5866 Unchecked_Convert_To (Etyp, 5867 Make_Op_Add (Loc, 5868 Left_Opnd => 5869 Make_Integer_Literal (Loc, 5870 Enumeration_Rep (First_Literal (Etyp))), 5871 Right_Opnd => 5872 Make_Function_Call (Loc, 5873 Name => 5874 New_Occurrence_Of 5875 (TSS (Etyp, TSS_Rep_To_Pos), Loc), 5876 Parameter_Associations => New_List ( 5877 Rep_Node, 5878 Rep_To_Pos_Flag (Etyp, Loc)))))); 5879 end; 5880 5881 else 5882 Rewrite (N, 5883 Make_Indexed_Component (Loc, 5884 Prefix => New_Occurrence_Of (Enum_Pos_To_Rep (Etyp), Loc), 5885 Expressions => New_List ( 5886 Convert_To (Standard_Integer, 5887 Relocate_Node (First (Exprs)))))); 5888 end if; 5889 5890 Analyze_And_Resolve (N, Typ); 5891 5892 -- If the argument is marked as requiring a range check then generate 5893 -- it here. 5894 5895 elsif Do_Range_Check (First (Exprs)) then 5896 Set_Do_Range_Check (First (Exprs), False); 5897 Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed); 5898 end if; 5899 end Val; 5900 5901 ----------- 5902 -- Valid -- 5903 ----------- 5904 5905 -- The code for valid is dependent on the particular types involved. 5906 -- See separate sections below for the generated code in each case. 5907 5908 when Attribute_Valid => Valid : declare 5909 Btyp : Entity_Id := Base_Type (Ptyp); 5910 Tst : Node_Id; 5911 5912 Save_Validity_Checks_On : constant Boolean := Validity_Checks_On; 5913 -- Save the validity checking mode. We always turn off validity 5914 -- checking during process of 'Valid since this is one place 5915 -- where we do not want the implicit validity checks to intefere 5916 -- with the explicit validity check that the programmer is doing. 5917 5918 function Make_Range_Test return Node_Id; 5919 -- Build the code for a range test of the form 5920 -- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last) 5921 5922 --------------------- 5923 -- Make_Range_Test -- 5924 --------------------- 5925 5926 function Make_Range_Test return Node_Id is 5927 Temp : constant Node_Id := Duplicate_Subexpr (Pref); 5928 5929 begin 5930 -- The value whose validity is being checked has been captured in 5931 -- an object declaration. We certainly don't want this object to 5932 -- appear valid because the declaration initializes it. 5933 5934 if Is_Entity_Name (Temp) then 5935 Set_Is_Known_Valid (Entity (Temp), False); 5936 end if; 5937 5938 return 5939 Make_In (Loc, 5940 Left_Opnd => 5941 Unchecked_Convert_To (Btyp, Temp), 5942 Right_Opnd => 5943 Make_Range (Loc, 5944 Low_Bound => 5945 Unchecked_Convert_To (Btyp, 5946 Make_Attribute_Reference (Loc, 5947 Prefix => New_Occurrence_Of (Ptyp, Loc), 5948 Attribute_Name => Name_First)), 5949 High_Bound => 5950 Unchecked_Convert_To (Btyp, 5951 Make_Attribute_Reference (Loc, 5952 Prefix => New_Occurrence_Of (Ptyp, Loc), 5953 Attribute_Name => Name_Last)))); 5954 end Make_Range_Test; 5955 5956 -- Start of processing for Attribute_Valid 5957 5958 begin 5959 -- Do not expand sourced code 'Valid reference in CodePeer mode, 5960 -- will be handled by the back-end directly. 5961 5962 if CodePeer_Mode and then Comes_From_Source (N) then 5963 return; 5964 end if; 5965 5966 -- Turn off validity checks. We do not want any implicit validity 5967 -- checks to intefere with the explicit check from the attribute 5968 5969 Validity_Checks_On := False; 5970 5971 -- Retrieve the base type. Handle the case where the base type is a 5972 -- private enumeration type. 5973 5974 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then 5975 Btyp := Full_View (Btyp); 5976 end if; 5977 5978 -- Floating-point case. This case is handled by the Valid attribute 5979 -- code in the floating-point attribute run-time library. 5980 5981 if Is_Floating_Point_Type (Ptyp) then 5982 declare 5983 Pkg : RE_Id; 5984 Ftp : Entity_Id; 5985 5986 begin 5987 case Float_Rep (Btyp) is 5988 5989 -- For vax fpt types, call appropriate routine in special 5990 -- vax floating point unit. No need to worry about loads in 5991 -- this case, since these types have no signalling NaN's. 5992 5993 when VAX_Native => Expand_Vax_Valid (N); 5994 5995 -- The AAMP back end handles Valid for floating-point types 5996 5997 when AAMP => 5998 Analyze_And_Resolve (Pref, Ptyp); 5999 Set_Etype (N, Standard_Boolean); 6000 Set_Analyzed (N); 6001 6002 when IEEE_Binary => 6003 Find_Fat_Info (Ptyp, Ftp, Pkg); 6004 6005 -- If the floating-point object might be unaligned, we 6006 -- need to call the special routine Unaligned_Valid, 6007 -- which makes the needed copy, being careful not to 6008 -- load the value into any floating-point register. 6009 -- The argument in this case is obj'Address (see 6010 -- Unaligned_Valid routine in Fat_Gen). 6011 6012 if Is_Possibly_Unaligned_Object (Pref) then 6013 Expand_Fpt_Attribute 6014 (N, Pkg, Name_Unaligned_Valid, 6015 New_List ( 6016 Make_Attribute_Reference (Loc, 6017 Prefix => Relocate_Node (Pref), 6018 Attribute_Name => Name_Address))); 6019 6020 -- In the normal case where we are sure the object is 6021 -- aligned, we generate a call to Valid, and the argument 6022 -- in this case is obj'Unrestricted_Access (after 6023 -- converting obj to the right floating-point type). 6024 6025 else 6026 Expand_Fpt_Attribute 6027 (N, Pkg, Name_Valid, 6028 New_List ( 6029 Make_Attribute_Reference (Loc, 6030 Prefix => Unchecked_Convert_To (Ftp, Pref), 6031 Attribute_Name => Name_Unrestricted_Access))); 6032 end if; 6033 end case; 6034 6035 -- One more task, we still need a range check. Required 6036 -- only if we have a constraint, since the Valid routine 6037 -- catches infinities properly (infinities are never valid). 6038 6039 -- The way we do the range check is simply to create the 6040 -- expression: Valid (N) and then Base_Type(Pref) in Typ. 6041 6042 if not Subtypes_Statically_Match (Ptyp, Btyp) then 6043 Rewrite (N, 6044 Make_And_Then (Loc, 6045 Left_Opnd => Relocate_Node (N), 6046 Right_Opnd => 6047 Make_In (Loc, 6048 Left_Opnd => Convert_To (Btyp, Pref), 6049 Right_Opnd => New_Occurrence_Of (Ptyp, Loc)))); 6050 end if; 6051 end; 6052 6053 -- Enumeration type with holes 6054 6055 -- For enumeration types with holes, the Pos value constructed by 6056 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a 6057 -- second argument of False returns minus one for an invalid value, 6058 -- and the non-negative pos value for a valid value, so the 6059 -- expansion of X'Valid is simply: 6060 6061 -- type(X)'Pos (X) >= 0 6062 6063 -- We can't quite generate it that way because of the requirement 6064 -- for the non-standard second argument of False in the resulting 6065 -- rep_to_pos call, so we have to explicitly create: 6066 6067 -- _rep_to_pos (X, False) >= 0 6068 6069 -- If we have an enumeration subtype, we also check that the 6070 -- value is in range: 6071 6072 -- _rep_to_pos (X, False) >= 0 6073 -- and then 6074 -- (X >= type(X)'First and then type(X)'Last <= X) 6075 6076 elsif Is_Enumeration_Type (Ptyp) 6077 and then Present (Enum_Pos_To_Rep (Btyp)) 6078 then 6079 Tst := 6080 Make_Op_Ge (Loc, 6081 Left_Opnd => 6082 Make_Function_Call (Loc, 6083 Name => 6084 New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc), 6085 Parameter_Associations => New_List ( 6086 Pref, 6087 New_Occurrence_Of (Standard_False, Loc))), 6088 Right_Opnd => Make_Integer_Literal (Loc, 0)); 6089 6090 if Ptyp /= Btyp 6091 and then 6092 (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp) 6093 or else 6094 Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp)) 6095 then 6096 -- The call to Make_Range_Test will create declarations 6097 -- that need a proper insertion point, but Pref is now 6098 -- attached to a node with no ancestor. Attach to tree 6099 -- even if it is to be rewritten below. 6100 6101 Set_Parent (Tst, Parent (N)); 6102 6103 Tst := 6104 Make_And_Then (Loc, 6105 Left_Opnd => Make_Range_Test, 6106 Right_Opnd => Tst); 6107 end if; 6108 6109 Rewrite (N, Tst); 6110 6111 -- Fortran convention booleans 6112 6113 -- For the very special case of Fortran convention booleans, the 6114 -- value is always valid, since it is an integer with the semantics 6115 -- that non-zero is true, and any value is permissible. 6116 6117 elsif Is_Boolean_Type (Ptyp) 6118 and then Convention (Ptyp) = Convention_Fortran 6119 then 6120 Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); 6121 6122 -- For biased representations, we will be doing an unchecked 6123 -- conversion without unbiasing the result. That means that the range 6124 -- test has to take this into account, and the proper form of the 6125 -- test is: 6126 6127 -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length) 6128 6129 elsif Has_Biased_Representation (Ptyp) then 6130 Btyp := RTE (RE_Unsigned_32); 6131 Rewrite (N, 6132 Make_Op_Lt (Loc, 6133 Left_Opnd => 6134 Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)), 6135 Right_Opnd => 6136 Unchecked_Convert_To (Btyp, 6137 Make_Attribute_Reference (Loc, 6138 Prefix => New_Occurrence_Of (Ptyp, Loc), 6139 Attribute_Name => Name_Range_Length)))); 6140 6141 -- For all other scalar types, what we want logically is a 6142 -- range test: 6143 6144 -- X in type(X)'First .. type(X)'Last 6145 6146 -- But that's precisely what won't work because of possible 6147 -- unwanted optimization (and indeed the basic motivation for 6148 -- the Valid attribute is exactly that this test does not work). 6149 -- What will work is: 6150 6151 -- Btyp!(X) >= Btyp!(type(X)'First) 6152 -- and then 6153 -- Btyp!(X) <= Btyp!(type(X)'Last) 6154 6155 -- where Btyp is an integer type large enough to cover the full 6156 -- range of possible stored values (i.e. it is chosen on the basis 6157 -- of the size of the type, not the range of the values). We write 6158 -- this as two tests, rather than a range check, so that static 6159 -- evaluation will easily remove either or both of the checks if 6160 -- they can be -statically determined to be true (this happens 6161 -- when the type of X is static and the range extends to the full 6162 -- range of stored values). 6163 6164 -- Unsigned types. Note: it is safe to consider only whether the 6165 -- subtype is unsigned, since we will in that case be doing all 6166 -- unsigned comparisons based on the subtype range. Since we use the 6167 -- actual subtype object size, this is appropriate. 6168 6169 -- For example, if we have 6170 6171 -- subtype x is integer range 1 .. 200; 6172 -- for x'Object_Size use 8; 6173 6174 -- Now the base type is signed, but objects of this type are bits 6175 -- unsigned, and doing an unsigned test of the range 1 to 200 is 6176 -- correct, even though a value greater than 127 looks signed to a 6177 -- signed comparison. 6178 6179 elsif Is_Unsigned_Type (Ptyp) then 6180 if Esize (Ptyp) <= 32 then 6181 Btyp := RTE (RE_Unsigned_32); 6182 else 6183 Btyp := RTE (RE_Unsigned_64); 6184 end if; 6185 6186 Rewrite (N, Make_Range_Test); 6187 6188 -- Signed types 6189 6190 else 6191 if Esize (Ptyp) <= Esize (Standard_Integer) then 6192 Btyp := Standard_Integer; 6193 else 6194 Btyp := Universal_Integer; 6195 end if; 6196 6197 Rewrite (N, Make_Range_Test); 6198 end if; 6199 6200 -- If a predicate is present, then we do the predicate test, even if 6201 -- within the predicate function (infinite recursion is warned about 6202 -- in Sem_Attr in that case). 6203 6204 declare 6205 Pred_Func : constant Entity_Id := Predicate_Function (Ptyp); 6206 6207 begin 6208 if Present (Pred_Func) then 6209 Rewrite (N, 6210 Make_And_Then (Loc, 6211 Left_Opnd => Relocate_Node (N), 6212 Right_Opnd => Make_Predicate_Call (Ptyp, Pref))); 6213 end if; 6214 end; 6215 6216 Analyze_And_Resolve (N, Standard_Boolean); 6217 Validity_Checks_On := Save_Validity_Checks_On; 6218 end Valid; 6219 6220 ------------------- 6221 -- Valid_Scalars -- 6222 ------------------- 6223 6224 when Attribute_Valid_Scalars => Valid_Scalars : declare 6225 Ftyp : Entity_Id; 6226 6227 begin 6228 if Present (Underlying_Type (Ptyp)) then 6229 Ftyp := Underlying_Type (Ptyp); 6230 else 6231 Ftyp := Ptyp; 6232 end if; 6233 6234 -- For scalar types, Valid_Scalars is the same as Valid 6235 6236 if Is_Scalar_Type (Ftyp) then 6237 Rewrite (N, 6238 Make_Attribute_Reference (Loc, 6239 Attribute_Name => Name_Valid, 6240 Prefix => Pref)); 6241 Analyze_And_Resolve (N, Standard_Boolean); 6242 6243 -- For array types, we construct a function that determines if there 6244 -- are any non-valid scalar subcomponents, and call the function. 6245 -- We only do this for arrays whose component type needs checking 6246 6247 elsif Is_Array_Type (Ftyp) 6248 and then not No_Scalar_Parts (Component_Type (Ftyp)) 6249 then 6250 Rewrite (N, 6251 Make_Function_Call (Loc, 6252 Name => 6253 New_Occurrence_Of (Build_Array_VS_Func (Ftyp, N), Loc), 6254 Parameter_Associations => New_List (Pref))); 6255 6256 Analyze_And_Resolve (N, Standard_Boolean); 6257 6258 -- For record types, we build a big if expression, applying Valid or 6259 -- Valid_Scalars as appropriate to all relevant components. 6260 6261 elsif (Is_Record_Type (Ptyp) or else Has_Discriminants (Ptyp)) 6262 and then not No_Scalar_Parts (Ptyp) 6263 then 6264 declare 6265 C : Entity_Id; 6266 X : Node_Id; 6267 A : Name_Id; 6268 6269 begin 6270 X := New_Occurrence_Of (Standard_True, Loc); 6271 C := First_Component_Or_Discriminant (Ptyp); 6272 while Present (C) loop 6273 if No_Scalar_Parts (Etype (C)) then 6274 goto Continue; 6275 elsif Is_Scalar_Type (Etype (C)) then 6276 A := Name_Valid; 6277 else 6278 A := Name_Valid_Scalars; 6279 end if; 6280 6281 X := 6282 Make_And_Then (Loc, 6283 Left_Opnd => X, 6284 Right_Opnd => 6285 Make_Attribute_Reference (Loc, 6286 Attribute_Name => A, 6287 Prefix => 6288 Make_Selected_Component (Loc, 6289 Prefix => 6290 Duplicate_Subexpr (Pref, Name_Req => True), 6291 Selector_Name => 6292 New_Occurrence_Of (C, Loc)))); 6293 <<Continue>> 6294 Next_Component_Or_Discriminant (C); 6295 end loop; 6296 6297 Rewrite (N, X); 6298 Analyze_And_Resolve (N, Standard_Boolean); 6299 end; 6300 6301 -- For all other types, result is True (but not static) 6302 6303 else 6304 Rewrite (N, New_Occurrence_Of (Standard_Boolean, Loc)); 6305 Analyze_And_Resolve (N, Standard_Boolean); 6306 Set_Is_Static_Expression (N, False); 6307 end if; 6308 end Valid_Scalars; 6309 6310 ----------- 6311 -- Value -- 6312 ----------- 6313 6314 -- Value attribute is handled in separate unit Exp_Imgv 6315 6316 when Attribute_Value => 6317 Exp_Imgv.Expand_Value_Attribute (N); 6318 6319 ----------------- 6320 -- Value_Size -- 6321 ----------------- 6322 6323 -- The processing for Value_Size shares the processing for Size 6324 6325 ------------- 6326 -- Version -- 6327 ------------- 6328 6329 -- The processing for Version shares the processing for Body_Version 6330 6331 ---------------- 6332 -- Wide_Image -- 6333 ---------------- 6334 6335 -- Wide_Image attribute is handled in separate unit Exp_Imgv 6336 6337 when Attribute_Wide_Image => 6338 Exp_Imgv.Expand_Wide_Image_Attribute (N); 6339 6340 --------------------- 6341 -- Wide_Wide_Image -- 6342 --------------------- 6343 6344 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv 6345 6346 when Attribute_Wide_Wide_Image => 6347 Exp_Imgv.Expand_Wide_Wide_Image_Attribute (N); 6348 6349 ---------------- 6350 -- Wide_Value -- 6351 ---------------- 6352 6353 -- We expand typ'Wide_Value (X) into 6354 6355 -- typ'Value 6356 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method)) 6357 6358 -- Wide_String_To_String is a runtime function that converts its wide 6359 -- string argument to String, converting any non-translatable characters 6360 -- into appropriate escape sequences. This preserves the required 6361 -- semantics of Wide_Value in all cases, and results in a very simple 6362 -- implementation approach. 6363 6364 -- Note: for this approach to be fully standard compliant for the cases 6365 -- where typ is Wide_Character and Wide_Wide_Character, the encoding 6366 -- method must cover the entire character range (e.g. UTF-8). But that 6367 -- is a reasonable requirement when dealing with encoded character 6368 -- sequences. Presumably if one of the restrictive encoding mechanisms 6369 -- is in use such as Shift-JIS, then characters that cannot be 6370 -- represented using this encoding will not appear in any case. 6371 6372 when Attribute_Wide_Value => Wide_Value : 6373 begin 6374 Rewrite (N, 6375 Make_Attribute_Reference (Loc, 6376 Prefix => Pref, 6377 Attribute_Name => Name_Value, 6378 6379 Expressions => New_List ( 6380 Make_Function_Call (Loc, 6381 Name => 6382 New_Occurrence_Of (RTE (RE_Wide_String_To_String), Loc), 6383 6384 Parameter_Associations => New_List ( 6385 Relocate_Node (First (Exprs)), 6386 Make_Integer_Literal (Loc, 6387 Intval => Int (Wide_Character_Encoding_Method))))))); 6388 6389 Analyze_And_Resolve (N, Typ); 6390 end Wide_Value; 6391 6392 --------------------- 6393 -- Wide_Wide_Value -- 6394 --------------------- 6395 6396 -- We expand typ'Wide_Value_Value (X) into 6397 6398 -- typ'Value 6399 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method)) 6400 6401 -- Wide_Wide_String_To_String is a runtime function that converts its 6402 -- wide string argument to String, converting any non-translatable 6403 -- characters into appropriate escape sequences. This preserves the 6404 -- required semantics of Wide_Wide_Value in all cases, and results in a 6405 -- very simple implementation approach. 6406 6407 -- It's not quite right where typ = Wide_Wide_Character, because the 6408 -- encoding method may not cover the whole character type ??? 6409 6410 when Attribute_Wide_Wide_Value => Wide_Wide_Value : 6411 begin 6412 Rewrite (N, 6413 Make_Attribute_Reference (Loc, 6414 Prefix => Pref, 6415 Attribute_Name => Name_Value, 6416 6417 Expressions => New_List ( 6418 Make_Function_Call (Loc, 6419 Name => 6420 New_Occurrence_Of 6421 (RTE (RE_Wide_Wide_String_To_String), Loc), 6422 6423 Parameter_Associations => New_List ( 6424 Relocate_Node (First (Exprs)), 6425 Make_Integer_Literal (Loc, 6426 Intval => Int (Wide_Character_Encoding_Method))))))); 6427 6428 Analyze_And_Resolve (N, Typ); 6429 end Wide_Wide_Value; 6430 6431 --------------------- 6432 -- Wide_Wide_Width -- 6433 --------------------- 6434 6435 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv 6436 6437 when Attribute_Wide_Wide_Width => 6438 Exp_Imgv.Expand_Width_Attribute (N, Wide_Wide); 6439 6440 ---------------- 6441 -- Wide_Width -- 6442 ---------------- 6443 6444 -- Wide_Width attribute is handled in separate unit Exp_Imgv 6445 6446 when Attribute_Wide_Width => 6447 Exp_Imgv.Expand_Width_Attribute (N, Wide); 6448 6449 ----------- 6450 -- Width -- 6451 ----------- 6452 6453 -- Width attribute is handled in separate unit Exp_Imgv 6454 6455 when Attribute_Width => 6456 Exp_Imgv.Expand_Width_Attribute (N, Normal); 6457 6458 ----------- 6459 -- Write -- 6460 ----------- 6461 6462 when Attribute_Write => Write : declare 6463 P_Type : constant Entity_Id := Entity (Pref); 6464 U_Type : constant Entity_Id := Underlying_Type (P_Type); 6465 Pname : Entity_Id; 6466 Decl : Node_Id; 6467 Prag : Node_Id; 6468 Arg3 : Node_Id; 6469 Wfunc : Node_Id; 6470 6471 begin 6472 -- If no underlying type, we have an error that will be diagnosed 6473 -- elsewhere, so here we just completely ignore the expansion. 6474 6475 if No (U_Type) then 6476 return; 6477 end if; 6478 6479 -- The simple case, if there is a TSS for Write, just call it 6480 6481 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write); 6482 6483 if Present (Pname) then 6484 null; 6485 6486 else 6487 -- If there is a Stream_Convert pragma, use it, we rewrite 6488 6489 -- sourcetyp'Output (stream, Item) 6490 6491 -- as 6492 6493 -- strmtyp'Output (Stream, strmwrite (acttyp (Item))); 6494 6495 -- where strmwrite is the given Write function that converts an 6496 -- argument of type sourcetyp or a type acctyp, from which it is 6497 -- derived to type strmtyp. The conversion to acttyp is required 6498 -- for the derived case. 6499 6500 Prag := Get_Stream_Convert_Pragma (P_Type); 6501 6502 if Present (Prag) then 6503 Arg3 := 6504 Next (Next (First (Pragma_Argument_Associations (Prag)))); 6505 Wfunc := Entity (Expression (Arg3)); 6506 6507 Rewrite (N, 6508 Make_Attribute_Reference (Loc, 6509 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc), 6510 Attribute_Name => Name_Output, 6511 Expressions => New_List ( 6512 Relocate_Node (First (Exprs)), 6513 Make_Function_Call (Loc, 6514 Name => New_Occurrence_Of (Wfunc, Loc), 6515 Parameter_Associations => New_List ( 6516 OK_Convert_To (Etype (First_Formal (Wfunc)), 6517 Relocate_Node (Next (First (Exprs))))))))); 6518 6519 Analyze (N); 6520 return; 6521 6522 -- For elementary types, we call the W_xxx routine directly 6523 6524 elsif Is_Elementary_Type (U_Type) then 6525 Rewrite (N, Build_Elementary_Write_Call (N)); 6526 Analyze (N); 6527 return; 6528 6529 -- Array type case 6530 6531 elsif Is_Array_Type (U_Type) then 6532 Build_Array_Write_Procedure (N, U_Type, Decl, Pname); 6533 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False); 6534 6535 -- Tagged type case, use the primitive Write function. Note that 6536 -- this will dispatch in the class-wide case which is what we want 6537 6538 elsif Is_Tagged_Type (U_Type) then 6539 Pname := Find_Prim_Op (U_Type, TSS_Stream_Write); 6540 6541 -- All other record type cases, including protected records. 6542 -- The latter only arise for expander generated code for 6543 -- handling shared passive partition access. 6544 6545 else 6546 pragma Assert 6547 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); 6548 6549 -- Ada 2005 (AI-216): Program_Error is raised when executing 6550 -- the default implementation of the Write attribute of an 6551 -- Unchecked_Union type. However, if the 'Write reference is 6552 -- within the generated Output stream procedure, Write outputs 6553 -- the components, and the default values of the discriminant 6554 -- are streamed by the Output procedure itself. 6555 6556 if Is_Unchecked_Union (Base_Type (U_Type)) 6557 and not Is_TSS (Current_Scope, TSS_Stream_Output) 6558 then 6559 Insert_Action (N, 6560 Make_Raise_Program_Error (Loc, 6561 Reason => PE_Unchecked_Union_Restriction)); 6562 end if; 6563 6564 if Has_Discriminants (U_Type) 6565 and then Present 6566 (Discriminant_Default_Value (First_Discriminant (U_Type))) 6567 then 6568 Build_Mutable_Record_Write_Procedure 6569 (Loc, Full_Base (U_Type), Decl, Pname); 6570 else 6571 Build_Record_Write_Procedure 6572 (Loc, Full_Base (U_Type), Decl, Pname); 6573 end if; 6574 6575 Insert_Action (N, Decl); 6576 end if; 6577 end if; 6578 6579 -- If we fall through, Pname is the procedure to be called 6580 6581 Rewrite_Stream_Proc_Call (Pname); 6582 end Write; 6583 6584 -- Component_Size is handled by the back end, unless the component size 6585 -- is known at compile time, which is always true in the packed array 6586 -- case. It is important that the packed array case is handled in the 6587 -- front end (see Eval_Attribute) since the back end would otherwise get 6588 -- confused by the equivalent packed array type. 6589 6590 when Attribute_Component_Size => 6591 null; 6592 6593 -- The following attributes are handled by the back end (except that 6594 -- static cases have already been evaluated during semantic processing, 6595 -- but in any case the back end should not count on this). 6596 6597 -- The back end also handles the non-class-wide cases of Size 6598 6599 when Attribute_Bit_Order | 6600 Attribute_Code_Address | 6601 Attribute_Definite | 6602 Attribute_Null_Parameter | 6603 Attribute_Passed_By_Reference | 6604 Attribute_Pool_Address | 6605 Attribute_Scalar_Storage_Order => 6606 null; 6607 6608 -- The following attributes are also handled by the back end, but return 6609 -- a universal integer result, so may need a conversion for checking 6610 -- that the result is in range. 6611 6612 when Attribute_Aft | 6613 Attribute_Max_Alignment_For_Allocation => 6614 Apply_Universal_Integer_Attribute_Checks (N); 6615 6616 -- The following attributes should not appear at this stage, since they 6617 -- have already been handled by the analyzer (and properly rewritten 6618 -- with corresponding values or entities to represent the right values) 6619 6620 when Attribute_Abort_Signal | 6621 Attribute_Address_Size | 6622 Attribute_Atomic_Always_Lock_Free | 6623 Attribute_Base | 6624 Attribute_Class | 6625 Attribute_Compiler_Version | 6626 Attribute_Default_Bit_Order | 6627 Attribute_Delta | 6628 Attribute_Denorm | 6629 Attribute_Digits | 6630 Attribute_Emax | 6631 Attribute_Enabled | 6632 Attribute_Epsilon | 6633 Attribute_Fast_Math | 6634 Attribute_First_Valid | 6635 Attribute_Has_Access_Values | 6636 Attribute_Has_Discriminants | 6637 Attribute_Has_Tagged_Values | 6638 Attribute_Large | 6639 Attribute_Last_Valid | 6640 Attribute_Library_Level | 6641 Attribute_Lock_Free | 6642 Attribute_Machine_Emax | 6643 Attribute_Machine_Emin | 6644 Attribute_Machine_Mantissa | 6645 Attribute_Machine_Overflows | 6646 Attribute_Machine_Radix | 6647 Attribute_Machine_Rounds | 6648 Attribute_Maximum_Alignment | 6649 Attribute_Model_Emin | 6650 Attribute_Model_Epsilon | 6651 Attribute_Model_Mantissa | 6652 Attribute_Model_Small | 6653 Attribute_Modulus | 6654 Attribute_Partition_ID | 6655 Attribute_Range | 6656 Attribute_Restriction_Set | 6657 Attribute_Safe_Emax | 6658 Attribute_Safe_First | 6659 Attribute_Safe_Large | 6660 Attribute_Safe_Last | 6661 Attribute_Safe_Small | 6662 Attribute_Scale | 6663 Attribute_Signed_Zeros | 6664 Attribute_Small | 6665 Attribute_Storage_Unit | 6666 Attribute_Stub_Type | 6667 Attribute_System_Allocator_Alignment | 6668 Attribute_Target_Name | 6669 Attribute_Type_Class | 6670 Attribute_Type_Key | 6671 Attribute_Unconstrained_Array | 6672 Attribute_Universal_Literal_String | 6673 Attribute_Wchar_T_Size | 6674 Attribute_Word_Size => 6675 raise Program_Error; 6676 6677 -- The Asm_Input and Asm_Output attributes are not expanded at this 6678 -- stage, but will be eliminated in the expansion of the Asm call, see 6679 -- Exp_Intr for details. So the back end will never see these either. 6680 6681 when Attribute_Asm_Input | 6682 Attribute_Asm_Output => 6683 null; 6684 end case; 6685 6686 -- Note: as mentioned earlier, individual sections of the above case 6687 -- statement assume there is no code after the case statement, and are 6688 -- legitimately allowed to execute return statements if they have nothing 6689 -- more to do, so DO NOT add code at this point. 6690 6691 exception 6692 when RE_Not_Available => 6693 return; 6694 end Expand_N_Attribute_Reference; 6695 6696 -------------------------------- 6697 -- Expand_Pred_Succ_Attribute -- 6698 -------------------------------- 6699 6700 -- For typ'Pred (exp), we generate the check 6701 6702 -- [constraint_error when exp = typ'Base'First] 6703 6704 -- Similarly, for typ'Succ (exp), we generate the check 6705 6706 -- [constraint_error when exp = typ'Base'Last] 6707 6708 -- These checks are not generated for modular types, since the proper 6709 -- semantics for Succ and Pred on modular types is to wrap, not raise CE. 6710 -- We also suppress these checks if we are the right side of an assignment 6711 -- statement or the expression of an object declaration, where the flag 6712 -- Suppress_Assignment_Checks is set for the assignment/declaration. 6713 6714 procedure Expand_Pred_Succ_Attribute (N : Node_Id) is 6715 Loc : constant Source_Ptr := Sloc (N); 6716 P : constant Node_Id := Parent (N); 6717 Cnam : Name_Id; 6718 6719 begin 6720 if Attribute_Name (N) = Name_Pred then 6721 Cnam := Name_First; 6722 else 6723 Cnam := Name_Last; 6724 end if; 6725 6726 if not Nkind_In (P, N_Assignment_Statement, N_Object_Declaration) 6727 or else not Suppress_Assignment_Checks (P) 6728 then 6729 Insert_Action (N, 6730 Make_Raise_Constraint_Error (Loc, 6731 Condition => 6732 Make_Op_Eq (Loc, 6733 Left_Opnd => 6734 Duplicate_Subexpr_Move_Checks (First (Expressions (N))), 6735 Right_Opnd => 6736 Make_Attribute_Reference (Loc, 6737 Prefix => 6738 New_Occurrence_Of (Base_Type (Etype (Prefix (N))), Loc), 6739 Attribute_Name => Cnam)), 6740 Reason => CE_Overflow_Check_Failed)); 6741 end if; 6742 end Expand_Pred_Succ_Attribute; 6743 6744 ----------------------------- 6745 -- Expand_Update_Attribute -- 6746 ----------------------------- 6747 6748 procedure Expand_Update_Attribute (N : Node_Id) is 6749 procedure Process_Component_Or_Element_Update 6750 (Temp : Entity_Id; 6751 Comp : Node_Id; 6752 Expr : Node_Id; 6753 Typ : Entity_Id); 6754 -- Generate the statements necessary to update a single component or an 6755 -- element of the prefix. The code is inserted before the attribute N. 6756 -- Temp denotes the entity of the anonymous object created to reflect 6757 -- the changes in values. Comp is the component/index expression to be 6758 -- updated. Expr is an expression yielding the new value of Comp. Typ 6759 -- is the type of the prefix of attribute Update. 6760 6761 procedure Process_Range_Update 6762 (Temp : Entity_Id; 6763 Comp : Node_Id; 6764 Expr : Node_Id; 6765 Typ : Entity_Id); 6766 -- Generate the statements necessary to update a slice of the prefix. 6767 -- The code is inserted before the attribute N. Temp denotes the entity 6768 -- of the anonymous object created to reflect the changes in values. 6769 -- Comp is range of the slice to be updated. Expr is an expression 6770 -- yielding the new value of Comp. Typ is the type of the prefix of 6771 -- attribute Update. 6772 6773 ----------------------------------------- 6774 -- Process_Component_Or_Element_Update -- 6775 ----------------------------------------- 6776 6777 procedure Process_Component_Or_Element_Update 6778 (Temp : Entity_Id; 6779 Comp : Node_Id; 6780 Expr : Node_Id; 6781 Typ : Entity_Id) 6782 is 6783 Loc : constant Source_Ptr := Sloc (Comp); 6784 Exprs : List_Id; 6785 LHS : Node_Id; 6786 6787 begin 6788 -- An array element may be modified by the following relations 6789 -- depending on the number of dimensions: 6790 6791 -- 1 => Expr -- one dimensional update 6792 -- (1, ..., N) => Expr -- multi dimensional update 6793 6794 -- The above forms are converted in assignment statements where the 6795 -- left hand side is an indexed component: 6796 6797 -- Temp (1) := Expr; -- one dimensional update 6798 -- Temp (1, ..., N) := Expr; -- multi dimensional update 6799 6800 if Is_Array_Type (Typ) then 6801 6802 -- The index expressions of a multi dimensional array update 6803 -- appear as an aggregate. 6804 6805 if Nkind (Comp) = N_Aggregate then 6806 Exprs := New_Copy_List_Tree (Expressions (Comp)); 6807 else 6808 Exprs := New_List (Relocate_Node (Comp)); 6809 end if; 6810 6811 LHS := 6812 Make_Indexed_Component (Loc, 6813 Prefix => New_Occurrence_Of (Temp, Loc), 6814 Expressions => Exprs); 6815 6816 -- A record component update appears in the following form: 6817 6818 -- Comp => Expr 6819 6820 -- The above relation is transformed into an assignment statement 6821 -- where the left hand side is a selected component: 6822 6823 -- Temp.Comp := Expr; 6824 6825 else pragma Assert (Is_Record_Type (Typ)); 6826 LHS := 6827 Make_Selected_Component (Loc, 6828 Prefix => New_Occurrence_Of (Temp, Loc), 6829 Selector_Name => Relocate_Node (Comp)); 6830 end if; 6831 6832 Insert_Action (N, 6833 Make_Assignment_Statement (Loc, 6834 Name => LHS, 6835 Expression => Relocate_Node (Expr))); 6836 end Process_Component_Or_Element_Update; 6837 6838 -------------------------- 6839 -- Process_Range_Update -- 6840 -------------------------- 6841 6842 procedure Process_Range_Update 6843 (Temp : Entity_Id; 6844 Comp : Node_Id; 6845 Expr : Node_Id; 6846 Typ : Entity_Id) 6847 is 6848 Index_Typ : constant Entity_Id := Etype (First_Index (Typ)); 6849 Loc : constant Source_Ptr := Sloc (Comp); 6850 Index : Entity_Id; 6851 6852 begin 6853 -- A range update appears as 6854 6855 -- (Low .. High => Expr) 6856 6857 -- The above construct is transformed into a loop that iterates over 6858 -- the given range and modifies the corresponding array values to the 6859 -- value of Expr: 6860 6861 -- for Index in Low .. High loop 6862 -- Temp (<Index_Typ> (Index)) := Expr; 6863 -- end loop; 6864 6865 Index := Make_Temporary (Loc, 'I'); 6866 6867 Insert_Action (N, 6868 Make_Loop_Statement (Loc, 6869 Iteration_Scheme => 6870 Make_Iteration_Scheme (Loc, 6871 Loop_Parameter_Specification => 6872 Make_Loop_Parameter_Specification (Loc, 6873 Defining_Identifier => Index, 6874 Discrete_Subtype_Definition => Relocate_Node (Comp))), 6875 6876 Statements => New_List ( 6877 Make_Assignment_Statement (Loc, 6878 Name => 6879 Make_Indexed_Component (Loc, 6880 Prefix => New_Occurrence_Of (Temp, Loc), 6881 Expressions => New_List ( 6882 Convert_To (Index_Typ, 6883 New_Occurrence_Of (Index, Loc)))), 6884 Expression => Relocate_Node (Expr))), 6885 6886 End_Label => Empty)); 6887 end Process_Range_Update; 6888 6889 -- Local variables 6890 6891 Aggr : constant Node_Id := First (Expressions (N)); 6892 Loc : constant Source_Ptr := Sloc (N); 6893 Pref : constant Node_Id := Prefix (N); 6894 Typ : constant Entity_Id := Etype (Pref); 6895 Assoc : Node_Id; 6896 Comp : Node_Id; 6897 Expr : Node_Id; 6898 Temp : Entity_Id; 6899 6900 -- Start of processing for Expand_Update_Attribute 6901 6902 begin 6903 -- Create the anonymous object that stores the value of the prefix and 6904 -- reflects subsequent changes in value. Generate: 6905 6906 -- Temp : <type of Pref> := Pref; 6907 6908 Temp := Make_Temporary (Loc, 'T'); 6909 6910 Insert_Action (N, 6911 Make_Object_Declaration (Loc, 6912 Defining_Identifier => Temp, 6913 Object_Definition => New_Occurrence_Of (Typ, Loc), 6914 Expression => Relocate_Node (Pref))); 6915 6916 -- Process the update aggregate 6917 6918 Assoc := First (Component_Associations (Aggr)); 6919 while Present (Assoc) loop 6920 Comp := First (Choices (Assoc)); 6921 Expr := Expression (Assoc); 6922 while Present (Comp) loop 6923 if Nkind (Comp) = N_Range then 6924 Process_Range_Update (Temp, Comp, Expr, Typ); 6925 else 6926 Process_Component_Or_Element_Update (Temp, Comp, Expr, Typ); 6927 end if; 6928 6929 Next (Comp); 6930 end loop; 6931 6932 Next (Assoc); 6933 end loop; 6934 6935 -- The attribute is replaced by a reference to the anonymous object 6936 6937 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 6938 Analyze (N); 6939 end Expand_Update_Attribute; 6940 6941 ------------------- 6942 -- Find_Fat_Info -- 6943 ------------------- 6944 6945 procedure Find_Fat_Info 6946 (T : Entity_Id; 6947 Fat_Type : out Entity_Id; 6948 Fat_Pkg : out RE_Id) 6949 is 6950 Btyp : constant Entity_Id := Base_Type (T); 6951 Rtyp : constant Entity_Id := Root_Type (T); 6952 Digs : constant Nat := UI_To_Int (Digits_Value (Btyp)); 6953 6954 begin 6955 -- If the base type is VAX float, then get appropriate VAX float type 6956 6957 if Vax_Float (Btyp) then 6958 case Digs is 6959 when 6 => 6960 Fat_Type := RTE (RE_Fat_VAX_F); 6961 Fat_Pkg := RE_Attr_VAX_F_Float; 6962 6963 when 9 => 6964 Fat_Type := RTE (RE_Fat_VAX_D); 6965 Fat_Pkg := RE_Attr_VAX_D_Float; 6966 6967 when 15 => 6968 Fat_Type := RTE (RE_Fat_VAX_G); 6969 Fat_Pkg := RE_Attr_VAX_G_Float; 6970 6971 when others => 6972 raise Program_Error; 6973 end case; 6974 6975 -- If root type is VAX float, this is the case where the library has 6976 -- been recompiled in VAX float mode, and we have an IEEE float type. 6977 -- This is when we use the special IEEE Fat packages. 6978 6979 elsif Vax_Float (Rtyp) then 6980 case Digs is 6981 when 6 => 6982 Fat_Type := RTE (RE_Fat_IEEE_Short); 6983 Fat_Pkg := RE_Attr_IEEE_Short; 6984 6985 when 15 => 6986 Fat_Type := RTE (RE_Fat_IEEE_Long); 6987 Fat_Pkg := RE_Attr_IEEE_Long; 6988 6989 when others => 6990 raise Program_Error; 6991 end case; 6992 6993 -- If neither the base type nor the root type is VAX_Native then VAX 6994 -- float is out of the picture, and we can just use the root type. 6995 6996 else 6997 Fat_Type := Rtyp; 6998 6999 if Fat_Type = Standard_Short_Float then 7000 Fat_Pkg := RE_Attr_Short_Float; 7001 7002 elsif Fat_Type = Standard_Float then 7003 Fat_Pkg := RE_Attr_Float; 7004 7005 elsif Fat_Type = Standard_Long_Float then 7006 Fat_Pkg := RE_Attr_Long_Float; 7007 7008 elsif Fat_Type = Standard_Long_Long_Float then 7009 Fat_Pkg := RE_Attr_Long_Long_Float; 7010 7011 -- Universal real (which is its own root type) is treated as being 7012 -- equivalent to Standard.Long_Long_Float, since it is defined to 7013 -- have the same precision as the longest Float type. 7014 7015 elsif Fat_Type = Universal_Real then 7016 Fat_Type := Standard_Long_Long_Float; 7017 Fat_Pkg := RE_Attr_Long_Long_Float; 7018 7019 else 7020 raise Program_Error; 7021 end if; 7022 end if; 7023 end Find_Fat_Info; 7024 7025 ---------------------------- 7026 -- Find_Stream_Subprogram -- 7027 ---------------------------- 7028 7029 function Find_Stream_Subprogram 7030 (Typ : Entity_Id; 7031 Nam : TSS_Name_Type) return Entity_Id 7032 is 7033 Base_Typ : constant Entity_Id := Base_Type (Typ); 7034 Ent : constant Entity_Id := TSS (Typ, Nam); 7035 7036 function Is_Available (Entity : RE_Id) return Boolean; 7037 pragma Inline (Is_Available); 7038 -- Function to check whether the specified run-time call is available 7039 -- in the run time used. In the case of a configurable run time, it 7040 -- is normal that some subprograms are not there. 7041 -- 7042 -- I don't understand this routine at all, why is this not just a 7043 -- call to RTE_Available? And if for some reason we need a different 7044 -- routine with different semantics, why is not in Rtsfind ??? 7045 7046 ------------------ 7047 -- Is_Available -- 7048 ------------------ 7049 7050 function Is_Available (Entity : RE_Id) return Boolean is 7051 begin 7052 -- Assume that the unit will always be available when using a 7053 -- "normal" (not configurable) run time. 7054 7055 return not Configurable_Run_Time_Mode or else RTE_Available (Entity); 7056 end Is_Available; 7057 7058 -- Start of processing for Find_Stream_Subprogram 7059 7060 begin 7061 if Present (Ent) then 7062 return Ent; 7063 end if; 7064 7065 -- Stream attributes for strings are expanded into library calls. The 7066 -- following checks are disabled when the run-time is not available or 7067 -- when compiling predefined types due to bootstrap issues. As a result, 7068 -- the compiler will generate in-place stream routines for string types 7069 -- that appear in GNAT's library, but will generate calls via rtsfind 7070 -- to library routines for user code. 7071 7072 -- ??? For now, disable this code for JVM, since this generates a 7073 -- VerifyError exception at run time on e.g. c330001. 7074 7075 -- This is disabled for AAMP, to avoid creating dependences on files not 7076 -- supported in the AAMP library (such as s-fileio.adb). 7077 7078 -- Note: In the case of using a configurable run time, it is very likely 7079 -- that stream routines for string types are not present (they require 7080 -- file system support). In this case, the specific stream routines for 7081 -- strings are not used, relying on the regular stream mechanism 7082 -- instead. That is why we include the test Is_Available when dealing 7083 -- with these cases. 7084 7085 if VM_Target /= JVM_Target 7086 and then not AAMP_On_Target 7087 and then 7088 not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) 7089 then 7090 -- Storage_Array as defined in package System.Storage_Elements 7091 7092 if Is_RTE (Base_Typ, RE_Storage_Array) then 7093 7094 -- Case of No_Stream_Optimizations restriction active 7095 7096 if Restriction_Active (No_Stream_Optimizations) then 7097 if Nam = TSS_Stream_Input 7098 and then Is_Available (RE_Storage_Array_Input) 7099 then 7100 return RTE (RE_Storage_Array_Input); 7101 7102 elsif Nam = TSS_Stream_Output 7103 and then Is_Available (RE_Storage_Array_Output) 7104 then 7105 return RTE (RE_Storage_Array_Output); 7106 7107 elsif Nam = TSS_Stream_Read 7108 and then Is_Available (RE_Storage_Array_Read) 7109 then 7110 return RTE (RE_Storage_Array_Read); 7111 7112 elsif Nam = TSS_Stream_Write 7113 and then Is_Available (RE_Storage_Array_Write) 7114 then 7115 return RTE (RE_Storage_Array_Write); 7116 7117 elsif Nam /= TSS_Stream_Input and then 7118 Nam /= TSS_Stream_Output and then 7119 Nam /= TSS_Stream_Read and then 7120 Nam /= TSS_Stream_Write 7121 then 7122 raise Program_Error; 7123 end if; 7124 7125 -- Restriction No_Stream_Optimizations is not set, so we can go 7126 -- ahead and optimize using the block IO forms of the routines. 7127 7128 else 7129 if Nam = TSS_Stream_Input 7130 and then Is_Available (RE_Storage_Array_Input_Blk_IO) 7131 then 7132 return RTE (RE_Storage_Array_Input_Blk_IO); 7133 7134 elsif Nam = TSS_Stream_Output 7135 and then Is_Available (RE_Storage_Array_Output_Blk_IO) 7136 then 7137 return RTE (RE_Storage_Array_Output_Blk_IO); 7138 7139 elsif Nam = TSS_Stream_Read 7140 and then Is_Available (RE_Storage_Array_Read_Blk_IO) 7141 then 7142 return RTE (RE_Storage_Array_Read_Blk_IO); 7143 7144 elsif Nam = TSS_Stream_Write 7145 and then Is_Available (RE_Storage_Array_Write_Blk_IO) 7146 then 7147 return RTE (RE_Storage_Array_Write_Blk_IO); 7148 7149 elsif Nam /= TSS_Stream_Input and then 7150 Nam /= TSS_Stream_Output and then 7151 Nam /= TSS_Stream_Read and then 7152 Nam /= TSS_Stream_Write 7153 then 7154 raise Program_Error; 7155 end if; 7156 end if; 7157 7158 -- Stream_Element_Array as defined in package Ada.Streams 7159 7160 elsif Is_RTE (Base_Typ, RE_Stream_Element_Array) then 7161 7162 -- Case of No_Stream_Optimizations restriction active 7163 7164 if Restriction_Active (No_Stream_Optimizations) then 7165 if Nam = TSS_Stream_Input 7166 and then Is_Available (RE_Stream_Element_Array_Input) 7167 then 7168 return RTE (RE_Stream_Element_Array_Input); 7169 7170 elsif Nam = TSS_Stream_Output 7171 and then Is_Available (RE_Stream_Element_Array_Output) 7172 then 7173 return RTE (RE_Stream_Element_Array_Output); 7174 7175 elsif Nam = TSS_Stream_Read 7176 and then Is_Available (RE_Stream_Element_Array_Read) 7177 then 7178 return RTE (RE_Stream_Element_Array_Read); 7179 7180 elsif Nam = TSS_Stream_Write 7181 and then Is_Available (RE_Stream_Element_Array_Write) 7182 then 7183 return RTE (RE_Stream_Element_Array_Write); 7184 7185 elsif Nam /= TSS_Stream_Input and then 7186 Nam /= TSS_Stream_Output and then 7187 Nam /= TSS_Stream_Read and then 7188 Nam /= TSS_Stream_Write 7189 then 7190 raise Program_Error; 7191 end if; 7192 7193 -- Restriction No_Stream_Optimizations is not set, so we can go 7194 -- ahead and optimize using the block IO forms of the routines. 7195 7196 else 7197 if Nam = TSS_Stream_Input 7198 and then Is_Available (RE_Stream_Element_Array_Input_Blk_IO) 7199 then 7200 return RTE (RE_Stream_Element_Array_Input_Blk_IO); 7201 7202 elsif Nam = TSS_Stream_Output 7203 and then Is_Available (RE_Stream_Element_Array_Output_Blk_IO) 7204 then 7205 return RTE (RE_Stream_Element_Array_Output_Blk_IO); 7206 7207 elsif Nam = TSS_Stream_Read 7208 and then Is_Available (RE_Stream_Element_Array_Read_Blk_IO) 7209 then 7210 return RTE (RE_Stream_Element_Array_Read_Blk_IO); 7211 7212 elsif Nam = TSS_Stream_Write 7213 and then Is_Available (RE_Stream_Element_Array_Write_Blk_IO) 7214 then 7215 return RTE (RE_Stream_Element_Array_Write_Blk_IO); 7216 7217 elsif Nam /= TSS_Stream_Input and then 7218 Nam /= TSS_Stream_Output and then 7219 Nam /= TSS_Stream_Read and then 7220 Nam /= TSS_Stream_Write 7221 then 7222 raise Program_Error; 7223 end if; 7224 end if; 7225 7226 -- String as defined in package Ada 7227 7228 elsif Base_Typ = Standard_String then 7229 7230 -- Case of No_Stream_Optimizations restriction active 7231 7232 if Restriction_Active (No_Stream_Optimizations) then 7233 if Nam = TSS_Stream_Input 7234 and then Is_Available (RE_String_Input) 7235 then 7236 return RTE (RE_String_Input); 7237 7238 elsif Nam = TSS_Stream_Output 7239 and then Is_Available (RE_String_Output) 7240 then 7241 return RTE (RE_String_Output); 7242 7243 elsif Nam = TSS_Stream_Read 7244 and then Is_Available (RE_String_Read) 7245 then 7246 return RTE (RE_String_Read); 7247 7248 elsif Nam = TSS_Stream_Write 7249 and then Is_Available (RE_String_Write) 7250 then 7251 return RTE (RE_String_Write); 7252 7253 elsif Nam /= TSS_Stream_Input and then 7254 Nam /= TSS_Stream_Output and then 7255 Nam /= TSS_Stream_Read and then 7256 Nam /= TSS_Stream_Write 7257 then 7258 raise Program_Error; 7259 end if; 7260 7261 -- Restriction No_Stream_Optimizations is not set, so we can go 7262 -- ahead and optimize using the block IO forms of the routines. 7263 7264 else 7265 if Nam = TSS_Stream_Input 7266 and then Is_Available (RE_String_Input_Blk_IO) 7267 then 7268 return RTE (RE_String_Input_Blk_IO); 7269 7270 elsif Nam = TSS_Stream_Output 7271 and then Is_Available (RE_String_Output_Blk_IO) 7272 then 7273 return RTE (RE_String_Output_Blk_IO); 7274 7275 elsif Nam = TSS_Stream_Read 7276 and then Is_Available (RE_String_Read_Blk_IO) 7277 then 7278 return RTE (RE_String_Read_Blk_IO); 7279 7280 elsif Nam = TSS_Stream_Write 7281 and then Is_Available (RE_String_Write_Blk_IO) 7282 then 7283 return RTE (RE_String_Write_Blk_IO); 7284 7285 elsif Nam /= TSS_Stream_Input and then 7286 Nam /= TSS_Stream_Output and then 7287 Nam /= TSS_Stream_Read and then 7288 Nam /= TSS_Stream_Write 7289 then 7290 raise Program_Error; 7291 end if; 7292 end if; 7293 7294 -- Wide_String as defined in package Ada 7295 7296 elsif Base_Typ = Standard_Wide_String then 7297 7298 -- Case of No_Stream_Optimizations restriction active 7299 7300 if Restriction_Active (No_Stream_Optimizations) then 7301 if Nam = TSS_Stream_Input 7302 and then Is_Available (RE_Wide_String_Input) 7303 then 7304 return RTE (RE_Wide_String_Input); 7305 7306 elsif Nam = TSS_Stream_Output 7307 and then Is_Available (RE_Wide_String_Output) 7308 then 7309 return RTE (RE_Wide_String_Output); 7310 7311 elsif Nam = TSS_Stream_Read 7312 and then Is_Available (RE_Wide_String_Read) 7313 then 7314 return RTE (RE_Wide_String_Read); 7315 7316 elsif Nam = TSS_Stream_Write 7317 and then Is_Available (RE_Wide_String_Write) 7318 then 7319 return RTE (RE_Wide_String_Write); 7320 7321 elsif Nam /= TSS_Stream_Input and then 7322 Nam /= TSS_Stream_Output and then 7323 Nam /= TSS_Stream_Read and then 7324 Nam /= TSS_Stream_Write 7325 then 7326 raise Program_Error; 7327 end if; 7328 7329 -- Restriction No_Stream_Optimizations is not set, so we can go 7330 -- ahead and optimize using the block IO forms of the routines. 7331 7332 else 7333 if Nam = TSS_Stream_Input 7334 and then Is_Available (RE_Wide_String_Input_Blk_IO) 7335 then 7336 return RTE (RE_Wide_String_Input_Blk_IO); 7337 7338 elsif Nam = TSS_Stream_Output 7339 and then Is_Available (RE_Wide_String_Output_Blk_IO) 7340 then 7341 return RTE (RE_Wide_String_Output_Blk_IO); 7342 7343 elsif Nam = TSS_Stream_Read 7344 and then Is_Available (RE_Wide_String_Read_Blk_IO) 7345 then 7346 return RTE (RE_Wide_String_Read_Blk_IO); 7347 7348 elsif Nam = TSS_Stream_Write 7349 and then Is_Available (RE_Wide_String_Write_Blk_IO) 7350 then 7351 return RTE (RE_Wide_String_Write_Blk_IO); 7352 7353 elsif Nam /= TSS_Stream_Input and then 7354 Nam /= TSS_Stream_Output and then 7355 Nam /= TSS_Stream_Read and then 7356 Nam /= TSS_Stream_Write 7357 then 7358 raise Program_Error; 7359 end if; 7360 end if; 7361 7362 -- Wide_Wide_String as defined in package Ada 7363 7364 elsif Base_Typ = Standard_Wide_Wide_String then 7365 7366 -- Case of No_Stream_Optimizations restriction active 7367 7368 if Restriction_Active (No_Stream_Optimizations) then 7369 if Nam = TSS_Stream_Input 7370 and then Is_Available (RE_Wide_Wide_String_Input) 7371 then 7372 return RTE (RE_Wide_Wide_String_Input); 7373 7374 elsif Nam = TSS_Stream_Output 7375 and then Is_Available (RE_Wide_Wide_String_Output) 7376 then 7377 return RTE (RE_Wide_Wide_String_Output); 7378 7379 elsif Nam = TSS_Stream_Read 7380 and then Is_Available (RE_Wide_Wide_String_Read) 7381 then 7382 return RTE (RE_Wide_Wide_String_Read); 7383 7384 elsif Nam = TSS_Stream_Write 7385 and then Is_Available (RE_Wide_Wide_String_Write) 7386 then 7387 return RTE (RE_Wide_Wide_String_Write); 7388 7389 elsif Nam /= TSS_Stream_Input and then 7390 Nam /= TSS_Stream_Output and then 7391 Nam /= TSS_Stream_Read and then 7392 Nam /= TSS_Stream_Write 7393 then 7394 raise Program_Error; 7395 end if; 7396 7397 -- Restriction No_Stream_Optimizations is not set, so we can go 7398 -- ahead and optimize using the block IO forms of the routines. 7399 7400 else 7401 if Nam = TSS_Stream_Input 7402 and then Is_Available (RE_Wide_Wide_String_Input_Blk_IO) 7403 then 7404 return RTE (RE_Wide_Wide_String_Input_Blk_IO); 7405 7406 elsif Nam = TSS_Stream_Output 7407 and then Is_Available (RE_Wide_Wide_String_Output_Blk_IO) 7408 then 7409 return RTE (RE_Wide_Wide_String_Output_Blk_IO); 7410 7411 elsif Nam = TSS_Stream_Read 7412 and then Is_Available (RE_Wide_Wide_String_Read_Blk_IO) 7413 then 7414 return RTE (RE_Wide_Wide_String_Read_Blk_IO); 7415 7416 elsif Nam = TSS_Stream_Write 7417 and then Is_Available (RE_Wide_Wide_String_Write_Blk_IO) 7418 then 7419 return RTE (RE_Wide_Wide_String_Write_Blk_IO); 7420 7421 elsif Nam /= TSS_Stream_Input and then 7422 Nam /= TSS_Stream_Output and then 7423 Nam /= TSS_Stream_Read and then 7424 Nam /= TSS_Stream_Write 7425 then 7426 raise Program_Error; 7427 end if; 7428 end if; 7429 end if; 7430 end if; 7431 7432 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then 7433 return Find_Prim_Op (Typ, Nam); 7434 else 7435 return Find_Inherited_TSS (Typ, Nam); 7436 end if; 7437 end Find_Stream_Subprogram; 7438 7439 --------------- 7440 -- Full_Base -- 7441 --------------- 7442 7443 function Full_Base (T : Entity_Id) return Entity_Id is 7444 BT : Entity_Id; 7445 7446 begin 7447 BT := Base_Type (T); 7448 7449 if Is_Private_Type (BT) 7450 and then Present (Full_View (BT)) 7451 then 7452 BT := Full_View (BT); 7453 end if; 7454 7455 return BT; 7456 end Full_Base; 7457 7458 ----------------------- 7459 -- Get_Index_Subtype -- 7460 ----------------------- 7461 7462 function Get_Index_Subtype (N : Node_Id) return Node_Id is 7463 P_Type : Entity_Id := Etype (Prefix (N)); 7464 Indx : Node_Id; 7465 J : Int; 7466 7467 begin 7468 if Is_Access_Type (P_Type) then 7469 P_Type := Designated_Type (P_Type); 7470 end if; 7471 7472 if No (Expressions (N)) then 7473 J := 1; 7474 else 7475 J := UI_To_Int (Expr_Value (First (Expressions (N)))); 7476 end if; 7477 7478 Indx := First_Index (P_Type); 7479 while J > 1 loop 7480 Next_Index (Indx); 7481 J := J - 1; 7482 end loop; 7483 7484 return Etype (Indx); 7485 end Get_Index_Subtype; 7486 7487 ------------------------------- 7488 -- Get_Stream_Convert_Pragma -- 7489 ------------------------------- 7490 7491 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id is 7492 Typ : Entity_Id; 7493 N : Node_Id; 7494 7495 begin 7496 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity 7497 -- that a stream convert pragma for a tagged type is not inherited from 7498 -- its parent. Probably what is wrong here is that it is basically 7499 -- incorrect to consider a stream convert pragma to be a representation 7500 -- pragma at all ??? 7501 7502 N := First_Rep_Item (Implementation_Base_Type (T)); 7503 while Present (N) loop 7504 if Nkind (N) = N_Pragma 7505 and then Pragma_Name (N) = Name_Stream_Convert 7506 then 7507 -- For tagged types this pragma is not inherited, so we 7508 -- must verify that it is defined for the given type and 7509 -- not an ancestor. 7510 7511 Typ := 7512 Entity (Expression (First (Pragma_Argument_Associations (N)))); 7513 7514 if not Is_Tagged_Type (T) 7515 or else T = Typ 7516 or else (Is_Private_Type (Typ) and then T = Full_View (Typ)) 7517 then 7518 return N; 7519 end if; 7520 end if; 7521 7522 Next_Rep_Item (N); 7523 end loop; 7524 7525 return Empty; 7526 end Get_Stream_Convert_Pragma; 7527 7528 --------------------------------- 7529 -- Is_Constrained_Packed_Array -- 7530 --------------------------------- 7531 7532 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean is 7533 Arr : Entity_Id := Typ; 7534 7535 begin 7536 if Is_Access_Type (Arr) then 7537 Arr := Designated_Type (Arr); 7538 end if; 7539 7540 return Is_Array_Type (Arr) 7541 and then Is_Constrained (Arr) 7542 and then Present (Packed_Array_Type (Arr)); 7543 end Is_Constrained_Packed_Array; 7544 7545 ---------------------------------------- 7546 -- Is_Inline_Floating_Point_Attribute -- 7547 ---------------------------------------- 7548 7549 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean is 7550 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); 7551 7552 begin 7553 if Nkind (Parent (N)) /= N_Type_Conversion 7554 or else not Is_Integer_Type (Etype (Parent (N))) 7555 then 7556 return False; 7557 end if; 7558 7559 -- Should also support 'Machine_Rounding and 'Unbiased_Rounding, but 7560 -- required back end support has not been implemented yet ??? 7561 7562 return Id = Attribute_Truncation; 7563 end Is_Inline_Floating_Point_Attribute; 7564 7565end Exp_Attr; 7566