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