annotate gcc/ada/exp_pakd.adb @ 131:84e7813d76e9

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