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