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