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