1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ P A K D -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Checks; use Checks; 28with Einfo; use Einfo; 29with Errout; use Errout; 30with Exp_Dbug; use Exp_Dbug; 31with Exp_Util; use Exp_Util; 32with Layout; use Layout; 33with Lib.Xref; use Lib.Xref; 34with Namet; use Namet; 35with Nlists; use Nlists; 36with Nmake; use Nmake; 37with Opt; use Opt; 38with Sem; use Sem; 39with Sem_Aux; use Sem_Aux; 40with Sem_Ch3; use Sem_Ch3; 41with Sem_Ch8; use Sem_Ch8; 42with Sem_Ch13; use Sem_Ch13; 43with Sem_Eval; use Sem_Eval; 44with Sem_Res; use Sem_Res; 45with Sem_Util; use Sem_Util; 46with Sinfo; use Sinfo; 47with Snames; use Snames; 48with Stand; use Stand; 49with Targparm; use Targparm; 50with Tbuild; use Tbuild; 51with Ttypes; use Ttypes; 52with Uintp; use Uintp; 53 54package body Exp_Pakd is 55 56 --------------------------- 57 -- Endian Considerations -- 58 --------------------------- 59 60 -- As described in the specification, bit numbering in a packed array 61 -- is consistent with bit numbering in a record representation clause, 62 -- and hence dependent on the endianness of the machine: 63 64 -- For little-endian machines, element zero is at the right hand end 65 -- (low order end) of a bit field. 66 67 -- For big-endian machines, element zero is at the left hand end 68 -- (high order end) of a bit field. 69 70 -- The shifts that are used to right justify a field therefore differ in 71 -- the two cases. For the little-endian case, we can simply use the bit 72 -- number (i.e. the element number * element size) as the count for a right 73 -- shift. For the big-endian case, we have to subtract the shift count from 74 -- an appropriate constant to use in the right shift. We use rotates 75 -- instead of shifts (which is necessary in the store case to preserve 76 -- other fields), and we expect that the backend will be able to change the 77 -- right rotate into a left rotate, avoiding the subtract, if the machine 78 -- architecture provides such an instruction. 79 80 ----------------------- 81 -- Local Subprograms -- 82 ----------------------- 83 84 procedure Compute_Linear_Subscript 85 (Atyp : Entity_Id; 86 N : Node_Id; 87 Subscr : out Node_Id); 88 -- Given a constrained array type Atyp, and an indexed component node N 89 -- referencing an array object of this type, build an expression of type 90 -- Standard.Integer representing the zero-based linear subscript value. 91 -- This expression includes any required range checks. 92 93 procedure Convert_To_PAT_Type (Aexp : Node_Id); 94 -- Given an expression of a packed array type, builds a corresponding 95 -- expression whose type is the implementation type used to represent 96 -- the packed array. Aexp is analyzed and resolved on entry and on exit. 97 98 procedure Get_Base_And_Bit_Offset 99 (N : Node_Id; 100 Base : out Node_Id; 101 Offset : out Node_Id); 102 -- Given a node N for a name which involves a packed array reference, 103 -- return the base object of the reference and build an expression of 104 -- type Standard.Integer representing the zero-based offset in bits 105 -- from Base'Address to the first bit of the reference. 106 107 function Known_Aligned_Enough (Obj : Node_Id; Csiz : Nat) return Boolean; 108 -- There are two versions of the Set routines, the ones used when the 109 -- object is known to be sufficiently well aligned given the number of 110 -- bits, and the ones used when the object is not known to be aligned. 111 -- This routine is used to determine which set to use. Obj is a reference 112 -- to the object, and Csiz is the component size of the packed array. 113 -- True is returned if the alignment of object is known to be sufficient, 114 -- defined as 1 for odd bit sizes, 4 for bit sizes divisible by 4, and 115 -- 2 otherwise. 116 117 function Make_Shift_Left (N : Node_Id; S : Node_Id) return Node_Id; 118 -- Build a left shift node, checking for the case of a shift count of zero 119 120 function Make_Shift_Right (N : Node_Id; S : Node_Id) return Node_Id; 121 -- Build a right shift node, checking for the case of a shift count of zero 122 123 function RJ_Unchecked_Convert_To 124 (Typ : Entity_Id; 125 Expr : Node_Id) return Node_Id; 126 -- The packed array code does unchecked conversions which in some cases 127 -- may involve non-discrete types with differing sizes. The semantics of 128 -- such conversions is potentially endianness dependent, and the effect 129 -- we want here for such a conversion is to do the conversion in size as 130 -- though numeric items are involved, and we extend or truncate on the 131 -- left side. This happens naturally in the little-endian case, but in 132 -- the big endian case we can get left justification, when what we want 133 -- is right justification. This routine does the unchecked conversion in 134 -- a stepwise manner to ensure that it gives the expected result. Hence 135 -- the name (RJ = Right justified). The parameters Typ and Expr are as 136 -- for the case of a normal Unchecked_Convert_To call. 137 138 procedure Setup_Enumeration_Packed_Array_Reference (N : Node_Id); 139 -- This routine is called in the Get and Set case for arrays that are 140 -- packed but not bit-packed, meaning that they have at least one 141 -- subscript that is of an enumeration type with a non-standard 142 -- representation. This routine modifies the given node to properly 143 -- reference the corresponding packed array type. 144 145 procedure Setup_Inline_Packed_Array_Reference 146 (N : Node_Id; 147 Atyp : Entity_Id; 148 Obj : in out Node_Id; 149 Cmask : out Uint; 150 Shift : out Node_Id); 151 -- This procedure performs common processing on the N_Indexed_Component 152 -- parameter given as N, whose prefix is a reference to a packed array. 153 -- This is used for the get and set when the component size is 1, 2, 4, 154 -- or for other component sizes when the packed array type is a modular 155 -- type (i.e. the cases that are handled with inline code). 156 -- 157 -- On entry: 158 -- 159 -- N is the N_Indexed_Component node for the packed array reference 160 -- 161 -- Atyp is the constrained array type (the actual subtype has been 162 -- computed if necessary to obtain the constraints, but this is still 163 -- the original array type, not the Packed_Array_Impl_Type value). 164 -- 165 -- Obj is the object which is to be indexed. It is always of type Atyp. 166 -- 167 -- On return: 168 -- 169 -- Obj is the object containing the desired bit field. It is of type 170 -- Unsigned, Long_Unsigned, or Long_Long_Unsigned, and is either the 171 -- entire value, for the small static case, or the proper selected byte 172 -- from the array in the large or dynamic case. This node is analyzed 173 -- and resolved on return. 174 -- 175 -- Shift is a node representing the shift count to be used in the 176 -- rotate right instruction that positions the field for access. 177 -- This node is analyzed and resolved on return. 178 -- 179 -- Cmask is a mask corresponding to the width of the component field. 180 -- Its value is 2 ** Csize - 1 (e.g. 2#1111# for component size of 4). 181 -- 182 -- Note: in some cases the call to this routine may generate actions 183 -- (for handling multi-use references and the generation of the packed 184 -- array type on the fly). Such actions are inserted into the tree 185 -- directly using Insert_Action. 186 187 function Revert_Storage_Order (N : Node_Id) return Node_Id; 188 -- Perform appropriate justification and byte ordering adjustments for N, 189 -- an element of a packed array type, when both the component type and 190 -- the enclosing packed array type have reverse scalar storage order. 191 -- On little-endian targets, the value is left justified before byte 192 -- swapping. The Etype of the returned expression is an integer type of 193 -- an appropriate power-of-2 size. 194 195 -------------------------- 196 -- Revert_Storage_Order -- 197 -------------------------- 198 199 function Revert_Storage_Order (N : Node_Id) return Node_Id is 200 Loc : constant Source_Ptr := Sloc (N); 201 T : constant Entity_Id := Etype (N); 202 T_Size : constant Uint := RM_Size (T); 203 204 Swap_RE : RE_Id; 205 Swap_F : Entity_Id; 206 Swap_T : Entity_Id; 207 -- Swapping function 208 209 Arg : Node_Id; 210 Adjusted : Node_Id; 211 Shift : Uint; 212 213 begin 214 if T_Size <= 8 then 215 216 -- Array component size is less than a byte: no swapping needed 217 218 Swap_F := Empty; 219 Swap_T := RTE (RE_Unsigned_8); 220 221 else 222 -- Select byte swapping function depending on array component size 223 224 if T_Size <= 16 then 225 Swap_RE := RE_Bswap_16; 226 227 elsif T_Size <= 32 then 228 Swap_RE := RE_Bswap_32; 229 230 else pragma Assert (T_Size <= 64); 231 Swap_RE := RE_Bswap_64; 232 end if; 233 234 Swap_F := RTE (Swap_RE); 235 Swap_T := Etype (Swap_F); 236 237 end if; 238 239 Shift := Esize (Swap_T) - T_Size; 240 241 Arg := RJ_Unchecked_Convert_To (Swap_T, N); 242 243 if not Bytes_Big_Endian and then Shift > Uint_0 then 244 Arg := 245 Make_Op_Shift_Left (Loc, 246 Left_Opnd => Arg, 247 Right_Opnd => Make_Integer_Literal (Loc, Shift)); 248 end if; 249 250 if Present (Swap_F) then 251 Adjusted := 252 Make_Function_Call (Loc, 253 Name => New_Occurrence_Of (Swap_F, Loc), 254 Parameter_Associations => New_List (Arg)); 255 else 256 Adjusted := Arg; 257 end if; 258 259 Set_Etype (Adjusted, Swap_T); 260 return Adjusted; 261 end Revert_Storage_Order; 262 263 ------------------------------ 264 -- Compute_Linear_Subscript -- 265 ------------------------------ 266 267 procedure Compute_Linear_Subscript 268 (Atyp : Entity_Id; 269 N : Node_Id; 270 Subscr : out Node_Id) 271 is 272 Loc : constant Source_Ptr := Sloc (N); 273 Oldsub : Node_Id; 274 Newsub : Node_Id; 275 Indx : Node_Id; 276 Styp : Entity_Id; 277 278 begin 279 Subscr := Empty; 280 281 -- Loop through dimensions 282 283 Indx := First_Index (Atyp); 284 Oldsub := First (Expressions (N)); 285 286 while Present (Indx) loop 287 Styp := Etype (Indx); 288 Newsub := Relocate_Node (Oldsub); 289 290 -- Get expression for the subscript value. First, if Do_Range_Check 291 -- is set on a subscript, then we must do a range check against the 292 -- original bounds (not the bounds of the packed array type). We do 293 -- this by introducing a subtype conversion. 294 295 if Do_Range_Check (Newsub) 296 and then Etype (Newsub) /= Styp 297 then 298 Newsub := Convert_To (Styp, Newsub); 299 end if; 300 301 -- Now evolve the expression for the subscript. First convert 302 -- the subscript to be zero based and of an integer type. 303 304 -- Case of integer type, where we just subtract to get lower bound 305 306 if Is_Integer_Type (Styp) then 307 308 -- If length of integer type is smaller than standard integer, 309 -- then we convert to integer first, then do the subtract 310 311 -- Integer (subscript) - Integer (Styp'First) 312 313 if Esize (Styp) < Esize (Standard_Integer) then 314 Newsub := 315 Make_Op_Subtract (Loc, 316 Left_Opnd => Convert_To (Standard_Integer, Newsub), 317 Right_Opnd => 318 Convert_To (Standard_Integer, 319 Make_Attribute_Reference (Loc, 320 Prefix => New_Occurrence_Of (Styp, Loc), 321 Attribute_Name => Name_First))); 322 323 -- For larger integer types, subtract first, then convert to 324 -- integer, this deals with strange long long integer bounds. 325 326 -- Integer (subscript - Styp'First) 327 328 else 329 Newsub := 330 Convert_To (Standard_Integer, 331 Make_Op_Subtract (Loc, 332 Left_Opnd => Newsub, 333 Right_Opnd => 334 Make_Attribute_Reference (Loc, 335 Prefix => New_Occurrence_Of (Styp, Loc), 336 Attribute_Name => Name_First))); 337 end if; 338 339 -- For the enumeration case, we have to use 'Pos to get the value 340 -- to work with before subtracting the lower bound. 341 342 -- Integer (Styp'Pos (subscr)) - Integer (Styp'Pos (Styp'First)); 343 344 -- This is not quite right for bizarre cases where the size of the 345 -- enumeration type is > Integer'Size bits due to rep clause ??? 346 347 else 348 pragma Assert (Is_Enumeration_Type (Styp)); 349 350 Newsub := 351 Make_Op_Subtract (Loc, 352 Left_Opnd => Convert_To (Standard_Integer, 353 Make_Attribute_Reference (Loc, 354 Prefix => New_Occurrence_Of (Styp, Loc), 355 Attribute_Name => Name_Pos, 356 Expressions => New_List (Newsub))), 357 358 Right_Opnd => 359 Convert_To (Standard_Integer, 360 Make_Attribute_Reference (Loc, 361 Prefix => New_Occurrence_Of (Styp, Loc), 362 Attribute_Name => Name_Pos, 363 Expressions => New_List ( 364 Make_Attribute_Reference (Loc, 365 Prefix => New_Occurrence_Of (Styp, Loc), 366 Attribute_Name => Name_First))))); 367 end if; 368 369 Set_Paren_Count (Newsub, 1); 370 371 -- For the first subscript, we just copy that subscript value 372 373 if No (Subscr) then 374 Subscr := Newsub; 375 376 -- Otherwise, we must multiply what we already have by the current 377 -- stride and then add in the new value to the evolving subscript. 378 379 else 380 Subscr := 381 Make_Op_Add (Loc, 382 Left_Opnd => 383 Make_Op_Multiply (Loc, 384 Left_Opnd => Subscr, 385 Right_Opnd => 386 Make_Attribute_Reference (Loc, 387 Attribute_Name => Name_Range_Length, 388 Prefix => New_Occurrence_Of (Styp, Loc))), 389 Right_Opnd => Newsub); 390 end if; 391 392 -- Move to next subscript 393 394 Next_Index (Indx); 395 Next (Oldsub); 396 end loop; 397 end Compute_Linear_Subscript; 398 399 ------------------------- 400 -- Convert_To_PAT_Type -- 401 ------------------------- 402 403 -- The PAT is always obtained from the actual subtype 404 405 procedure Convert_To_PAT_Type (Aexp : Node_Id) is 406 Act_ST : Entity_Id; 407 408 begin 409 Convert_To_Actual_Subtype (Aexp); 410 Act_ST := Underlying_Type (Etype (Aexp)); 411 Create_Packed_Array_Impl_Type (Act_ST); 412 413 -- Just replace the etype with the packed array type. This works because 414 -- the expression will not be further analyzed, and Gigi considers the 415 -- two types equivalent in any case. 416 417 -- This is not strictly the case ??? If the reference is an actual in 418 -- call, the expansion of the prefix is delayed, and must be reanalyzed, 419 -- see Reset_Packed_Prefix. On the other hand, if the prefix is a simple 420 -- array reference, reanalysis can produce spurious type errors when the 421 -- PAT type is replaced again with the original type of the array. Same 422 -- for the case of a dereference. Ditto for function calls: expansion 423 -- may introduce additional actuals which will trigger errors if call is 424 -- reanalyzed. The following is correct and minimal, but the handling of 425 -- more complex packed expressions in actuals is confused. Probably the 426 -- problem only remains for actuals in calls. 427 428 Set_Etype (Aexp, Packed_Array_Impl_Type (Act_ST)); 429 430 if Is_Entity_Name (Aexp) 431 or else 432 (Nkind (Aexp) = N_Indexed_Component 433 and then Is_Entity_Name (Prefix (Aexp))) 434 or else Nkind_In (Aexp, N_Explicit_Dereference, N_Function_Call) 435 then 436 Set_Analyzed (Aexp); 437 end if; 438 end Convert_To_PAT_Type; 439 440 ----------------------------------- 441 -- Create_Packed_Array_Impl_Type -- 442 ----------------------------------- 443 444 procedure Create_Packed_Array_Impl_Type (Typ : Entity_Id) is 445 Loc : constant Source_Ptr := Sloc (Typ); 446 Ctyp : constant Entity_Id := Component_Type (Typ); 447 Csize : constant Uint := Component_Size (Typ); 448 449 Ancest : Entity_Id; 450 PB_Type : Entity_Id; 451 PASize : Uint; 452 Decl : Node_Id; 453 PAT : Entity_Id; 454 Len_Dim : Node_Id; 455 Len_Expr : Node_Id; 456 Len_Bits : Uint; 457 Bits_U1 : Node_Id; 458 PAT_High : Node_Id; 459 Btyp : Entity_Id; 460 Lit : Node_Id; 461 462 procedure Install_PAT; 463 -- This procedure is called with Decl set to the declaration for the 464 -- packed array type. It creates the type and installs it as required. 465 466 procedure Set_PB_Type; 467 -- Sets PB_Type to Packed_Bytes{1,2,4} as required by the alignment 468 -- requirements (see documentation in the spec of this package). 469 470 ----------------- 471 -- Install_PAT -- 472 ----------------- 473 474 procedure Install_PAT is 475 Pushed_Scope : Boolean := False; 476 477 begin 478 -- We do not want to put the declaration we have created in the tree 479 -- since it is often hard, and sometimes impossible to find a proper 480 -- place for it (the impossible case arises for a packed array type 481 -- with bounds depending on the discriminant, a declaration cannot 482 -- be put inside the record, and the reference to the discriminant 483 -- cannot be outside the record). 484 485 -- The solution is to analyze the declaration while temporarily 486 -- attached to the tree at an appropriate point, and then we install 487 -- the resulting type as an Itype in the packed array type field of 488 -- the original type, so that no explicit declaration is required. 489 490 -- Note: the packed type is created in the scope of its parent type. 491 -- There are at least some cases where the current scope is deeper, 492 -- and so when this is the case, we temporarily reset the scope 493 -- for the definition. This is clearly safe, since the first use 494 -- of the packed array type will be the implicit reference from 495 -- the corresponding unpacked type when it is elaborated. 496 497 if Is_Itype (Typ) then 498 Set_Parent (Decl, Associated_Node_For_Itype (Typ)); 499 else 500 Set_Parent (Decl, Declaration_Node (Typ)); 501 end if; 502 503 if Scope (Typ) /= Current_Scope then 504 Push_Scope (Scope (Typ)); 505 Pushed_Scope := True; 506 end if; 507 508 Set_Is_Itype (PAT, True); 509 Set_Packed_Array_Impl_Type (Typ, PAT); 510 Analyze (Decl, Suppress => All_Checks); 511 512 if Pushed_Scope then 513 Pop_Scope; 514 end if; 515 516 -- Set Esize and RM_Size to the actual size of the packed object 517 -- Do not reset RM_Size if already set, as happens in the case of 518 -- a modular type. 519 520 if Unknown_Esize (PAT) then 521 Set_Esize (PAT, PASize); 522 end if; 523 524 if Unknown_RM_Size (PAT) then 525 Set_RM_Size (PAT, PASize); 526 end if; 527 528 Adjust_Esize_Alignment (PAT); 529 530 -- Set remaining fields of packed array type 531 532 Init_Alignment (PAT); 533 Set_Parent (PAT, Empty); 534 Set_Associated_Node_For_Itype (PAT, Typ); 535 Set_Is_Packed_Array_Impl_Type (PAT, True); 536 Set_Original_Array_Type (PAT, Typ); 537 538 -- Propagate representation aspects 539 540 Set_Is_Atomic (PAT, Is_Atomic (Typ)); 541 Set_Is_Independent (PAT, Is_Independent (Typ)); 542 Set_Is_Volatile (PAT, Is_Volatile (Typ)); 543 Set_Is_Volatile_Full_Access (PAT, Is_Volatile_Full_Access (Typ)); 544 Set_Treat_As_Volatile (PAT, Treat_As_Volatile (Typ)); 545 546 -- For a non-bit-packed array, propagate reverse storage order 547 -- flag from original base type to packed array base type. 548 549 if not Is_Bit_Packed_Array (Typ) then 550 Set_Reverse_Storage_Order 551 (Etype (PAT), Reverse_Storage_Order (Base_Type (Typ))); 552 end if; 553 554 -- We definitely do not want to delay freezing for packed array 555 -- types. This is of particular importance for the itypes that are 556 -- generated for record components depending on discriminants where 557 -- there is no place to put the freeze node. 558 559 Set_Has_Delayed_Freeze (PAT, False); 560 Set_Has_Delayed_Freeze (Etype (PAT), False); 561 562 -- If we did allocate a freeze node, then clear out the reference 563 -- since it is obsolete (should we delete the freeze node???) 564 565 Set_Freeze_Node (PAT, Empty); 566 Set_Freeze_Node (Etype (PAT), Empty); 567 end Install_PAT; 568 569 ----------------- 570 -- Set_PB_Type -- 571 ----------------- 572 573 procedure Set_PB_Type is 574 begin 575 -- If the user has specified an explicit alignment for the 576 -- type or component, take it into account. 577 578 if Csize <= 2 or else Csize = 4 or else Csize mod 2 /= 0 579 or else Alignment (Typ) = 1 580 or else Component_Alignment (Typ) = Calign_Storage_Unit 581 then 582 PB_Type := RTE (RE_Packed_Bytes1); 583 584 elsif Csize mod 4 /= 0 585 or else Alignment (Typ) = 2 586 then 587 PB_Type := RTE (RE_Packed_Bytes2); 588 589 else 590 PB_Type := RTE (RE_Packed_Bytes4); 591 end if; 592 end Set_PB_Type; 593 594 -- Start of processing for Create_Packed_Array_Impl_Type 595 596 begin 597 -- If we already have a packed array type, nothing to do 598 599 if Present (Packed_Array_Impl_Type (Typ)) then 600 return; 601 end if; 602 603 -- If our immediate ancestor subtype is constrained, and it already 604 -- has a packed array type, then just share the same type, since the 605 -- bounds must be the same. If the ancestor is not an array type but 606 -- a private type, as can happen with multiple instantiations, create 607 -- a new packed type, to avoid privacy issues. 608 609 if Ekind (Typ) = E_Array_Subtype then 610 Ancest := Ancestor_Subtype (Typ); 611 612 if Present (Ancest) 613 and then Is_Array_Type (Ancest) 614 and then Is_Constrained (Ancest) 615 and then Present (Packed_Array_Impl_Type (Ancest)) 616 then 617 Set_Packed_Array_Impl_Type (Typ, Packed_Array_Impl_Type (Ancest)); 618 return; 619 end if; 620 end if; 621 622 -- We preset the result type size from the size of the original array 623 -- type, since this size clearly belongs to the packed array type. The 624 -- size of the conceptual unpacked type is always set to unknown. 625 626 PASize := RM_Size (Typ); 627 628 -- Case of an array where at least one index is of an enumeration 629 -- type with a non-standard representation, but the component size 630 -- is not appropriate for bit packing. This is the case where we 631 -- have Is_Packed set (we would never be in this unit otherwise), 632 -- but Is_Bit_Packed_Array is false. 633 634 -- Note that if the component size is appropriate for bit packing, 635 -- then the circuit for the computation of the subscript properly 636 -- deals with the non-standard enumeration type case by taking the 637 -- Pos anyway. 638 639 if not Is_Bit_Packed_Array (Typ) then 640 641 -- Here we build a declaration: 642 643 -- type tttP is array (index1, index2, ...) of component_type 644 645 -- where index1, index2, are the index types. These are the same 646 -- as the index types of the original array, except for the non- 647 -- standard representation enumeration type case, where we have 648 -- two subcases. 649 650 -- For the unconstrained array case, we use 651 652 -- Natural range <> 653 654 -- For the constrained case, we use 655 656 -- Natural range Enum_Type'Pos (Enum_Type'First) .. 657 -- Enum_Type'Pos (Enum_Type'Last); 658 659 -- Note that tttP is created even if no index subtype is a non 660 -- standard enumeration, because we still need to remove padding 661 -- normally inserted for component alignment. 662 663 PAT := 664 Make_Defining_Identifier (Loc, 665 Chars => New_External_Name (Chars (Typ), 'P')); 666 667 Set_Packed_Array_Impl_Type (Typ, PAT); 668 669 declare 670 Indexes : constant List_Id := New_List; 671 Indx : Node_Id; 672 Indx_Typ : Entity_Id; 673 Enum_Case : Boolean; 674 Typedef : Node_Id; 675 676 begin 677 Indx := First_Index (Typ); 678 679 while Present (Indx) loop 680 Indx_Typ := Etype (Indx); 681 682 Enum_Case := Is_Enumeration_Type (Indx_Typ) 683 and then Has_Non_Standard_Rep (Indx_Typ); 684 685 -- Unconstrained case 686 687 if not Is_Constrained (Typ) then 688 if Enum_Case then 689 Indx_Typ := Standard_Natural; 690 end if; 691 692 Append_To (Indexes, New_Occurrence_Of (Indx_Typ, Loc)); 693 694 -- Constrained case 695 696 else 697 if not Enum_Case then 698 Append_To (Indexes, New_Occurrence_Of (Indx_Typ, Loc)); 699 700 else 701 Append_To (Indexes, 702 Make_Subtype_Indication (Loc, 703 Subtype_Mark => 704 New_Occurrence_Of (Standard_Natural, Loc), 705 Constraint => 706 Make_Range_Constraint (Loc, 707 Range_Expression => 708 Make_Range (Loc, 709 Low_Bound => 710 Make_Attribute_Reference (Loc, 711 Prefix => 712 New_Occurrence_Of (Indx_Typ, Loc), 713 Attribute_Name => Name_Pos, 714 Expressions => New_List ( 715 Make_Attribute_Reference (Loc, 716 Prefix => 717 New_Occurrence_Of (Indx_Typ, Loc), 718 Attribute_Name => Name_First))), 719 720 High_Bound => 721 Make_Attribute_Reference (Loc, 722 Prefix => 723 New_Occurrence_Of (Indx_Typ, Loc), 724 Attribute_Name => Name_Pos, 725 Expressions => New_List ( 726 Make_Attribute_Reference (Loc, 727 Prefix => 728 New_Occurrence_Of (Indx_Typ, Loc), 729 Attribute_Name => Name_Last))))))); 730 731 end if; 732 end if; 733 734 Next_Index (Indx); 735 end loop; 736 737 if not Is_Constrained (Typ) then 738 Typedef := 739 Make_Unconstrained_Array_Definition (Loc, 740 Subtype_Marks => Indexes, 741 Component_Definition => 742 Make_Component_Definition (Loc, 743 Aliased_Present => False, 744 Subtype_Indication => 745 New_Occurrence_Of (Ctyp, Loc))); 746 747 else 748 Typedef := 749 Make_Constrained_Array_Definition (Loc, 750 Discrete_Subtype_Definitions => Indexes, 751 Component_Definition => 752 Make_Component_Definition (Loc, 753 Aliased_Present => False, 754 Subtype_Indication => 755 New_Occurrence_Of (Ctyp, Loc))); 756 end if; 757 758 Decl := 759 Make_Full_Type_Declaration (Loc, 760 Defining_Identifier => PAT, 761 Type_Definition => Typedef); 762 end; 763 764 -- Set type as packed array type and install it 765 766 Set_Is_Packed_Array_Impl_Type (PAT); 767 Install_PAT; 768 return; 769 770 -- Case of bit-packing required for unconstrained array. We create 771 -- a subtype that is equivalent to use Packed_Bytes{1,2,4} as needed. 772 773 elsif not Is_Constrained (Typ) then 774 775 -- When generating standard DWARF (i.e when GNAT_Encodings is 776 -- DWARF_GNAT_Encodings_Minimal), the ___XP suffix will be stripped 777 -- by the back-end but generate it anyway to ease compiler debugging. 778 -- This will help to distinguish implementation types from original 779 -- packed arrays. 780 781 PAT := 782 Make_Defining_Identifier (Loc, 783 Chars => Make_Packed_Array_Impl_Type_Name (Typ, Csize)); 784 785 Set_Packed_Array_Impl_Type (Typ, PAT); 786 Set_PB_Type; 787 788 Decl := 789 Make_Subtype_Declaration (Loc, 790 Defining_Identifier => PAT, 791 Subtype_Indication => New_Occurrence_Of (PB_Type, Loc)); 792 Install_PAT; 793 return; 794 795 -- Remaining code is for the case of bit-packing for constrained array 796 797 -- The name of the packed array subtype is 798 799 -- ttt___XPsss 800 801 -- where sss is the component size in bits and ttt is the name of 802 -- the parent packed type. 803 804 else 805 PAT := 806 Make_Defining_Identifier (Loc, 807 Chars => Make_Packed_Array_Impl_Type_Name (Typ, Csize)); 808 809 Set_Packed_Array_Impl_Type (Typ, PAT); 810 811 -- Build an expression for the length of the array in bits. 812 -- This is the product of the length of each of the dimensions 813 814 declare 815 J : Nat := 1; 816 817 begin 818 Len_Expr := Empty; -- suppress junk warning 819 820 loop 821 Len_Dim := 822 Make_Attribute_Reference (Loc, 823 Attribute_Name => Name_Length, 824 Prefix => New_Occurrence_Of (Typ, Loc), 825 Expressions => New_List ( 826 Make_Integer_Literal (Loc, J))); 827 828 if J = 1 then 829 Len_Expr := Len_Dim; 830 831 else 832 Len_Expr := 833 Make_Op_Multiply (Loc, 834 Left_Opnd => Len_Expr, 835 Right_Opnd => Len_Dim); 836 end if; 837 838 J := J + 1; 839 exit when J > Number_Dimensions (Typ); 840 end loop; 841 end; 842 843 -- Temporarily attach the length expression to the tree and analyze 844 -- and resolve it, so that we can test its value. We assume that the 845 -- total length fits in type Integer. This expression may involve 846 -- discriminants, so we treat it as a default/per-object expression. 847 848 Set_Parent (Len_Expr, Typ); 849 Preanalyze_Spec_Expression (Len_Expr, Standard_Long_Long_Integer); 850 851 -- Use a modular type if possible. We can do this if we have 852 -- static bounds, and the length is small enough, and the length 853 -- is not zero. We exclude the zero length case because the size 854 -- of things is always at least one, and the zero length object 855 -- would have an anomalous size. 856 857 if Compile_Time_Known_Value (Len_Expr) then 858 Len_Bits := Expr_Value (Len_Expr) * Csize; 859 860 -- Check for size known to be too large 861 862 if Len_Bits > 863 Uint_2 ** (Standard_Integer_Size - 1) * System_Storage_Unit 864 then 865 if System_Storage_Unit = 8 then 866 Error_Msg_N 867 ("packed array size cannot exceed " & 868 "Integer''Last bytes", Typ); 869 else 870 Error_Msg_N 871 ("packed array size cannot exceed " & 872 "Integer''Last storage units", Typ); 873 end if; 874 875 -- Reset length to arbitrary not too high value to continue 876 877 Len_Expr := Make_Integer_Literal (Loc, 65535); 878 Analyze_And_Resolve (Len_Expr, Standard_Long_Long_Integer); 879 end if; 880 881 -- We normally consider small enough to mean no larger than the 882 -- value of System_Max_Binary_Modulus_Power, checking that in the 883 -- case of values longer than word size, we have long shifts. 884 885 if Len_Bits > 0 886 and then 887 (Len_Bits <= System_Word_Size 888 or else (Len_Bits <= System_Max_Binary_Modulus_Power 889 and then Support_Long_Shifts_On_Target)) 890 then 891 -- We can use the modular type, it has the form: 892 893 -- subtype tttPn is btyp 894 -- range 0 .. 2 ** ((Typ'Length (1) 895 -- * ... * Typ'Length (n)) * Csize) - 1; 896 897 -- The bounds are statically known, and btyp is one of the 898 -- unsigned types, depending on the length. 899 900 if Len_Bits <= Standard_Short_Short_Integer_Size then 901 Btyp := RTE (RE_Short_Short_Unsigned); 902 903 elsif Len_Bits <= Standard_Short_Integer_Size then 904 Btyp := RTE (RE_Short_Unsigned); 905 906 elsif Len_Bits <= Standard_Integer_Size then 907 Btyp := RTE (RE_Unsigned); 908 909 elsif Len_Bits <= Standard_Long_Integer_Size then 910 Btyp := RTE (RE_Long_Unsigned); 911 912 else 913 Btyp := RTE (RE_Long_Long_Unsigned); 914 end if; 915 916 Lit := Make_Integer_Literal (Loc, 2 ** Len_Bits - 1); 917 Set_Print_In_Hex (Lit); 918 919 Decl := 920 Make_Subtype_Declaration (Loc, 921 Defining_Identifier => PAT, 922 Subtype_Indication => 923 Make_Subtype_Indication (Loc, 924 Subtype_Mark => New_Occurrence_Of (Btyp, Loc), 925 926 Constraint => 927 Make_Range_Constraint (Loc, 928 Range_Expression => 929 Make_Range (Loc, 930 Low_Bound => 931 Make_Integer_Literal (Loc, 0), 932 High_Bound => Lit)))); 933 934 if PASize = Uint_0 then 935 PASize := Len_Bits; 936 end if; 937 938 Install_PAT; 939 940 -- Propagate a given alignment to the modular type. This can 941 -- cause it to be under-aligned, but that's OK. 942 943 if Present (Alignment_Clause (Typ)) then 944 Set_Alignment (PAT, Alignment (Typ)); 945 end if; 946 947 return; 948 end if; 949 end if; 950 951 -- Could not use a modular type, for all other cases, we build 952 -- a packed array subtype: 953 954 -- subtype tttPn is 955 -- System.Packed_Bytes{1,2,4} (0 .. (Bits + 7) / 8 - 1); 956 957 -- Bits is the length of the array in bits 958 959 Set_PB_Type; 960 961 Bits_U1 := 962 Make_Op_Add (Loc, 963 Left_Opnd => 964 Make_Op_Multiply (Loc, 965 Left_Opnd => 966 Make_Integer_Literal (Loc, Csize), 967 Right_Opnd => Len_Expr), 968 969 Right_Opnd => 970 Make_Integer_Literal (Loc, 7)); 971 972 Set_Paren_Count (Bits_U1, 1); 973 974 PAT_High := 975 Make_Op_Subtract (Loc, 976 Left_Opnd => 977 Make_Op_Divide (Loc, 978 Left_Opnd => Bits_U1, 979 Right_Opnd => Make_Integer_Literal (Loc, 8)), 980 Right_Opnd => Make_Integer_Literal (Loc, 1)); 981 982 Decl := 983 Make_Subtype_Declaration (Loc, 984 Defining_Identifier => PAT, 985 Subtype_Indication => 986 Make_Subtype_Indication (Loc, 987 Subtype_Mark => New_Occurrence_Of (PB_Type, Loc), 988 Constraint => 989 Make_Index_Or_Discriminant_Constraint (Loc, 990 Constraints => New_List ( 991 Make_Range (Loc, 992 Low_Bound => 993 Make_Integer_Literal (Loc, 0), 994 High_Bound => 995 Convert_To (Standard_Integer, PAT_High)))))); 996 997 Install_PAT; 998 999 -- Currently the code in this unit requires that packed arrays 1000 -- represented by non-modular arrays of bytes be on a byte 1001 -- boundary for bit sizes handled by System.Pack_nn units. 1002 -- That's because these units assume the array being accessed 1003 -- starts on a byte boundary. 1004 1005 if Get_Id (UI_To_Int (Csize)) /= RE_Null then 1006 Set_Must_Be_On_Byte_Boundary (Typ); 1007 end if; 1008 end if; 1009 end Create_Packed_Array_Impl_Type; 1010 1011 ----------------------------------- 1012 -- Expand_Bit_Packed_Element_Set -- 1013 ----------------------------------- 1014 1015 procedure Expand_Bit_Packed_Element_Set (N : Node_Id) is 1016 Loc : constant Source_Ptr := Sloc (N); 1017 Lhs : constant Node_Id := Name (N); 1018 1019 Ass_OK : constant Boolean := Assignment_OK (Lhs); 1020 -- Used to preserve assignment OK status when assignment is rewritten 1021 1022 Rhs : Node_Id := Expression (N); 1023 -- Initially Rhs is the right hand side value, it will be replaced 1024 -- later by an appropriate unchecked conversion for the assignment. 1025 1026 Obj : Node_Id; 1027 Atyp : Entity_Id; 1028 PAT : Entity_Id; 1029 Ctyp : Entity_Id; 1030 Csiz : Int; 1031 Cmask : Uint; 1032 1033 Shift : Node_Id; 1034 -- The expression for the shift value that is required 1035 1036 Shift_Used : Boolean := False; 1037 -- Set True if Shift has been used in the generated code at least once, 1038 -- so that it must be duplicated if used again. 1039 1040 New_Lhs : Node_Id; 1041 New_Rhs : Node_Id; 1042 1043 Rhs_Val_Known : Boolean; 1044 Rhs_Val : Uint; 1045 -- If the value of the right hand side as an integer constant is 1046 -- known at compile time, Rhs_Val_Known is set True, and Rhs_Val 1047 -- contains the value. Otherwise Rhs_Val_Known is set False, and 1048 -- the Rhs_Val is undefined. 1049 1050 function Get_Shift return Node_Id; 1051 -- Function used to get the value of Shift, making sure that it 1052 -- gets duplicated if the function is called more than once. 1053 1054 --------------- 1055 -- Get_Shift -- 1056 --------------- 1057 1058 function Get_Shift return Node_Id is 1059 begin 1060 -- If we used the shift value already, then duplicate it. We 1061 -- set a temporary parent in case actions have to be inserted. 1062 1063 if Shift_Used then 1064 Set_Parent (Shift, N); 1065 return Duplicate_Subexpr_No_Checks (Shift); 1066 1067 -- If first time, use Shift unchanged, and set flag for first use 1068 1069 else 1070 Shift_Used := True; 1071 return Shift; 1072 end if; 1073 end Get_Shift; 1074 1075 -- Start of processing for Expand_Bit_Packed_Element_Set 1076 1077 begin 1078 pragma Assert (Is_Bit_Packed_Array (Etype (Prefix (Lhs)))); 1079 1080 Obj := Relocate_Node (Prefix (Lhs)); 1081 Convert_To_Actual_Subtype (Obj); 1082 Atyp := Etype (Obj); 1083 PAT := Packed_Array_Impl_Type (Atyp); 1084 Ctyp := Component_Type (Atyp); 1085 Csiz := UI_To_Int (Component_Size (Atyp)); 1086 1087 -- We remove side effects, in case the rhs modifies the lhs, because we 1088 -- are about to transform the rhs into an expression that first READS 1089 -- the lhs, so we can do the necessary shifting and masking. Example: 1090 -- "X(2) := F(...);" where F modifies X(3). Otherwise, the side effect 1091 -- will be lost. 1092 1093 Remove_Side_Effects (Rhs); 1094 1095 -- We convert the right hand side to the proper subtype to ensure 1096 -- that an appropriate range check is made (since the normal range 1097 -- check from assignment will be lost in the transformations). This 1098 -- conversion is analyzed immediately so that subsequent processing 1099 -- can work with an analyzed Rhs (and e.g. look at its Etype) 1100 1101 -- If the right-hand side is a string literal, create a temporary for 1102 -- it, constant-folding is not ready to wrap the bit representation 1103 -- of a string literal. 1104 1105 if Nkind (Rhs) = N_String_Literal then 1106 declare 1107 Decl : Node_Id; 1108 begin 1109 Decl := 1110 Make_Object_Declaration (Loc, 1111 Defining_Identifier => Make_Temporary (Loc, 'T', Rhs), 1112 Object_Definition => New_Occurrence_Of (Ctyp, Loc), 1113 Expression => New_Copy_Tree (Rhs)); 1114 1115 Insert_Actions (N, New_List (Decl)); 1116 Rhs := New_Occurrence_Of (Defining_Identifier (Decl), Loc); 1117 end; 1118 end if; 1119 1120 Rhs := Convert_To (Ctyp, Rhs); 1121 Set_Parent (Rhs, N); 1122 1123 -- If we are building the initialization procedure for a packed array, 1124 -- and Initialize_Scalars is enabled, each component assignment is an 1125 -- out-of-range value by design. Compile this value without checks, 1126 -- because a call to the array init_proc must not raise an exception. 1127 1128 -- Condition is not consistent with description above, Within_Init_Proc 1129 -- is True also when we are building the IP for a record or protected 1130 -- type that has a packed array component??? 1131 1132 if Within_Init_Proc 1133 and then Initialize_Scalars 1134 then 1135 Analyze_And_Resolve (Rhs, Ctyp, Suppress => All_Checks); 1136 else 1137 Analyze_And_Resolve (Rhs, Ctyp); 1138 end if; 1139 1140 -- For the AAMP target, indexing of certain packed array is passed 1141 -- through to the back end without expansion, because the expansion 1142 -- results in very inefficient code on that target. This allows the 1143 -- GNAAMP back end to generate specialized macros that support more 1144 -- efficient indexing of packed arrays with components having sizes 1145 -- that are small powers of two. 1146 1147 if AAMP_On_Target 1148 and then (Csiz = 1 or else Csiz = 2 or else Csiz = 4) 1149 then 1150 return; 1151 end if; 1152 1153 -- Case of component size 1,2,4 or any component size for the modular 1154 -- case. These are the cases for which we can inline the code. 1155 1156 if Csiz = 1 or else Csiz = 2 or else Csiz = 4 1157 or else (Present (PAT) and then Is_Modular_Integer_Type (PAT)) 1158 then 1159 Setup_Inline_Packed_Array_Reference (Lhs, Atyp, Obj, Cmask, Shift); 1160 1161 -- The statement to be generated is: 1162 1163 -- Obj := atyp!((Obj and Mask1) or (shift_left (rhs, Shift))) 1164 1165 -- or in the case of a freestanding Reverse_Storage_Order object, 1166 1167 -- Obj := Swap (atyp!((Swap (Obj) and Mask1) 1168 -- or (shift_left (rhs, Shift)))) 1169 1170 -- where Mask1 is obtained by shifting Cmask left Shift bits 1171 -- and then complementing the result. 1172 1173 -- the "and Mask1" is omitted if rhs is constant and all 1 bits 1174 1175 -- the "or ..." is omitted if rhs is constant and all 0 bits 1176 1177 -- rhs is converted to the appropriate type 1178 1179 -- The result is converted back to the array type, since 1180 -- otherwise we lose knowledge of the packed nature. 1181 1182 -- Determine if right side is all 0 bits or all 1 bits 1183 1184 if Compile_Time_Known_Value (Rhs) then 1185 Rhs_Val := Expr_Rep_Value (Rhs); 1186 Rhs_Val_Known := True; 1187 1188 -- The following test catches the case of an unchecked conversion of 1189 -- an integer literal. This results from optimizing aggregates of 1190 -- packed types. 1191 1192 elsif Nkind (Rhs) = N_Unchecked_Type_Conversion 1193 and then Compile_Time_Known_Value (Expression (Rhs)) 1194 then 1195 Rhs_Val := Expr_Rep_Value (Expression (Rhs)); 1196 Rhs_Val_Known := True; 1197 1198 else 1199 Rhs_Val := No_Uint; 1200 Rhs_Val_Known := False; 1201 end if; 1202 1203 -- Some special checks for the case where the right hand value is 1204 -- known at compile time. Basically we have to take care of the 1205 -- implicit conversion to the subtype of the component object. 1206 1207 if Rhs_Val_Known then 1208 1209 -- If we have a biased component type then we must manually do the 1210 -- biasing, since we are taking responsibility in this case for 1211 -- constructing the exact bit pattern to be used. 1212 1213 if Has_Biased_Representation (Ctyp) then 1214 Rhs_Val := Rhs_Val - Expr_Rep_Value (Type_Low_Bound (Ctyp)); 1215 end if; 1216 1217 -- For a negative value, we manually convert the two's complement 1218 -- value to a corresponding unsigned value, so that the proper 1219 -- field width is maintained. If we did not do this, we would 1220 -- get too many leading sign bits later on. 1221 1222 if Rhs_Val < 0 then 1223 Rhs_Val := 2 ** UI_From_Int (Csiz) + Rhs_Val; 1224 end if; 1225 end if; 1226 1227 -- Now create copies removing side effects. Note that in some complex 1228 -- cases, this may cause the fact that we have already set a packed 1229 -- array type on Obj to get lost. So we save the type of Obj, and 1230 -- make sure it is reset properly. 1231 1232 New_Lhs := Duplicate_Subexpr (Obj, Name_Req => True); 1233 New_Rhs := Duplicate_Subexpr_No_Checks (Obj); 1234 1235 -- First we deal with the "and" 1236 1237 if not Rhs_Val_Known or else Rhs_Val /= Cmask then 1238 declare 1239 Mask1 : Node_Id; 1240 Lit : Node_Id; 1241 1242 begin 1243 if Compile_Time_Known_Value (Shift) then 1244 Mask1 := 1245 Make_Integer_Literal (Loc, 1246 Modulus (Etype (Obj)) - 1 - 1247 (Cmask * (2 ** Expr_Value (Get_Shift)))); 1248 Set_Print_In_Hex (Mask1); 1249 1250 else 1251 Lit := Make_Integer_Literal (Loc, Cmask); 1252 Set_Print_In_Hex (Lit); 1253 Mask1 := 1254 Make_Op_Not (Loc, 1255 Right_Opnd => Make_Shift_Left (Lit, Get_Shift)); 1256 end if; 1257 1258 New_Rhs := 1259 Make_Op_And (Loc, 1260 Left_Opnd => New_Rhs, 1261 Right_Opnd => Mask1); 1262 end; 1263 end if; 1264 1265 -- Then deal with the "or" 1266 1267 if not Rhs_Val_Known or else Rhs_Val /= 0 then 1268 declare 1269 Or_Rhs : Node_Id; 1270 1271 procedure Fixup_Rhs; 1272 -- Adjust Rhs by bias if biased representation for components 1273 -- or remove extraneous high order sign bits if signed. 1274 1275 procedure Fixup_Rhs is 1276 Etyp : constant Entity_Id := Etype (Rhs); 1277 1278 begin 1279 -- For biased case, do the required biasing by simply 1280 -- converting to the biased subtype (the conversion 1281 -- will generate the required bias). 1282 1283 if Has_Biased_Representation (Ctyp) then 1284 Rhs := Convert_To (Ctyp, Rhs); 1285 1286 -- For a signed integer type that is not biased, generate 1287 -- a conversion to unsigned to strip high order sign bits. 1288 1289 elsif Is_Signed_Integer_Type (Ctyp) then 1290 Rhs := Unchecked_Convert_To (RTE (Bits_Id (Csiz)), Rhs); 1291 end if; 1292 1293 -- Set Etype, since it can be referenced before the node is 1294 -- completely analyzed. 1295 1296 Set_Etype (Rhs, Etyp); 1297 1298 -- We now need to do an unchecked conversion of the 1299 -- result to the target type, but it is important that 1300 -- this conversion be a right justified conversion and 1301 -- not a left justified conversion. 1302 1303 Rhs := RJ_Unchecked_Convert_To (Etype (Obj), Rhs); 1304 end Fixup_Rhs; 1305 1306 begin 1307 if Rhs_Val_Known 1308 and then Compile_Time_Known_Value (Get_Shift) 1309 then 1310 Or_Rhs := 1311 Make_Integer_Literal (Loc, 1312 Rhs_Val * (2 ** Expr_Value (Get_Shift))); 1313 Set_Print_In_Hex (Or_Rhs); 1314 1315 else 1316 -- We have to convert the right hand side to Etype (Obj). 1317 -- A special case arises if what we have now is a Val 1318 -- attribute reference whose expression type is Etype (Obj). 1319 -- This happens for assignments of fields from the same 1320 -- array. In this case we get the required right hand side 1321 -- by simply removing the inner attribute reference. 1322 1323 if Nkind (Rhs) = N_Attribute_Reference 1324 and then Attribute_Name (Rhs) = Name_Val 1325 and then Etype (First (Expressions (Rhs))) = Etype (Obj) 1326 then 1327 Rhs := Relocate_Node (First (Expressions (Rhs))); 1328 Fixup_Rhs; 1329 1330 -- If the value of the right hand side is a known integer 1331 -- value, then just replace it by an untyped constant, 1332 -- which will be properly retyped when we analyze and 1333 -- resolve the expression. 1334 1335 elsif Rhs_Val_Known then 1336 1337 -- Note that Rhs_Val has already been normalized to 1338 -- be an unsigned value with the proper number of bits. 1339 1340 Rhs := Make_Integer_Literal (Loc, Rhs_Val); 1341 1342 -- Otherwise we need an unchecked conversion 1343 1344 else 1345 Fixup_Rhs; 1346 end if; 1347 1348 Or_Rhs := Make_Shift_Left (Rhs, Get_Shift); 1349 end if; 1350 1351 if Nkind (New_Rhs) = N_Op_And then 1352 Set_Paren_Count (New_Rhs, 1); 1353 Set_Etype (New_Rhs, Etype (Left_Opnd (New_Rhs))); 1354 end if; 1355 1356 New_Rhs := 1357 Make_Op_Or (Loc, 1358 Left_Opnd => New_Rhs, 1359 Right_Opnd => Or_Rhs); 1360 end; 1361 end if; 1362 1363 -- Now do the rewrite 1364 1365 Rewrite (N, 1366 Make_Assignment_Statement (Loc, 1367 Name => New_Lhs, 1368 Expression => 1369 Unchecked_Convert_To (Etype (New_Lhs), New_Rhs))); 1370 Set_Assignment_OK (Name (N), Ass_OK); 1371 1372 -- All other component sizes for non-modular case 1373 1374 else 1375 -- We generate 1376 1377 -- Set_nn (Arr'address, Subscr, Bits_nn!(Rhs)) 1378 1379 -- where Subscr is the computed linear subscript 1380 1381 declare 1382 Bits_nn : constant Entity_Id := RTE (Bits_Id (Csiz)); 1383 Set_nn : Entity_Id; 1384 Subscr : Node_Id; 1385 Atyp : Entity_Id; 1386 Rev_SSO : Node_Id; 1387 1388 begin 1389 if No (Bits_nn) then 1390 1391 -- Error, most likely High_Integrity_Mode restriction 1392 1393 return; 1394 end if; 1395 1396 -- Acquire proper Set entity. We use the aligned or unaligned 1397 -- case as appropriate. 1398 1399 if Known_Aligned_Enough (Obj, Csiz) then 1400 Set_nn := RTE (Set_Id (Csiz)); 1401 else 1402 Set_nn := RTE (SetU_Id (Csiz)); 1403 end if; 1404 1405 -- Now generate the set reference 1406 1407 Obj := Relocate_Node (Prefix (Lhs)); 1408 Convert_To_Actual_Subtype (Obj); 1409 Atyp := Etype (Obj); 1410 Compute_Linear_Subscript (Atyp, Lhs, Subscr); 1411 1412 -- Set indication of whether the packed array has reverse SSO 1413 1414 Rev_SSO := 1415 New_Occurrence_Of 1416 (Boolean_Literals (Reverse_Storage_Order (Atyp)), Loc); 1417 1418 -- Below we must make the assumption that Obj is 1419 -- at least byte aligned, since otherwise its address 1420 -- cannot be taken. The assumption holds since the 1421 -- only arrays that can be misaligned are small packed 1422 -- arrays which are implemented as a modular type, and 1423 -- that is not the case here. 1424 1425 Rewrite (N, 1426 Make_Procedure_Call_Statement (Loc, 1427 Name => New_Occurrence_Of (Set_nn, Loc), 1428 Parameter_Associations => New_List ( 1429 Make_Attribute_Reference (Loc, 1430 Prefix => Obj, 1431 Attribute_Name => Name_Address), 1432 Subscr, 1433 Unchecked_Convert_To (Bits_nn, Convert_To (Ctyp, Rhs)), 1434 Rev_SSO))); 1435 1436 end; 1437 end if; 1438 1439 Analyze (N, Suppress => All_Checks); 1440 end Expand_Bit_Packed_Element_Set; 1441 1442 ------------------------------------- 1443 -- Expand_Packed_Address_Reference -- 1444 ------------------------------------- 1445 1446 procedure Expand_Packed_Address_Reference (N : Node_Id) is 1447 Loc : constant Source_Ptr := Sloc (N); 1448 Base : Node_Id; 1449 Offset : Node_Id; 1450 1451 begin 1452 -- We build an expression that has the form 1453 1454 -- outer_object'Address 1455 -- + (linear-subscript * component_size for each array reference 1456 -- + field'Bit_Position for each record field 1457 -- + ... 1458 -- + ...) / Storage_Unit; 1459 1460 Get_Base_And_Bit_Offset (Prefix (N), Base, Offset); 1461 1462 Rewrite (N, 1463 Unchecked_Convert_To (RTE (RE_Address), 1464 Make_Op_Add (Loc, 1465 Left_Opnd => 1466 Unchecked_Convert_To (RTE (RE_Integer_Address), 1467 Make_Attribute_Reference (Loc, 1468 Prefix => Base, 1469 Attribute_Name => Name_Address)), 1470 1471 Right_Opnd => 1472 Unchecked_Convert_To (RTE (RE_Integer_Address), 1473 Make_Op_Divide (Loc, 1474 Left_Opnd => Offset, 1475 Right_Opnd => 1476 Make_Integer_Literal (Loc, System_Storage_Unit)))))); 1477 1478 Analyze_And_Resolve (N, RTE (RE_Address)); 1479 end Expand_Packed_Address_Reference; 1480 1481 --------------------------------- 1482 -- Expand_Packed_Bit_Reference -- 1483 --------------------------------- 1484 1485 procedure Expand_Packed_Bit_Reference (N : Node_Id) is 1486 Loc : constant Source_Ptr := Sloc (N); 1487 Base : Node_Id; 1488 Offset : Node_Id; 1489 1490 begin 1491 -- We build an expression that has the form 1492 1493 -- (linear-subscript * component_size for each array reference 1494 -- + field'Bit_Position for each record field 1495 -- + ... 1496 -- + ...) mod Storage_Unit; 1497 1498 Get_Base_And_Bit_Offset (Prefix (N), Base, Offset); 1499 1500 Rewrite (N, 1501 Unchecked_Convert_To (Universal_Integer, 1502 Make_Op_Mod (Loc, 1503 Left_Opnd => Offset, 1504 Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit)))); 1505 1506 Analyze_And_Resolve (N, Universal_Integer); 1507 end Expand_Packed_Bit_Reference; 1508 1509 ------------------------------------ 1510 -- Expand_Packed_Boolean_Operator -- 1511 ------------------------------------ 1512 1513 -- This routine expands "a op b" for the packed cases 1514 1515 procedure Expand_Packed_Boolean_Operator (N : Node_Id) is 1516 Loc : constant Source_Ptr := Sloc (N); 1517 Typ : constant Entity_Id := Etype (N); 1518 L : constant Node_Id := Relocate_Node (Left_Opnd (N)); 1519 R : constant Node_Id := Relocate_Node (Right_Opnd (N)); 1520 1521 Ltyp : Entity_Id; 1522 Rtyp : Entity_Id; 1523 PAT : Entity_Id; 1524 1525 begin 1526 Convert_To_Actual_Subtype (L); 1527 Convert_To_Actual_Subtype (R); 1528 1529 Ensure_Defined (Etype (L), N); 1530 Ensure_Defined (Etype (R), N); 1531 1532 Apply_Length_Check (R, Etype (L)); 1533 1534 Ltyp := Etype (L); 1535 Rtyp := Etype (R); 1536 1537 -- Deal with silly case of XOR where the subcomponent has a range 1538 -- True .. True where an exception must be raised. 1539 1540 if Nkind (N) = N_Op_Xor then 1541 Silly_Boolean_Array_Xor_Test (N, Rtyp); 1542 end if; 1543 1544 -- Now that that silliness is taken care of, get packed array type 1545 1546 Convert_To_PAT_Type (L); 1547 Convert_To_PAT_Type (R); 1548 1549 PAT := Etype (L); 1550 1551 -- For the modular case, we expand a op b into 1552 1553 -- rtyp!(pat!(a) op pat!(b)) 1554 1555 -- where rtyp is the Etype of the left operand. Note that we do not 1556 -- convert to the base type, since this would be unconstrained, and 1557 -- hence not have a corresponding packed array type set. 1558 1559 -- Note that both operands must be modular for this code to be used 1560 1561 if Is_Modular_Integer_Type (PAT) 1562 and then 1563 Is_Modular_Integer_Type (Etype (R)) 1564 then 1565 declare 1566 P : Node_Id; 1567 1568 begin 1569 if Nkind (N) = N_Op_And then 1570 P := Make_Op_And (Loc, L, R); 1571 1572 elsif Nkind (N) = N_Op_Or then 1573 P := Make_Op_Or (Loc, L, R); 1574 1575 else -- Nkind (N) = N_Op_Xor 1576 P := Make_Op_Xor (Loc, L, R); 1577 end if; 1578 1579 Rewrite (N, Unchecked_Convert_To (Ltyp, P)); 1580 end; 1581 1582 -- For the array case, we insert the actions 1583 1584 -- Result : Ltype; 1585 1586 -- System.Bit_Ops.Bit_And/Or/Xor 1587 -- (Left'Address, 1588 -- Ltype'Length * Ltype'Component_Size; 1589 -- Right'Address, 1590 -- Rtype'Length * Rtype'Component_Size 1591 -- Result'Address); 1592 1593 -- where Left and Right are the Packed_Bytes{1,2,4} operands and 1594 -- the second argument and fourth arguments are the lengths of the 1595 -- operands in bits. Then we replace the expression by a reference 1596 -- to Result. 1597 1598 -- Note that if we are mixing a modular and array operand, everything 1599 -- works fine, since we ensure that the modular representation has the 1600 -- same physical layout as the array representation (that's what the 1601 -- left justified modular stuff in the big-endian case is about). 1602 1603 else 1604 declare 1605 Result_Ent : constant Entity_Id := Make_Temporary (Loc, 'T'); 1606 E_Id : RE_Id; 1607 1608 begin 1609 if Nkind (N) = N_Op_And then 1610 E_Id := RE_Bit_And; 1611 1612 elsif Nkind (N) = N_Op_Or then 1613 E_Id := RE_Bit_Or; 1614 1615 else -- Nkind (N) = N_Op_Xor 1616 E_Id := RE_Bit_Xor; 1617 end if; 1618 1619 Insert_Actions (N, New_List ( 1620 1621 Make_Object_Declaration (Loc, 1622 Defining_Identifier => Result_Ent, 1623 Object_Definition => New_Occurrence_Of (Ltyp, Loc)), 1624 1625 Make_Procedure_Call_Statement (Loc, 1626 Name => New_Occurrence_Of (RTE (E_Id), Loc), 1627 Parameter_Associations => New_List ( 1628 1629 Make_Byte_Aligned_Attribute_Reference (Loc, 1630 Prefix => L, 1631 Attribute_Name => Name_Address), 1632 1633 Make_Op_Multiply (Loc, 1634 Left_Opnd => 1635 Make_Attribute_Reference (Loc, 1636 Prefix => 1637 New_Occurrence_Of 1638 (Etype (First_Index (Ltyp)), Loc), 1639 Attribute_Name => Name_Range_Length), 1640 1641 Right_Opnd => 1642 Make_Integer_Literal (Loc, Component_Size (Ltyp))), 1643 1644 Make_Byte_Aligned_Attribute_Reference (Loc, 1645 Prefix => R, 1646 Attribute_Name => Name_Address), 1647 1648 Make_Op_Multiply (Loc, 1649 Left_Opnd => 1650 Make_Attribute_Reference (Loc, 1651 Prefix => 1652 New_Occurrence_Of 1653 (Etype (First_Index (Rtyp)), Loc), 1654 Attribute_Name => Name_Range_Length), 1655 1656 Right_Opnd => 1657 Make_Integer_Literal (Loc, Component_Size (Rtyp))), 1658 1659 Make_Byte_Aligned_Attribute_Reference (Loc, 1660 Prefix => New_Occurrence_Of (Result_Ent, Loc), 1661 Attribute_Name => Name_Address))))); 1662 1663 Rewrite (N, 1664 New_Occurrence_Of (Result_Ent, Loc)); 1665 end; 1666 end if; 1667 1668 Analyze_And_Resolve (N, Typ, Suppress => All_Checks); 1669 end Expand_Packed_Boolean_Operator; 1670 1671 ------------------------------------- 1672 -- Expand_Packed_Element_Reference -- 1673 ------------------------------------- 1674 1675 procedure Expand_Packed_Element_Reference (N : Node_Id) is 1676 Loc : constant Source_Ptr := Sloc (N); 1677 Obj : Node_Id; 1678 Atyp : Entity_Id; 1679 PAT : Entity_Id; 1680 Ctyp : Entity_Id; 1681 Csiz : Int; 1682 Shift : Node_Id; 1683 Cmask : Uint; 1684 Lit : Node_Id; 1685 Arg : Node_Id; 1686 1687 begin 1688 -- If the node is an actual in a call, the prefix has not been fully 1689 -- expanded, to account for the additional expansion for in-out actuals 1690 -- (see expand_actuals for details). If the prefix itself is a packed 1691 -- reference as well, we have to recurse to complete the transformation 1692 -- of the prefix. 1693 1694 if Nkind (Prefix (N)) = N_Indexed_Component 1695 and then not Analyzed (Prefix (N)) 1696 and then Is_Bit_Packed_Array (Etype (Prefix (Prefix (N)))) 1697 then 1698 Expand_Packed_Element_Reference (Prefix (N)); 1699 end if; 1700 1701 -- The prefix may be rewritten below as a conversion. If it is a source 1702 -- entity generate reference to it now, to prevent spurious warnings 1703 -- about unused entities. 1704 1705 if Is_Entity_Name (Prefix (N)) 1706 and then Comes_From_Source (Prefix (N)) 1707 then 1708 Generate_Reference (Entity (Prefix (N)), Prefix (N), 'r'); 1709 end if; 1710 1711 -- If not bit packed, we have the enumeration case, which is easily 1712 -- dealt with (just adjust the subscripts of the indexed component) 1713 1714 -- Note: this leaves the result as an indexed component, which is 1715 -- still a variable, so can be used in the assignment case, as is 1716 -- required in the enumeration case. 1717 1718 if not Is_Bit_Packed_Array (Etype (Prefix (N))) then 1719 Setup_Enumeration_Packed_Array_Reference (N); 1720 return; 1721 end if; 1722 1723 -- Remaining processing is for the bit-packed case 1724 1725 Obj := Relocate_Node (Prefix (N)); 1726 Convert_To_Actual_Subtype (Obj); 1727 Atyp := Etype (Obj); 1728 PAT := Packed_Array_Impl_Type (Atyp); 1729 Ctyp := Component_Type (Atyp); 1730 Csiz := UI_To_Int (Component_Size (Atyp)); 1731 1732 -- For the AAMP target, indexing of certain packed array is passed 1733 -- through to the back end without expansion, because the expansion 1734 -- results in very inefficient code on that target. This allows the 1735 -- GNAAMP back end to generate specialized macros that support more 1736 -- efficient indexing of packed arrays with components having sizes 1737 -- that are small powers of two. 1738 1739 if AAMP_On_Target 1740 and then (Csiz = 1 or else Csiz = 2 or else Csiz = 4) 1741 then 1742 return; 1743 end if; 1744 1745 -- Case of component size 1,2,4 or any component size for the modular 1746 -- case. These are the cases for which we can inline the code. 1747 1748 if Csiz = 1 or else Csiz = 2 or else Csiz = 4 1749 or else (Present (PAT) and then Is_Modular_Integer_Type (PAT)) 1750 then 1751 Setup_Inline_Packed_Array_Reference (N, Atyp, Obj, Cmask, Shift); 1752 Lit := Make_Integer_Literal (Loc, Cmask); 1753 Set_Print_In_Hex (Lit); 1754 1755 -- We generate a shift right to position the field, followed by a 1756 -- masking operation to extract the bit field, and we finally do an 1757 -- unchecked conversion to convert the result to the required target. 1758 1759 -- Note that the unchecked conversion automatically deals with the 1760 -- bias if we are dealing with a biased representation. What will 1761 -- happen is that we temporarily generate the biased representation, 1762 -- but almost immediately that will be converted to the original 1763 -- unbiased component type, and the bias will disappear. 1764 1765 Arg := 1766 Make_Op_And (Loc, 1767 Left_Opnd => Make_Shift_Right (Obj, Shift), 1768 Right_Opnd => Lit); 1769 Set_Etype (Arg, Ctyp); 1770 1771 -- Component extraction is performed on a native endianness scalar 1772 -- value: if Atyp has reverse storage order, then it has been byte 1773 -- swapped, and if the component being extracted is itself of a 1774 -- composite type with reverse storage order, then we need to swap 1775 -- it back to its expected endianness after extraction. 1776 1777 if Reverse_Storage_Order (Atyp) 1778 and then (Is_Record_Type (Ctyp) or else Is_Array_Type (Ctyp)) 1779 and then Reverse_Storage_Order (Ctyp) 1780 then 1781 Arg := Revert_Storage_Order (Arg); 1782 end if; 1783 1784 -- We needed to analyze this before we do the unchecked convert 1785 -- below, but we need it temporarily attached to the tree for 1786 -- this analysis (hence the temporary Set_Parent call). 1787 1788 Set_Parent (Arg, Parent (N)); 1789 Analyze_And_Resolve (Arg); 1790 1791 Rewrite (N, RJ_Unchecked_Convert_To (Ctyp, Arg)); 1792 1793 -- All other component sizes for non-modular case 1794 1795 else 1796 -- We generate 1797 1798 -- Component_Type!(Get_nn (Arr'address, Subscr)) 1799 1800 -- where Subscr is the computed linear subscript 1801 1802 declare 1803 Get_nn : Entity_Id; 1804 Subscr : Node_Id; 1805 Rev_SSO : constant Node_Id := 1806 New_Occurrence_Of 1807 (Boolean_Literals (Reverse_Storage_Order (Atyp)), Loc); 1808 1809 begin 1810 -- Acquire proper Get entity. We use the aligned or unaligned 1811 -- case as appropriate. 1812 1813 if Known_Aligned_Enough (Obj, Csiz) then 1814 Get_nn := RTE (Get_Id (Csiz)); 1815 else 1816 Get_nn := RTE (GetU_Id (Csiz)); 1817 end if; 1818 1819 -- Now generate the get reference 1820 1821 Compute_Linear_Subscript (Atyp, N, Subscr); 1822 1823 -- Below we make the assumption that Obj is at least byte 1824 -- aligned, since otherwise its address cannot be taken. 1825 -- The assumption holds since the only arrays that can be 1826 -- misaligned are small packed arrays which are implemented 1827 -- as a modular type, and that is not the case here. 1828 1829 Rewrite (N, 1830 Unchecked_Convert_To (Ctyp, 1831 Make_Function_Call (Loc, 1832 Name => New_Occurrence_Of (Get_nn, Loc), 1833 Parameter_Associations => New_List ( 1834 Make_Attribute_Reference (Loc, 1835 Prefix => Obj, 1836 Attribute_Name => Name_Address), 1837 Subscr, 1838 Rev_SSO)))); 1839 end; 1840 end if; 1841 1842 Analyze_And_Resolve (N, Ctyp, Suppress => All_Checks); 1843 end Expand_Packed_Element_Reference; 1844 1845 ---------------------- 1846 -- Expand_Packed_Eq -- 1847 ---------------------- 1848 1849 -- Handles expansion of "=" on packed array types 1850 1851 procedure Expand_Packed_Eq (N : Node_Id) is 1852 Loc : constant Source_Ptr := Sloc (N); 1853 L : constant Node_Id := Relocate_Node (Left_Opnd (N)); 1854 R : constant Node_Id := Relocate_Node (Right_Opnd (N)); 1855 1856 LLexpr : Node_Id; 1857 RLexpr : Node_Id; 1858 1859 Ltyp : Entity_Id; 1860 Rtyp : Entity_Id; 1861 PAT : Entity_Id; 1862 1863 begin 1864 Convert_To_Actual_Subtype (L); 1865 Convert_To_Actual_Subtype (R); 1866 Ltyp := Underlying_Type (Etype (L)); 1867 Rtyp := Underlying_Type (Etype (R)); 1868 1869 Convert_To_PAT_Type (L); 1870 Convert_To_PAT_Type (R); 1871 PAT := Etype (L); 1872 1873 LLexpr := 1874 Make_Op_Multiply (Loc, 1875 Left_Opnd => 1876 Make_Attribute_Reference (Loc, 1877 Prefix => New_Occurrence_Of (Ltyp, Loc), 1878 Attribute_Name => Name_Length), 1879 Right_Opnd => 1880 Make_Integer_Literal (Loc, Component_Size (Ltyp))); 1881 1882 RLexpr := 1883 Make_Op_Multiply (Loc, 1884 Left_Opnd => 1885 Make_Attribute_Reference (Loc, 1886 Prefix => New_Occurrence_Of (Rtyp, Loc), 1887 Attribute_Name => Name_Length), 1888 Right_Opnd => 1889 Make_Integer_Literal (Loc, Component_Size (Rtyp))); 1890 1891 -- For the modular case, we transform the comparison to: 1892 1893 -- Ltyp'Length = Rtyp'Length and then PAT!(L) = PAT!(R) 1894 1895 -- where PAT is the packed array type. This works fine, since in the 1896 -- modular case we guarantee that the unused bits are always zeroes. 1897 -- We do have to compare the lengths because we could be comparing 1898 -- two different subtypes of the same base type. 1899 1900 if Is_Modular_Integer_Type (PAT) then 1901 Rewrite (N, 1902 Make_And_Then (Loc, 1903 Left_Opnd => 1904 Make_Op_Eq (Loc, 1905 Left_Opnd => LLexpr, 1906 Right_Opnd => RLexpr), 1907 1908 Right_Opnd => 1909 Make_Op_Eq (Loc, 1910 Left_Opnd => L, 1911 Right_Opnd => R))); 1912 1913 -- For the non-modular case, we call a runtime routine 1914 1915 -- System.Bit_Ops.Bit_Eq 1916 -- (L'Address, L_Length, R'Address, R_Length) 1917 1918 -- where PAT is the packed array type, and the lengths are the lengths 1919 -- in bits of the original packed arrays. This routine takes care of 1920 -- not comparing the unused bits in the last byte. 1921 1922 else 1923 Rewrite (N, 1924 Make_Function_Call (Loc, 1925 Name => New_Occurrence_Of (RTE (RE_Bit_Eq), Loc), 1926 Parameter_Associations => New_List ( 1927 Make_Byte_Aligned_Attribute_Reference (Loc, 1928 Prefix => L, 1929 Attribute_Name => Name_Address), 1930 1931 LLexpr, 1932 1933 Make_Byte_Aligned_Attribute_Reference (Loc, 1934 Prefix => R, 1935 Attribute_Name => Name_Address), 1936 1937 RLexpr))); 1938 end if; 1939 1940 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 1941 end Expand_Packed_Eq; 1942 1943 ----------------------- 1944 -- Expand_Packed_Not -- 1945 ----------------------- 1946 1947 -- Handles expansion of "not" on packed array types 1948 1949 procedure Expand_Packed_Not (N : Node_Id) is 1950 Loc : constant Source_Ptr := Sloc (N); 1951 Typ : constant Entity_Id := Etype (N); 1952 Opnd : constant Node_Id := Relocate_Node (Right_Opnd (N)); 1953 1954 Rtyp : Entity_Id; 1955 PAT : Entity_Id; 1956 Lit : Node_Id; 1957 1958 begin 1959 Convert_To_Actual_Subtype (Opnd); 1960 Rtyp := Etype (Opnd); 1961 1962 -- Deal with silly False..False and True..True subtype case 1963 1964 Silly_Boolean_Array_Not_Test (N, Rtyp); 1965 1966 -- Now that the silliness is taken care of, get packed array type 1967 1968 Convert_To_PAT_Type (Opnd); 1969 PAT := Etype (Opnd); 1970 1971 -- For the case where the packed array type is a modular type, "not A" 1972 -- expands simply into: 1973 1974 -- Rtyp!(PAT!(A) xor Mask) 1975 1976 -- where PAT is the packed array type, Mask is a mask of all 1 bits of 1977 -- length equal to the size of this packed type, and Rtyp is the actual 1978 -- actual subtype of the operand. 1979 1980 Lit := Make_Integer_Literal (Loc, 2 ** RM_Size (PAT) - 1); 1981 Set_Print_In_Hex (Lit); 1982 1983 if not Is_Array_Type (PAT) then 1984 Rewrite (N, 1985 Unchecked_Convert_To (Rtyp, 1986 Make_Op_Xor (Loc, 1987 Left_Opnd => Opnd, 1988 Right_Opnd => Lit))); 1989 1990 -- For the array case, we insert the actions 1991 1992 -- Result : Typ; 1993 1994 -- System.Bit_Ops.Bit_Not 1995 -- (Opnd'Address, 1996 -- Typ'Length * Typ'Component_Size, 1997 -- Result'Address); 1998 1999 -- where Opnd is the Packed_Bytes{1,2,4} operand and the second argument 2000 -- is the length of the operand in bits. We then replace the expression 2001 -- with a reference to Result. 2002 2003 else 2004 declare 2005 Result_Ent : constant Entity_Id := Make_Temporary (Loc, 'T'); 2006 2007 begin 2008 Insert_Actions (N, New_List ( 2009 Make_Object_Declaration (Loc, 2010 Defining_Identifier => Result_Ent, 2011 Object_Definition => New_Occurrence_Of (Rtyp, Loc)), 2012 2013 Make_Procedure_Call_Statement (Loc, 2014 Name => New_Occurrence_Of (RTE (RE_Bit_Not), Loc), 2015 Parameter_Associations => New_List ( 2016 Make_Byte_Aligned_Attribute_Reference (Loc, 2017 Prefix => Opnd, 2018 Attribute_Name => Name_Address), 2019 2020 Make_Op_Multiply (Loc, 2021 Left_Opnd => 2022 Make_Attribute_Reference (Loc, 2023 Prefix => 2024 New_Occurrence_Of 2025 (Etype (First_Index (Rtyp)), Loc), 2026 Attribute_Name => Name_Range_Length), 2027 2028 Right_Opnd => 2029 Make_Integer_Literal (Loc, Component_Size (Rtyp))), 2030 2031 Make_Byte_Aligned_Attribute_Reference (Loc, 2032 Prefix => New_Occurrence_Of (Result_Ent, Loc), 2033 Attribute_Name => Name_Address))))); 2034 2035 Rewrite (N, New_Occurrence_Of (Result_Ent, Loc)); 2036 end; 2037 end if; 2038 2039 Analyze_And_Resolve (N, Typ, Suppress => All_Checks); 2040 end Expand_Packed_Not; 2041 2042 ----------------------------- 2043 -- Get_Base_And_Bit_Offset -- 2044 ----------------------------- 2045 2046 procedure Get_Base_And_Bit_Offset 2047 (N : Node_Id; 2048 Base : out Node_Id; 2049 Offset : out Node_Id) 2050 is 2051 Loc : Source_Ptr; 2052 Term : Node_Id; 2053 Atyp : Entity_Id; 2054 Subscr : Node_Id; 2055 2056 begin 2057 Base := N; 2058 Offset := Empty; 2059 2060 -- We build up an expression serially that has the form 2061 2062 -- linear-subscript * component_size for each array reference 2063 -- + field'Bit_Position for each record field 2064 -- + ... 2065 2066 loop 2067 Loc := Sloc (Base); 2068 2069 if Nkind (Base) = N_Indexed_Component then 2070 Convert_To_Actual_Subtype (Prefix (Base)); 2071 Atyp := Etype (Prefix (Base)); 2072 Compute_Linear_Subscript (Atyp, Base, Subscr); 2073 2074 Term := 2075 Make_Op_Multiply (Loc, 2076 Left_Opnd => Subscr, 2077 Right_Opnd => 2078 Make_Attribute_Reference (Loc, 2079 Prefix => New_Occurrence_Of (Atyp, Loc), 2080 Attribute_Name => Name_Component_Size)); 2081 2082 elsif Nkind (Base) = N_Selected_Component then 2083 Term := 2084 Make_Attribute_Reference (Loc, 2085 Prefix => Selector_Name (Base), 2086 Attribute_Name => Name_Bit_Position); 2087 2088 else 2089 return; 2090 end if; 2091 2092 if No (Offset) then 2093 Offset := Term; 2094 2095 else 2096 Offset := 2097 Make_Op_Add (Loc, 2098 Left_Opnd => Offset, 2099 Right_Opnd => Term); 2100 end if; 2101 2102 Base := Prefix (Base); 2103 end loop; 2104 end Get_Base_And_Bit_Offset; 2105 2106 ------------------------------------- 2107 -- Involves_Packed_Array_Reference -- 2108 ------------------------------------- 2109 2110 function Involves_Packed_Array_Reference (N : Node_Id) return Boolean is 2111 begin 2112 if Nkind (N) = N_Indexed_Component 2113 and then Is_Bit_Packed_Array (Etype (Prefix (N))) 2114 then 2115 return True; 2116 2117 elsif Nkind (N) = N_Selected_Component then 2118 return Involves_Packed_Array_Reference (Prefix (N)); 2119 2120 else 2121 return False; 2122 end if; 2123 end Involves_Packed_Array_Reference; 2124 2125 -------------------------- 2126 -- Known_Aligned_Enough -- 2127 -------------------------- 2128 2129 function Known_Aligned_Enough (Obj : Node_Id; Csiz : Nat) return Boolean is 2130 Typ : constant Entity_Id := Etype (Obj); 2131 2132 function In_Partially_Packed_Record (Comp : Entity_Id) return Boolean; 2133 -- If the component is in a record that contains previous packed 2134 -- components, consider it unaligned because the back-end might 2135 -- choose to pack the rest of the record. Lead to less efficient code, 2136 -- but safer vis-a-vis of back-end choices. 2137 2138 -------------------------------- 2139 -- In_Partially_Packed_Record -- 2140 -------------------------------- 2141 2142 function In_Partially_Packed_Record (Comp : Entity_Id) return Boolean is 2143 Rec_Type : constant Entity_Id := Scope (Comp); 2144 Prev_Comp : Entity_Id; 2145 2146 begin 2147 Prev_Comp := First_Entity (Rec_Type); 2148 while Present (Prev_Comp) loop 2149 if Is_Packed (Etype (Prev_Comp)) then 2150 return True; 2151 2152 elsif Prev_Comp = Comp then 2153 return False; 2154 end if; 2155 2156 Next_Entity (Prev_Comp); 2157 end loop; 2158 2159 return False; 2160 end In_Partially_Packed_Record; 2161 2162 -- Start of processing for Known_Aligned_Enough 2163 2164 begin 2165 -- Odd bit sizes don't need alignment anyway 2166 2167 if Csiz mod 2 = 1 then 2168 return True; 2169 2170 -- If we have a specified alignment, see if it is sufficient, if not 2171 -- then we can't possibly be aligned enough in any case. 2172 2173 elsif Known_Alignment (Etype (Obj)) then 2174 -- Alignment required is 4 if size is a multiple of 4, and 2175 -- 2 otherwise (e.g. 12 bits requires 4, 10 bits requires 2) 2176 2177 if Alignment (Etype (Obj)) < 4 - (Csiz mod 4) then 2178 return False; 2179 end if; 2180 end if; 2181 2182 -- OK, alignment should be sufficient, if object is aligned 2183 2184 -- If object is strictly aligned, then it is definitely aligned 2185 2186 if Strict_Alignment (Typ) then 2187 return True; 2188 2189 -- Case of subscripted array reference 2190 2191 elsif Nkind (Obj) = N_Indexed_Component then 2192 2193 -- If we have a pointer to an array, then this is definitely 2194 -- aligned, because pointers always point to aligned versions. 2195 2196 if Is_Access_Type (Etype (Prefix (Obj))) then 2197 return True; 2198 2199 -- Otherwise, go look at the prefix 2200 2201 else 2202 return Known_Aligned_Enough (Prefix (Obj), Csiz); 2203 end if; 2204 2205 -- Case of record field 2206 2207 elsif Nkind (Obj) = N_Selected_Component then 2208 2209 -- What is significant here is whether the record type is packed 2210 2211 if Is_Record_Type (Etype (Prefix (Obj))) 2212 and then Is_Packed (Etype (Prefix (Obj))) 2213 then 2214 return False; 2215 2216 -- Or the component has a component clause which might cause 2217 -- the component to become unaligned (we can't tell if the 2218 -- backend is doing alignment computations). 2219 2220 elsif Present (Component_Clause (Entity (Selector_Name (Obj)))) then 2221 return False; 2222 2223 elsif In_Partially_Packed_Record (Entity (Selector_Name (Obj))) then 2224 return False; 2225 2226 -- In all other cases, go look at prefix 2227 2228 else 2229 return Known_Aligned_Enough (Prefix (Obj), Csiz); 2230 end if; 2231 2232 elsif Nkind (Obj) = N_Type_Conversion then 2233 return Known_Aligned_Enough (Expression (Obj), Csiz); 2234 2235 -- For a formal parameter, it is safer to assume that it is not 2236 -- aligned, because the formal may be unconstrained while the actual 2237 -- is constrained. In this situation, a small constrained packed 2238 -- array, represented in modular form, may be unaligned. 2239 2240 elsif Is_Entity_Name (Obj) then 2241 return not Is_Formal (Entity (Obj)); 2242 else 2243 2244 -- If none of the above, must be aligned 2245 return True; 2246 end if; 2247 end Known_Aligned_Enough; 2248 2249 --------------------- 2250 -- Make_Shift_Left -- 2251 --------------------- 2252 2253 function Make_Shift_Left (N : Node_Id; S : Node_Id) return Node_Id is 2254 Nod : Node_Id; 2255 2256 begin 2257 if Compile_Time_Known_Value (S) and then Expr_Value (S) = 0 then 2258 return N; 2259 else 2260 Nod := 2261 Make_Op_Shift_Left (Sloc (N), 2262 Left_Opnd => N, 2263 Right_Opnd => S); 2264 Set_Shift_Count_OK (Nod, True); 2265 return Nod; 2266 end if; 2267 end Make_Shift_Left; 2268 2269 ---------------------- 2270 -- Make_Shift_Right -- 2271 ---------------------- 2272 2273 function Make_Shift_Right (N : Node_Id; S : Node_Id) return Node_Id is 2274 Nod : Node_Id; 2275 2276 begin 2277 if Compile_Time_Known_Value (S) and then Expr_Value (S) = 0 then 2278 return N; 2279 else 2280 Nod := 2281 Make_Op_Shift_Right (Sloc (N), 2282 Left_Opnd => N, 2283 Right_Opnd => S); 2284 Set_Shift_Count_OK (Nod, True); 2285 return Nod; 2286 end if; 2287 end Make_Shift_Right; 2288 2289 ----------------------------- 2290 -- RJ_Unchecked_Convert_To -- 2291 ----------------------------- 2292 2293 function RJ_Unchecked_Convert_To 2294 (Typ : Entity_Id; 2295 Expr : Node_Id) return Node_Id 2296 is 2297 Source_Typ : constant Entity_Id := Etype (Expr); 2298 Target_Typ : constant Entity_Id := Typ; 2299 2300 Src : Node_Id := Expr; 2301 2302 Source_Siz : Nat; 2303 Target_Siz : Nat; 2304 2305 begin 2306 Source_Siz := UI_To_Int (RM_Size (Source_Typ)); 2307 Target_Siz := UI_To_Int (RM_Size (Target_Typ)); 2308 2309 -- For a little-endian target type stored byte-swapped on a 2310 -- big-endian machine, do not mask to Target_Siz bits. 2311 2312 if Bytes_Big_Endian 2313 and then (Is_Record_Type (Target_Typ) 2314 or else 2315 Is_Array_Type (Target_Typ)) 2316 and then Reverse_Storage_Order (Target_Typ) 2317 then 2318 Source_Siz := Target_Siz; 2319 end if; 2320 2321 -- First step, if the source type is not a discrete type, then we first 2322 -- convert to a modular type of the source length, since otherwise, on 2323 -- a big-endian machine, we get left-justification. We do it for little- 2324 -- endian machines as well, because there might be junk bits that are 2325 -- not cleared if the type is not numeric. 2326 2327 if Source_Siz /= Target_Siz 2328 and then not Is_Discrete_Type (Source_Typ) 2329 then 2330 Src := Unchecked_Convert_To (RTE (Bits_Id (Source_Siz)), Src); 2331 end if; 2332 2333 -- In the big endian case, if the lengths of the two types differ, then 2334 -- we must worry about possible left justification in the conversion, 2335 -- and avoiding that is what this is all about. 2336 2337 if Bytes_Big_Endian and then Source_Siz /= Target_Siz then 2338 2339 -- Next step. If the target is not a discrete type, then we first 2340 -- convert to a modular type of the target length, since otherwise, 2341 -- on a big-endian machine, we get left-justification. 2342 2343 if not Is_Discrete_Type (Target_Typ) then 2344 Src := Unchecked_Convert_To (RTE (Bits_Id (Target_Siz)), Src); 2345 end if; 2346 end if; 2347 2348 -- And now we can do the final conversion to the target type 2349 2350 return Unchecked_Convert_To (Target_Typ, Src); 2351 end RJ_Unchecked_Convert_To; 2352 2353 ---------------------------------------------- 2354 -- Setup_Enumeration_Packed_Array_Reference -- 2355 ---------------------------------------------- 2356 2357 -- All we have to do here is to find the subscripts that correspond to the 2358 -- index positions that have non-standard enumeration types and insert a 2359 -- Pos attribute to get the proper subscript value. 2360 2361 -- Finally the prefix must be uncheck-converted to the corresponding packed 2362 -- array type. 2363 2364 -- Note that the component type is unchanged, so we do not need to fiddle 2365 -- with the types (Gigi always automatically takes the packed array type if 2366 -- it is set, as it will be in this case). 2367 2368 procedure Setup_Enumeration_Packed_Array_Reference (N : Node_Id) is 2369 Pfx : constant Node_Id := Prefix (N); 2370 Typ : constant Entity_Id := Etype (N); 2371 Exprs : constant List_Id := Expressions (N); 2372 Expr : Node_Id; 2373 2374 begin 2375 -- If the array is unconstrained, then we replace the array reference 2376 -- with its actual subtype. This actual subtype will have a packed array 2377 -- type with appropriate bounds. 2378 2379 if not Is_Constrained (Packed_Array_Impl_Type (Etype (Pfx))) then 2380 Convert_To_Actual_Subtype (Pfx); 2381 end if; 2382 2383 Expr := First (Exprs); 2384 while Present (Expr) loop 2385 declare 2386 Loc : constant Source_Ptr := Sloc (Expr); 2387 Expr_Typ : constant Entity_Id := Etype (Expr); 2388 2389 begin 2390 if Is_Enumeration_Type (Expr_Typ) 2391 and then Has_Non_Standard_Rep (Expr_Typ) 2392 then 2393 Rewrite (Expr, 2394 Make_Attribute_Reference (Loc, 2395 Prefix => New_Occurrence_Of (Expr_Typ, Loc), 2396 Attribute_Name => Name_Pos, 2397 Expressions => New_List (Relocate_Node (Expr)))); 2398 Analyze_And_Resolve (Expr, Standard_Natural); 2399 end if; 2400 end; 2401 2402 Next (Expr); 2403 end loop; 2404 2405 Rewrite (N, 2406 Make_Indexed_Component (Sloc (N), 2407 Prefix => 2408 Unchecked_Convert_To (Packed_Array_Impl_Type (Etype (Pfx)), Pfx), 2409 Expressions => Exprs)); 2410 2411 Analyze_And_Resolve (N, Typ); 2412 end Setup_Enumeration_Packed_Array_Reference; 2413 2414 ----------------------------------------- 2415 -- Setup_Inline_Packed_Array_Reference -- 2416 ----------------------------------------- 2417 2418 procedure Setup_Inline_Packed_Array_Reference 2419 (N : Node_Id; 2420 Atyp : Entity_Id; 2421 Obj : in out Node_Id; 2422 Cmask : out Uint; 2423 Shift : out Node_Id) 2424 is 2425 Loc : constant Source_Ptr := Sloc (N); 2426 PAT : Entity_Id; 2427 Otyp : Entity_Id; 2428 Csiz : Uint; 2429 Osiz : Uint; 2430 2431 begin 2432 Csiz := Component_Size (Atyp); 2433 2434 Convert_To_PAT_Type (Obj); 2435 PAT := Etype (Obj); 2436 2437 Cmask := 2 ** Csiz - 1; 2438 2439 if Is_Array_Type (PAT) then 2440 Otyp := Component_Type (PAT); 2441 Osiz := Component_Size (PAT); 2442 2443 else 2444 Otyp := PAT; 2445 2446 -- In the case where the PAT is a modular type, we want the actual 2447 -- size in bits of the modular value we use. This is neither the 2448 -- Object_Size nor the Value_Size, either of which may have been 2449 -- reset to strange values, but rather the minimum size. Note that 2450 -- since this is a modular type with full range, the issue of 2451 -- biased representation does not arise. 2452 2453 Osiz := UI_From_Int (Minimum_Size (Otyp)); 2454 end if; 2455 2456 Compute_Linear_Subscript (Atyp, N, Shift); 2457 2458 -- If the component size is not 1, then the subscript must be multiplied 2459 -- by the component size to get the shift count. 2460 2461 if Csiz /= 1 then 2462 Shift := 2463 Make_Op_Multiply (Loc, 2464 Left_Opnd => Make_Integer_Literal (Loc, Csiz), 2465 Right_Opnd => Shift); 2466 end if; 2467 2468 -- If we have the array case, then this shift count must be broken down 2469 -- into a byte subscript, and a shift within the byte. 2470 2471 if Is_Array_Type (PAT) then 2472 2473 declare 2474 New_Shift : Node_Id; 2475 2476 begin 2477 -- We must analyze shift, since we will duplicate it 2478 2479 Set_Parent (Shift, N); 2480 Analyze_And_Resolve 2481 (Shift, Standard_Integer, Suppress => All_Checks); 2482 2483 -- The shift count within the word is 2484 -- shift mod Osiz 2485 2486 New_Shift := 2487 Make_Op_Mod (Loc, 2488 Left_Opnd => Duplicate_Subexpr (Shift), 2489 Right_Opnd => Make_Integer_Literal (Loc, Osiz)); 2490 2491 -- The subscript to be used on the PAT array is 2492 -- shift / Osiz 2493 2494 Obj := 2495 Make_Indexed_Component (Loc, 2496 Prefix => Obj, 2497 Expressions => New_List ( 2498 Make_Op_Divide (Loc, 2499 Left_Opnd => Duplicate_Subexpr (Shift), 2500 Right_Opnd => Make_Integer_Literal (Loc, Osiz)))); 2501 2502 Shift := New_Shift; 2503 end; 2504 2505 -- For the modular integer case, the object to be manipulated is the 2506 -- entire array, so Obj is unchanged. Note that we will reset its type 2507 -- to PAT before returning to the caller. 2508 2509 else 2510 null; 2511 end if; 2512 2513 -- The one remaining step is to modify the shift count for the 2514 -- big-endian case. Consider the following example in a byte: 2515 2516 -- xxxxxxxx bits of byte 2517 -- vvvvvvvv bits of value 2518 -- 33221100 little-endian numbering 2519 -- 00112233 big-endian numbering 2520 2521 -- Here we have the case of 2-bit fields 2522 2523 -- For the little-endian case, we already have the proper shift count 2524 -- set, e.g. for element 2, the shift count is 2*2 = 4. 2525 2526 -- For the big endian case, we have to adjust the shift count, computing 2527 -- it as (N - F) - Shift, where N is the number of bits in an element of 2528 -- the array used to implement the packed array, F is the number of bits 2529 -- in a source array element, and Shift is the count so far computed. 2530 2531 -- We also have to adjust if the storage order is reversed 2532 2533 if Bytes_Big_Endian xor Reverse_Storage_Order (Base_Type (Atyp)) then 2534 Shift := 2535 Make_Op_Subtract (Loc, 2536 Left_Opnd => Make_Integer_Literal (Loc, Osiz - Csiz), 2537 Right_Opnd => Shift); 2538 end if; 2539 2540 Set_Parent (Shift, N); 2541 Set_Parent (Obj, N); 2542 Analyze_And_Resolve (Obj, Otyp, Suppress => All_Checks); 2543 Analyze_And_Resolve (Shift, Standard_Integer, Suppress => All_Checks); 2544 2545 -- Make sure final type of object is the appropriate packed type 2546 2547 Set_Etype (Obj, Otyp); 2548 2549 end Setup_Inline_Packed_Array_Reference; 2550 2551end Exp_Pakd; 2552