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