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