1 |
281 |
jeremybenn |
------------------------------------------------------------------------------
|
2 |
|
|
-- --
|
3 |
|
|
-- GNAT COMPILER COMPONENTS --
|
4 |
|
|
-- --
|
5 |
|
|
-- E X P _ I M G V --
|
6 |
|
|
-- --
|
7 |
|
|
-- B o d y --
|
8 |
|
|
-- --
|
9 |
|
|
-- Copyright (C) 2001-2008, Free Software Foundation, Inc. --
|
10 |
|
|
-- --
|
11 |
|
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
12 |
|
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
13 |
|
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
14 |
|
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
15 |
|
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
16 |
|
|
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
17 |
|
|
-- for more details. You should have received a copy of the GNU General --
|
18 |
|
|
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
19 |
|
|
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
20 |
|
|
-- --
|
21 |
|
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
22 |
|
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
23 |
|
|
-- --
|
24 |
|
|
------------------------------------------------------------------------------
|
25 |
|
|
|
26 |
|
|
with Atree; use Atree;
|
27 |
|
|
with Casing; use Casing;
|
28 |
|
|
with Checks; use Checks;
|
29 |
|
|
with Einfo; use Einfo;
|
30 |
|
|
with Exp_Util; use Exp_Util;
|
31 |
|
|
with Lib; use Lib;
|
32 |
|
|
with Namet; use Namet;
|
33 |
|
|
with Nmake; use Nmake;
|
34 |
|
|
with Nlists; use Nlists;
|
35 |
|
|
with Opt; use Opt;
|
36 |
|
|
with Rtsfind; use Rtsfind;
|
37 |
|
|
with Sem_Aux; use Sem_Aux;
|
38 |
|
|
with Sem_Res; use Sem_Res;
|
39 |
|
|
with Sinfo; use Sinfo;
|
40 |
|
|
with Snames; use Snames;
|
41 |
|
|
with Stand; use Stand;
|
42 |
|
|
with Stringt; use Stringt;
|
43 |
|
|
with Tbuild; use Tbuild;
|
44 |
|
|
with Ttypes; use Ttypes;
|
45 |
|
|
with Uintp; use Uintp;
|
46 |
|
|
|
47 |
|
|
package body Exp_Imgv is
|
48 |
|
|
|
49 |
|
|
------------------------------------
|
50 |
|
|
-- Build_Enumeration_Image_Tables --
|
51 |
|
|
------------------------------------
|
52 |
|
|
|
53 |
|
|
procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is
|
54 |
|
|
Loc : constant Source_Ptr := Sloc (E);
|
55 |
|
|
Str : String_Id;
|
56 |
|
|
Ind : List_Id;
|
57 |
|
|
Lit : Entity_Id;
|
58 |
|
|
Nlit : Nat;
|
59 |
|
|
Len : Nat;
|
60 |
|
|
Estr : Entity_Id;
|
61 |
|
|
Eind : Entity_Id;
|
62 |
|
|
Ityp : Node_Id;
|
63 |
|
|
|
64 |
|
|
begin
|
65 |
|
|
-- Nothing to do for other than a root enumeration type
|
66 |
|
|
|
67 |
|
|
if E /= Root_Type (E) then
|
68 |
|
|
return;
|
69 |
|
|
|
70 |
|
|
-- Nothing to do if pragma Discard_Names applies
|
71 |
|
|
|
72 |
|
|
elsif Discard_Names (E) then
|
73 |
|
|
return;
|
74 |
|
|
end if;
|
75 |
|
|
|
76 |
|
|
-- Otherwise tables need constructing
|
77 |
|
|
|
78 |
|
|
Start_String;
|
79 |
|
|
Ind := New_List;
|
80 |
|
|
Lit := First_Literal (E);
|
81 |
|
|
Len := 1;
|
82 |
|
|
Nlit := 0;
|
83 |
|
|
|
84 |
|
|
loop
|
85 |
|
|
Append_To (Ind,
|
86 |
|
|
Make_Integer_Literal (Loc, UI_From_Int (Len)));
|
87 |
|
|
|
88 |
|
|
exit when No (Lit);
|
89 |
|
|
Nlit := Nlit + 1;
|
90 |
|
|
|
91 |
|
|
Get_Unqualified_Decoded_Name_String (Chars (Lit));
|
92 |
|
|
|
93 |
|
|
if Name_Buffer (1) /= ''' then
|
94 |
|
|
Set_Casing (All_Upper_Case);
|
95 |
|
|
end if;
|
96 |
|
|
|
97 |
|
|
Store_String_Chars (Name_Buffer (1 .. Name_Len));
|
98 |
|
|
Len := Len + Int (Name_Len);
|
99 |
|
|
Next_Literal (Lit);
|
100 |
|
|
end loop;
|
101 |
|
|
|
102 |
|
|
if Len < Int (2 ** (8 - 1)) then
|
103 |
|
|
Ityp := Standard_Integer_8;
|
104 |
|
|
elsif Len < Int (2 ** (16 - 1)) then
|
105 |
|
|
Ityp := Standard_Integer_16;
|
106 |
|
|
else
|
107 |
|
|
Ityp := Standard_Integer_32;
|
108 |
|
|
end if;
|
109 |
|
|
|
110 |
|
|
Str := End_String;
|
111 |
|
|
|
112 |
|
|
Estr :=
|
113 |
|
|
Make_Defining_Identifier (Loc,
|
114 |
|
|
Chars => New_External_Name (Chars (E), 'S'));
|
115 |
|
|
|
116 |
|
|
Eind :=
|
117 |
|
|
Make_Defining_Identifier (Loc,
|
118 |
|
|
Chars => New_External_Name (Chars (E), 'N'));
|
119 |
|
|
|
120 |
|
|
Set_Lit_Strings (E, Estr);
|
121 |
|
|
Set_Lit_Indexes (E, Eind);
|
122 |
|
|
|
123 |
|
|
Insert_Actions (N,
|
124 |
|
|
New_List (
|
125 |
|
|
Make_Object_Declaration (Loc,
|
126 |
|
|
Defining_Identifier => Estr,
|
127 |
|
|
Constant_Present => True,
|
128 |
|
|
Object_Definition =>
|
129 |
|
|
New_Occurrence_Of (Standard_String, Loc),
|
130 |
|
|
Expression =>
|
131 |
|
|
Make_String_Literal (Loc,
|
132 |
|
|
Strval => Str)),
|
133 |
|
|
|
134 |
|
|
Make_Object_Declaration (Loc,
|
135 |
|
|
Defining_Identifier => Eind,
|
136 |
|
|
Constant_Present => True,
|
137 |
|
|
|
138 |
|
|
Object_Definition =>
|
139 |
|
|
Make_Constrained_Array_Definition (Loc,
|
140 |
|
|
Discrete_Subtype_Definitions => New_List (
|
141 |
|
|
Make_Range (Loc,
|
142 |
|
|
Low_Bound => Make_Integer_Literal (Loc, 0),
|
143 |
|
|
High_Bound => Make_Integer_Literal (Loc, Nlit))),
|
144 |
|
|
Component_Definition =>
|
145 |
|
|
Make_Component_Definition (Loc,
|
146 |
|
|
Aliased_Present => False,
|
147 |
|
|
Subtype_Indication => New_Occurrence_Of (Ityp, Loc))),
|
148 |
|
|
|
149 |
|
|
Expression =>
|
150 |
|
|
Make_Aggregate (Loc,
|
151 |
|
|
Expressions => Ind))),
|
152 |
|
|
Suppress => All_Checks);
|
153 |
|
|
end Build_Enumeration_Image_Tables;
|
154 |
|
|
|
155 |
|
|
----------------------------
|
156 |
|
|
-- Expand_Image_Attribute --
|
157 |
|
|
----------------------------
|
158 |
|
|
|
159 |
|
|
-- For all cases other than user defined enumeration types, the scheme
|
160 |
|
|
-- is as follows. First we insert the following code:
|
161 |
|
|
|
162 |
|
|
-- Snn : String (1 .. rt'Width);
|
163 |
|
|
-- Pnn : Natural;
|
164 |
|
|
-- Image_xx (tv, Snn, Pnn [,pm]);
|
165 |
|
|
--
|
166 |
|
|
-- and then Expr is replaced by Snn (1 .. Pnn)
|
167 |
|
|
|
168 |
|
|
-- In the above expansion:
|
169 |
|
|
|
170 |
|
|
-- rt is the root type of the expression
|
171 |
|
|
-- tv is the expression with the value, usually a type conversion
|
172 |
|
|
-- pm is an extra parameter present in some cases
|
173 |
|
|
|
174 |
|
|
-- The following table shows tv, xx, and (if used) pm for the various
|
175 |
|
|
-- possible types of the argument:
|
176 |
|
|
|
177 |
|
|
-- For types whose root type is Character
|
178 |
|
|
-- xx = Character
|
179 |
|
|
-- tv = Character (Expr)
|
180 |
|
|
|
181 |
|
|
-- For types whose root type is Boolean
|
182 |
|
|
-- xx = Boolean
|
183 |
|
|
-- tv = Boolean (Expr)
|
184 |
|
|
|
185 |
|
|
-- For signed integer types with size <= Integer'Size
|
186 |
|
|
-- xx = Integer
|
187 |
|
|
-- tv = Integer (Expr)
|
188 |
|
|
|
189 |
|
|
-- For other signed integer types
|
190 |
|
|
-- xx = Long_Long_Integer
|
191 |
|
|
-- tv = Long_Long_Integer (Expr)
|
192 |
|
|
|
193 |
|
|
-- For modular types with modulus <= System.Unsigned_Types.Unsigned
|
194 |
|
|
-- xx = Unsigned
|
195 |
|
|
-- tv = System.Unsigned_Types.Unsigned (Expr)
|
196 |
|
|
|
197 |
|
|
-- For other modular integer types
|
198 |
|
|
-- xx = Long_Long_Unsigned
|
199 |
|
|
-- tv = System.Unsigned_Types.Long_Long_Unsigned (Expr)
|
200 |
|
|
|
201 |
|
|
-- For types whose root type is Wide_Character
|
202 |
|
|
-- xx = Wide_Character
|
203 |
|
|
-- tv = Wide_Character (Expr)
|
204 |
|
|
-- pm = Boolean, true if Ada 2005 mode, False otherwise
|
205 |
|
|
|
206 |
|
|
-- For types whose root type is Wide_Wide_Character
|
207 |
|
|
-- xx = Wide_Wide_Character
|
208 |
|
|
-- tv = Wide_Wide_Character (Expr)
|
209 |
|
|
|
210 |
|
|
-- For floating-point types
|
211 |
|
|
-- xx = Floating_Point
|
212 |
|
|
-- tv = Long_Long_Float (Expr)
|
213 |
|
|
-- pm = typ'Digits (typ = subtype of expression)
|
214 |
|
|
|
215 |
|
|
-- For ordinary fixed-point types
|
216 |
|
|
-- xx = Ordinary_Fixed_Point
|
217 |
|
|
-- tv = Long_Long_Float (Expr)
|
218 |
|
|
-- pm = typ'Aft (typ = subtype of expression)
|
219 |
|
|
|
220 |
|
|
-- For decimal fixed-point types with size = Integer'Size
|
221 |
|
|
-- xx = Decimal
|
222 |
|
|
-- tv = Integer (Expr)
|
223 |
|
|
-- pm = typ'Scale (typ = subtype of expression)
|
224 |
|
|
|
225 |
|
|
-- For decimal fixed-point types with size > Integer'Size
|
226 |
|
|
-- xx = Long_Long_Decimal
|
227 |
|
|
-- tv = Long_Long_Integer?(Expr) [convert with no scaling]
|
228 |
|
|
-- pm = typ'Scale (typ = subtype of expression)
|
229 |
|
|
|
230 |
|
|
-- For enumeration types other than those declared packages Standard
|
231 |
|
|
-- or System, Snn, Pnn, are expanded as above, but the call looks like:
|
232 |
|
|
|
233 |
|
|
-- Image_Enumeration_NN (rt'Pos (X), Snn, Pnn, typS, typI'Address)
|
234 |
|
|
|
235 |
|
|
-- where rt is the root type of the expression, and typS and typI are
|
236 |
|
|
-- the entities constructed as described in the spec for the procedure
|
237 |
|
|
-- Build_Enumeration_Image_Tables and NN is 32/16/8 depending on the
|
238 |
|
|
-- element type of Lit_Indexes. The rewriting of the expression to
|
239 |
|
|
-- Snn (1 .. Pnn) then occurs as in the other cases. A special case is
|
240 |
|
|
-- when pragma Discard_Names applies, in which case we replace expr by:
|
241 |
|
|
|
242 |
|
|
-- Missing ???
|
243 |
|
|
|
244 |
|
|
procedure Expand_Image_Attribute (N : Node_Id) is
|
245 |
|
|
Loc : constant Source_Ptr := Sloc (N);
|
246 |
|
|
Exprs : constant List_Id := Expressions (N);
|
247 |
|
|
Pref : constant Node_Id := Prefix (N);
|
248 |
|
|
Ptyp : constant Entity_Id := Entity (Pref);
|
249 |
|
|
Rtyp : constant Entity_Id := Root_Type (Ptyp);
|
250 |
|
|
Expr : constant Node_Id := Relocate_Node (First (Exprs));
|
251 |
|
|
Imid : RE_Id;
|
252 |
|
|
Tent : Entity_Id;
|
253 |
|
|
Ttyp : Entity_Id;
|
254 |
|
|
Proc_Ent : Entity_Id;
|
255 |
|
|
Enum_Case : Boolean;
|
256 |
|
|
|
257 |
|
|
Arg_List : List_Id;
|
258 |
|
|
-- List of arguments for run-time procedure call
|
259 |
|
|
|
260 |
|
|
Ins_List : List_Id;
|
261 |
|
|
-- List of actions to be inserted
|
262 |
|
|
|
263 |
|
|
Snn : constant Entity_Id :=
|
264 |
|
|
Make_Defining_Identifier (Loc,
|
265 |
|
|
Chars => New_Internal_Name ('S'));
|
266 |
|
|
|
267 |
|
|
Pnn : constant Entity_Id :=
|
268 |
|
|
Make_Defining_Identifier (Loc,
|
269 |
|
|
Chars => New_Internal_Name ('P'));
|
270 |
|
|
|
271 |
|
|
begin
|
272 |
|
|
-- Build declarations of Snn and Pnn to be inserted
|
273 |
|
|
|
274 |
|
|
Ins_List := New_List (
|
275 |
|
|
|
276 |
|
|
-- Snn : String (1 .. typ'Width);
|
277 |
|
|
|
278 |
|
|
Make_Object_Declaration (Loc,
|
279 |
|
|
Defining_Identifier => Snn,
|
280 |
|
|
Object_Definition =>
|
281 |
|
|
Make_Subtype_Indication (Loc,
|
282 |
|
|
Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
|
283 |
|
|
Constraint =>
|
284 |
|
|
Make_Index_Or_Discriminant_Constraint (Loc,
|
285 |
|
|
Constraints => New_List (
|
286 |
|
|
Make_Range (Loc,
|
287 |
|
|
Low_Bound => Make_Integer_Literal (Loc, 1),
|
288 |
|
|
High_Bound =>
|
289 |
|
|
Make_Attribute_Reference (Loc,
|
290 |
|
|
Prefix => New_Occurrence_Of (Rtyp, Loc),
|
291 |
|
|
Attribute_Name => Name_Width)))))),
|
292 |
|
|
|
293 |
|
|
-- Pnn : Natural;
|
294 |
|
|
|
295 |
|
|
Make_Object_Declaration (Loc,
|
296 |
|
|
Defining_Identifier => Pnn,
|
297 |
|
|
Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)));
|
298 |
|
|
|
299 |
|
|
-- Set Imid (RE_Id of procedure to call), and Tent, target for the
|
300 |
|
|
-- type conversion of the first argument for all possibilities.
|
301 |
|
|
|
302 |
|
|
Enum_Case := False;
|
303 |
|
|
|
304 |
|
|
if Rtyp = Standard_Boolean then
|
305 |
|
|
Imid := RE_Image_Boolean;
|
306 |
|
|
Tent := Rtyp;
|
307 |
|
|
|
308 |
|
|
elsif Rtyp = Standard_Character then
|
309 |
|
|
Imid := RE_Image_Character;
|
310 |
|
|
Tent := Rtyp;
|
311 |
|
|
|
312 |
|
|
elsif Rtyp = Standard_Wide_Character then
|
313 |
|
|
Imid := RE_Image_Wide_Character;
|
314 |
|
|
Tent := Rtyp;
|
315 |
|
|
|
316 |
|
|
elsif Rtyp = Standard_Wide_Wide_Character then
|
317 |
|
|
Imid := RE_Image_Wide_Wide_Character;
|
318 |
|
|
Tent := Rtyp;
|
319 |
|
|
|
320 |
|
|
elsif Is_Signed_Integer_Type (Rtyp) then
|
321 |
|
|
if Esize (Rtyp) <= Esize (Standard_Integer) then
|
322 |
|
|
Imid := RE_Image_Integer;
|
323 |
|
|
Tent := Standard_Integer;
|
324 |
|
|
else
|
325 |
|
|
Imid := RE_Image_Long_Long_Integer;
|
326 |
|
|
Tent := Standard_Long_Long_Integer;
|
327 |
|
|
end if;
|
328 |
|
|
|
329 |
|
|
elsif Is_Modular_Integer_Type (Rtyp) then
|
330 |
|
|
if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
|
331 |
|
|
Imid := RE_Image_Unsigned;
|
332 |
|
|
Tent := RTE (RE_Unsigned);
|
333 |
|
|
else
|
334 |
|
|
Imid := RE_Image_Long_Long_Unsigned;
|
335 |
|
|
Tent := RTE (RE_Long_Long_Unsigned);
|
336 |
|
|
end if;
|
337 |
|
|
|
338 |
|
|
elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
|
339 |
|
|
if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
|
340 |
|
|
Imid := RE_Image_Decimal;
|
341 |
|
|
Tent := Standard_Integer;
|
342 |
|
|
else
|
343 |
|
|
Imid := RE_Image_Long_Long_Decimal;
|
344 |
|
|
Tent := Standard_Long_Long_Integer;
|
345 |
|
|
end if;
|
346 |
|
|
|
347 |
|
|
elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
|
348 |
|
|
Imid := RE_Image_Ordinary_Fixed_Point;
|
349 |
|
|
Tent := Standard_Long_Long_Float;
|
350 |
|
|
|
351 |
|
|
elsif Is_Floating_Point_Type (Rtyp) then
|
352 |
|
|
Imid := RE_Image_Floating_Point;
|
353 |
|
|
Tent := Standard_Long_Long_Float;
|
354 |
|
|
|
355 |
|
|
-- Only other possibility is user defined enumeration type
|
356 |
|
|
|
357 |
|
|
else
|
358 |
|
|
if Discard_Names (First_Subtype (Ptyp))
|
359 |
|
|
or else No (Lit_Strings (Root_Type (Ptyp)))
|
360 |
|
|
then
|
361 |
|
|
-- When pragma Discard_Names applies to the first subtype,
|
362 |
|
|
-- then build (Pref'Pos)'Img.
|
363 |
|
|
|
364 |
|
|
Rewrite (N,
|
365 |
|
|
Make_Attribute_Reference (Loc,
|
366 |
|
|
Prefix =>
|
367 |
|
|
Make_Attribute_Reference (Loc,
|
368 |
|
|
Prefix => Pref,
|
369 |
|
|
Attribute_Name => Name_Pos,
|
370 |
|
|
Expressions => New_List (Expr)),
|
371 |
|
|
Attribute_Name =>
|
372 |
|
|
Name_Img));
|
373 |
|
|
Analyze_And_Resolve (N, Standard_String);
|
374 |
|
|
return;
|
375 |
|
|
|
376 |
|
|
else
|
377 |
|
|
-- Here for enumeration type case
|
378 |
|
|
|
379 |
|
|
Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
|
380 |
|
|
|
381 |
|
|
if Ttyp = Standard_Integer_8 then
|
382 |
|
|
Imid := RE_Image_Enumeration_8;
|
383 |
|
|
elsif Ttyp = Standard_Integer_16 then
|
384 |
|
|
Imid := RE_Image_Enumeration_16;
|
385 |
|
|
else
|
386 |
|
|
Imid := RE_Image_Enumeration_32;
|
387 |
|
|
end if;
|
388 |
|
|
|
389 |
|
|
-- Apply a validity check, since it is a bit drastic to get a
|
390 |
|
|
-- completely junk image value for an invalid value.
|
391 |
|
|
|
392 |
|
|
if not Expr_Known_Valid (Expr) then
|
393 |
|
|
Insert_Valid_Check (Expr);
|
394 |
|
|
end if;
|
395 |
|
|
|
396 |
|
|
Enum_Case := True;
|
397 |
|
|
end if;
|
398 |
|
|
end if;
|
399 |
|
|
|
400 |
|
|
-- Build first argument for call
|
401 |
|
|
|
402 |
|
|
if Enum_Case then
|
403 |
|
|
Arg_List := New_List (
|
404 |
|
|
Make_Attribute_Reference (Loc,
|
405 |
|
|
Attribute_Name => Name_Pos,
|
406 |
|
|
Prefix => New_Occurrence_Of (Ptyp, Loc),
|
407 |
|
|
Expressions => New_List (Expr)));
|
408 |
|
|
|
409 |
|
|
else
|
410 |
|
|
Arg_List := New_List (Convert_To (Tent, Expr));
|
411 |
|
|
end if;
|
412 |
|
|
|
413 |
|
|
-- Append Snn, Pnn arguments
|
414 |
|
|
|
415 |
|
|
Append_To (Arg_List, New_Occurrence_Of (Snn, Loc));
|
416 |
|
|
Append_To (Arg_List, New_Occurrence_Of (Pnn, Loc));
|
417 |
|
|
|
418 |
|
|
-- Get entity of procedure to call
|
419 |
|
|
|
420 |
|
|
Proc_Ent := RTE (Imid);
|
421 |
|
|
|
422 |
|
|
-- If the procedure entity is empty, that means we have a case in
|
423 |
|
|
-- no run time mode where the operation is not allowed, and an
|
424 |
|
|
-- appropriate diagnostic has already been issued.
|
425 |
|
|
|
426 |
|
|
if No (Proc_Ent) then
|
427 |
|
|
return;
|
428 |
|
|
end if;
|
429 |
|
|
|
430 |
|
|
-- Otherwise complete preparation of arguments for run-time call
|
431 |
|
|
|
432 |
|
|
-- Add extra arguments for Enumeration case
|
433 |
|
|
|
434 |
|
|
if Enum_Case then
|
435 |
|
|
Append_To (Arg_List, New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
|
436 |
|
|
Append_To (Arg_List,
|
437 |
|
|
Make_Attribute_Reference (Loc,
|
438 |
|
|
Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
|
439 |
|
|
Attribute_Name => Name_Address));
|
440 |
|
|
|
441 |
|
|
-- For floating-point types, append Digits argument
|
442 |
|
|
|
443 |
|
|
elsif Is_Floating_Point_Type (Rtyp) then
|
444 |
|
|
Append_To (Arg_List,
|
445 |
|
|
Make_Attribute_Reference (Loc,
|
446 |
|
|
Prefix => New_Reference_To (Ptyp, Loc),
|
447 |
|
|
Attribute_Name => Name_Digits));
|
448 |
|
|
|
449 |
|
|
-- For ordinary fixed-point types, append Aft parameter
|
450 |
|
|
|
451 |
|
|
elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
|
452 |
|
|
Append_To (Arg_List,
|
453 |
|
|
Make_Attribute_Reference (Loc,
|
454 |
|
|
Prefix => New_Reference_To (Ptyp, Loc),
|
455 |
|
|
Attribute_Name => Name_Aft));
|
456 |
|
|
|
457 |
|
|
-- For decimal, append Scale and also set to do literal conversion
|
458 |
|
|
|
459 |
|
|
elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
|
460 |
|
|
Append_To (Arg_List,
|
461 |
|
|
Make_Attribute_Reference (Loc,
|
462 |
|
|
Prefix => New_Reference_To (Ptyp, Loc),
|
463 |
|
|
Attribute_Name => Name_Scale));
|
464 |
|
|
|
465 |
|
|
Set_Conversion_OK (First (Arg_List));
|
466 |
|
|
Set_Etype (First (Arg_List), Tent);
|
467 |
|
|
|
468 |
|
|
-- For Wide_Character, append Ada 2005 indication
|
469 |
|
|
|
470 |
|
|
elsif Rtyp = Standard_Wide_Character then
|
471 |
|
|
Append_To (Arg_List,
|
472 |
|
|
New_Reference_To (Boolean_Literals (Ada_Version >= Ada_05), Loc));
|
473 |
|
|
end if;
|
474 |
|
|
|
475 |
|
|
-- Now append the procedure call to the insert list
|
476 |
|
|
|
477 |
|
|
Append_To (Ins_List,
|
478 |
|
|
Make_Procedure_Call_Statement (Loc,
|
479 |
|
|
Name => New_Reference_To (Proc_Ent, Loc),
|
480 |
|
|
Parameter_Associations => Arg_List));
|
481 |
|
|
|
482 |
|
|
-- Insert declarations of Snn, Pnn, and the procedure call. We suppress
|
483 |
|
|
-- checks because we are sure that everything is in range at this stage.
|
484 |
|
|
|
485 |
|
|
Insert_Actions (N, Ins_List, Suppress => All_Checks);
|
486 |
|
|
|
487 |
|
|
-- Final step is to rewrite the expression as a slice and analyze,
|
488 |
|
|
-- again with no checks, since we are sure that everything is OK.
|
489 |
|
|
|
490 |
|
|
Rewrite (N,
|
491 |
|
|
Make_Slice (Loc,
|
492 |
|
|
Prefix => New_Occurrence_Of (Snn, Loc),
|
493 |
|
|
Discrete_Range =>
|
494 |
|
|
Make_Range (Loc,
|
495 |
|
|
Low_Bound => Make_Integer_Literal (Loc, 1),
|
496 |
|
|
High_Bound => New_Occurrence_Of (Pnn, Loc))));
|
497 |
|
|
|
498 |
|
|
Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks);
|
499 |
|
|
end Expand_Image_Attribute;
|
500 |
|
|
|
501 |
|
|
----------------------------
|
502 |
|
|
-- Expand_Value_Attribute --
|
503 |
|
|
----------------------------
|
504 |
|
|
|
505 |
|
|
-- For scalar types derived from Boolean, Character and integer types
|
506 |
|
|
-- in package Standard, typ'Value (X) expands into:
|
507 |
|
|
|
508 |
|
|
-- btyp (Value_xx (X))
|
509 |
|
|
|
510 |
|
|
-- where btyp is he base type of the prefix
|
511 |
|
|
|
512 |
|
|
-- For types whose root type is Character
|
513 |
|
|
-- xx = Character
|
514 |
|
|
|
515 |
|
|
-- For types whose root type is Wide_Character
|
516 |
|
|
-- xx = Wide_Character
|
517 |
|
|
|
518 |
|
|
-- For types whose root type is Wide_Wide_Character
|
519 |
|
|
-- xx = Wide_Wide_Character
|
520 |
|
|
|
521 |
|
|
-- For types whose root type is Boolean
|
522 |
|
|
-- xx = Boolean
|
523 |
|
|
|
524 |
|
|
-- For signed integer types with size <= Integer'Size
|
525 |
|
|
-- xx = Integer
|
526 |
|
|
|
527 |
|
|
-- For other signed integer types
|
528 |
|
|
-- xx = Long_Long_Integer
|
529 |
|
|
|
530 |
|
|
-- For modular types with modulus <= System.Unsigned_Types.Unsigned
|
531 |
|
|
-- xx = Unsigned
|
532 |
|
|
|
533 |
|
|
-- For other modular integer types
|
534 |
|
|
-- xx = Long_Long_Unsigned
|
535 |
|
|
|
536 |
|
|
-- For floating-point types and ordinary fixed-point types
|
537 |
|
|
-- xx = Real
|
538 |
|
|
|
539 |
|
|
-- For Wide_[Wide_]Character types, typ'Value (X) expands into:
|
540 |
|
|
|
541 |
|
|
-- btyp (Value_xx (X, EM))
|
542 |
|
|
|
543 |
|
|
-- where btyp is the base type of the prefix, and EM is the encoding method
|
544 |
|
|
|
545 |
|
|
-- For decimal types with size <= Integer'Size, typ'Value (X)
|
546 |
|
|
-- expands into
|
547 |
|
|
|
548 |
|
|
-- btyp?(Value_Decimal (X, typ'Scale));
|
549 |
|
|
|
550 |
|
|
-- For all other decimal types, typ'Value (X) expands into
|
551 |
|
|
|
552 |
|
|
-- btyp?(Value_Long_Long_Decimal (X, typ'Scale))
|
553 |
|
|
|
554 |
|
|
-- For enumeration types other than those derived from types Boolean,
|
555 |
|
|
-- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
|
556 |
|
|
|
557 |
|
|
-- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
|
558 |
|
|
|
559 |
|
|
-- where typS and typI and the Lit_Strings and Lit_Indexes entities
|
560 |
|
|
-- from T's root type entity, and Num is Enum'Pos (Enum'Last). The
|
561 |
|
|
-- Value_Enumeration_NN function will search the tables looking for
|
562 |
|
|
-- X and return the position number in the table if found which is
|
563 |
|
|
-- used to provide the result of 'Value (using Enum'Val). If the
|
564 |
|
|
-- value is not found Constraint_Error is raised. The suffix _NN
|
565 |
|
|
-- depends on the element type of typI.
|
566 |
|
|
|
567 |
|
|
procedure Expand_Value_Attribute (N : Node_Id) is
|
568 |
|
|
Loc : constant Source_Ptr := Sloc (N);
|
569 |
|
|
Typ : constant Entity_Id := Etype (N);
|
570 |
|
|
Btyp : constant Entity_Id := Base_Type (Typ);
|
571 |
|
|
Rtyp : constant Entity_Id := Root_Type (Typ);
|
572 |
|
|
Exprs : constant List_Id := Expressions (N);
|
573 |
|
|
Vid : RE_Id;
|
574 |
|
|
Args : List_Id;
|
575 |
|
|
Func : RE_Id;
|
576 |
|
|
Ttyp : Entity_Id;
|
577 |
|
|
|
578 |
|
|
begin
|
579 |
|
|
Args := Exprs;
|
580 |
|
|
|
581 |
|
|
if Rtyp = Standard_Character then
|
582 |
|
|
Vid := RE_Value_Character;
|
583 |
|
|
|
584 |
|
|
elsif Rtyp = Standard_Boolean then
|
585 |
|
|
Vid := RE_Value_Boolean;
|
586 |
|
|
|
587 |
|
|
elsif Rtyp = Standard_Wide_Character then
|
588 |
|
|
Vid := RE_Value_Wide_Character;
|
589 |
|
|
|
590 |
|
|
Append_To (Args,
|
591 |
|
|
Make_Integer_Literal (Loc,
|
592 |
|
|
Intval => Int (Wide_Character_Encoding_Method)));
|
593 |
|
|
|
594 |
|
|
elsif Rtyp = Standard_Wide_Wide_Character then
|
595 |
|
|
Vid := RE_Value_Wide_Wide_Character;
|
596 |
|
|
|
597 |
|
|
Append_To (Args,
|
598 |
|
|
Make_Integer_Literal (Loc,
|
599 |
|
|
Intval => Int (Wide_Character_Encoding_Method)));
|
600 |
|
|
|
601 |
|
|
elsif Rtyp = Base_Type (Standard_Short_Short_Integer)
|
602 |
|
|
or else Rtyp = Base_Type (Standard_Short_Integer)
|
603 |
|
|
or else Rtyp = Base_Type (Standard_Integer)
|
604 |
|
|
then
|
605 |
|
|
Vid := RE_Value_Integer;
|
606 |
|
|
|
607 |
|
|
elsif Is_Signed_Integer_Type (Rtyp) then
|
608 |
|
|
Vid := RE_Value_Long_Long_Integer;
|
609 |
|
|
|
610 |
|
|
elsif Is_Modular_Integer_Type (Rtyp) then
|
611 |
|
|
if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
|
612 |
|
|
Vid := RE_Value_Unsigned;
|
613 |
|
|
else
|
614 |
|
|
Vid := RE_Value_Long_Long_Unsigned;
|
615 |
|
|
end if;
|
616 |
|
|
|
617 |
|
|
elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
|
618 |
|
|
if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
|
619 |
|
|
Vid := RE_Value_Decimal;
|
620 |
|
|
else
|
621 |
|
|
Vid := RE_Value_Long_Long_Decimal;
|
622 |
|
|
end if;
|
623 |
|
|
|
624 |
|
|
Append_To (Args,
|
625 |
|
|
Make_Attribute_Reference (Loc,
|
626 |
|
|
Prefix => New_Reference_To (Typ, Loc),
|
627 |
|
|
Attribute_Name => Name_Scale));
|
628 |
|
|
|
629 |
|
|
Rewrite (N,
|
630 |
|
|
OK_Convert_To (Btyp,
|
631 |
|
|
Make_Function_Call (Loc,
|
632 |
|
|
Name => New_Reference_To (RTE (Vid), Loc),
|
633 |
|
|
Parameter_Associations => Args)));
|
634 |
|
|
|
635 |
|
|
Set_Etype (N, Btyp);
|
636 |
|
|
Analyze_And_Resolve (N, Btyp);
|
637 |
|
|
return;
|
638 |
|
|
|
639 |
|
|
elsif Is_Real_Type (Rtyp) then
|
640 |
|
|
Vid := RE_Value_Real;
|
641 |
|
|
|
642 |
|
|
-- Only other possibility is user defined enumeration type
|
643 |
|
|
|
644 |
|
|
else
|
645 |
|
|
pragma Assert (Is_Enumeration_Type (Rtyp));
|
646 |
|
|
|
647 |
|
|
-- Case of pragma Discard_Names, transform the Value
|
648 |
|
|
-- attribute to Btyp'Val (Long_Long_Integer'Value (Args))
|
649 |
|
|
|
650 |
|
|
if Discard_Names (First_Subtype (Typ))
|
651 |
|
|
or else No (Lit_Strings (Rtyp))
|
652 |
|
|
then
|
653 |
|
|
Rewrite (N,
|
654 |
|
|
Make_Attribute_Reference (Loc,
|
655 |
|
|
Prefix => New_Reference_To (Btyp, Loc),
|
656 |
|
|
Attribute_Name => Name_Val,
|
657 |
|
|
Expressions => New_List (
|
658 |
|
|
Make_Attribute_Reference (Loc,
|
659 |
|
|
Prefix =>
|
660 |
|
|
New_Occurrence_Of (Standard_Long_Long_Integer, Loc),
|
661 |
|
|
Attribute_Name => Name_Value,
|
662 |
|
|
Expressions => Args))));
|
663 |
|
|
|
664 |
|
|
Analyze_And_Resolve (N, Btyp);
|
665 |
|
|
|
666 |
|
|
-- Here for normal case where we have enumeration tables, this
|
667 |
|
|
-- is where we build
|
668 |
|
|
|
669 |
|
|
-- T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
|
670 |
|
|
|
671 |
|
|
else
|
672 |
|
|
Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
|
673 |
|
|
|
674 |
|
|
if Ttyp = Standard_Integer_8 then
|
675 |
|
|
Func := RE_Value_Enumeration_8;
|
676 |
|
|
elsif Ttyp = Standard_Integer_16 then
|
677 |
|
|
Func := RE_Value_Enumeration_16;
|
678 |
|
|
else
|
679 |
|
|
Func := RE_Value_Enumeration_32;
|
680 |
|
|
end if;
|
681 |
|
|
|
682 |
|
|
Prepend_To (Args,
|
683 |
|
|
Make_Attribute_Reference (Loc,
|
684 |
|
|
Prefix => New_Occurrence_Of (Rtyp, Loc),
|
685 |
|
|
Attribute_Name => Name_Pos,
|
686 |
|
|
Expressions => New_List (
|
687 |
|
|
Make_Attribute_Reference (Loc,
|
688 |
|
|
Prefix => New_Occurrence_Of (Rtyp, Loc),
|
689 |
|
|
Attribute_Name => Name_Last))));
|
690 |
|
|
|
691 |
|
|
Prepend_To (Args,
|
692 |
|
|
Make_Attribute_Reference (Loc,
|
693 |
|
|
Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
|
694 |
|
|
Attribute_Name => Name_Address));
|
695 |
|
|
|
696 |
|
|
Prepend_To (Args,
|
697 |
|
|
New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
|
698 |
|
|
|
699 |
|
|
Rewrite (N,
|
700 |
|
|
Make_Attribute_Reference (Loc,
|
701 |
|
|
Prefix => New_Reference_To (Typ, Loc),
|
702 |
|
|
Attribute_Name => Name_Val,
|
703 |
|
|
Expressions => New_List (
|
704 |
|
|
Make_Function_Call (Loc,
|
705 |
|
|
Name =>
|
706 |
|
|
New_Reference_To (RTE (Func), Loc),
|
707 |
|
|
Parameter_Associations => Args))));
|
708 |
|
|
|
709 |
|
|
Analyze_And_Resolve (N, Btyp);
|
710 |
|
|
end if;
|
711 |
|
|
|
712 |
|
|
return;
|
713 |
|
|
end if;
|
714 |
|
|
|
715 |
|
|
-- Fall through for all cases except user defined enumeration type
|
716 |
|
|
-- and decimal types, with Vid set to the Id of the entity for the
|
717 |
|
|
-- Value routine and Args set to the list of parameters for the call.
|
718 |
|
|
|
719 |
|
|
-- Compiling package Ada.Tags under No_Run_Time_Mode we disable the
|
720 |
|
|
-- expansion of the attribute into the function call statement to avoid
|
721 |
|
|
-- generating spurious errors caused by the use of Integer_Address'Value
|
722 |
|
|
-- in our implementation of Ada.Tags.Internal_Tag
|
723 |
|
|
|
724 |
|
|
-- Seems like a bit of a kludge, there should be a better way ???
|
725 |
|
|
|
726 |
|
|
-- There is a better way, you should also test RTE_Available ???
|
727 |
|
|
|
728 |
|
|
if No_Run_Time_Mode
|
729 |
|
|
and then Rtyp = RTE (RE_Integer_Address)
|
730 |
|
|
and then RTU_Loaded (Ada_Tags)
|
731 |
|
|
and then Cunit_Entity (Current_Sem_Unit)
|
732 |
|
|
= Body_Entity (RTU_Entity (Ada_Tags))
|
733 |
|
|
then
|
734 |
|
|
Rewrite (N,
|
735 |
|
|
Unchecked_Convert_To (Rtyp,
|
736 |
|
|
Make_Integer_Literal (Loc, Uint_0)));
|
737 |
|
|
else
|
738 |
|
|
Rewrite (N,
|
739 |
|
|
Convert_To (Btyp,
|
740 |
|
|
Make_Function_Call (Loc,
|
741 |
|
|
Name => New_Reference_To (RTE (Vid), Loc),
|
742 |
|
|
Parameter_Associations => Args)));
|
743 |
|
|
end if;
|
744 |
|
|
|
745 |
|
|
Analyze_And_Resolve (N, Btyp);
|
746 |
|
|
end Expand_Value_Attribute;
|
747 |
|
|
|
748 |
|
|
---------------------------------
|
749 |
|
|
-- Expand_Wide_Image_Attribute --
|
750 |
|
|
---------------------------------
|
751 |
|
|
|
752 |
|
|
-- We expand typ'Wide_Image (X) as follows. First we insert this code:
|
753 |
|
|
|
754 |
|
|
-- Rnn : Wide_String (1 .. rt'Wide_Width);
|
755 |
|
|
-- Lnn : Natural;
|
756 |
|
|
-- String_To_Wide_String
|
757 |
|
|
-- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
|
758 |
|
|
|
759 |
|
|
-- where rt is the root type of the prefix type
|
760 |
|
|
|
761 |
|
|
-- Now we replace the Wide_Image reference by
|
762 |
|
|
|
763 |
|
|
-- Rnn (1 .. Lnn)
|
764 |
|
|
|
765 |
|
|
-- This works in all cases because String_To_Wide_String converts any
|
766 |
|
|
-- wide character escape sequences resulting from the Image call to the
|
767 |
|
|
-- proper Wide_Character equivalent
|
768 |
|
|
|
769 |
|
|
-- not quite right for typ = Wide_Character ???
|
770 |
|
|
|
771 |
|
|
procedure Expand_Wide_Image_Attribute (N : Node_Id) is
|
772 |
|
|
Loc : constant Source_Ptr := Sloc (N);
|
773 |
|
|
Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N)));
|
774 |
|
|
|
775 |
|
|
Rnn : constant Entity_Id :=
|
776 |
|
|
Make_Defining_Identifier (Loc,
|
777 |
|
|
Chars => New_Internal_Name ('S'));
|
778 |
|
|
|
779 |
|
|
Lnn : constant Entity_Id :=
|
780 |
|
|
Make_Defining_Identifier (Loc,
|
781 |
|
|
Chars => New_Internal_Name ('P'));
|
782 |
|
|
|
783 |
|
|
begin
|
784 |
|
|
Insert_Actions (N, New_List (
|
785 |
|
|
|
786 |
|
|
-- Rnn : Wide_String (1 .. base_typ'Width);
|
787 |
|
|
|
788 |
|
|
Make_Object_Declaration (Loc,
|
789 |
|
|
Defining_Identifier => Rnn,
|
790 |
|
|
Object_Definition =>
|
791 |
|
|
Make_Subtype_Indication (Loc,
|
792 |
|
|
Subtype_Mark =>
|
793 |
|
|
New_Occurrence_Of (Standard_Wide_String, Loc),
|
794 |
|
|
Constraint =>
|
795 |
|
|
Make_Index_Or_Discriminant_Constraint (Loc,
|
796 |
|
|
Constraints => New_List (
|
797 |
|
|
Make_Range (Loc,
|
798 |
|
|
Low_Bound => Make_Integer_Literal (Loc, 1),
|
799 |
|
|
High_Bound =>
|
800 |
|
|
Make_Attribute_Reference (Loc,
|
801 |
|
|
Prefix => New_Occurrence_Of (Rtyp, Loc),
|
802 |
|
|
Attribute_Name => Name_Wide_Width)))))),
|
803 |
|
|
|
804 |
|
|
-- Lnn : Natural;
|
805 |
|
|
|
806 |
|
|
Make_Object_Declaration (Loc,
|
807 |
|
|
Defining_Identifier => Lnn,
|
808 |
|
|
Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)),
|
809 |
|
|
|
810 |
|
|
-- String_To_Wide_String
|
811 |
|
|
-- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
|
812 |
|
|
|
813 |
|
|
Make_Procedure_Call_Statement (Loc,
|
814 |
|
|
Name =>
|
815 |
|
|
New_Reference_To (RTE (RE_String_To_Wide_String), Loc),
|
816 |
|
|
|
817 |
|
|
Parameter_Associations => New_List (
|
818 |
|
|
Make_Attribute_Reference (Loc,
|
819 |
|
|
Prefix => Prefix (N),
|
820 |
|
|
Attribute_Name => Name_Image,
|
821 |
|
|
Expressions => Expressions (N)),
|
822 |
|
|
New_Reference_To (Rnn, Loc),
|
823 |
|
|
New_Reference_To (Lnn, Loc),
|
824 |
|
|
Make_Integer_Literal (Loc,
|
825 |
|
|
Intval => Int (Wide_Character_Encoding_Method))))),
|
826 |
|
|
|
827 |
|
|
-- Suppress checks because we know everything is properly in range
|
828 |
|
|
|
829 |
|
|
Suppress => All_Checks);
|
830 |
|
|
|
831 |
|
|
-- Final step is to rewrite the expression as a slice and analyze,
|
832 |
|
|
-- again with no checks, since we are sure that everything is OK.
|
833 |
|
|
|
834 |
|
|
Rewrite (N,
|
835 |
|
|
Make_Slice (Loc,
|
836 |
|
|
Prefix => New_Occurrence_Of (Rnn, Loc),
|
837 |
|
|
Discrete_Range =>
|
838 |
|
|
Make_Range (Loc,
|
839 |
|
|
Low_Bound => Make_Integer_Literal (Loc, 1),
|
840 |
|
|
High_Bound => New_Occurrence_Of (Lnn, Loc))));
|
841 |
|
|
|
842 |
|
|
Analyze_And_Resolve (N, Standard_Wide_String, Suppress => All_Checks);
|
843 |
|
|
end Expand_Wide_Image_Attribute;
|
844 |
|
|
|
845 |
|
|
--------------------------------------
|
846 |
|
|
-- Expand_Wide_Wide_Image_Attribute --
|
847 |
|
|
--------------------------------------
|
848 |
|
|
|
849 |
|
|
-- We expand typ'Wide_Wide_Image (X) as follows. First we insert this code:
|
850 |
|
|
|
851 |
|
|
-- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
|
852 |
|
|
-- Lnn : Natural;
|
853 |
|
|
-- String_To_Wide_Wide_String
|
854 |
|
|
-- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
|
855 |
|
|
|
856 |
|
|
-- where rt is the root type of the prefix type
|
857 |
|
|
|
858 |
|
|
-- Now we replace the Wide_Wide_Image reference by
|
859 |
|
|
|
860 |
|
|
-- Rnn (1 .. Lnn)
|
861 |
|
|
|
862 |
|
|
-- This works in all cases because String_To_Wide_Wide_String converts any
|
863 |
|
|
-- wide character escape sequences resulting from the Image call to the
|
864 |
|
|
-- proper Wide_Wide_Character equivalent
|
865 |
|
|
|
866 |
|
|
-- not quite right for typ = Wide_Wide_Character ???
|
867 |
|
|
|
868 |
|
|
procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is
|
869 |
|
|
Loc : constant Source_Ptr := Sloc (N);
|
870 |
|
|
Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N)));
|
871 |
|
|
|
872 |
|
|
Rnn : constant Entity_Id :=
|
873 |
|
|
Make_Defining_Identifier (Loc,
|
874 |
|
|
Chars => New_Internal_Name ('S'));
|
875 |
|
|
|
876 |
|
|
Lnn : constant Entity_Id :=
|
877 |
|
|
Make_Defining_Identifier (Loc,
|
878 |
|
|
Chars => New_Internal_Name ('P'));
|
879 |
|
|
|
880 |
|
|
begin
|
881 |
|
|
Insert_Actions (N, New_List (
|
882 |
|
|
|
883 |
|
|
-- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
|
884 |
|
|
|
885 |
|
|
Make_Object_Declaration (Loc,
|
886 |
|
|
Defining_Identifier => Rnn,
|
887 |
|
|
Object_Definition =>
|
888 |
|
|
Make_Subtype_Indication (Loc,
|
889 |
|
|
Subtype_Mark =>
|
890 |
|
|
New_Occurrence_Of (Standard_Wide_Wide_String, Loc),
|
891 |
|
|
Constraint =>
|
892 |
|
|
Make_Index_Or_Discriminant_Constraint (Loc,
|
893 |
|
|
Constraints => New_List (
|
894 |
|
|
Make_Range (Loc,
|
895 |
|
|
Low_Bound => Make_Integer_Literal (Loc, 1),
|
896 |
|
|
High_Bound =>
|
897 |
|
|
Make_Attribute_Reference (Loc,
|
898 |
|
|
Prefix => New_Occurrence_Of (Rtyp, Loc),
|
899 |
|
|
Attribute_Name => Name_Wide_Wide_Width)))))),
|
900 |
|
|
|
901 |
|
|
-- Lnn : Natural;
|
902 |
|
|
|
903 |
|
|
Make_Object_Declaration (Loc,
|
904 |
|
|
Defining_Identifier => Lnn,
|
905 |
|
|
Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)),
|
906 |
|
|
|
907 |
|
|
-- String_To_Wide_Wide_String
|
908 |
|
|
-- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
|
909 |
|
|
|
910 |
|
|
Make_Procedure_Call_Statement (Loc,
|
911 |
|
|
Name =>
|
912 |
|
|
New_Reference_To (RTE (RE_String_To_Wide_Wide_String), Loc),
|
913 |
|
|
|
914 |
|
|
Parameter_Associations => New_List (
|
915 |
|
|
Make_Attribute_Reference (Loc,
|
916 |
|
|
Prefix => Prefix (N),
|
917 |
|
|
Attribute_Name => Name_Image,
|
918 |
|
|
Expressions => Expressions (N)),
|
919 |
|
|
New_Reference_To (Rnn, Loc),
|
920 |
|
|
New_Reference_To (Lnn, Loc),
|
921 |
|
|
Make_Integer_Literal (Loc,
|
922 |
|
|
Intval => Int (Wide_Character_Encoding_Method))))),
|
923 |
|
|
|
924 |
|
|
-- Suppress checks because we know everything is properly in range
|
925 |
|
|
|
926 |
|
|
Suppress => All_Checks);
|
927 |
|
|
|
928 |
|
|
-- Final step is to rewrite the expression as a slice and analyze,
|
929 |
|
|
-- again with no checks, since we are sure that everything is OK.
|
930 |
|
|
|
931 |
|
|
Rewrite (N,
|
932 |
|
|
Make_Slice (Loc,
|
933 |
|
|
Prefix => New_Occurrence_Of (Rnn, Loc),
|
934 |
|
|
Discrete_Range =>
|
935 |
|
|
Make_Range (Loc,
|
936 |
|
|
Low_Bound => Make_Integer_Literal (Loc, 1),
|
937 |
|
|
High_Bound => New_Occurrence_Of (Lnn, Loc))));
|
938 |
|
|
|
939 |
|
|
Analyze_And_Resolve
|
940 |
|
|
(N, Standard_Wide_Wide_String, Suppress => All_Checks);
|
941 |
|
|
end Expand_Wide_Wide_Image_Attribute;
|
942 |
|
|
|
943 |
|
|
----------------------------
|
944 |
|
|
-- Expand_Width_Attribute --
|
945 |
|
|
----------------------------
|
946 |
|
|
|
947 |
|
|
-- The processing here also handles the case of Wide_[Wide_]Width. With the
|
948 |
|
|
-- exceptions noted, the processing is identical
|
949 |
|
|
|
950 |
|
|
-- For scalar types derived from Boolean, character and integer types
|
951 |
|
|
-- in package Standard. Note that the Width attribute is computed at
|
952 |
|
|
-- compile time for all cases except those involving non-static sub-
|
953 |
|
|
-- types. For such subtypes, typ'[Wide_[Wide_]]Width expands into:
|
954 |
|
|
|
955 |
|
|
-- Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last)))
|
956 |
|
|
|
957 |
|
|
-- where
|
958 |
|
|
|
959 |
|
|
-- For types whose root type is Character
|
960 |
|
|
-- xx = Width_Character
|
961 |
|
|
-- yy = Character
|
962 |
|
|
|
963 |
|
|
-- For types whose root type is Wide_Character
|
964 |
|
|
-- xx = Wide_Width_Character
|
965 |
|
|
-- yy = Character
|
966 |
|
|
|
967 |
|
|
-- For types whose root type is Wide_Wide_Character
|
968 |
|
|
-- xx = Wide_Wide_Width_Character
|
969 |
|
|
-- yy = Character
|
970 |
|
|
|
971 |
|
|
-- For types whose root type is Boolean
|
972 |
|
|
-- xx = Width_Boolean
|
973 |
|
|
-- yy = Boolean
|
974 |
|
|
|
975 |
|
|
-- For signed integer types
|
976 |
|
|
-- xx = Width_Long_Long_Integer
|
977 |
|
|
-- yy = Long_Long_Integer
|
978 |
|
|
|
979 |
|
|
-- For modular integer types
|
980 |
|
|
-- xx = Width_Long_Long_Unsigned
|
981 |
|
|
-- yy = Long_Long_Unsigned
|
982 |
|
|
|
983 |
|
|
-- For types derived from Wide_Character, typ'Width expands into
|
984 |
|
|
|
985 |
|
|
-- Result_Type (Width_Wide_Character (
|
986 |
|
|
-- Wide_Character (typ'First),
|
987 |
|
|
-- Wide_Character (typ'Last),
|
988 |
|
|
|
989 |
|
|
-- and typ'Wide_Width expands into:
|
990 |
|
|
|
991 |
|
|
-- Result_Type (Wide_Width_Wide_Character (
|
992 |
|
|
-- Wide_Character (typ'First),
|
993 |
|
|
-- Wide_Character (typ'Last));
|
994 |
|
|
|
995 |
|
|
-- and typ'Wide_Wide_Width expands into
|
996 |
|
|
|
997 |
|
|
-- Result_Type (Wide_Wide_Width_Wide_Character (
|
998 |
|
|
-- Wide_Character (typ'First),
|
999 |
|
|
-- Wide_Character (typ'Last));
|
1000 |
|
|
|
1001 |
|
|
-- For types derived from Wide_Wide_Character, typ'Width expands into
|
1002 |
|
|
|
1003 |
|
|
-- Result_Type (Width_Wide_Wide_Character (
|
1004 |
|
|
-- Wide_Wide_Character (typ'First),
|
1005 |
|
|
-- Wide_Wide_Character (typ'Last),
|
1006 |
|
|
|
1007 |
|
|
-- and typ'Wide_Width expands into:
|
1008 |
|
|
|
1009 |
|
|
-- Result_Type (Wide_Width_Wide_Wide_Character (
|
1010 |
|
|
-- Wide_Wide_Character (typ'First),
|
1011 |
|
|
-- Wide_Wide_Character (typ'Last));
|
1012 |
|
|
|
1013 |
|
|
-- and typ'Wide_Wide_Width expands into
|
1014 |
|
|
|
1015 |
|
|
-- Result_Type (Wide_Wide_Width_Wide_Wide_Char (
|
1016 |
|
|
-- Wide_Wide_Character (typ'First),
|
1017 |
|
|
-- Wide_Wide_Character (typ'Last));
|
1018 |
|
|
|
1019 |
|
|
-- For real types, typ'Width and typ'Wide_[Wide_]Width expand into
|
1020 |
|
|
|
1021 |
|
|
-- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if
|
1022 |
|
|
|
1023 |
|
|
-- where btyp is the base type. This looks recursive but it isn't
|
1024 |
|
|
-- because the base type is always static, and hence the expression
|
1025 |
|
|
-- in the else is reduced to an integer literal.
|
1026 |
|
|
|
1027 |
|
|
-- For user defined enumeration types, typ'Width expands into
|
1028 |
|
|
|
1029 |
|
|
-- Result_Type (Width_Enumeration_NN
|
1030 |
|
|
-- (typS,
|
1031 |
|
|
-- typI'Address,
|
1032 |
|
|
-- typ'Pos (typ'First),
|
1033 |
|
|
-- typ'Pos (Typ'Last)));
|
1034 |
|
|
|
1035 |
|
|
-- and typ'Wide_Width expands into:
|
1036 |
|
|
|
1037 |
|
|
-- Result_Type (Wide_Width_Enumeration_NN
|
1038 |
|
|
-- (typS,
|
1039 |
|
|
-- typI,
|
1040 |
|
|
-- typ'Pos (typ'First),
|
1041 |
|
|
-- typ'Pos (Typ'Last))
|
1042 |
|
|
-- Wide_Character_Encoding_Method);
|
1043 |
|
|
|
1044 |
|
|
-- and typ'Wide_Wide_Width expands into:
|
1045 |
|
|
|
1046 |
|
|
-- Result_Type (Wide_Wide_Width_Enumeration_NN
|
1047 |
|
|
-- (typS,
|
1048 |
|
|
-- typI,
|
1049 |
|
|
-- typ'Pos (typ'First),
|
1050 |
|
|
-- typ'Pos (Typ'Last))
|
1051 |
|
|
-- Wide_Character_Encoding_Method);
|
1052 |
|
|
|
1053 |
|
|
-- where typS and typI are the enumeration image strings and
|
1054 |
|
|
-- indexes table, as described in Build_Enumeration_Image_Tables.
|
1055 |
|
|
-- NN is 8/16/32 for depending on the element type for typI.
|
1056 |
|
|
|
1057 |
|
|
procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal) is
|
1058 |
|
|
Loc : constant Source_Ptr := Sloc (N);
|
1059 |
|
|
Typ : constant Entity_Id := Etype (N);
|
1060 |
|
|
Pref : constant Node_Id := Prefix (N);
|
1061 |
|
|
Ptyp : constant Entity_Id := Etype (Pref);
|
1062 |
|
|
Rtyp : constant Entity_Id := Root_Type (Ptyp);
|
1063 |
|
|
XX : RE_Id;
|
1064 |
|
|
YY : Entity_Id;
|
1065 |
|
|
Arglist : List_Id;
|
1066 |
|
|
Ttyp : Entity_Id;
|
1067 |
|
|
|
1068 |
|
|
begin
|
1069 |
|
|
-- Types derived from Standard.Boolean
|
1070 |
|
|
|
1071 |
|
|
if Rtyp = Standard_Boolean then
|
1072 |
|
|
XX := RE_Width_Boolean;
|
1073 |
|
|
YY := Rtyp;
|
1074 |
|
|
|
1075 |
|
|
-- Types derived from Standard.Character
|
1076 |
|
|
|
1077 |
|
|
elsif Rtyp = Standard_Character then
|
1078 |
|
|
case Attr is
|
1079 |
|
|
when Normal => XX := RE_Width_Character;
|
1080 |
|
|
when Wide => XX := RE_Wide_Width_Character;
|
1081 |
|
|
when Wide_Wide => XX := RE_Wide_Wide_Width_Character;
|
1082 |
|
|
end case;
|
1083 |
|
|
|
1084 |
|
|
YY := Rtyp;
|
1085 |
|
|
|
1086 |
|
|
-- Types derived from Standard.Wide_Character
|
1087 |
|
|
|
1088 |
|
|
elsif Rtyp = Standard_Wide_Character then
|
1089 |
|
|
case Attr is
|
1090 |
|
|
when Normal => XX := RE_Width_Wide_Character;
|
1091 |
|
|
when Wide => XX := RE_Wide_Width_Wide_Character;
|
1092 |
|
|
when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Character;
|
1093 |
|
|
end case;
|
1094 |
|
|
|
1095 |
|
|
YY := Rtyp;
|
1096 |
|
|
|
1097 |
|
|
-- Types derived from Standard.Wide_Wide_Character
|
1098 |
|
|
|
1099 |
|
|
elsif Rtyp = Standard_Wide_Wide_Character then
|
1100 |
|
|
case Attr is
|
1101 |
|
|
when Normal => XX := RE_Width_Wide_Wide_Character;
|
1102 |
|
|
when Wide => XX := RE_Wide_Width_Wide_Wide_Character;
|
1103 |
|
|
when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Wide_Char;
|
1104 |
|
|
end case;
|
1105 |
|
|
|
1106 |
|
|
YY := Rtyp;
|
1107 |
|
|
|
1108 |
|
|
-- Signed integer types
|
1109 |
|
|
|
1110 |
|
|
elsif Is_Signed_Integer_Type (Rtyp) then
|
1111 |
|
|
XX := RE_Width_Long_Long_Integer;
|
1112 |
|
|
YY := Standard_Long_Long_Integer;
|
1113 |
|
|
|
1114 |
|
|
-- Modular integer types
|
1115 |
|
|
|
1116 |
|
|
elsif Is_Modular_Integer_Type (Rtyp) then
|
1117 |
|
|
XX := RE_Width_Long_Long_Unsigned;
|
1118 |
|
|
YY := RTE (RE_Long_Long_Unsigned);
|
1119 |
|
|
|
1120 |
|
|
-- Real types
|
1121 |
|
|
|
1122 |
|
|
elsif Is_Real_Type (Rtyp) then
|
1123 |
|
|
|
1124 |
|
|
Rewrite (N,
|
1125 |
|
|
Make_Conditional_Expression (Loc,
|
1126 |
|
|
Expressions => New_List (
|
1127 |
|
|
|
1128 |
|
|
Make_Op_Gt (Loc,
|
1129 |
|
|
Left_Opnd =>
|
1130 |
|
|
Make_Attribute_Reference (Loc,
|
1131 |
|
|
Prefix => New_Reference_To (Ptyp, Loc),
|
1132 |
|
|
Attribute_Name => Name_First),
|
1133 |
|
|
|
1134 |
|
|
Right_Opnd =>
|
1135 |
|
|
Make_Attribute_Reference (Loc,
|
1136 |
|
|
Prefix => New_Reference_To (Ptyp, Loc),
|
1137 |
|
|
Attribute_Name => Name_Last)),
|
1138 |
|
|
|
1139 |
|
|
Make_Integer_Literal (Loc, 0),
|
1140 |
|
|
|
1141 |
|
|
Make_Attribute_Reference (Loc,
|
1142 |
|
|
Prefix => New_Reference_To (Base_Type (Ptyp), Loc),
|
1143 |
|
|
Attribute_Name => Name_Width))));
|
1144 |
|
|
|
1145 |
|
|
Analyze_And_Resolve (N, Typ);
|
1146 |
|
|
return;
|
1147 |
|
|
|
1148 |
|
|
-- User defined enumeration types
|
1149 |
|
|
|
1150 |
|
|
else
|
1151 |
|
|
pragma Assert (Is_Enumeration_Type (Rtyp));
|
1152 |
|
|
|
1153 |
|
|
if Discard_Names (Rtyp) then
|
1154 |
|
|
|
1155 |
|
|
-- This is a configurable run-time, or else a restriction is in
|
1156 |
|
|
-- effect. In either case the attribute cannot be supported. Force
|
1157 |
|
|
-- a load error from Rtsfind to generate an appropriate message,
|
1158 |
|
|
-- as is done with other ZFP violations.
|
1159 |
|
|
|
1160 |
|
|
declare
|
1161 |
|
|
Discard : constant Entity_Id := RTE (RE_Null);
|
1162 |
|
|
pragma Unreferenced (Discard);
|
1163 |
|
|
begin
|
1164 |
|
|
return;
|
1165 |
|
|
end;
|
1166 |
|
|
end if;
|
1167 |
|
|
|
1168 |
|
|
Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
|
1169 |
|
|
|
1170 |
|
|
case Attr is
|
1171 |
|
|
when Normal =>
|
1172 |
|
|
if Ttyp = Standard_Integer_8 then
|
1173 |
|
|
XX := RE_Width_Enumeration_8;
|
1174 |
|
|
elsif Ttyp = Standard_Integer_16 then
|
1175 |
|
|
XX := RE_Width_Enumeration_16;
|
1176 |
|
|
else
|
1177 |
|
|
XX := RE_Width_Enumeration_32;
|
1178 |
|
|
end if;
|
1179 |
|
|
|
1180 |
|
|
when Wide =>
|
1181 |
|
|
if Ttyp = Standard_Integer_8 then
|
1182 |
|
|
XX := RE_Wide_Width_Enumeration_8;
|
1183 |
|
|
elsif Ttyp = Standard_Integer_16 then
|
1184 |
|
|
XX := RE_Wide_Width_Enumeration_16;
|
1185 |
|
|
else
|
1186 |
|
|
XX := RE_Wide_Width_Enumeration_32;
|
1187 |
|
|
end if;
|
1188 |
|
|
|
1189 |
|
|
when Wide_Wide =>
|
1190 |
|
|
if Ttyp = Standard_Integer_8 then
|
1191 |
|
|
XX := RE_Wide_Wide_Width_Enumeration_8;
|
1192 |
|
|
elsif Ttyp = Standard_Integer_16 then
|
1193 |
|
|
XX := RE_Wide_Wide_Width_Enumeration_16;
|
1194 |
|
|
else
|
1195 |
|
|
XX := RE_Wide_Wide_Width_Enumeration_32;
|
1196 |
|
|
end if;
|
1197 |
|
|
end case;
|
1198 |
|
|
|
1199 |
|
|
Arglist :=
|
1200 |
|
|
New_List (
|
1201 |
|
|
New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
|
1202 |
|
|
|
1203 |
|
|
Make_Attribute_Reference (Loc,
|
1204 |
|
|
Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
|
1205 |
|
|
Attribute_Name => Name_Address),
|
1206 |
|
|
|
1207 |
|
|
Make_Attribute_Reference (Loc,
|
1208 |
|
|
Prefix => New_Reference_To (Ptyp, Loc),
|
1209 |
|
|
Attribute_Name => Name_Pos,
|
1210 |
|
|
|
1211 |
|
|
Expressions => New_List (
|
1212 |
|
|
Make_Attribute_Reference (Loc,
|
1213 |
|
|
Prefix => New_Reference_To (Ptyp, Loc),
|
1214 |
|
|
Attribute_Name => Name_First))),
|
1215 |
|
|
|
1216 |
|
|
Make_Attribute_Reference (Loc,
|
1217 |
|
|
Prefix => New_Reference_To (Ptyp, Loc),
|
1218 |
|
|
Attribute_Name => Name_Pos,
|
1219 |
|
|
|
1220 |
|
|
Expressions => New_List (
|
1221 |
|
|
Make_Attribute_Reference (Loc,
|
1222 |
|
|
Prefix => New_Reference_To (Ptyp, Loc),
|
1223 |
|
|
Attribute_Name => Name_Last))));
|
1224 |
|
|
|
1225 |
|
|
Rewrite (N,
|
1226 |
|
|
Convert_To (Typ,
|
1227 |
|
|
Make_Function_Call (Loc,
|
1228 |
|
|
Name => New_Reference_To (RTE (XX), Loc),
|
1229 |
|
|
Parameter_Associations => Arglist)));
|
1230 |
|
|
|
1231 |
|
|
Analyze_And_Resolve (N, Typ);
|
1232 |
|
|
return;
|
1233 |
|
|
end if;
|
1234 |
|
|
|
1235 |
|
|
-- If we fall through XX and YY are set
|
1236 |
|
|
|
1237 |
|
|
Arglist := New_List (
|
1238 |
|
|
Convert_To (YY,
|
1239 |
|
|
Make_Attribute_Reference (Loc,
|
1240 |
|
|
Prefix => New_Reference_To (Ptyp, Loc),
|
1241 |
|
|
Attribute_Name => Name_First)),
|
1242 |
|
|
|
1243 |
|
|
Convert_To (YY,
|
1244 |
|
|
Make_Attribute_Reference (Loc,
|
1245 |
|
|
Prefix => New_Reference_To (Ptyp, Loc),
|
1246 |
|
|
Attribute_Name => Name_Last)));
|
1247 |
|
|
|
1248 |
|
|
Rewrite (N,
|
1249 |
|
|
Convert_To (Typ,
|
1250 |
|
|
Make_Function_Call (Loc,
|
1251 |
|
|
Name => New_Reference_To (RTE (XX), Loc),
|
1252 |
|
|
Parameter_Associations => Arglist)));
|
1253 |
|
|
|
1254 |
|
|
Analyze_And_Resolve (N, Typ);
|
1255 |
|
|
end Expand_Width_Attribute;
|
1256 |
|
|
|
1257 |
|
|
end Exp_Imgv;
|