1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Einfo
; use Einfo
;
29 with Einfo
.Entities
; use Einfo
.Entities
;
30 with Einfo
.Utils
; use Einfo
.Utils
;
31 with Errout
; use Errout
;
32 with Exp_Dbug
; use Exp_Dbug
;
33 with Exp_Util
; use Exp_Util
;
34 with Layout
; use Layout
;
35 with Lib
.Xref
; use Lib
.Xref
;
36 with Namet
; use Namet
;
37 with Nlists
; use Nlists
;
38 with Nmake
; use Nmake
;
41 with Sem_Aux
; use Sem_Aux
;
42 with Sem_Ch3
; use Sem_Ch3
;
43 with Sem_Ch8
; use Sem_Ch8
;
44 with Sem_Ch13
; use Sem_Ch13
;
45 with Sem_Eval
; use Sem_Eval
;
46 with Sem_Res
; use Sem_Res
;
47 with Sem_Util
; use Sem_Util
;
48 with Sinfo
; use Sinfo
;
49 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
50 with Sinfo
.Utils
; use Sinfo
.Utils
;
51 with Snames
; use Snames
;
52 with Stand
; use Stand
;
53 with Targparm
; use Targparm
;
54 with Tbuild
; use Tbuild
;
55 with Ttypes
; use Ttypes
;
56 with Uintp
; use Uintp
;
58 package body Exp_Pakd
is
60 ---------------------------
61 -- Endian Considerations --
62 ---------------------------
64 -- As described in the specification, bit numbering in a packed array
65 -- is consistent with bit numbering in a record representation clause,
66 -- and hence dependent on the endianness of the machine:
68 -- For little-endian machines, element zero is at the right hand end
69 -- (low order end) of a bit field.
71 -- For big-endian machines, element zero is at the left hand end
72 -- (high order end) of a bit field.
74 -- The shifts that are used to right justify a field therefore differ in
75 -- the two cases. For the little-endian case, we can simply use the bit
76 -- number (i.e. the element number * element size) as the count for a right
77 -- shift. For the big-endian case, we have to subtract the shift count from
78 -- an appropriate constant to use in the right shift. We use rotates
79 -- instead of shifts (which is necessary in the store case to preserve
80 -- other fields), and we expect that the backend will be able to change the
81 -- right rotate into a left rotate, avoiding the subtract, if the machine
82 -- architecture provides such an instruction.
84 -----------------------
85 -- Local Subprograms --
86 -----------------------
88 procedure Compute_Linear_Subscript
91 Subscr
: out Node_Id
);
92 -- Given a constrained array type Atyp, and an indexed component node N
93 -- referencing an array object of this type, build an expression of type
94 -- Standard.Integer representing the zero-based linear subscript value.
95 -- This expression includes any required range checks.
97 function Compute_Number_Components
99 Typ
: Entity_Id
) return Node_Id
;
100 -- Build an expression that multiplies the length of the dimensions of the
101 -- array, used to control array equality checks.
103 procedure Convert_To_PAT_Type
(Aexp
: Node_Id
);
104 -- Given an expression of a packed array type, builds a corresponding
105 -- expression whose type is the implementation type used to represent
106 -- the packed array. Aexp is analyzed and resolved on entry and on exit.
108 procedure Get_Base_And_Bit_Offset
111 Offset
: out Node_Id
);
112 -- Given a node N for a name which involves a packed array reference,
113 -- return the base object of the reference and build an expression of
114 -- type Standard.Integer representing the zero-based offset in bits
115 -- from Base'Address to the first bit of the reference.
117 function Known_Aligned_Enough
(Obj
: Node_Id
; Csiz
: Nat
) return Boolean;
118 -- There are two versions of the Set routines, the ones used when the
119 -- object is known to be sufficiently well aligned given the number of
120 -- bits, and the ones used when the object is not known to be aligned.
121 -- This routine is used to determine which set to use. Obj is a reference
122 -- to the object, and Csiz is the component size of the packed array.
123 -- True is returned if the alignment of object is known to be sufficient,
124 -- defined as 1 for odd bit sizes, 4 for bit sizes divisible by 4, and
127 function Make_Shift_Left
(N
: Node_Id
; S
: Node_Id
) return Node_Id
;
128 -- Build a left shift node, checking for the case of a shift count of zero
130 function Make_Shift_Right
(N
: Node_Id
; S
: Node_Id
) return Node_Id
;
131 -- Build a right shift node, checking for the case of a shift count of zero
133 function RJ_Unchecked_Convert_To
135 Expr
: Node_Id
) return Node_Id
;
136 -- The packed array code does unchecked conversions which in some cases
137 -- may involve non-discrete types with differing sizes. The semantics of
138 -- such conversions is potentially endianness dependent, and the effect
139 -- we want here for such a conversion is to do the conversion in size as
140 -- though numeric items are involved, and we extend or truncate on the
141 -- left side. This happens naturally in the little-endian case, but in
142 -- the big endian case we can get left justification, when what we want
143 -- is right justification. This routine does the unchecked conversion in
144 -- a stepwise manner to ensure that it gives the expected result. Hence
145 -- the name (RJ = Right justified). The parameters Typ and Expr are as
146 -- for the case of a normal Unchecked_Convert_To call.
148 procedure Setup_Enumeration_Packed_Array_Reference
(N
: Node_Id
);
149 -- This routine is called in the Get and Set case for arrays that are
150 -- packed but not bit-packed, meaning that they have at least one
151 -- subscript that is of an enumeration type with a non-standard
152 -- representation. This routine modifies the given node to properly
153 -- reference the corresponding packed array type.
155 procedure Setup_Inline_Packed_Array_Reference
158 Obj
: in out Node_Id
;
160 Shift
: out Node_Id
);
161 -- This procedure performs common processing on the N_Indexed_Component
162 -- parameter given as N, whose prefix is a reference to a packed array.
163 -- This is used for the get and set when the component size is 1, 2, 4,
164 -- or for other component sizes when the packed array type is a modular
165 -- type (i.e. the cases that are handled with inline code).
169 -- N is the N_Indexed_Component node for the packed array reference
171 -- Atyp is the constrained array type (the actual subtype has been
172 -- computed if necessary to obtain the constraints, but this is still
173 -- the original array type, not the Packed_Array_Impl_Type value).
175 -- Obj is the object which is to be indexed. It is always of type Atyp.
179 -- Obj is the object containing the desired bit field. It is of type
180 -- Unsigned, Long_Unsigned, or Long_Long_Unsigned, and is either the
181 -- entire value, for the small static case, or the proper selected byte
182 -- from the array in the large or dynamic case. This node is analyzed
183 -- and resolved on return.
185 -- Shift is a node representing the shift count to be used in the
186 -- rotate right instruction that positions the field for access.
187 -- This node is analyzed and resolved on return.
189 -- Cmask is a mask corresponding to the width of the component field.
190 -- Its value is 2 ** Csize - 1 (e.g. 2#1111# for component size of 4).
192 -- Note: in some cases the call to this routine may generate actions
193 -- (for handling multi-use references and the generation of the packed
194 -- array type on the fly). Such actions are inserted into the tree
195 -- directly using Insert_Action.
197 function Revert_Storage_Order
(N
: Node_Id
) return Node_Id
;
198 -- Perform appropriate justification and byte ordering adjustments for N,
199 -- an element of a packed array type, when both the component type and
200 -- the enclosing packed array type have reverse scalar storage order.
201 -- On little-endian targets, the value is left justified before byte
202 -- swapping. The Etype of the returned expression is an integer type of
203 -- an appropriate power-of-2 size.
205 --------------------------
206 -- Revert_Storage_Order --
207 --------------------------
209 function Revert_Storage_Order
(N
: Node_Id
) return Node_Id
is
210 Loc
: constant Source_Ptr
:= Sloc
(N
);
211 T
: constant Entity_Id
:= Etype
(N
);
212 T_Size
: constant Uint
:= RM_Size
(T
);
226 -- Array component size is less than a byte: no swapping needed
229 Swap_T
:= RTE
(RE_Unsigned_8
);
232 -- Select byte swapping function depending on array component size
235 Swap_RE
:= RE_Bswap_16
;
237 elsif T_Size
<= 32 then
238 Swap_RE
:= RE_Bswap_32
;
240 elsif T_Size
<= 64 then
241 Swap_RE
:= RE_Bswap_64
;
243 else pragma Assert
(T_Size
<= 128);
244 Swap_RE
:= RE_Bswap_128
;
247 Swap_F
:= RTE
(Swap_RE
);
248 Swap_T
:= Etype
(Swap_F
);
252 Shift
:= Esize
(Swap_T
) - T_Size
;
254 Arg
:= RJ_Unchecked_Convert_To
(Swap_T
, N
);
256 if not Bytes_Big_Endian
and then Shift
> Uint_0
then
258 Make_Op_Shift_Left
(Loc
,
260 Right_Opnd
=> Make_Integer_Literal
(Loc
, Shift
));
263 if Present
(Swap_F
) then
265 Make_Function_Call
(Loc
,
266 Name
=> New_Occurrence_Of
(Swap_F
, Loc
),
267 Parameter_Associations
=> New_List
(Arg
));
272 Set_Etype
(Adjusted
, Swap_T
);
274 end Revert_Storage_Order
;
276 ------------------------------
277 -- Compute_Linear_Subscript --
278 ------------------------------
280 procedure Compute_Linear_Subscript
283 Subscr
: out Node_Id
)
285 Loc
: constant Source_Ptr
:= Sloc
(N
);
294 -- Loop through dimensions
296 Indx
:= First_Index
(Atyp
);
297 Oldsub
:= First
(Expressions
(N
));
299 while Present
(Indx
) loop
300 Styp
:= Etype
(Indx
);
301 Newsub
:= Relocate_Node
(Oldsub
);
303 -- Get expression for the subscript value. First, if Do_Range_Check
304 -- is set on a subscript, then we must do a range check against the
305 -- original bounds (not the bounds of the packed array type). We do
306 -- this by introducing a subtype conversion.
308 if Do_Range_Check
(Newsub
)
309 and then Etype
(Newsub
) /= Styp
311 Newsub
:= Convert_To
(Styp
, Newsub
);
314 -- Now evolve the expression for the subscript. First convert
315 -- the subscript to be zero based and of an integer type.
317 -- Case of integer type, where we just subtract to get lower bound
319 if Is_Integer_Type
(Styp
) then
321 -- If length of integer type is smaller than standard integer,
322 -- then we convert to integer first, then do the subtract
324 -- Integer (subscript) - Integer (Styp'First)
326 if Esize
(Styp
) < Standard_Integer_Size
then
328 Make_Op_Subtract
(Loc
,
329 Left_Opnd
=> Convert_To
(Standard_Integer
, Newsub
),
331 Convert_To
(Standard_Integer
,
332 Make_Attribute_Reference
(Loc
,
333 Prefix
=> New_Occurrence_Of
(Styp
, Loc
),
334 Attribute_Name
=> Name_First
)));
336 -- For larger integer types, subtract first, then convert to
337 -- integer, this deals with strange long long integer bounds.
339 -- Integer (subscript - Styp'First)
343 Convert_To
(Standard_Integer
,
344 Make_Op_Subtract
(Loc
,
347 Make_Attribute_Reference
(Loc
,
348 Prefix
=> New_Occurrence_Of
(Styp
, Loc
),
349 Attribute_Name
=> Name_First
)));
352 -- For the enumeration case, we have to use 'Pos to get the value
353 -- to work with before subtracting the lower bound.
355 -- Integer (Styp'Pos (subscr)) - Integer (Styp'Pos (Styp'First));
357 -- This is not quite right for bizarre cases where the size of the
358 -- enumeration type is > Integer'Size bits due to rep clause ???
361 pragma Assert
(Is_Enumeration_Type
(Styp
));
364 Make_Op_Subtract
(Loc
,
365 Left_Opnd
=> 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
(Newsub
))),
372 Convert_To
(Standard_Integer
,
373 Make_Attribute_Reference
(Loc
,
374 Prefix
=> New_Occurrence_Of
(Styp
, Loc
),
375 Attribute_Name
=> Name_Pos
,
376 Expressions
=> New_List
(
377 Make_Attribute_Reference
(Loc
,
378 Prefix
=> New_Occurrence_Of
(Styp
, Loc
),
379 Attribute_Name
=> Name_First
)))));
382 Set_Paren_Count
(Newsub
, 1);
384 -- For the first subscript, we just copy that subscript value
389 -- Otherwise, we must multiply what we already have by the current
390 -- stride and then add in the new value to the evolving subscript.
396 Make_Op_Multiply
(Loc
,
399 Make_Attribute_Reference
(Loc
,
400 Attribute_Name
=> Name_Range_Length
,
401 Prefix
=> New_Occurrence_Of
(Styp
, Loc
))),
402 Right_Opnd
=> Newsub
);
405 -- Move to next subscript
410 end Compute_Linear_Subscript
;
412 -------------------------------
413 -- Compute_Number_Components --
414 -------------------------------
416 function Compute_Number_Components
418 Typ
: Entity_Id
) return Node_Id
420 Loc
: constant Source_Ptr
:= Sloc
(N
);
425 Make_Attribute_Reference
(Loc
,
426 Attribute_Name
=> Name_Length
,
427 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
428 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, 1)));
430 for J
in 2 .. Number_Dimensions
(Typ
) loop
432 Make_Op_Multiply
(Loc
,
433 Left_Opnd
=> Len_Expr
,
435 Make_Attribute_Reference
(Loc
,
436 Attribute_Name
=> Name_Length
,
437 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
438 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, J
))));
442 end Compute_Number_Components
;
444 -------------------------
445 -- Convert_To_PAT_Type --
446 -------------------------
448 -- The PAT is always obtained from the actual subtype
450 procedure Convert_To_PAT_Type
(Aexp
: Node_Id
) is
454 Convert_To_Actual_Subtype
(Aexp
);
455 Act_ST
:= Underlying_Type
(Etype
(Aexp
));
456 Create_Packed_Array_Impl_Type
(Act_ST
);
458 -- Just replace the etype with the packed array type. This works because
459 -- the expression will not be further analyzed, and Gigi considers the
460 -- two types equivalent in any case.
462 -- This is not strictly the case ??? If the reference is an actual in
463 -- call, the expansion of the prefix is delayed, and must be reanalyzed,
464 -- see Reset_Packed_Prefix. On the other hand, if the prefix is a simple
465 -- array reference, reanalysis can produce spurious type errors when the
466 -- PAT type is replaced again with the original type of the array. Same
467 -- for the case of a dereference. Ditto for function calls: expansion
468 -- may introduce additional actuals which will trigger errors if call is
469 -- reanalyzed. The following is correct and minimal, but the handling of
470 -- more complex packed expressions in actuals is confused. Probably the
471 -- problem only remains for actuals in calls.
473 Set_Etype
(Aexp
, Packed_Array_Impl_Type
(Act_ST
));
475 if Is_Entity_Name
(Aexp
)
477 (Nkind
(Aexp
) = N_Indexed_Component
478 and then Is_Entity_Name
(Prefix
(Aexp
)))
479 or else Nkind
(Aexp
) in N_Explicit_Dereference | N_Function_Call
483 end Convert_To_PAT_Type
;
485 -----------------------------------
486 -- Create_Packed_Array_Impl_Type --
487 -----------------------------------
489 procedure Create_Packed_Array_Impl_Type
(Typ
: Entity_Id
) is
490 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
491 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
492 Csize
: constant Uint
:= Component_Size
(Typ
);
496 PASize
: Uint
:= No_Uint
;
506 procedure Install_PAT
;
507 -- This procedure is called with Decl set to the declaration for the
508 -- packed array type. It creates the type and installs it as required.
510 procedure Set_PB_Type
;
511 -- Set PB_Type to [Rev_]Packed_Bytes{1,2,4} as required by the alignment
512 -- and the scalar storage order requirements (see documentation in the
513 -- spec of this package).
519 procedure Install_PAT
is
520 Pushed_Scope
: Boolean := False;
523 -- We do not want to put the declaration we have created in the tree
524 -- since it is often hard, and sometimes impossible to find a proper
525 -- place for it (the impossible case arises for a packed array type
526 -- with bounds depending on the discriminant, a declaration cannot
527 -- be put inside the record, and the reference to the discriminant
528 -- cannot be outside the record).
530 -- The solution is to analyze the declaration while temporarily
531 -- attached to the tree at an appropriate point, and then we install
532 -- the resulting type as an Itype in the packed array type field of
533 -- the original type, so that no explicit declaration is required.
535 -- Note: the packed type is created in the scope of its parent type.
536 -- There are at least some cases where the current scope is deeper,
537 -- and so when this is the case, we temporarily reset the scope
538 -- for the definition. This is clearly safe, since the first use
539 -- of the packed array type will be the implicit reference from
540 -- the corresponding unpacked type when it is elaborated.
542 if Is_Itype
(Typ
) then
543 Set_Parent
(Decl
, Associated_Node_For_Itype
(Typ
));
545 Set_Parent
(Decl
, Declaration_Node
(Typ
));
548 if Scope
(Typ
) /= Current_Scope
then
549 Push_Scope
(Scope
(Typ
));
550 Pushed_Scope
:= True;
553 Set_Is_Itype
(PAT
, True);
554 Set_Is_Packed_Array_Impl_Type
(PAT
, True);
555 Set_Packed_Array_Impl_Type
(Typ
, PAT
);
556 Analyze
(Decl
, Suppress
=> All_Checks
);
562 -- Set Esize and RM_Size to the actual size of the packed object
563 -- Do not reset RM_Size if already set, as happens in the case of
566 if Present
(PASize
) then
567 if not Known_Esize
(PAT
) then
568 Set_Esize
(PAT
, PASize
);
571 if not Known_RM_Size
(PAT
) then
572 Set_RM_Size
(PAT
, PASize
);
576 -- In the case of a modular type, make sure the alignment is
577 -- consistent with the Esize.
579 if Is_Scalar_Type
(PAT
) then
580 while Alignment
(PAT
) * System_Storage_Unit
< Esize
(PAT
)
581 and then Alignment
(PAT
) < Maximum_Alignment
583 Set_Alignment
(PAT
, 2 * Alignment
(PAT
));
587 -- Then, in all cases, make sure the opposite is also true
589 Adjust_Esize_Alignment
(PAT
);
591 -- Set remaining fields of packed array type
593 Set_Parent
(PAT
, Empty
);
594 Set_Associated_Node_For_Itype
(PAT
, Typ
);
595 Set_Original_Array_Type
(PAT
, Typ
);
597 -- Propagate representation aspects
599 Set_Is_Atomic
(PAT
, Is_Atomic
(Typ
));
600 Set_Is_Independent
(PAT
, Is_Independent
(Typ
));
601 Set_Is_Volatile
(PAT
, Is_Volatile
(Typ
));
602 Set_Is_Volatile_Full_Access
(PAT
, Is_Volatile_Full_Access
(Typ
));
603 Set_Treat_As_Volatile
(PAT
, Treat_As_Volatile
(Typ
));
605 -- We definitely do not want to delay freezing for packed array
606 -- types. This is of particular importance for the itypes that are
607 -- generated for record components depending on discriminants where
608 -- there is no place to put the freeze node.
610 Set_Has_Delayed_Freeze
(PAT
, False);
611 Set_Has_Delayed_Freeze
(Etype
(PAT
), False);
613 -- If we did allocate a freeze node, then clear out the reference
614 -- since it is obsolete (should we delete the freeze node???)
616 Set_Freeze_Node
(PAT
, Empty
);
617 Set_Freeze_Node
(Etype
(PAT
), Empty
);
624 procedure Set_PB_Type
is
626 -- If the user has specified an explicit alignment for the
627 -- type or component, take it into account.
629 if Csize
<= 2 or else Csize
= 4 or else Csize
mod 2 /= 0
630 or else (Known_Alignment
(Typ
) and then Alignment
(Typ
) = 1)
631 or else Component_Alignment
(Typ
) = Calign_Storage_Unit
633 if Reverse_Storage_Order
(Typ
) then
634 PB_Type
:= RTE
(RE_Rev_Packed_Bytes1
);
636 PB_Type
:= RTE
(RE_Packed_Bytes1
);
639 elsif Csize
mod 4 /= 0
640 or else (Known_Alignment
(Typ
) and then Alignment
(Typ
) = 2)
642 if Reverse_Storage_Order
(Typ
) then
643 PB_Type
:= RTE
(RE_Rev_Packed_Bytes2
);
645 PB_Type
:= RTE
(RE_Packed_Bytes2
);
649 if Reverse_Storage_Order
(Typ
) then
650 PB_Type
:= RTE
(RE_Rev_Packed_Bytes4
);
652 PB_Type
:= RTE
(RE_Packed_Bytes4
);
656 -- The Rev_Packed_Bytes{1,2,4} types cannot be directly declared with
657 -- the reverse scalar storage order in System.Unsigned_Types because
658 -- their component type is aliased and the combination would then be
659 -- flagged as illegal by the compiler. Moreover changing the compiler
660 -- would not address the bootstrap path issue with earlier versions.
662 Set_Reverse_Storage_Order
(PB_Type
, Reverse_Storage_Order
(Typ
));
665 -- Start of processing for Create_Packed_Array_Impl_Type
668 -- If we already have a packed array type, nothing to do
670 if Present
(Packed_Array_Impl_Type
(Typ
)) then
674 -- If our immediate ancestor subtype is constrained, and it already has
675 -- a packed array type, and it has the same size, then just share the
676 -- same type, since the bounds must be the same. If the ancestor is not
677 -- an array type but a private type, as can happen with multiple
678 -- instantiations, create a new packed type, to avoid privacy issues.
680 if Ekind
(Typ
) = E_Array_Subtype
then
681 Ancest
:= Ancestor_Subtype
(Typ
);
684 and then Is_Array_Type
(Ancest
)
685 and then Is_Constrained
(Ancest
)
686 and then Present
(Packed_Array_Impl_Type
(Ancest
))
687 and then Known_Esize
(Typ
)
688 and then Known_Esize
(Ancest
)
689 and then Esize
(Typ
) = Esize
(Ancest
)
691 Set_Packed_Array_Impl_Type
(Typ
, Packed_Array_Impl_Type
(Ancest
));
696 -- We preset the result type size from the size of the original array
697 -- type, since this size clearly belongs to the packed array type. The
698 -- size of the conceptual unpacked type is always set to unknown.
700 if Known_RM_Size
(Typ
) then
701 PASize
:= RM_Size
(Typ
);
704 -- Case of an array where at least one index is of an enumeration
705 -- type with a non-standard representation, but the component size
706 -- is not appropriate for bit packing. This is the case where we
707 -- have Is_Packed set (we would never be in this unit otherwise),
708 -- but Is_Bit_Packed_Array is false.
710 -- Note that if the component size is appropriate for bit packing,
711 -- then the circuit for the computation of the subscript properly
712 -- deals with the non-standard enumeration type case by taking the
715 if not Is_Bit_Packed_Array
(Typ
) then
717 -- Here we build a declaration:
719 -- type tttP is array (index1, index2, ...) of component_type
721 -- where index1, index2, are the index types. These are the same
722 -- as the index types of the original array, except for the non-
723 -- standard representation enumeration type case, where we have
726 -- For the unconstrained array case, we use
730 -- For the constrained case, we use
732 -- Natural range Enum_Type'Pos (Enum_Type'First) ..
733 -- Enum_Type'Pos (Enum_Type'Last);
735 -- Note that tttP is created even if no index subtype is a non
736 -- standard enumeration, because we still need to remove padding
737 -- normally inserted for component alignment.
740 Make_Defining_Identifier
(Loc
,
741 Chars
=> New_External_Name
(Chars
(Typ
), 'P'));
744 Indexes
: constant List_Id
:= New_List
;
746 Indx_Typ
: Entity_Id
;
751 Indx
:= First_Index
(Typ
);
753 while Present
(Indx
) loop
754 Indx_Typ
:= Etype
(Indx
);
756 Enum_Case
:= Is_Enumeration_Type
(Indx_Typ
)
757 and then Has_Non_Standard_Rep
(Indx_Typ
);
759 -- Unconstrained case
761 if not Is_Constrained
(Typ
) then
763 Indx_Typ
:= Standard_Natural
;
766 Append_To
(Indexes
, New_Occurrence_Of
(Indx_Typ
, Loc
));
771 if not Enum_Case
then
772 Append_To
(Indexes
, New_Occurrence_Of
(Indx_Typ
, Loc
));
776 Make_Subtype_Indication
(Loc
,
778 New_Occurrence_Of
(Standard_Natural
, Loc
),
780 Make_Range_Constraint
(Loc
,
784 Make_Attribute_Reference
(Loc
,
786 New_Occurrence_Of
(Indx_Typ
, Loc
),
787 Attribute_Name
=> Name_Pos
,
788 Expressions
=> New_List
(
789 Make_Attribute_Reference
(Loc
,
791 New_Occurrence_Of
(Indx_Typ
, Loc
),
792 Attribute_Name
=> Name_First
))),
795 Make_Attribute_Reference
(Loc
,
797 New_Occurrence_Of
(Indx_Typ
, Loc
),
798 Attribute_Name
=> Name_Pos
,
799 Expressions
=> New_List
(
800 Make_Attribute_Reference
(Loc
,
802 New_Occurrence_Of
(Indx_Typ
, Loc
),
803 Attribute_Name
=> Name_Last
)))))));
811 if not Is_Constrained
(Typ
) then
813 Make_Unconstrained_Array_Definition
(Loc
,
814 Subtype_Marks
=> Indexes
,
815 Component_Definition
=>
816 Make_Component_Definition
(Loc
,
817 Aliased_Present
=> False,
818 Subtype_Indication
=>
819 New_Occurrence_Of
(Ctyp
, Loc
)));
823 Make_Constrained_Array_Definition
(Loc
,
824 Discrete_Subtype_Definitions
=> Indexes
,
825 Component_Definition
=>
826 Make_Component_Definition
(Loc
,
827 Aliased_Present
=> False,
828 Subtype_Indication
=>
829 New_Occurrence_Of
(Ctyp
, Loc
)));
833 Make_Full_Type_Declaration
(Loc
,
834 Defining_Identifier
=> PAT
,
835 Type_Definition
=> Typedef
);
840 -- Propagate the reverse storage order flag to the base type
842 Set_Reverse_Storage_Order
(Etype
(PAT
), Reverse_Storage_Order
(Typ
));
845 -- Case of bit-packing required for unconstrained array. We create
846 -- a subtype that is equivalent to use Packed_Bytes{1,2,4} as needed.
848 elsif not Is_Constrained
(Typ
) then
850 -- When generating standard DWARF (i.e when GNAT_Encodings is not
851 -- DWARF_GNAT_Encodings_All), the ___XP suffix will be stripped
852 -- by the back-end but generate it anyway to ease compiler debugging.
853 -- This will help to distinguish implementation types from original
857 Make_Defining_Identifier
(Loc
,
858 Chars
=> Make_Packed_Array_Impl_Type_Name
(Typ
, Csize
));
863 Make_Subtype_Declaration
(Loc
,
864 Defining_Identifier
=> PAT
,
865 Subtype_Indication
=> New_Occurrence_Of
(PB_Type
, Loc
));
870 -- Remaining code is for the case of bit-packing for constrained array
872 -- The name of the packed array subtype is
876 -- where sss is the component size in bits and ttt is the name of
877 -- the parent packed type.
881 Make_Defining_Identifier
(Loc
,
882 Chars
=> Make_Packed_Array_Impl_Type_Name
(Typ
, Csize
));
884 -- Build an expression for the length of the array in bits.
885 -- This is the product of the length of each of the dimensions
887 Len_Expr
:= Compute_Number_Components
(Typ
, Typ
);
889 -- Temporarily attach the length expression to the tree and analyze
890 -- and resolve it, so that we can test its value. We assume that the
891 -- total length fits in type Integer. This expression may involve
892 -- discriminants, so we treat it as a default/per-object expression.
894 Set_Parent
(Len_Expr
, Typ
);
895 Preanalyze_Spec_Expression
(Len_Expr
, Standard_Long_Long_Integer
);
897 -- Use a modular type if possible. We can do this if we have
898 -- static bounds, and the length is small enough, and the length
899 -- is not zero. We exclude the zero length case because the size
900 -- of things is always at least one, and the zero length object
901 -- would have an anomalous size.
903 if Compile_Time_Known_Value
(Len_Expr
) then
904 Len_Bits
:= Expr_Value
(Len_Expr
) * Csize
;
906 -- Check for size known to be too large
909 Uint_2
** (Standard_Integer_Size
- 1) * System_Storage_Unit
911 if System_Storage_Unit
= 8 then
913 ("packed array size cannot exceed " &
914 "Integer''Last bytes", Typ
);
917 ("packed array size cannot exceed " &
918 "Integer''Last storage units", Typ
);
921 -- Reset length to arbitrary not too high value to continue
923 Len_Expr
:= Make_Integer_Literal
(Loc
, 65535);
924 Analyze_And_Resolve
(Len_Expr
, Standard_Long_Long_Integer
);
927 -- We normally consider small enough to mean no larger than the
928 -- value of System_Max_Binary_Modulus_Power, checking that in the
929 -- case of values longer than word size, we have long shifts.
933 (Len_Bits
<= System_Word_Size
934 or else (Len_Bits
<= System_Max_Binary_Modulus_Power
935 and then Support_Long_Shifts_On_Target
))
937 -- We can use the modular type, it has the form:
939 -- subtype tttPn is btyp
940 -- range 0 .. 2 ** ((Typ'Length (1)
941 -- * ... * Typ'Length (n)) * Csize) - 1;
943 -- The bounds are statically known, and btyp is one of the
944 -- unsigned types, depending on the length.
946 Btyp
:= Small_Integer_Type_For
(Len_Bits
, Uns
=> True);
947 Lit
:= Make_Integer_Literal
(Loc
, 2 ** Len_Bits
- 1);
948 Set_Print_In_Hex
(Lit
);
951 Make_Subtype_Declaration
(Loc
,
952 Defining_Identifier
=> PAT
,
953 Subtype_Indication
=>
954 Make_Subtype_Indication
(Loc
,
955 Subtype_Mark
=> New_Occurrence_Of
(Btyp
, Loc
),
958 Make_Range_Constraint
(Loc
,
962 Make_Integer_Literal
(Loc
, 0),
963 High_Bound
=> Lit
))));
965 if Present
(PASize
) then
971 -- Propagate a given alignment to the modular type. This can
972 -- cause it to be under-aligned, but that's OK.
974 if Present
(Alignment_Clause
(Typ
)) then
975 Set_Alignment
(PAT
, Alignment
(Typ
));
982 -- Could not use a modular type, for all other cases, we build
983 -- a packed array subtype:
986 -- System.Packed_Bytes{1,2,4} (0 .. (Bits + 7) / 8 - 1);
988 -- Bits is the length of the array in bits
995 Make_Op_Multiply
(Loc
,
997 Make_Integer_Literal
(Loc
, Csize
),
998 Right_Opnd
=> Len_Expr
),
1001 Make_Integer_Literal
(Loc
, 7));
1003 Set_Paren_Count
(Bits_U1
, 1);
1006 Make_Op_Subtract
(Loc
,
1008 Make_Op_Divide
(Loc
,
1009 Left_Opnd
=> Bits_U1
,
1010 Right_Opnd
=> Make_Integer_Literal
(Loc
, 8)),
1011 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
1014 Make_Subtype_Declaration
(Loc
,
1015 Defining_Identifier
=> PAT
,
1016 Subtype_Indication
=>
1017 Make_Subtype_Indication
(Loc
,
1018 Subtype_Mark
=> New_Occurrence_Of
(PB_Type
, Loc
),
1020 Make_Index_Or_Discriminant_Constraint
(Loc
,
1021 Constraints
=> New_List
(
1024 Make_Integer_Literal
(Loc
, 0),
1026 Convert_To
(Standard_Integer
, PAT_High
))))));
1030 -- Currently the code in this unit requires that packed arrays
1031 -- represented by non-modular arrays of bytes be on a byte
1032 -- boundary for bit sizes handled by System.Pack_nn units.
1033 -- That's because these units assume the array being accessed
1034 -- starts on a byte boundary.
1036 if Get_Id
(UI_To_Int
(Csize
)) /= RE_Null
then
1037 Set_Must_Be_On_Byte_Boundary
(Typ
);
1040 end Create_Packed_Array_Impl_Type
;
1042 -----------------------------------
1043 -- Expand_Bit_Packed_Element_Set --
1044 -----------------------------------
1046 procedure Expand_Bit_Packed_Element_Set
(N
: Node_Id
) is
1047 Loc
: constant Source_Ptr
:= Sloc
(N
);
1048 Lhs
: constant Node_Id
:= Name
(N
);
1050 Ass_OK
: constant Boolean := Assignment_OK
(Lhs
);
1051 -- Used to preserve assignment OK status when assignment is rewritten
1055 Rhs
: Node_Id
:= Expression
(N
);
1056 -- Initially Rhs is the right hand side value, it will be replaced
1057 -- later by an appropriate unchecked conversion for the assignment.
1067 -- The expression for the shift value that is required
1069 Shift_Used
: Boolean := False;
1070 -- Set True if Shift has been used in the generated code at least once,
1071 -- so that it must be duplicated if used again.
1077 -- If the value of the right hand side as an integer constant is
1078 -- known at compile time, Rhs_Val contains the value.
1080 function Get_Shift
return Node_Id
;
1081 -- Function used to get the value of Shift, making sure that it
1082 -- gets duplicated if the function is called more than once.
1088 function Get_Shift
return Node_Id
is
1090 -- If we used the shift value already, then duplicate it. We
1091 -- set a temporary parent in case actions have to be inserted.
1094 Set_Parent
(Shift
, N
);
1095 return Duplicate_Subexpr_No_Checks
(Shift
);
1097 -- If first time, use Shift unchanged, and set flag for first use
1105 -- Start of processing for Expand_Bit_Packed_Element_Set
1108 pragma Assert
(Is_Bit_Packed_Array
(Etype
(Prefix
(Lhs
))));
1110 Obj
:= Relocate_Node
(Prefix
(Lhs
));
1111 Convert_To_Actual_Subtype
(Obj
);
1112 Atyp
:= Etype
(Obj
);
1113 PAT
:= Packed_Array_Impl_Type
(Atyp
);
1114 Ctyp
:= Component_Type
(Atyp
);
1115 Csiz
:= UI_To_Int
(Component_Size
(Atyp
));
1117 -- We remove side effects, in case the rhs modifies the lhs, because we
1118 -- are about to transform the rhs into an expression that first READS
1119 -- the lhs, so we can do the necessary shifting and masking. Example:
1120 -- "X(2) := F(...);" where F modifies X(3). Otherwise, the side effect
1123 Remove_Side_Effects
(Rhs
);
1125 -- We convert the right hand side to the proper subtype to ensure
1126 -- that an appropriate range check is made (since the normal range
1127 -- check from assignment will be lost in the transformations). This
1128 -- conversion is analyzed immediately so that subsequent processing
1129 -- can work with an analyzed Rhs (and e.g. look at its Etype)
1131 -- If the right-hand side is a string literal, create a temporary for
1132 -- it, constant-folding is not ready to wrap the bit representation
1133 -- of a string literal.
1135 if Nkind
(Rhs
) = N_String_Literal
then
1137 Decl
: constant Node_Id
:=
1138 Make_Object_Declaration
(Loc
,
1139 Defining_Identifier
=> Make_Temporary
(Loc
, 'T', Rhs
),
1140 Object_Definition
=> New_Occurrence_Of
(Ctyp
, Loc
),
1141 Expression
=> New_Copy_Tree
(Rhs
));
1143 Insert_Actions
(N
, New_List
(Decl
));
1144 Rhs
:= New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
);
1147 Rhs
:= Convert_To
(Ctyp
, Rhs
);
1150 Set_Parent
(Rhs
, N
);
1152 -- If we are building the initialization procedure for a packed array,
1153 -- and Initialize_Scalars is enabled, each component assignment is an
1154 -- out-of-range value by design. Compile this value without checks,
1155 -- because a call to the array init_proc must not raise an exception.
1157 -- Condition is not consistent with description above, Within_Init_Proc
1158 -- is True also when we are building the IP for a record or protected
1159 -- type that has a packed array component???
1162 and then Initialize_Scalars
1164 Analyze_And_Resolve
(Rhs
, Ctyp
, Suppress
=> All_Checks
);
1166 Analyze_And_Resolve
(Rhs
, Ctyp
);
1169 -- If any of the indices has a nonstandard representation, introduce
1170 -- the proper Rep_To_Pos conversion, which in turn will generate index
1171 -- checks when needed. We do this on a copy of the index expression,
1172 -- rather that rewriting the LHS altogether.
1174 Expr
:= First
(Expressions
(Lhs
));
1175 while Present
(Expr
) loop
1177 Expr_Typ
: constant Entity_Id
:= Etype
(Expr
);
1178 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
1180 Expr_Copy
: Node_Id
;
1183 if Is_Enumeration_Type
(Expr_Typ
)
1184 and then Has_Non_Standard_Rep
(Expr_Typ
)
1187 Make_Attribute_Reference
(Loc
,
1188 Prefix
=> New_Occurrence_Of
(Expr_Typ
, Loc
),
1189 Attribute_Name
=> Name_Pos
,
1190 Expressions
=> New_List
(Relocate_Node
(Expr
)));
1191 Set_Parent
(Expr_Copy
, N
);
1192 Analyze_And_Resolve
(Expr_Copy
, Standard_Natural
);
1199 -- Case of component size 1,2,4 or any component size for the modular
1200 -- case. These are the cases for which we can inline the code.
1202 if Csiz
= 1 or else Csiz
= 2 or else Csiz
= 4
1203 or else (Present
(PAT
) and then Is_Modular_Integer_Type
(PAT
))
1205 Setup_Inline_Packed_Array_Reference
(Lhs
, Atyp
, Obj
, Cmask
, Shift
);
1207 -- The statement to be generated is:
1209 -- Obj := atyp!((Obj and Mask1) or (shift_left (rhs, Shift)))
1211 -- or in the case of a freestanding Reverse_Storage_Order object,
1213 -- Obj := Swap (atyp!((Swap (Obj) and Mask1)
1214 -- or (shift_left (rhs, Shift))))
1216 -- where Mask1 is obtained by shifting Cmask left Shift bits
1217 -- and then complementing the result.
1219 -- the "and Mask1" is omitted if rhs is constant and all 1 bits
1221 -- the "or ..." is omitted if rhs is constant and all 0 bits
1223 -- rhs is converted to the appropriate type
1225 -- The result is converted back to the array type, since
1226 -- otherwise we lose knowledge of the packed nature.
1228 -- Determine if right side is all 0 bits or all 1 bits
1230 if Compile_Time_Known_Value
(Rhs
) then
1231 Rhs_Val
:= Expr_Rep_Value
(Rhs
);
1233 -- The following test catches the case of an unchecked conversion of
1234 -- an integer literal. This results from optimizing aggregates of
1237 elsif Nkind
(Rhs
) = N_Unchecked_Type_Conversion
1238 and then Compile_Time_Known_Value
(Expression
(Rhs
))
1240 Rhs_Val
:= Expr_Rep_Value
(Expression
(Rhs
));
1246 -- Some special checks for the case where the right hand value is
1247 -- known at compile time. Basically we have to take care of the
1248 -- implicit conversion to the subtype of the component object.
1250 if Present
(Rhs_Val
) then
1252 -- If we have a biased component type then we must manually do the
1253 -- biasing, since we are taking responsibility in this case for
1254 -- constructing the exact bit pattern to be used.
1256 if Has_Biased_Representation
(Ctyp
) then
1257 Rhs_Val
:= Rhs_Val
- Expr_Rep_Value
(Type_Low_Bound
(Ctyp
));
1260 -- For a negative value, we manually convert the two's complement
1261 -- value to a corresponding unsigned value, so that the proper
1262 -- field width is maintained. If we did not do this, we would
1263 -- get too many leading sign bits later on.
1266 Rhs_Val
:= 2 ** UI_From_Int
(Csiz
) + Rhs_Val
;
1270 -- Now create copies removing side effects. Note that in some complex
1271 -- cases, this may cause the fact that we have already set a packed
1272 -- array type on Obj to get lost. So we save the type of Obj, and
1273 -- make sure it is reset properly.
1276 T
: constant Entity_Id
:= Etype
(Obj
);
1278 New_Lhs
:= Duplicate_Subexpr
(Obj
, Name_Req
=> True);
1279 New_Rhs
:= Duplicate_Subexpr_No_Checks
(Obj
);
1281 Set_Etype
(New_Lhs
, T
);
1282 Set_Etype
(New_Rhs
, T
);
1285 -- First we deal with the "and"
1287 if No
(Rhs_Val
) or else Rhs_Val
/= Cmask
then
1293 if Compile_Time_Known_Value
(Shift
) then
1295 Make_Integer_Literal
(Loc
,
1296 Modulus
(Etype
(Obj
)) - 1 -
1297 (Cmask
* (2 ** Expr_Value
(Get_Shift
))));
1298 Set_Print_In_Hex
(Mask1
);
1301 Lit
:= Make_Integer_Literal
(Loc
, Cmask
);
1302 Set_Print_In_Hex
(Lit
);
1305 Right_Opnd
=> Make_Shift_Left
(Lit
, Get_Shift
));
1310 Left_Opnd
=> New_Rhs
,
1311 Right_Opnd
=> Mask1
);
1315 -- Then deal with the "or"
1317 if No
(Rhs_Val
) or else Rhs_Val
/= 0 then
1321 procedure Fixup_Rhs
;
1322 -- Adjust Rhs by bias if biased representation for components
1323 -- or remove extraneous high order sign bits if signed.
1325 procedure Fixup_Rhs
is
1326 Etyp
: constant Entity_Id
:= Etype
(Rhs
);
1329 -- For biased case, do the required biasing by simply
1330 -- converting to the biased subtype (the conversion
1331 -- will generate the required bias).
1333 if Has_Biased_Representation
(Ctyp
) then
1334 Rhs
:= Convert_To
(Ctyp
, Rhs
);
1336 -- For a signed integer type that is not biased, generate
1337 -- a conversion to unsigned to strip high order sign bits.
1339 elsif Is_Signed_Integer_Type
(Ctyp
) then
1340 Rhs
:= Unchecked_Convert_To
(RTE
(Bits_Id
(Csiz
)), Rhs
);
1343 -- Set Etype, since it can be referenced before the node is
1344 -- completely analyzed.
1346 Set_Etype
(Rhs
, Etyp
);
1348 -- We now need to do an unchecked conversion of the
1349 -- result to the target type, but it is important that
1350 -- this conversion be a right justified conversion and
1351 -- not a left justified conversion.
1353 Rhs
:= RJ_Unchecked_Convert_To
(Etype
(Obj
), Rhs
);
1357 if Present
(Rhs_Val
)
1358 and then Compile_Time_Known_Value
(Get_Shift
)
1361 Make_Integer_Literal
(Loc
,
1362 Rhs_Val
* (2 ** Expr_Value
(Get_Shift
)));
1363 Set_Print_In_Hex
(Or_Rhs
);
1366 -- We have to convert the right hand side to Etype (Obj).
1367 -- A special case arises if what we have now is a Val
1368 -- attribute reference whose expression type is Etype (Obj).
1369 -- This happens for assignments of fields from the same
1370 -- array. In this case we get the required right hand side
1371 -- by simply removing the inner attribute reference.
1373 if Nkind
(Rhs
) = N_Attribute_Reference
1374 and then Attribute_Name
(Rhs
) = Name_Val
1375 and then Etype
(First
(Expressions
(Rhs
))) = Etype
(Obj
)
1377 Rhs
:= Relocate_Node
(First
(Expressions
(Rhs
)));
1380 -- If the value of the right hand side is a known integer
1381 -- value, then just replace it by an untyped constant,
1382 -- which will be properly retyped when we analyze and
1383 -- resolve the expression.
1385 elsif Present
(Rhs_Val
) then
1387 -- Note that Rhs_Val has already been normalized to
1388 -- be an unsigned value with the proper number of bits.
1390 Rhs
:= Make_Integer_Literal
(Loc
, Rhs_Val
);
1392 -- Otherwise we need an unchecked conversion
1398 Or_Rhs
:= Make_Shift_Left
(Rhs
, Get_Shift
);
1401 if Nkind
(New_Rhs
) = N_Op_And
then
1402 Set_Paren_Count
(New_Rhs
, 1);
1403 Set_Etype
(New_Rhs
, Etype
(Left_Opnd
(New_Rhs
)));
1408 Left_Opnd
=> New_Rhs
,
1409 Right_Opnd
=> Or_Rhs
);
1413 -- Now do the rewrite
1416 Make_Assignment_Statement
(Loc
,
1419 Unchecked_Convert_To
(Etype
(New_Lhs
), New_Rhs
)));
1420 Set_Assignment_OK
(Name
(N
), Ass_OK
);
1422 -- All other component sizes for non-modular case
1427 -- Set_nn (Arr'address, Subscr, Bits_nn!(Rhs))
1429 -- where Subscr is the computed linear subscript
1432 Bits_nn
: constant Entity_Id
:= RTE
(Bits_Id
(Csiz
));
1439 if No
(Bits_nn
) then
1441 -- Error, most likely High_Integrity_Mode restriction
1446 -- Acquire proper Set entity. We use the aligned or unaligned
1447 -- case as appropriate.
1449 if Known_Aligned_Enough
(Obj
, Csiz
) then
1450 Set_nn
:= RTE
(Set_Id
(Csiz
));
1452 Set_nn
:= RTE
(SetU_Id
(Csiz
));
1455 -- Now generate the set reference
1457 Obj
:= Relocate_Node
(Prefix
(Lhs
));
1458 Convert_To_Actual_Subtype
(Obj
);
1459 Atyp
:= Etype
(Obj
);
1460 Compute_Linear_Subscript
(Atyp
, Lhs
, Subscr
);
1462 -- Set indication of whether the packed array has reverse SSO
1466 (Boolean_Literals
(Reverse_Storage_Order
(Atyp
)), Loc
);
1468 -- Below we must make the assumption that Obj is
1469 -- at least byte aligned, since otherwise its address
1470 -- cannot be taken. The assumption holds since the
1471 -- only arrays that can be misaligned are small packed
1472 -- arrays which are implemented as a modular type, and
1473 -- that is not the case here.
1476 Make_Procedure_Call_Statement
(Loc
,
1477 Name
=> New_Occurrence_Of
(Set_nn
, Loc
),
1478 Parameter_Associations
=> New_List
(
1479 Make_Attribute_Reference
(Loc
,
1481 Attribute_Name
=> Name_Address
),
1483 Unchecked_Convert_To
(Bits_nn
, Convert_To
(Ctyp
, Rhs
)),
1489 Analyze
(N
, Suppress
=> All_Checks
);
1490 end Expand_Bit_Packed_Element_Set
;
1492 -------------------------------------
1493 -- Expand_Packed_Address_Reference --
1494 -------------------------------------
1496 procedure Expand_Packed_Address_Reference
(N
: Node_Id
) is
1497 Loc
: constant Source_Ptr
:= Sloc
(N
);
1502 -- We build an expression that has the form
1504 -- outer_object'Address
1505 -- + (linear-subscript * component_size for each array reference
1506 -- + field'Bit_Position for each record field
1508 -- + ...) / Storage_Unit;
1510 Get_Base_And_Bit_Offset
(Prefix
(N
), Base
, Offset
);
1513 Unchecked_Convert_To
(RTE
(RE_Address
),
1516 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
1517 Make_Attribute_Reference
(Loc
,
1519 Attribute_Name
=> Name_Address
)),
1522 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
1523 Make_Op_Divide
(Loc
,
1524 Left_Opnd
=> Offset
,
1526 Make_Integer_Literal
(Loc
, System_Storage_Unit
))))));
1528 Analyze_And_Resolve
(N
, RTE
(RE_Address
));
1529 end Expand_Packed_Address_Reference
;
1531 ---------------------------------
1532 -- Expand_Packed_Bit_Reference --
1533 ---------------------------------
1535 procedure Expand_Packed_Bit_Reference
(N
: Node_Id
) is
1536 Loc
: constant Source_Ptr
:= Sloc
(N
);
1541 -- We build an expression that has the form
1543 -- (linear-subscript * component_size for each array reference
1544 -- + field'Bit_Position for each record field
1546 -- + ...) mod Storage_Unit;
1548 Get_Base_And_Bit_Offset
(Prefix
(N
), Base
, Offset
);
1551 Unchecked_Convert_To
(Standard_Natural
,
1553 Left_Opnd
=> Offset
,
1554 Right_Opnd
=> Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
1556 Analyze_And_Resolve
(N
, Standard_Natural
);
1557 end Expand_Packed_Bit_Reference
;
1559 ------------------------------------
1560 -- Expand_Packed_Boolean_Operator --
1561 ------------------------------------
1563 -- This routine expands "a op b" for the packed cases
1565 procedure Expand_Packed_Boolean_Operator
(N
: Node_Id
) is
1566 Loc
: constant Source_Ptr
:= Sloc
(N
);
1567 Typ
: constant Entity_Id
:= Etype
(N
);
1568 L
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
1569 R
: Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
1576 Convert_To_Actual_Subtype
(L
);
1577 Convert_To_Actual_Subtype
(R
);
1579 Ensure_Defined
(Etype
(L
), N
);
1580 Ensure_Defined
(Etype
(R
), N
);
1582 Apply_Length_Check
(R
, Etype
(L
));
1587 -- Deal with silly case of XOR where the subcomponent has a range
1588 -- True .. True where an exception must be raised.
1590 if Nkind
(N
) = N_Op_Xor
then
1591 R
:= Duplicate_Subexpr
(R
);
1592 Silly_Boolean_Array_Xor_Test
(N
, R
, Rtyp
);
1595 -- Now that silliness is taken care of, get packed array type
1597 Convert_To_PAT_Type
(L
);
1598 Convert_To_PAT_Type
(R
);
1602 -- For the modular case, we expand a op b into
1604 -- rtyp!(pat!(a) op pat!(b))
1606 -- where rtyp is the Etype of the left operand. Note that we do not
1607 -- convert to the base type, since this would be unconstrained, and
1608 -- hence not have a corresponding packed array type set.
1610 -- Note that both operands must be modular for this code to be used
1612 if Is_Modular_Integer_Type
(PAT
)
1614 Is_Modular_Integer_Type
(Etype
(R
))
1620 if Nkind
(N
) = N_Op_And
then
1621 P
:= Make_Op_And
(Loc
, L
, R
);
1623 elsif Nkind
(N
) = N_Op_Or
then
1624 P
:= Make_Op_Or
(Loc
, L
, R
);
1626 else -- Nkind (N) = N_Op_Xor
1627 P
:= Make_Op_Xor
(Loc
, L
, R
);
1630 Rewrite
(N
, Unchecked_Convert_To
(Ltyp
, P
));
1633 -- For the array case, we insert the actions
1637 -- System.Bit_Ops.Bit_And/Or/Xor
1639 -- Ltype'Length * Ltype'Component_Size;
1641 -- Rtype'Length * Rtype'Component_Size
1644 -- where Left and Right are the Packed_Bytes{1,2,4} operands and
1645 -- the second argument and fourth arguments are the lengths of the
1646 -- operands in bits. Then we replace the expression by a reference
1649 -- Note that if we are mixing a modular and array operand, everything
1650 -- works fine, since we ensure that the modular representation has the
1651 -- same physical layout as the array representation (that's what the
1652 -- left justified modular stuff in the big-endian case is about).
1656 Result_Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
1660 if Nkind
(N
) = N_Op_And
then
1663 elsif Nkind
(N
) = N_Op_Or
then
1666 else -- Nkind (N) = N_Op_Xor
1670 Insert_Actions
(N
, New_List
(
1672 Make_Object_Declaration
(Loc
,
1673 Defining_Identifier
=> Result_Ent
,
1674 Object_Definition
=> New_Occurrence_Of
(Ltyp
, Loc
)),
1676 Make_Procedure_Call_Statement
(Loc
,
1677 Name
=> New_Occurrence_Of
(RTE
(E_Id
), Loc
),
1678 Parameter_Associations
=> New_List
(
1680 Make_Byte_Aligned_Attribute_Reference
(Loc
,
1682 Attribute_Name
=> Name_Address
),
1684 Make_Op_Multiply
(Loc
,
1686 Make_Attribute_Reference
(Loc
,
1689 (Etype
(First_Index
(Ltyp
)), Loc
),
1690 Attribute_Name
=> Name_Range_Length
),
1693 Make_Integer_Literal
(Loc
, Component_Size
(Ltyp
))),
1695 Make_Byte_Aligned_Attribute_Reference
(Loc
,
1697 Attribute_Name
=> Name_Address
),
1699 Make_Op_Multiply
(Loc
,
1701 Make_Attribute_Reference
(Loc
,
1704 (Etype
(First_Index
(Rtyp
)), Loc
),
1705 Attribute_Name
=> Name_Range_Length
),
1708 Make_Integer_Literal
(Loc
, Component_Size
(Rtyp
))),
1710 Make_Byte_Aligned_Attribute_Reference
(Loc
,
1711 Prefix
=> New_Occurrence_Of
(Result_Ent
, Loc
),
1712 Attribute_Name
=> Name_Address
)))));
1715 New_Occurrence_Of
(Result_Ent
, Loc
));
1719 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
1720 end Expand_Packed_Boolean_Operator
;
1722 -------------------------------------
1723 -- Expand_Packed_Element_Reference --
1724 -------------------------------------
1726 procedure Expand_Packed_Element_Reference
(N
: Node_Id
) is
1727 Loc
: constant Source_Ptr
:= Sloc
(N
);
1739 -- If the node is an actual in a call, the prefix has not been fully
1740 -- expanded, to account for the additional expansion for in-out actuals
1741 -- (see expand_actuals for details). If the prefix itself is a packed
1742 -- reference as well, we have to recurse to complete the transformation
1745 if Nkind
(Prefix
(N
)) = N_Indexed_Component
1746 and then not Analyzed
(Prefix
(N
))
1747 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Prefix
(N
))))
1749 Expand_Packed_Element_Reference
(Prefix
(N
));
1752 -- The prefix may be rewritten below as a conversion. If it is a source
1753 -- entity generate reference to it now, to prevent spurious warnings
1754 -- about unused entities.
1756 if Is_Entity_Name
(Prefix
(N
))
1757 and then Comes_From_Source
(Prefix
(N
))
1759 Generate_Reference
(Entity
(Prefix
(N
)), Prefix
(N
), 'r');
1762 -- If not bit packed, we have the enumeration case, which is easily
1763 -- dealt with (just adjust the subscripts of the indexed component)
1765 -- Note: this leaves the result as an indexed component, which is
1766 -- still a variable, so can be used in the assignment case, as is
1767 -- required in the enumeration case.
1769 if not Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
1770 Setup_Enumeration_Packed_Array_Reference
(N
);
1774 -- Remaining processing is for the bit-packed case
1776 Obj
:= Relocate_Node
(Prefix
(N
));
1777 Convert_To_Actual_Subtype
(Obj
);
1778 Atyp
:= Etype
(Obj
);
1779 PAT
:= Packed_Array_Impl_Type
(Atyp
);
1780 Ctyp
:= Component_Type
(Atyp
);
1781 Csiz
:= UI_To_Int
(Component_Size
(Atyp
));
1783 -- Case of component size 1,2,4 or any component size for the modular
1784 -- case. These are the cases for which we can inline the code.
1786 if Csiz
= 1 or else Csiz
= 2 or else Csiz
= 4
1787 or else (Present
(PAT
) and then Is_Modular_Integer_Type
(PAT
))
1789 Setup_Inline_Packed_Array_Reference
(N
, Atyp
, Obj
, Cmask
, Shift
);
1790 Lit
:= Make_Integer_Literal
(Loc
, Cmask
);
1791 Set_Print_In_Hex
(Lit
);
1793 -- We generate a shift right to position the field, followed by a
1794 -- masking operation to extract the bit field, and we finally do an
1795 -- unchecked conversion to convert the result to the required target.
1797 -- Note that the unchecked conversion automatically deals with the
1798 -- bias if we are dealing with a biased representation. What will
1799 -- happen is that we temporarily generate the biased representation,
1800 -- but almost immediately that will be converted to the original
1801 -- unbiased component type, and the bias will disappear.
1805 Left_Opnd
=> Make_Shift_Right
(Obj
, Shift
),
1807 Set_Etype
(Arg
, Ctyp
);
1809 -- Component extraction is performed on a native endianness scalar
1810 -- value: if Atyp has reverse storage order, then it has been byte
1811 -- swapped, and if the component being extracted is itself of a
1812 -- composite type with reverse storage order, then we need to swap
1813 -- it back to its expected endianness after extraction.
1815 if Reverse_Storage_Order
(Atyp
)
1816 and then (Is_Record_Type
(Ctyp
) or else Is_Array_Type
(Ctyp
))
1817 and then Reverse_Storage_Order
(Ctyp
)
1819 Arg
:= Revert_Storage_Order
(Arg
);
1822 -- We needed to analyze this before we do the unchecked convert
1823 -- below, but we need it temporarily attached to the tree for
1824 -- this analysis (hence the temporary Set_Parent call).
1826 Set_Parent
(Arg
, Parent
(N
));
1827 Analyze_And_Resolve
(Arg
);
1829 Rewrite
(N
, RJ_Unchecked_Convert_To
(Ctyp
, Arg
));
1831 -- All other component sizes for non-modular case
1836 -- Component_Type!(Get_nn (Arr'address, Subscr))
1838 -- where Subscr is the computed linear subscript
1843 Rev_SSO
: constant Node_Id
:=
1845 (Boolean_Literals
(Reverse_Storage_Order
(Atyp
)), Loc
);
1848 -- Acquire proper Get entity. We use the aligned or unaligned
1849 -- case as appropriate.
1851 if Known_Aligned_Enough
(Obj
, Csiz
) then
1852 Get_nn
:= RTE
(Get_Id
(Csiz
));
1854 Get_nn
:= RTE
(GetU_Id
(Csiz
));
1857 -- Now generate the get reference
1859 Compute_Linear_Subscript
(Atyp
, N
, Subscr
);
1861 -- Below we make the assumption that Obj is at least byte
1862 -- aligned, since otherwise its address cannot be taken.
1863 -- The assumption holds since the only arrays that can be
1864 -- misaligned are small packed arrays which are implemented
1865 -- as a modular type, and that is not the case here.
1868 Unchecked_Convert_To
(Ctyp
,
1869 Make_Function_Call
(Loc
,
1870 Name
=> New_Occurrence_Of
(Get_nn
, Loc
),
1871 Parameter_Associations
=> New_List
(
1872 Make_Attribute_Reference
(Loc
,
1874 Attribute_Name
=> Name_Address
),
1880 Analyze_And_Resolve
(N
, Ctyp
, Suppress
=> All_Checks
);
1881 end Expand_Packed_Element_Reference
;
1883 ----------------------
1884 -- Expand_Packed_Eq --
1885 ----------------------
1887 -- Handles expansion of "=" on packed array types
1889 procedure Expand_Packed_Eq
(N
: Node_Id
) is
1890 Loc
: constant Source_Ptr
:= Sloc
(N
);
1891 L
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
1892 R
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
1902 Convert_To_Actual_Subtype
(L
);
1903 Convert_To_Actual_Subtype
(R
);
1904 Ltyp
:= Underlying_Type
(Etype
(L
));
1905 Rtyp
:= Underlying_Type
(Etype
(R
));
1907 Convert_To_PAT_Type
(L
);
1908 Convert_To_PAT_Type
(R
);
1912 Make_Op_Multiply
(Loc
,
1913 Left_Opnd
=> Compute_Number_Components
(N
, Ltyp
),
1914 Right_Opnd
=> Make_Integer_Literal
(Loc
, Component_Size
(Ltyp
)));
1917 Make_Op_Multiply
(Loc
,
1918 Left_Opnd
=> Compute_Number_Components
(N
, Rtyp
),
1919 Right_Opnd
=> Make_Integer_Literal
(Loc
, Component_Size
(Rtyp
)));
1921 -- For the modular case, we transform the comparison to:
1923 -- Ltyp'Length = Rtyp'Length and then PAT!(L) = PAT!(R)
1925 -- where PAT is the packed array type. This works fine, since in the
1926 -- modular case we guarantee that the unused bits are always zeroes.
1927 -- We do have to compare the lengths because we could be comparing
1928 -- two different subtypes of the same base type. We can only do this
1929 -- if the PATs on both sides are modular (in which case they are
1930 -- necessarily structurally the same -- same Modulus and so on);
1931 -- otherwise, we have a case where the right operand is not of
1932 -- compile time known size.
1934 if Is_Modular_Integer_Type
(PAT
)
1935 and then Is_Modular_Integer_Type
(Etype
(R
))
1937 pragma Assert
(RM_Size
(Etype
(R
)) = RM_Size
(PAT
));
1938 pragma Assert
(Modulus
(Etype
(R
)) = Modulus
(PAT
));
1944 Left_Opnd
=> LLexpr
,
1945 Right_Opnd
=> RLexpr
),
1952 -- For the non-modular case, we call a runtime routine
1954 -- System.Bit_Ops.Bit_Eq
1955 -- (L'Address, L_Length, R'Address, R_Length)
1957 -- where PAT is the packed array type, and the lengths are the lengths
1958 -- in bits of the original packed arrays. This routine takes care of
1959 -- not comparing the unused bits in the last byte.
1963 Make_Function_Call
(Loc
,
1964 Name
=> New_Occurrence_Of
(RTE
(RE_Bit_Eq
), Loc
),
1965 Parameter_Associations
=> New_List
(
1966 Make_Byte_Aligned_Attribute_Reference
(Loc
,
1968 Attribute_Name
=> Name_Address
),
1972 Make_Byte_Aligned_Attribute_Reference
(Loc
,
1974 Attribute_Name
=> Name_Address
),
1979 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
1980 end Expand_Packed_Eq
;
1982 -----------------------
1983 -- Expand_Packed_Not --
1984 -----------------------
1986 -- Handles expansion of "not" on packed array types
1988 procedure Expand_Packed_Not
(N
: Node_Id
) is
1989 Loc
: constant Source_Ptr
:= Sloc
(N
);
1990 Typ
: constant Entity_Id
:= Etype
(N
);
1991 Opnd
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
1999 Convert_To_Actual_Subtype
(Opnd
);
2000 Rtyp
:= Etype
(Opnd
);
2002 -- Deal with silly False..False and True..True subtype case
2004 Silly_Boolean_Array_Not_Test
(N
, Rtyp
);
2006 -- Now that the silliness is taken care of, get packed array type
2008 Convert_To_PAT_Type
(Opnd
);
2009 PAT
:= Etype
(Opnd
);
2011 -- For the case where the packed array type is a modular type, "not A"
2012 -- expands simply into:
2014 -- Rtyp!(PAT!(A) xor Mask)
2016 -- where PAT is the packed array type, Mask is a mask of all 1 bits of
2017 -- length equal to the size of this packed type, and Rtyp is the actual
2018 -- actual subtype of the operand. Preserve old behavior in case size is
2021 if Known_RM_Size
(PAT
) then
2022 Size
:= RM_Size
(PAT
);
2026 Lit
:= Make_Integer_Literal
(Loc
, 2 ** Size
- 1);
2027 Set_Print_In_Hex
(Lit
);
2029 if not Is_Array_Type
(PAT
) then
2031 Unchecked_Convert_To
(Rtyp
,
2034 Right_Opnd
=> Lit
)));
2036 -- For the array case, we insert the actions
2040 -- System.Bit_Ops.Bit_Not
2042 -- Typ'Length * Typ'Component_Size,
2045 -- where Opnd is the Packed_Bytes{1,2,4} operand and the second argument
2046 -- is the length of the operand in bits. We then replace the expression
2047 -- with a reference to Result.
2051 Result_Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
2054 Insert_Actions
(N
, New_List
(
2055 Make_Object_Declaration
(Loc
,
2056 Defining_Identifier
=> Result_Ent
,
2057 Object_Definition
=> New_Occurrence_Of
(Rtyp
, Loc
)),
2059 Make_Procedure_Call_Statement
(Loc
,
2060 Name
=> New_Occurrence_Of
(RTE
(RE_Bit_Not
), Loc
),
2061 Parameter_Associations
=> New_List
(
2062 Make_Byte_Aligned_Attribute_Reference
(Loc
,
2064 Attribute_Name
=> Name_Address
),
2066 Make_Op_Multiply
(Loc
,
2068 Make_Attribute_Reference
(Loc
,
2071 (Etype
(First_Index
(Rtyp
)), Loc
),
2072 Attribute_Name
=> Name_Range_Length
),
2075 Make_Integer_Literal
(Loc
, Component_Size
(Rtyp
))),
2077 Make_Byte_Aligned_Attribute_Reference
(Loc
,
2078 Prefix
=> New_Occurrence_Of
(Result_Ent
, Loc
),
2079 Attribute_Name
=> Name_Address
)))));
2081 Rewrite
(N
, New_Occurrence_Of
(Result_Ent
, Loc
));
2085 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
2086 end Expand_Packed_Not
;
2088 -----------------------------
2089 -- Get_Base_And_Bit_Offset --
2090 -----------------------------
2092 procedure Get_Base_And_Bit_Offset
2095 Offset
: out Node_Id
)
2106 -- We build up an expression serially that has the form
2108 -- linear-subscript * component_size for each array component ref
2109 -- + pref.component'Bit_Position for each record component ref
2115 if Nkind
(Base
) = N_Indexed_Component
then
2116 Convert_To_Actual_Subtype
(Prefix
(Base
));
2117 Atyp
:= Etype
(Prefix
(Base
));
2118 Compute_Linear_Subscript
(Atyp
, Base
, Subscr
);
2121 Make_Op_Multiply
(Loc
,
2122 Left_Opnd
=> Subscr
,
2124 Make_Attribute_Reference
(Loc
,
2125 Prefix
=> New_Occurrence_Of
(Atyp
, Loc
),
2126 Attribute_Name
=> Name_Component_Size
));
2128 elsif Nkind
(Base
) = N_Selected_Component
then
2130 Make_Attribute_Reference
(Loc
,
2132 Attribute_Name
=> Name_Bit_Position
);
2144 Left_Opnd
=> Offset
,
2145 Right_Opnd
=> Term
);
2148 Base
:= Prefix
(Base
);
2150 end Get_Base_And_Bit_Offset
;
2152 -------------------------------------
2153 -- Involves_Packed_Array_Reference --
2154 -------------------------------------
2156 function Involves_Packed_Array_Reference
(N
: Node_Id
) return Boolean is
2158 if Nkind
(N
) = N_Indexed_Component
2159 and then Is_Bit_Packed_Array
(Etype
(Prefix
(N
)))
2163 elsif Nkind
(N
) = N_Selected_Component
then
2164 return Involves_Packed_Array_Reference
(Prefix
(N
));
2169 end Involves_Packed_Array_Reference
;
2171 --------------------------
2172 -- Known_Aligned_Enough --
2173 --------------------------
2175 function Known_Aligned_Enough
(Obj
: Node_Id
; Csiz
: Nat
) return Boolean is
2176 Typ
: constant Entity_Id
:= Etype
(Obj
);
2178 function In_Partially_Packed_Record
(Comp
: Entity_Id
) return Boolean;
2179 -- If the component is in a record that contains previous packed
2180 -- components, consider it unaligned because the back-end might
2181 -- choose to pack the rest of the record. Lead to less efficient code,
2182 -- but safer vis-a-vis of back-end choices.
2184 --------------------------------
2185 -- In_Partially_Packed_Record --
2186 --------------------------------
2188 function In_Partially_Packed_Record
(Comp
: Entity_Id
) return Boolean is
2189 Rec_Type
: constant Entity_Id
:= Scope
(Comp
);
2190 Prev_Comp
: Entity_Id
;
2193 Prev_Comp
:= First_Entity
(Rec_Type
);
2194 while Present
(Prev_Comp
) loop
2195 if Is_Packed
(Etype
(Prev_Comp
)) then
2198 elsif Prev_Comp
= Comp
then
2202 Next_Entity
(Prev_Comp
);
2206 end In_Partially_Packed_Record
;
2208 -- Start of processing for Known_Aligned_Enough
2211 -- Odd bit sizes don't need alignment anyway
2213 if Csiz
mod 2 = 1 then
2216 -- If we have a specified alignment, see if it is sufficient, if not
2217 -- then we can't possibly be aligned enough in any case.
2219 elsif Known_Alignment
(Etype
(Obj
)) then
2220 -- Alignment required is 4 if size is a multiple of 4, and
2221 -- 2 otherwise (e.g. 12 bits requires 4, 10 bits requires 2)
2223 if Alignment
(Etype
(Obj
)) < 4 - (Csiz
mod 4) then
2228 -- OK, alignment should be sufficient, if object is aligned
2230 -- If object is strictly aligned, then it is definitely aligned
2232 if Strict_Alignment
(Typ
) then
2235 -- Case of subscripted array reference
2237 elsif Nkind
(Obj
) = N_Indexed_Component
then
2239 -- If we have a pointer to an array, then this is definitely
2240 -- aligned, because pointers always point to aligned versions.
2242 if Is_Access_Type
(Etype
(Prefix
(Obj
))) then
2245 -- Otherwise, go look at the prefix
2248 return Known_Aligned_Enough
(Prefix
(Obj
), Csiz
);
2251 -- Case of record field
2253 elsif Nkind
(Obj
) = N_Selected_Component
then
2255 -- What is significant here is whether the record type is packed
2257 if Is_Record_Type
(Etype
(Prefix
(Obj
)))
2258 and then Is_Packed
(Etype
(Prefix
(Obj
)))
2262 -- Or the component has a component clause which might cause
2263 -- the component to become unaligned (we can't tell if the
2264 -- backend is doing alignment computations).
2266 elsif Present
(Component_Clause
(Entity
(Selector_Name
(Obj
)))) then
2269 elsif In_Partially_Packed_Record
(Entity
(Selector_Name
(Obj
))) then
2272 -- In all other cases, go look at prefix
2275 return Known_Aligned_Enough
(Prefix
(Obj
), Csiz
);
2278 elsif Nkind
(Obj
) = N_Type_Conversion
then
2279 return Known_Aligned_Enough
(Expression
(Obj
), Csiz
);
2281 -- For a formal parameter, it is safer to assume that it is not
2282 -- aligned, because the formal may be unconstrained while the actual
2283 -- is constrained. In this situation, a small constrained packed
2284 -- array, represented in modular form, may be unaligned.
2286 elsif Is_Entity_Name
(Obj
) then
2287 return not Is_Formal
(Entity
(Obj
));
2290 -- If none of the above, must be aligned
2293 end Known_Aligned_Enough
;
2295 ---------------------
2296 -- Make_Shift_Left --
2297 ---------------------
2299 function Make_Shift_Left
(N
: Node_Id
; S
: Node_Id
) return Node_Id
is
2303 if Compile_Time_Known_Value
(S
) and then Expr_Value
(S
) = 0 then
2307 Make_Op_Shift_Left
(Sloc
(N
),
2310 Set_Shift_Count_OK
(Nod
, True);
2313 end Make_Shift_Left
;
2315 ----------------------
2316 -- Make_Shift_Right --
2317 ----------------------
2319 function Make_Shift_Right
(N
: Node_Id
; S
: Node_Id
) return Node_Id
is
2323 if Compile_Time_Known_Value
(S
) and then Expr_Value
(S
) = 0 then
2327 Make_Op_Shift_Right
(Sloc
(N
),
2330 Set_Shift_Count_OK
(Nod
, True);
2333 end Make_Shift_Right
;
2335 -----------------------------
2336 -- RJ_Unchecked_Convert_To --
2337 -----------------------------
2339 function RJ_Unchecked_Convert_To
2341 Expr
: Node_Id
) return Node_Id
2343 Source_Typ
: constant Entity_Id
:= Etype
(Expr
);
2344 Target_Typ
: constant Entity_Id
:= Typ
;
2346 Src
: Node_Id
:= Expr
;
2352 Source_Siz
:= UI_To_Int
(RM_Size
(Source_Typ
));
2353 Target_Siz
:= UI_To_Int
(RM_Size
(Target_Typ
));
2355 -- For a little-endian target type stored byte-swapped on a
2356 -- big-endian machine, do not mask to Target_Siz bits.
2359 and then (Is_Record_Type
(Target_Typ
)
2361 Is_Array_Type
(Target_Typ
))
2362 and then Reverse_Storage_Order
(Target_Typ
)
2364 Source_Siz
:= Target_Siz
;
2367 -- First step, if the source type is not a discrete type, then we first
2368 -- convert to a modular type of the source length, since otherwise, on
2369 -- a big-endian machine, we get left-justification. We do it for little-
2370 -- endian machines as well, because there might be junk bits that are
2371 -- not cleared if the type is not numeric. This can be done only if the
2372 -- source siz is different from 0 (i.e. known), otherwise we must trust
2373 -- the type declarations (case of non-discrete components).
2376 and then Source_Siz
/= Target_Siz
2377 and then not Is_Discrete_Type
(Source_Typ
)
2379 Src
:= Unchecked_Convert_To
(RTE
(Bits_Id
(Source_Siz
)), Src
);
2382 -- In the big endian case, if the lengths of the two types differ, then
2383 -- we must worry about possible left justification in the conversion,
2384 -- and avoiding that is what this is all about.
2386 if Bytes_Big_Endian
and then Source_Siz
/= Target_Siz
then
2388 -- Next step. If the target is not a discrete type, then we first
2389 -- convert to a modular type of the target length, since otherwise,
2390 -- on a big-endian machine, we get left-justification.
2392 if not Is_Discrete_Type
(Target_Typ
) then
2393 Src
:= Unchecked_Convert_To
(RTE
(Bits_Id
(Target_Siz
)), Src
);
2397 -- And now we can do the final conversion to the target type
2399 return Unchecked_Convert_To
(Target_Typ
, Src
);
2400 end RJ_Unchecked_Convert_To
;
2402 ----------------------------------------------
2403 -- Setup_Enumeration_Packed_Array_Reference --
2404 ----------------------------------------------
2406 -- All we have to do here is to find the subscripts that correspond to the
2407 -- index positions that have non-standard enumeration types and insert a
2408 -- Pos attribute to get the proper subscript value.
2410 -- Finally the prefix must be uncheck-converted to the corresponding packed
2413 -- Note that the component type is unchanged, so we do not need to fiddle
2414 -- with the types (Gigi always automatically takes the packed array type if
2415 -- it is set, as it will be in this case).
2417 procedure Setup_Enumeration_Packed_Array_Reference
(N
: Node_Id
) is
2418 Pfx
: constant Node_Id
:= Prefix
(N
);
2419 Typ
: constant Entity_Id
:= Etype
(N
);
2420 Exprs
: constant List_Id
:= Expressions
(N
);
2424 -- If the array is unconstrained, then we replace the array reference
2425 -- with its actual subtype. This actual subtype will have a packed array
2426 -- type with appropriate bounds.
2428 if not Is_Constrained
(Packed_Array_Impl_Type
(Etype
(Pfx
))) then
2429 Convert_To_Actual_Subtype
(Pfx
);
2432 Expr
:= First
(Exprs
);
2433 while Present
(Expr
) loop
2435 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
2436 Expr_Typ
: constant Entity_Id
:= Etype
(Expr
);
2439 if Is_Enumeration_Type
(Expr_Typ
)
2440 and then Has_Non_Standard_Rep
(Expr_Typ
)
2443 Make_Attribute_Reference
(Loc
,
2444 Prefix
=> New_Occurrence_Of
(Expr_Typ
, Loc
),
2445 Attribute_Name
=> Name_Pos
,
2446 Expressions
=> New_List
(Relocate_Node
(Expr
))));
2447 Analyze_And_Resolve
(Expr
, Standard_Natural
);
2455 Make_Indexed_Component
(Sloc
(N
),
2457 Unchecked_Convert_To
(Packed_Array_Impl_Type
(Etype
(Pfx
)), Pfx
),
2458 Expressions
=> Exprs
));
2460 Analyze_And_Resolve
(N
, Typ
);
2461 end Setup_Enumeration_Packed_Array_Reference
;
2463 -----------------------------------------
2464 -- Setup_Inline_Packed_Array_Reference --
2465 -----------------------------------------
2467 procedure Setup_Inline_Packed_Array_Reference
2470 Obj
: in out Node_Id
;
2472 Shift
: out Node_Id
)
2474 Loc
: constant Source_Ptr
:= Sloc
(N
);
2477 Csiz
: constant Uint
:= Component_Size
(Atyp
);
2481 Convert_To_PAT_Type
(Obj
);
2484 Cmask
:= 2 ** Csiz
- 1;
2486 if Is_Array_Type
(PAT
) then
2487 Otyp
:= Component_Type
(PAT
);
2488 Osiz
:= Component_Size
(PAT
);
2493 -- In the case where the PAT is a modular type, we want the actual
2494 -- size in bits of the modular value we use. This is neither the
2495 -- Object_Size nor the Value_Size, either of which may have been
2496 -- reset to strange values, but rather the minimum size. Note that
2497 -- since this is a modular type with full range, the issue of
2498 -- biased representation does not arise.
2500 Osiz
:= UI_From_Int
(Minimum_Size
(Otyp
));
2503 Compute_Linear_Subscript
(Atyp
, N
, Shift
);
2505 -- If the component size is not 1, then the subscript must be multiplied
2506 -- by the component size to get the shift count.
2510 Make_Op_Multiply
(Loc
,
2511 Left_Opnd
=> Make_Integer_Literal
(Loc
, Csiz
),
2512 Right_Opnd
=> Shift
);
2515 -- If we have the array case, then this shift count must be broken down
2516 -- into a byte subscript, and a shift within the byte.
2518 if Is_Array_Type
(PAT
) then
2521 New_Shift
: Node_Id
;
2524 -- We must analyze shift, since we will duplicate it
2526 Set_Parent
(Shift
, N
);
2528 (Shift
, Standard_Integer
, Suppress
=> All_Checks
);
2530 -- The shift count within the word is
2535 Left_Opnd
=> Duplicate_Subexpr
(Shift
),
2536 Right_Opnd
=> Make_Integer_Literal
(Loc
, Osiz
));
2538 -- The subscript to be used on the PAT array is
2542 Make_Indexed_Component
(Loc
,
2544 Expressions
=> New_List
(
2545 Make_Op_Divide
(Loc
,
2546 Left_Opnd
=> Duplicate_Subexpr
(Shift
),
2547 Right_Opnd
=> Make_Integer_Literal
(Loc
, Osiz
))));
2552 -- For the modular integer case, the object to be manipulated is the
2553 -- entire array, so Obj is unchanged. Note that we will reset its type
2554 -- to PAT before returning to the caller.
2560 -- The one remaining step is to modify the shift count for the
2561 -- big-endian case. Consider the following example in a byte:
2563 -- xxxxxxxx bits of byte
2564 -- vvvvvvvv bits of value
2565 -- 33221100 little-endian numbering
2566 -- 00112233 big-endian numbering
2568 -- Here we have the case of 2-bit fields
2570 -- For the little-endian case, we already have the proper shift count
2571 -- set, e.g. for element 2, the shift count is 2*2 = 4.
2573 -- For the big endian case, we have to adjust the shift count, computing
2574 -- it as (N - F) - Shift, where N is the number of bits in an element of
2575 -- the array used to implement the packed array, F is the number of bits
2576 -- in a source array element, and Shift is the count so far computed.
2578 -- We also have to adjust if the storage order is reversed
2580 if Bytes_Big_Endian
xor Reverse_Storage_Order
(Base_Type
(Atyp
)) then
2582 Make_Op_Subtract
(Loc
,
2583 Left_Opnd
=> Make_Integer_Literal
(Loc
, Osiz
- Csiz
),
2584 Right_Opnd
=> Shift
);
2587 Set_Parent
(Shift
, N
);
2588 Set_Parent
(Obj
, N
);
2589 Analyze_And_Resolve
(Obj
, Otyp
, Suppress
=> All_Checks
);
2590 Analyze_And_Resolve
(Shift
, Standard_Integer
, Suppress
=> All_Checks
);
2592 -- Make sure final type of object is the appropriate packed type
2594 Set_Etype
(Obj
, Otyp
);
2596 end Setup_Inline_Packed_Array_Reference
;