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