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