|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- E X P _ I M G V --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 2001-2018, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
11 -- GNAT is free software; you can redistribute it and/or modify it under --
|
|
|
12 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
|
17 -- for more details. You should have received a copy of the GNU General --
|
|
|
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
|
|
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
|
|
|
20 -- --
|
|
|
21 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
23 -- --
|
|
|
24 ------------------------------------------------------------------------------
|
|
|
25
|
|
|
26 with Atree; use Atree;
|
|
|
27 with 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 Sem_Util; use Sem_Util;
|
|
|
40 with Sinfo; use Sinfo;
|
|
|
41 with Snames; use Snames;
|
|
|
42 with Stand; use Stand;
|
|
|
43 with Stringt; use Stringt;
|
|
|
44 with Tbuild; use Tbuild;
|
|
|
45 with Ttypes; use Ttypes;
|
|
|
46 with Uintp; use Uintp;
|
|
|
47 with Urealp; use Urealp;
|
|
|
48
|
|
|
49 package body Exp_Imgv is
|
|
|
50
|
|
|
51 function Has_Decimal_Small (E : Entity_Id) return Boolean;
|
|
|
52 -- Applies to all entities. True for a Decimal_Fixed_Point_Type, or an
|
|
|
53 -- Ordinary_Fixed_Point_Type with a small that is a negative power of ten.
|
|
|
54 -- Shouldn't this be in einfo.adb or sem_aux.adb???
|
|
|
55
|
|
|
56 procedure Rewrite_Object_Image
|
|
|
57 (N : Node_Id;
|
|
|
58 Pref : Entity_Id;
|
|
|
59 Attr_Name : Name_Id;
|
|
|
60 Str_Typ : Entity_Id);
|
|
|
61 -- AI12-00124: Rewrite attribute 'Image when it is applied to an object
|
|
|
62 -- reference as an attribute applied to a type. N denotes the node to be
|
|
|
63 -- rewritten, Pref denotes the prefix of the 'Image attribute, and Name
|
|
|
64 -- and Str_Typ specify which specific string type and 'Image attribute to
|
|
|
65 -- apply (e.g. Name_Wide_Image and Standard_Wide_String).
|
|
|
66
|
|
|
67 ------------------------------------
|
|
|
68 -- Build_Enumeration_Image_Tables --
|
|
|
69 ------------------------------------
|
|
|
70
|
|
|
71 procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is
|
|
|
72 Loc : constant Source_Ptr := Sloc (E);
|
|
|
73 Str : String_Id;
|
|
|
74 Ind : List_Id;
|
|
|
75 Lit : Entity_Id;
|
|
|
76 Nlit : Nat;
|
|
|
77 Len : Nat;
|
|
|
78 Estr : Entity_Id;
|
|
|
79 Eind : Entity_Id;
|
|
|
80 Ityp : Node_Id;
|
|
|
81
|
|
|
82 begin
|
|
|
83 -- Nothing to do for other than a root enumeration type
|
|
|
84
|
|
|
85 if E /= Root_Type (E) then
|
|
|
86 return;
|
|
|
87
|
|
|
88 -- Nothing to do if pragma Discard_Names applies
|
|
|
89
|
|
|
90 elsif Discard_Names (E) then
|
|
|
91 return;
|
|
|
92 end if;
|
|
|
93
|
|
|
94 -- Otherwise tables need constructing
|
|
|
95
|
|
|
96 Start_String;
|
|
|
97 Ind := New_List;
|
|
|
98 Lit := First_Literal (E);
|
|
|
99 Len := 1;
|
|
|
100 Nlit := 0;
|
|
|
101
|
|
|
102 loop
|
|
|
103 Append_To (Ind,
|
|
|
104 Make_Integer_Literal (Loc, UI_From_Int (Len)));
|
|
|
105
|
|
|
106 exit when No (Lit);
|
|
|
107 Nlit := Nlit + 1;
|
|
|
108
|
|
|
109 Get_Unqualified_Decoded_Name_String (Chars (Lit));
|
|
|
110
|
|
|
111 if Name_Buffer (1) /= ''' then
|
|
|
112 Set_Casing (All_Upper_Case);
|
|
|
113 end if;
|
|
|
114
|
|
|
115 Store_String_Chars (Name_Buffer (1 .. Name_Len));
|
|
|
116 Len := Len + Int (Name_Len);
|
|
|
117 Next_Literal (Lit);
|
|
|
118 end loop;
|
|
|
119
|
|
|
120 if Len < Int (2 ** (8 - 1)) then
|
|
|
121 Ityp := Standard_Integer_8;
|
|
|
122 elsif Len < Int (2 ** (16 - 1)) then
|
|
|
123 Ityp := Standard_Integer_16;
|
|
|
124 else
|
|
|
125 Ityp := Standard_Integer_32;
|
|
|
126 end if;
|
|
|
127
|
|
|
128 Str := End_String;
|
|
|
129
|
|
|
130 Estr :=
|
|
|
131 Make_Defining_Identifier (Loc,
|
|
|
132 Chars => New_External_Name (Chars (E), 'S'));
|
|
|
133
|
|
|
134 Eind :=
|
|
|
135 Make_Defining_Identifier (Loc,
|
|
|
136 Chars => New_External_Name (Chars (E), 'N'));
|
|
|
137
|
|
|
138 Set_Lit_Strings (E, Estr);
|
|
|
139 Set_Lit_Indexes (E, Eind);
|
|
|
140
|
|
|
141 Insert_Actions (N,
|
|
|
142 New_List (
|
|
|
143 Make_Object_Declaration (Loc,
|
|
|
144 Defining_Identifier => Estr,
|
|
|
145 Constant_Present => True,
|
|
|
146 Object_Definition =>
|
|
|
147 New_Occurrence_Of (Standard_String, Loc),
|
|
|
148 Expression =>
|
|
|
149 Make_String_Literal (Loc,
|
|
|
150 Strval => Str)),
|
|
|
151
|
|
|
152 Make_Object_Declaration (Loc,
|
|
|
153 Defining_Identifier => Eind,
|
|
|
154 Constant_Present => True,
|
|
|
155
|
|
|
156 Object_Definition =>
|
|
|
157 Make_Constrained_Array_Definition (Loc,
|
|
|
158 Discrete_Subtype_Definitions => New_List (
|
|
|
159 Make_Range (Loc,
|
|
|
160 Low_Bound => Make_Integer_Literal (Loc, 0),
|
|
|
161 High_Bound => Make_Integer_Literal (Loc, Nlit))),
|
|
|
162 Component_Definition =>
|
|
|
163 Make_Component_Definition (Loc,
|
|
|
164 Aliased_Present => False,
|
|
|
165 Subtype_Indication => New_Occurrence_Of (Ityp, Loc))),
|
|
|
166
|
|
|
167 Expression =>
|
|
|
168 Make_Aggregate (Loc,
|
|
|
169 Expressions => Ind))),
|
|
|
170 Suppress => All_Checks);
|
|
|
171 end Build_Enumeration_Image_Tables;
|
|
|
172
|
|
|
173 ----------------------------
|
|
|
174 -- Expand_Image_Attribute --
|
|
|
175 ----------------------------
|
|
|
176
|
|
|
177 -- For all cases other than user-defined enumeration types, the scheme
|
|
|
178 -- is as follows. First we insert the following code:
|
|
|
179
|
|
|
180 -- Snn : String (1 .. rt'Width);
|
|
|
181 -- Pnn : Natural;
|
|
|
182 -- Image_xx (tv, Snn, Pnn [,pm]);
|
|
|
183 --
|
|
|
184 -- and then Expr is replaced by Snn (1 .. Pnn)
|
|
|
185
|
|
|
186 -- In the above expansion:
|
|
|
187
|
|
|
188 -- rt is the root type of the expression
|
|
|
189 -- tv is the expression with the value, usually a type conversion
|
|
|
190 -- pm is an extra parameter present in some cases
|
|
|
191
|
|
|
192 -- The following table shows tv, xx, and (if used) pm for the various
|
|
|
193 -- possible types of the argument:
|
|
|
194
|
|
|
195 -- For types whose root type is Character
|
|
|
196 -- xx = Character
|
|
|
197 -- tv = Character (Expr)
|
|
|
198
|
|
|
199 -- For types whose root type is Boolean
|
|
|
200 -- xx = Boolean
|
|
|
201 -- tv = Boolean (Expr)
|
|
|
202
|
|
|
203 -- For signed integer types with size <= Integer'Size
|
|
|
204 -- xx = Integer
|
|
|
205 -- tv = Integer (Expr)
|
|
|
206
|
|
|
207 -- For other signed integer types
|
|
|
208 -- xx = Long_Long_Integer
|
|
|
209 -- tv = Long_Long_Integer (Expr)
|
|
|
210
|
|
|
211 -- For modular types with modulus <= System.Unsigned_Types.Unsigned
|
|
|
212 -- xx = Unsigned
|
|
|
213 -- tv = System.Unsigned_Types.Unsigned (Expr)
|
|
|
214
|
|
|
215 -- For other modular integer types
|
|
|
216 -- xx = Long_Long_Unsigned
|
|
|
217 -- tv = System.Unsigned_Types.Long_Long_Unsigned (Expr)
|
|
|
218
|
|
|
219 -- For types whose root type is Wide_Character
|
|
|
220 -- xx = Wide_Character
|
|
|
221 -- tv = Wide_Character (Expr)
|
|
|
222 -- pm = Boolean, true if Ada 2005 mode, False otherwise
|
|
|
223
|
|
|
224 -- For types whose root type is Wide_Wide_Character
|
|
|
225 -- xx = Wide_Wide_Character
|
|
|
226 -- tv = Wide_Wide_Character (Expr)
|
|
|
227
|
|
|
228 -- For floating-point types
|
|
|
229 -- xx = Floating_Point
|
|
|
230 -- tv = Long_Long_Float (Expr)
|
|
|
231 -- pm = typ'Digits (typ = subtype of expression)
|
|
|
232
|
|
|
233 -- For ordinary fixed-point types
|
|
|
234 -- xx = Ordinary_Fixed_Point
|
|
|
235 -- tv = Long_Long_Float (Expr)
|
|
|
236 -- pm = typ'Aft (typ = subtype of expression)
|
|
|
237
|
|
|
238 -- For decimal fixed-point types with size = Integer'Size
|
|
|
239 -- xx = Decimal
|
|
|
240 -- tv = Integer (Expr)
|
|
|
241 -- pm = typ'Scale (typ = subtype of expression)
|
|
|
242
|
|
|
243 -- For decimal fixed-point types with size > Integer'Size
|
|
|
244 -- xx = Long_Long_Decimal
|
|
|
245 -- tv = Long_Long_Integer?(Expr) [convert with no scaling]
|
|
|
246 -- pm = typ'Scale (typ = subtype of expression)
|
|
|
247
|
|
|
248 -- For enumeration types other than those declared packages Standard
|
|
|
249 -- or System, Snn, Pnn, are expanded as above, but the call looks like:
|
|
|
250
|
|
|
251 -- Image_Enumeration_NN (rt'Pos (X), Snn, Pnn, typS, typI'Address)
|
|
|
252
|
|
|
253 -- where rt is the root type of the expression, and typS and typI are
|
|
|
254 -- the entities constructed as described in the spec for the procedure
|
|
|
255 -- Build_Enumeration_Image_Tables and NN is 32/16/8 depending on the
|
|
|
256 -- element type of Lit_Indexes. The rewriting of the expression to
|
|
|
257 -- Snn (1 .. Pnn) then occurs as in the other cases. A special case is
|
|
|
258 -- when pragma Discard_Names applies, in which case we replace expr by:
|
|
|
259
|
|
|
260 -- (rt'Pos (expr))'Img
|
|
|
261
|
|
|
262 -- So that the result is a space followed by the decimal value for the
|
|
|
263 -- position of the enumeration value in the enumeration type.
|
|
|
264
|
|
|
265 procedure Expand_Image_Attribute (N : Node_Id) is
|
|
|
266 Loc : constant Source_Ptr := Sloc (N);
|
|
|
267 Exprs : constant List_Id := Expressions (N);
|
|
|
268 Expr : constant Node_Id := Relocate_Node (First (Exprs));
|
|
|
269 Pref : constant Node_Id := Prefix (N);
|
|
|
270
|
|
|
271 procedure Expand_User_Defined_Enumeration_Image;
|
|
|
272 -- Expand attribute 'Image in user-defined enumeration types, avoiding
|
|
|
273 -- string copy.
|
|
|
274
|
|
|
275 function Is_User_Defined_Enumeration_Type
|
|
|
276 (Typ : Entity_Id) return Boolean;
|
|
|
277 -- Return True if Typ is a user-defined enumeration type
|
|
|
278
|
|
|
279 -------------------------------------------
|
|
|
280 -- Expand_User_Defined_Enumeration_Image --
|
|
|
281 -------------------------------------------
|
|
|
282
|
|
|
283 procedure Expand_User_Defined_Enumeration_Image is
|
|
|
284 Ins_List : constant List_Id := New_List;
|
|
|
285 P1_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
|
|
|
286 P2_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
|
|
|
287 P3_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
|
|
|
288 P4_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
|
|
|
289 Ptyp : constant Entity_Id := Entity (Pref);
|
|
|
290 Rtyp : constant Entity_Id := Root_Type (Ptyp);
|
|
|
291 S1_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
|
|
|
292
|
|
|
293 begin
|
|
|
294 -- Apply a validity check, since it is a bit drastic to get a
|
|
|
295 -- completely junk image value for an invalid value.
|
|
|
296
|
|
|
297 if not Expr_Known_Valid (Expr) then
|
|
|
298 Insert_Valid_Check (Expr);
|
|
|
299 end if;
|
|
|
300
|
|
|
301 -- Generate:
|
|
|
302 -- P1 : constant Natural := Pos;
|
|
|
303
|
|
|
304 Append_To (Ins_List,
|
|
|
305 Make_Object_Declaration (Loc,
|
|
|
306 Defining_Identifier => P1_Id,
|
|
|
307 Object_Definition =>
|
|
|
308 New_Occurrence_Of (Standard_Natural, Loc),
|
|
|
309 Constant_Present => True,
|
|
|
310 Expression =>
|
|
|
311 Convert_To (Standard_Natural,
|
|
|
312 Make_Attribute_Reference (Loc,
|
|
|
313 Attribute_Name => Name_Pos,
|
|
|
314 Prefix => New_Occurrence_Of (Ptyp, Loc),
|
|
|
315 Expressions => New_List (Expr)))));
|
|
|
316
|
|
|
317 -- Compute the index of the string start, generating:
|
|
|
318 -- P2 : constant Natural := call_put_enumN (P1);
|
|
|
319
|
|
|
320 Append_To (Ins_List,
|
|
|
321 Make_Object_Declaration (Loc,
|
|
|
322 Defining_Identifier => P2_Id,
|
|
|
323 Object_Definition =>
|
|
|
324 New_Occurrence_Of (Standard_Natural, Loc),
|
|
|
325 Constant_Present => True,
|
|
|
326 Expression =>
|
|
|
327 Convert_To (Standard_Natural,
|
|
|
328 Make_Indexed_Component (Loc,
|
|
|
329 Prefix =>
|
|
|
330 New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
|
|
|
331 Expressions =>
|
|
|
332 New_List (New_Occurrence_Of (P1_Id, Loc))))));
|
|
|
333
|
|
|
334 -- Compute the index of the next value, generating:
|
|
|
335 -- P3 : constant Natural := call_put_enumN (P1 + 1);
|
|
|
336
|
|
|
337 declare
|
|
|
338 Add_Node : constant Node_Id := New_Op_Node (N_Op_Add, Loc);
|
|
|
339
|
|
|
340 begin
|
|
|
341 Set_Left_Opnd (Add_Node, New_Occurrence_Of (P1_Id, Loc));
|
|
|
342 Set_Right_Opnd (Add_Node, Make_Integer_Literal (Loc, 1));
|
|
|
343
|
|
|
344 Append_To (Ins_List,
|
|
|
345 Make_Object_Declaration (Loc,
|
|
|
346 Defining_Identifier => P3_Id,
|
|
|
347 Object_Definition =>
|
|
|
348 New_Occurrence_Of (Standard_Natural, Loc),
|
|
|
349 Constant_Present => True,
|
|
|
350 Expression =>
|
|
|
351 Convert_To (Standard_Natural,
|
|
|
352 Make_Indexed_Component (Loc,
|
|
|
353 Prefix =>
|
|
|
354 New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
|
|
|
355 Expressions =>
|
|
|
356 New_List (Add_Node)))));
|
|
|
357 end;
|
|
|
358
|
|
|
359 -- Generate:
|
|
|
360 -- S4 : String renames call_put_enumS (S2 .. S3 - 1);
|
|
|
361
|
|
|
362 declare
|
|
|
363 Sub_Node : constant Node_Id := New_Op_Node (N_Op_Subtract, Loc);
|
|
|
364
|
|
|
365 begin
|
|
|
366 Set_Left_Opnd (Sub_Node, New_Occurrence_Of (P3_Id, Loc));
|
|
|
367 Set_Right_Opnd (Sub_Node, Make_Integer_Literal (Loc, 1));
|
|
|
368
|
|
|
369 Append_To (Ins_List,
|
|
|
370 Make_Object_Renaming_Declaration (Loc,
|
|
|
371 Defining_Identifier => P4_Id,
|
|
|
372 Subtype_Mark =>
|
|
|
373 New_Occurrence_Of (Standard_String, Loc),
|
|
|
374 Name =>
|
|
|
375 Make_Slice (Loc,
|
|
|
376 Prefix =>
|
|
|
377 New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
|
|
|
378 Discrete_Range =>
|
|
|
379 Make_Range (Loc,
|
|
|
380 Low_Bound => New_Occurrence_Of (P2_Id, Loc),
|
|
|
381 High_Bound => Sub_Node))));
|
|
|
382 end;
|
|
|
383
|
|
|
384 -- Generate:
|
|
|
385 -- subtype S1 is string (1 .. P3 - P2);
|
|
|
386
|
|
|
387 declare
|
|
|
388 HB : constant Node_Id := New_Op_Node (N_Op_Subtract, Loc);
|
|
|
389
|
|
|
390 begin
|
|
|
391 Set_Left_Opnd (HB, New_Occurrence_Of (P3_Id, Loc));
|
|
|
392 Set_Right_Opnd (HB, New_Occurrence_Of (P2_Id, Loc));
|
|
|
393
|
|
|
394 Append_To (Ins_List,
|
|
|
395 Make_Subtype_Declaration (Loc,
|
|
|
396 Defining_Identifier => S1_Id,
|
|
|
397 Subtype_Indication =>
|
|
|
398 Make_Subtype_Indication (Loc,
|
|
|
399 Subtype_Mark =>
|
|
|
400 New_Occurrence_Of (Standard_String, Loc),
|
|
|
401 Constraint =>
|
|
|
402 Make_Index_Or_Discriminant_Constraint (Loc,
|
|
|
403 Constraints => New_List (
|
|
|
404 Make_Range (Loc,
|
|
|
405 Low_Bound => Make_Integer_Literal (Loc, 1),
|
|
|
406 High_Bound => HB))))));
|
|
|
407 end;
|
|
|
408
|
|
|
409 -- Insert all the above declarations before N. We suppress checks
|
|
|
410 -- because everything is in range at this stage.
|
|
|
411
|
|
|
412 Insert_Actions (N, Ins_List, Suppress => All_Checks);
|
|
|
413
|
|
|
414 Rewrite (N,
|
|
|
415 Unchecked_Convert_To (S1_Id, New_Occurrence_Of (P4_Id, Loc)));
|
|
|
416
|
|
|
417 Analyze_And_Resolve (N, Standard_String);
|
|
|
418 end Expand_User_Defined_Enumeration_Image;
|
|
|
419
|
|
|
420 --------------------------------------
|
|
|
421 -- Is_User_Defined_Enumeration_Type --
|
|
|
422 --------------------------------------
|
|
|
423
|
|
|
424 function Is_User_Defined_Enumeration_Type
|
|
|
425 (Typ : Entity_Id) return Boolean is
|
|
|
426 begin
|
|
|
427 return Ekind (Typ) = E_Enumeration_Type
|
|
|
428 and then Typ /= Standard_Boolean
|
|
|
429 and then Typ /= Standard_Character
|
|
|
430 and then Typ /= Standard_Wide_Character
|
|
|
431 and then Typ /= Standard_Wide_Wide_Character;
|
|
|
432 end Is_User_Defined_Enumeration_Type;
|
|
|
433
|
|
|
434 -- Local variables
|
|
|
435
|
|
|
436 Imid : RE_Id;
|
|
|
437 Ptyp : Entity_Id;
|
|
|
438 Rtyp : Entity_Id;
|
|
131
|
439 Tent : Entity_Id := Empty;
|
|
111
|
440 Ttyp : Entity_Id;
|
|
|
441 Proc_Ent : Entity_Id;
|
|
|
442 Enum_Case : Boolean;
|
|
|
443
|
|
|
444 Arg_List : List_Id;
|
|
|
445 -- List of arguments for run-time procedure call
|
|
|
446
|
|
|
447 Ins_List : List_Id;
|
|
|
448 -- List of actions to be inserted
|
|
|
449
|
|
|
450 Snn : constant Entity_Id := Make_Temporary (Loc, 'S');
|
|
|
451 Pnn : constant Entity_Id := Make_Temporary (Loc, 'P');
|
|
|
452
|
|
|
453 begin
|
|
|
454 if Is_Object_Image (Pref) then
|
|
|
455 Rewrite_Object_Image (N, Pref, Name_Image, Standard_String);
|
|
|
456 return;
|
|
|
457
|
|
|
458 -- Enable speed-optimized expansion of user-defined enumeration types
|
|
|
459 -- if we are compiling with optimizations enabled and enumeration type
|
|
|
460 -- literals are generated. Otherwise the call will be expanded into a
|
|
|
461 -- call to the runtime library.
|
|
|
462
|
|
|
463 elsif Optimization_Level > 0
|
|
|
464 and then not Global_Discard_Names
|
|
|
465 and then Is_User_Defined_Enumeration_Type (Root_Type (Entity (Pref)))
|
|
|
466 then
|
|
|
467 Expand_User_Defined_Enumeration_Image;
|
|
|
468 return;
|
|
|
469 end if;
|
|
|
470
|
|
|
471 Ptyp := Entity (Pref);
|
|
|
472 Rtyp := Root_Type (Ptyp);
|
|
|
473
|
|
|
474 -- Build declarations of Snn and Pnn to be inserted
|
|
|
475
|
|
|
476 Ins_List := New_List (
|
|
|
477
|
|
|
478 -- Snn : String (1 .. typ'Width);
|
|
|
479
|
|
|
480 Make_Object_Declaration (Loc,
|
|
|
481 Defining_Identifier => Snn,
|
|
|
482 Object_Definition =>
|
|
|
483 Make_Subtype_Indication (Loc,
|
|
|
484 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
|
|
|
485 Constraint =>
|
|
|
486 Make_Index_Or_Discriminant_Constraint (Loc,
|
|
|
487 Constraints => New_List (
|
|
|
488 Make_Range (Loc,
|
|
|
489 Low_Bound => Make_Integer_Literal (Loc, 1),
|
|
|
490 High_Bound =>
|
|
|
491 Make_Attribute_Reference (Loc,
|
|
|
492 Prefix => New_Occurrence_Of (Rtyp, Loc),
|
|
|
493 Attribute_Name => Name_Width)))))),
|
|
|
494
|
|
|
495 -- Pnn : Natural;
|
|
|
496
|
|
|
497 Make_Object_Declaration (Loc,
|
|
|
498 Defining_Identifier => Pnn,
|
|
|
499 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)));
|
|
|
500
|
|
|
501 -- Set Imid (RE_Id of procedure to call), and Tent, target for the
|
|
|
502 -- type conversion of the first argument for all possibilities.
|
|
|
503
|
|
|
504 Enum_Case := False;
|
|
|
505
|
|
|
506 if Rtyp = Standard_Boolean then
|
|
|
507 Imid := RE_Image_Boolean;
|
|
|
508 Tent := Rtyp;
|
|
|
509
|
|
|
510 -- For standard character, we have to select the version which handles
|
|
|
511 -- soft hyphen correctly, based on the version of Ada in use (this is
|
|
|
512 -- ugly, but we have no choice).
|
|
|
513
|
|
|
514 elsif Rtyp = Standard_Character then
|
|
|
515 if Ada_Version < Ada_2005 then
|
|
|
516 Imid := RE_Image_Character;
|
|
|
517 else
|
|
|
518 Imid := RE_Image_Character_05;
|
|
|
519 end if;
|
|
|
520
|
|
|
521 Tent := Rtyp;
|
|
|
522
|
|
|
523 elsif Rtyp = Standard_Wide_Character then
|
|
|
524 Imid := RE_Image_Wide_Character;
|
|
|
525 Tent := Rtyp;
|
|
|
526
|
|
|
527 elsif Rtyp = Standard_Wide_Wide_Character then
|
|
|
528 Imid := RE_Image_Wide_Wide_Character;
|
|
|
529 Tent := Rtyp;
|
|
|
530
|
|
|
531 elsif Is_Signed_Integer_Type (Rtyp) then
|
|
|
532 if Esize (Rtyp) <= Esize (Standard_Integer) then
|
|
|
533 Imid := RE_Image_Integer;
|
|
|
534 Tent := Standard_Integer;
|
|
|
535 else
|
|
|
536 Imid := RE_Image_Long_Long_Integer;
|
|
|
537 Tent := Standard_Long_Long_Integer;
|
|
|
538 end if;
|
|
|
539
|
|
|
540 elsif Is_Modular_Integer_Type (Rtyp) then
|
|
|
541 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
|
|
|
542 Imid := RE_Image_Unsigned;
|
|
|
543 Tent := RTE (RE_Unsigned);
|
|
|
544 else
|
|
|
545 Imid := RE_Image_Long_Long_Unsigned;
|
|
|
546 Tent := RTE (RE_Long_Long_Unsigned);
|
|
|
547 end if;
|
|
|
548
|
|
|
549 elsif Is_Fixed_Point_Type (Rtyp) and then Has_Decimal_Small (Rtyp) then
|
|
|
550 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
|
|
|
551 Imid := RE_Image_Decimal;
|
|
|
552 Tent := Standard_Integer;
|
|
|
553 else
|
|
|
554 Imid := RE_Image_Long_Long_Decimal;
|
|
|
555 Tent := Standard_Long_Long_Integer;
|
|
|
556 end if;
|
|
|
557
|
|
|
558 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
|
|
|
559 Imid := RE_Image_Ordinary_Fixed_Point;
|
|
|
560 Tent := Standard_Long_Long_Float;
|
|
|
561
|
|
|
562 elsif Is_Floating_Point_Type (Rtyp) then
|
|
|
563 Imid := RE_Image_Floating_Point;
|
|
|
564 Tent := Standard_Long_Long_Float;
|
|
|
565
|
|
|
566 -- Only other possibility is user-defined enumeration type
|
|
|
567
|
|
|
568 else
|
|
|
569 if Discard_Names (First_Subtype (Ptyp))
|
|
|
570 or else No (Lit_Strings (Root_Type (Ptyp)))
|
|
|
571 then
|
|
|
572 -- When pragma Discard_Names applies to the first subtype, build
|
|
|
573 -- (Pref'Pos (Expr))'Img.
|
|
|
574
|
|
|
575 Rewrite (N,
|
|
|
576 Make_Attribute_Reference (Loc,
|
|
|
577 Prefix =>
|
|
|
578 Make_Attribute_Reference (Loc,
|
|
|
579 Prefix => Pref,
|
|
|
580 Attribute_Name => Name_Pos,
|
|
|
581 Expressions => New_List (Expr)),
|
|
|
582 Attribute_Name =>
|
|
|
583 Name_Img));
|
|
|
584 Analyze_And_Resolve (N, Standard_String);
|
|
|
585 return;
|
|
|
586
|
|
|
587 else
|
|
|
588 -- Here for enumeration type case
|
|
|
589
|
|
|
590 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
|
|
|
591
|
|
|
592 if Ttyp = Standard_Integer_8 then
|
|
|
593 Imid := RE_Image_Enumeration_8;
|
|
|
594
|
|
|
595 elsif Ttyp = Standard_Integer_16 then
|
|
|
596 Imid := RE_Image_Enumeration_16;
|
|
|
597
|
|
|
598 else
|
|
|
599 Imid := RE_Image_Enumeration_32;
|
|
|
600 end if;
|
|
|
601
|
|
|
602 -- Apply a validity check, since it is a bit drastic to get a
|
|
|
603 -- completely junk image value for an invalid value.
|
|
|
604
|
|
|
605 if not Expr_Known_Valid (Expr) then
|
|
|
606 Insert_Valid_Check (Expr);
|
|
|
607 end if;
|
|
|
608
|
|
|
609 Enum_Case := True;
|
|
|
610 end if;
|
|
|
611 end if;
|
|
|
612
|
|
|
613 -- Build first argument for call
|
|
|
614
|
|
|
615 if Enum_Case then
|
|
|
616 Arg_List := New_List (
|
|
|
617 Make_Attribute_Reference (Loc,
|
|
|
618 Attribute_Name => Name_Pos,
|
|
|
619 Prefix => New_Occurrence_Of (Ptyp, Loc),
|
|
|
620 Expressions => New_List (Expr)));
|
|
|
621
|
|
|
622 else
|
|
|
623 Arg_List := New_List (Convert_To (Tent, Expr));
|
|
|
624 end if;
|
|
|
625
|
|
|
626 -- Append Snn, Pnn arguments
|
|
|
627
|
|
|
628 Append_To (Arg_List, New_Occurrence_Of (Snn, Loc));
|
|
|
629 Append_To (Arg_List, New_Occurrence_Of (Pnn, Loc));
|
|
|
630
|
|
|
631 -- Get entity of procedure to call
|
|
|
632
|
|
|
633 Proc_Ent := RTE (Imid);
|
|
|
634
|
|
|
635 -- If the procedure entity is empty, that means we have a case in
|
|
|
636 -- no run time mode where the operation is not allowed, and an
|
|
|
637 -- appropriate diagnostic has already been issued.
|
|
|
638
|
|
|
639 if No (Proc_Ent) then
|
|
|
640 return;
|
|
|
641 end if;
|
|
|
642
|
|
|
643 -- Otherwise complete preparation of arguments for run-time call
|
|
|
644
|
|
|
645 -- Add extra arguments for Enumeration case
|
|
|
646
|
|
|
647 if Enum_Case then
|
|
|
648 Append_To (Arg_List, New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
|
|
|
649 Append_To (Arg_List,
|
|
|
650 Make_Attribute_Reference (Loc,
|
|
|
651 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
|
|
|
652 Attribute_Name => Name_Address));
|
|
|
653
|
|
|
654 -- For floating-point types, append Digits argument
|
|
|
655
|
|
|
656 elsif Is_Floating_Point_Type (Rtyp) then
|
|
|
657 Append_To (Arg_List,
|
|
|
658 Make_Attribute_Reference (Loc,
|
|
|
659 Prefix => New_Occurrence_Of (Ptyp, Loc),
|
|
|
660 Attribute_Name => Name_Digits));
|
|
|
661
|
|
|
662 -- For ordinary fixed-point types, append Aft parameter
|
|
|
663
|
|
|
664 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
|
|
|
665 Append_To (Arg_List,
|
|
|
666 Make_Attribute_Reference (Loc,
|
|
|
667 Prefix => New_Occurrence_Of (Ptyp, Loc),
|
|
|
668 Attribute_Name => Name_Aft));
|
|
|
669
|
|
|
670 if Has_Decimal_Small (Rtyp) then
|
|
|
671 Set_Conversion_OK (First (Arg_List));
|
|
|
672 Set_Etype (First (Arg_List), Tent);
|
|
|
673 end if;
|
|
|
674
|
|
|
675 -- For decimal, append Scale and also set to do literal conversion
|
|
|
676
|
|
|
677 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
|
|
|
678 Append_To (Arg_List,
|
|
|
679 Make_Attribute_Reference (Loc,
|
|
|
680 Prefix => New_Occurrence_Of (Ptyp, Loc),
|
|
|
681 Attribute_Name => Name_Scale));
|
|
|
682
|
|
|
683 Set_Conversion_OK (First (Arg_List));
|
|
|
684 Set_Etype (First (Arg_List), Tent);
|
|
|
685
|
|
|
686 -- For Wide_Character, append Ada 2005 indication
|
|
|
687
|
|
|
688 elsif Rtyp = Standard_Wide_Character then
|
|
|
689 Append_To (Arg_List,
|
|
|
690 New_Occurrence_Of
|
|
|
691 (Boolean_Literals (Ada_Version >= Ada_2005), Loc));
|
|
|
692 end if;
|
|
|
693
|
|
|
694 -- Now append the procedure call to the insert list
|
|
|
695
|
|
|
696 Append_To (Ins_List,
|
|
|
697 Make_Procedure_Call_Statement (Loc,
|
|
|
698 Name => New_Occurrence_Of (Proc_Ent, Loc),
|
|
|
699 Parameter_Associations => Arg_List));
|
|
|
700
|
|
|
701 -- Insert declarations of Snn, Pnn, and the procedure call. We suppress
|
|
|
702 -- checks because we are sure that everything is in range at this stage.
|
|
|
703
|
|
|
704 Insert_Actions (N, Ins_List, Suppress => All_Checks);
|
|
|
705
|
|
|
706 -- Final step is to rewrite the expression as a slice and analyze,
|
|
|
707 -- again with no checks, since we are sure that everything is OK.
|
|
|
708
|
|
|
709 Rewrite (N,
|
|
|
710 Make_Slice (Loc,
|
|
|
711 Prefix => New_Occurrence_Of (Snn, Loc),
|
|
|
712 Discrete_Range =>
|
|
|
713 Make_Range (Loc,
|
|
|
714 Low_Bound => Make_Integer_Literal (Loc, 1),
|
|
|
715 High_Bound => New_Occurrence_Of (Pnn, Loc))));
|
|
|
716
|
|
|
717 Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks);
|
|
|
718 end Expand_Image_Attribute;
|
|
|
719
|
|
|
720 ----------------------------
|
|
|
721 -- Expand_Value_Attribute --
|
|
|
722 ----------------------------
|
|
|
723
|
|
|
724 -- For scalar types derived from Boolean, Character and integer types
|
|
|
725 -- in package Standard, typ'Value (X) expands into:
|
|
|
726
|
|
|
727 -- btyp (Value_xx (X))
|
|
|
728
|
|
|
729 -- where btyp is he base type of the prefix
|
|
|
730
|
|
|
731 -- For types whose root type is Character
|
|
|
732 -- xx = Character
|
|
|
733
|
|
|
734 -- For types whose root type is Wide_Character
|
|
|
735 -- xx = Wide_Character
|
|
|
736
|
|
|
737 -- For types whose root type is Wide_Wide_Character
|
|
|
738 -- xx = Wide_Wide_Character
|
|
|
739
|
|
|
740 -- For types whose root type is Boolean
|
|
|
741 -- xx = Boolean
|
|
|
742
|
|
|
743 -- For signed integer types with size <= Integer'Size
|
|
|
744 -- xx = Integer
|
|
|
745
|
|
|
746 -- For other signed integer types
|
|
|
747 -- xx = Long_Long_Integer
|
|
|
748
|
|
|
749 -- For modular types with modulus <= System.Unsigned_Types.Unsigned
|
|
|
750 -- xx = Unsigned
|
|
|
751
|
|
|
752 -- For other modular integer types
|
|
|
753 -- xx = Long_Long_Unsigned
|
|
|
754
|
|
|
755 -- For floating-point types and ordinary fixed-point types
|
|
|
756 -- xx = Real
|
|
|
757
|
|
|
758 -- For Wide_[Wide_]Character types, typ'Value (X) expands into:
|
|
|
759
|
|
|
760 -- btyp (Value_xx (X, EM))
|
|
|
761
|
|
|
762 -- where btyp is the base type of the prefix, and EM is the encoding method
|
|
|
763
|
|
|
764 -- For decimal types with size <= Integer'Size, typ'Value (X)
|
|
|
765 -- expands into
|
|
|
766
|
|
|
767 -- btyp?(Value_Decimal (X, typ'Scale));
|
|
|
768
|
|
|
769 -- For all other decimal types, typ'Value (X) expands into
|
|
|
770
|
|
|
771 -- btyp?(Value_Long_Long_Decimal (X, typ'Scale))
|
|
|
772
|
|
|
773 -- For enumeration types other than those derived from types Boolean,
|
|
|
774 -- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
|
|
|
775
|
|
|
776 -- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
|
|
|
777
|
|
|
778 -- where typS and typI and the Lit_Strings and Lit_Indexes entities
|
|
|
779 -- from T's root type entity, and Num is Enum'Pos (Enum'Last). The
|
|
|
780 -- Value_Enumeration_NN function will search the tables looking for
|
|
|
781 -- X and return the position number in the table if found which is
|
|
|
782 -- used to provide the result of 'Value (using Enum'Val). If the
|
|
|
783 -- value is not found Constraint_Error is raised. The suffix _NN
|
|
|
784 -- depends on the element type of typI.
|
|
|
785
|
|
|
786 procedure Expand_Value_Attribute (N : Node_Id) is
|
|
|
787 Loc : constant Source_Ptr := Sloc (N);
|
|
|
788 Typ : constant Entity_Id := Etype (N);
|
|
|
789 Btyp : constant Entity_Id := Base_Type (Typ);
|
|
|
790 Rtyp : constant Entity_Id := Root_Type (Typ);
|
|
|
791 Exprs : constant List_Id := Expressions (N);
|
|
|
792 Vid : RE_Id;
|
|
|
793 Args : List_Id;
|
|
|
794 Func : RE_Id;
|
|
|
795 Ttyp : Entity_Id;
|
|
|
796
|
|
|
797 begin
|
|
|
798 Args := Exprs;
|
|
|
799
|
|
|
800 if Rtyp = Standard_Character then
|
|
|
801 Vid := RE_Value_Character;
|
|
|
802
|
|
|
803 elsif Rtyp = Standard_Boolean then
|
|
|
804 Vid := RE_Value_Boolean;
|
|
|
805
|
|
|
806 elsif Rtyp = Standard_Wide_Character then
|
|
|
807 Vid := RE_Value_Wide_Character;
|
|
|
808
|
|
|
809 Append_To (Args,
|
|
|
810 Make_Integer_Literal (Loc,
|
|
|
811 Intval => Int (Wide_Character_Encoding_Method)));
|
|
|
812
|
|
|
813 elsif Rtyp = Standard_Wide_Wide_Character then
|
|
|
814 Vid := RE_Value_Wide_Wide_Character;
|
|
|
815
|
|
|
816 Append_To (Args,
|
|
|
817 Make_Integer_Literal (Loc,
|
|
|
818 Intval => Int (Wide_Character_Encoding_Method)));
|
|
|
819
|
|
|
820 elsif Rtyp = Base_Type (Standard_Short_Short_Integer)
|
|
|
821 or else Rtyp = Base_Type (Standard_Short_Integer)
|
|
|
822 or else Rtyp = Base_Type (Standard_Integer)
|
|
|
823 then
|
|
|
824 Vid := RE_Value_Integer;
|
|
|
825
|
|
|
826 elsif Is_Signed_Integer_Type (Rtyp) then
|
|
|
827 Vid := RE_Value_Long_Long_Integer;
|
|
|
828
|
|
|
829 elsif Is_Modular_Integer_Type (Rtyp) then
|
|
|
830 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
|
|
|
831 Vid := RE_Value_Unsigned;
|
|
|
832 else
|
|
|
833 Vid := RE_Value_Long_Long_Unsigned;
|
|
|
834 end if;
|
|
|
835
|
|
|
836 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
|
|
|
837 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
|
|
|
838 Vid := RE_Value_Decimal;
|
|
|
839 else
|
|
|
840 Vid := RE_Value_Long_Long_Decimal;
|
|
|
841 end if;
|
|
|
842
|
|
|
843 Append_To (Args,
|
|
|
844 Make_Attribute_Reference (Loc,
|
|
|
845 Prefix => New_Occurrence_Of (Typ, Loc),
|
|
|
846 Attribute_Name => Name_Scale));
|
|
|
847
|
|
|
848 Rewrite (N,
|
|
|
849 OK_Convert_To (Btyp,
|
|
|
850 Make_Function_Call (Loc,
|
|
|
851 Name => New_Occurrence_Of (RTE (Vid), Loc),
|
|
|
852 Parameter_Associations => Args)));
|
|
|
853
|
|
|
854 Set_Etype (N, Btyp);
|
|
|
855 Analyze_And_Resolve (N, Btyp);
|
|
|
856 return;
|
|
|
857
|
|
|
858 elsif Is_Real_Type (Rtyp) then
|
|
|
859 Vid := RE_Value_Real;
|
|
|
860
|
|
|
861 -- Only other possibility is user-defined enumeration type
|
|
|
862
|
|
|
863 else
|
|
|
864 pragma Assert (Is_Enumeration_Type (Rtyp));
|
|
|
865
|
|
|
866 -- Case of pragma Discard_Names, transform the Value
|
|
|
867 -- attribute to Btyp'Val (Long_Long_Integer'Value (Args))
|
|
|
868
|
|
|
869 if Discard_Names (First_Subtype (Typ))
|
|
|
870 or else No (Lit_Strings (Rtyp))
|
|
|
871 then
|
|
|
872 Rewrite (N,
|
|
|
873 Make_Attribute_Reference (Loc,
|
|
|
874 Prefix => New_Occurrence_Of (Btyp, Loc),
|
|
|
875 Attribute_Name => Name_Val,
|
|
|
876 Expressions => New_List (
|
|
|
877 Make_Attribute_Reference (Loc,
|
|
|
878 Prefix =>
|
|
|
879 New_Occurrence_Of (Standard_Long_Long_Integer, Loc),
|
|
|
880 Attribute_Name => Name_Value,
|
|
|
881 Expressions => Args))));
|
|
|
882
|
|
|
883 Analyze_And_Resolve (N, Btyp);
|
|
|
884
|
|
|
885 -- Here for normal case where we have enumeration tables, this
|
|
|
886 -- is where we build
|
|
|
887
|
|
|
888 -- T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
|
|
|
889
|
|
|
890 else
|
|
|
891 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
|
|
|
892
|
|
|
893 if Ttyp = Standard_Integer_8 then
|
|
|
894 Func := RE_Value_Enumeration_8;
|
|
|
895 elsif Ttyp = Standard_Integer_16 then
|
|
|
896 Func := RE_Value_Enumeration_16;
|
|
|
897 else
|
|
|
898 Func := RE_Value_Enumeration_32;
|
|
|
899 end if;
|
|
|
900
|
|
|
901 Prepend_To (Args,
|
|
|
902 Make_Attribute_Reference (Loc,
|
|
|
903 Prefix => New_Occurrence_Of (Rtyp, Loc),
|
|
|
904 Attribute_Name => Name_Pos,
|
|
|
905 Expressions => New_List (
|
|
|
906 Make_Attribute_Reference (Loc,
|
|
|
907 Prefix => New_Occurrence_Of (Rtyp, Loc),
|
|
|
908 Attribute_Name => Name_Last))));
|
|
|
909
|
|
|
910 Prepend_To (Args,
|
|
|
911 Make_Attribute_Reference (Loc,
|
|
|
912 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
|
|
|
913 Attribute_Name => Name_Address));
|
|
|
914
|
|
|
915 Prepend_To (Args,
|
|
|
916 New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
|
|
|
917
|
|
|
918 Rewrite (N,
|
|
|
919 Make_Attribute_Reference (Loc,
|
|
|
920 Prefix => New_Occurrence_Of (Typ, Loc),
|
|
|
921 Attribute_Name => Name_Val,
|
|
|
922 Expressions => New_List (
|
|
|
923 Make_Function_Call (Loc,
|
|
|
924 Name =>
|
|
|
925 New_Occurrence_Of (RTE (Func), Loc),
|
|
|
926 Parameter_Associations => Args))));
|
|
|
927
|
|
|
928 Analyze_And_Resolve (N, Btyp);
|
|
|
929 end if;
|
|
|
930
|
|
|
931 return;
|
|
|
932 end if;
|
|
|
933
|
|
|
934 -- Fall through for all cases except user-defined enumeration type
|
|
|
935 -- and decimal types, with Vid set to the Id of the entity for the
|
|
|
936 -- Value routine and Args set to the list of parameters for the call.
|
|
|
937
|
|
|
938 -- Compiling package Ada.Tags under No_Run_Time_Mode we disable the
|
|
|
939 -- expansion of the attribute into the function call statement to avoid
|
|
|
940 -- generating spurious errors caused by the use of Integer_Address'Value
|
|
|
941 -- in our implementation of Ada.Tags.Internal_Tag
|
|
|
942
|
|
|
943 -- Seems like a bit of a odd approach, there should be a better way ???
|
|
|
944
|
|
|
945 -- There is a better way, test RTE_Available ???
|
|
|
946
|
|
|
947 if No_Run_Time_Mode
|
|
|
948 and then Rtyp = RTE (RE_Integer_Address)
|
|
|
949 and then RTU_Loaded (Ada_Tags)
|
|
|
950 and then Cunit_Entity (Current_Sem_Unit)
|
|
|
951 = Body_Entity (RTU_Entity (Ada_Tags))
|
|
|
952 then
|
|
|
953 Rewrite (N,
|
|
|
954 Unchecked_Convert_To (Rtyp,
|
|
|
955 Make_Integer_Literal (Loc, Uint_0)));
|
|
|
956 else
|
|
|
957 Rewrite (N,
|
|
|
958 Convert_To (Btyp,
|
|
|
959 Make_Function_Call (Loc,
|
|
|
960 Name => New_Occurrence_Of (RTE (Vid), Loc),
|
|
|
961 Parameter_Associations => Args)));
|
|
|
962 end if;
|
|
|
963
|
|
|
964 Analyze_And_Resolve (N, Btyp);
|
|
|
965 end Expand_Value_Attribute;
|
|
|
966
|
|
|
967 ---------------------------------
|
|
|
968 -- Expand_Wide_Image_Attribute --
|
|
|
969 ---------------------------------
|
|
|
970
|
|
|
971 -- We expand typ'Wide_Image (X) as follows. First we insert this code:
|
|
|
972
|
|
|
973 -- Rnn : Wide_String (1 .. rt'Wide_Width);
|
|
|
974 -- Lnn : Natural;
|
|
|
975 -- String_To_Wide_String
|
|
|
976 -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
|
|
|
977
|
|
|
978 -- where rt is the root type of the prefix type
|
|
|
979
|
|
|
980 -- Now we replace the Wide_Image reference by
|
|
|
981
|
|
|
982 -- Rnn (1 .. Lnn)
|
|
|
983
|
|
|
984 -- This works in all cases because String_To_Wide_String converts any
|
|
|
985 -- wide character escape sequences resulting from the Image call to the
|
|
|
986 -- proper Wide_Character equivalent
|
|
|
987
|
|
|
988 -- not quite right for typ = Wide_Character ???
|
|
|
989
|
|
|
990 procedure Expand_Wide_Image_Attribute (N : Node_Id) is
|
|
|
991 Loc : constant Source_Ptr := Sloc (N);
|
|
|
992 Pref : constant Entity_Id := Prefix (N);
|
|
|
993 Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
|
|
|
994 Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
|
|
|
995 Rtyp : Entity_Id;
|
|
|
996
|
|
|
997 begin
|
|
|
998 if Is_Object_Image (Pref) then
|
|
|
999 Rewrite_Object_Image (N, Pref, Name_Wide_Image, Standard_Wide_String);
|
|
|
1000 return;
|
|
|
1001 end if;
|
|
|
1002
|
|
|
1003 Rtyp := Root_Type (Entity (Pref));
|
|
|
1004
|
|
|
1005 Insert_Actions (N, New_List (
|
|
|
1006
|
|
|
1007 -- Rnn : Wide_String (1 .. base_typ'Width);
|
|
|
1008
|
|
|
1009 Make_Object_Declaration (Loc,
|
|
|
1010 Defining_Identifier => Rnn,
|
|
|
1011 Object_Definition =>
|
|
|
1012 Make_Subtype_Indication (Loc,
|
|
|
1013 Subtype_Mark =>
|
|
|
1014 New_Occurrence_Of (Standard_Wide_String, Loc),
|
|
|
1015 Constraint =>
|
|
|
1016 Make_Index_Or_Discriminant_Constraint (Loc,
|
|
|
1017 Constraints => New_List (
|
|
|
1018 Make_Range (Loc,
|
|
|
1019 Low_Bound => Make_Integer_Literal (Loc, 1),
|
|
|
1020 High_Bound =>
|
|
|
1021 Make_Attribute_Reference (Loc,
|
|
|
1022 Prefix => New_Occurrence_Of (Rtyp, Loc),
|
|
|
1023 Attribute_Name => Name_Wide_Width)))))),
|
|
|
1024
|
|
|
1025 -- Lnn : Natural;
|
|
|
1026
|
|
|
1027 Make_Object_Declaration (Loc,
|
|
|
1028 Defining_Identifier => Lnn,
|
|
|
1029 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)),
|
|
|
1030
|
|
|
1031 -- String_To_Wide_String
|
|
|
1032 -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
|
|
|
1033
|
|
|
1034 Make_Procedure_Call_Statement (Loc,
|
|
|
1035 Name =>
|
|
|
1036 New_Occurrence_Of (RTE (RE_String_To_Wide_String), Loc),
|
|
|
1037
|
|
|
1038 Parameter_Associations => New_List (
|
|
|
1039 Make_Attribute_Reference (Loc,
|
|
|
1040 Prefix => Prefix (N),
|
|
|
1041 Attribute_Name => Name_Image,
|
|
|
1042 Expressions => Expressions (N)),
|
|
|
1043 New_Occurrence_Of (Rnn, Loc),
|
|
|
1044 New_Occurrence_Of (Lnn, Loc),
|
|
|
1045 Make_Integer_Literal (Loc,
|
|
|
1046 Intval => Int (Wide_Character_Encoding_Method))))),
|
|
|
1047
|
|
|
1048 -- Suppress checks because we know everything is properly in range
|
|
|
1049
|
|
|
1050 Suppress => All_Checks);
|
|
|
1051
|
|
|
1052 -- Final step is to rewrite the expression as a slice and analyze,
|
|
|
1053 -- again with no checks, since we are sure that everything is OK.
|
|
|
1054
|
|
|
1055 Rewrite (N,
|
|
|
1056 Make_Slice (Loc,
|
|
|
1057 Prefix => New_Occurrence_Of (Rnn, Loc),
|
|
|
1058 Discrete_Range =>
|
|
|
1059 Make_Range (Loc,
|
|
|
1060 Low_Bound => Make_Integer_Literal (Loc, 1),
|
|
|
1061 High_Bound => New_Occurrence_Of (Lnn, Loc))));
|
|
|
1062
|
|
|
1063 Analyze_And_Resolve (N, Standard_Wide_String, Suppress => All_Checks);
|
|
|
1064 end Expand_Wide_Image_Attribute;
|
|
|
1065
|
|
|
1066 --------------------------------------
|
|
|
1067 -- Expand_Wide_Wide_Image_Attribute --
|
|
|
1068 --------------------------------------
|
|
|
1069
|
|
|
1070 -- We expand typ'Wide_Wide_Image (X) as follows. First we insert this code:
|
|
|
1071
|
|
|
1072 -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
|
|
|
1073 -- Lnn : Natural;
|
|
|
1074 -- String_To_Wide_Wide_String
|
|
|
1075 -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
|
|
|
1076
|
|
|
1077 -- where rt is the root type of the prefix type
|
|
|
1078
|
|
|
1079 -- Now we replace the Wide_Wide_Image reference by
|
|
|
1080
|
|
|
1081 -- Rnn (1 .. Lnn)
|
|
|
1082
|
|
|
1083 -- This works in all cases because String_To_Wide_Wide_String converts any
|
|
|
1084 -- wide character escape sequences resulting from the Image call to the
|
|
|
1085 -- proper Wide_Wide_Character equivalent
|
|
|
1086
|
|
|
1087 -- not quite right for typ = Wide_Wide_Character ???
|
|
|
1088
|
|
|
1089 procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is
|
|
|
1090 Loc : constant Source_Ptr := Sloc (N);
|
|
|
1091 Pref : constant Entity_Id := Prefix (N);
|
|
|
1092 Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
|
|
|
1093 Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
|
|
|
1094 Rtyp : Entity_Id;
|
|
|
1095
|
|
|
1096 begin
|
|
|
1097 if Is_Object_Image (Pref) then
|
|
|
1098 Rewrite_Object_Image
|
|
|
1099 (N, Pref, Name_Wide_Wide_Image, Standard_Wide_Wide_String);
|
|
|
1100 return;
|
|
|
1101 end if;
|
|
|
1102
|
|
|
1103 Rtyp := Root_Type (Entity (Pref));
|
|
|
1104
|
|
|
1105 Insert_Actions (N, New_List (
|
|
|
1106
|
|
|
1107 -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
|
|
|
1108
|
|
|
1109 Make_Object_Declaration (Loc,
|
|
|
1110 Defining_Identifier => Rnn,
|
|
|
1111 Object_Definition =>
|
|
|
1112 Make_Subtype_Indication (Loc,
|
|
|
1113 Subtype_Mark =>
|
|
|
1114 New_Occurrence_Of (Standard_Wide_Wide_String, Loc),
|
|
|
1115 Constraint =>
|
|
|
1116 Make_Index_Or_Discriminant_Constraint (Loc,
|
|
|
1117 Constraints => New_List (
|
|
|
1118 Make_Range (Loc,
|
|
|
1119 Low_Bound => Make_Integer_Literal (Loc, 1),
|
|
|
1120 High_Bound =>
|
|
|
1121 Make_Attribute_Reference (Loc,
|
|
|
1122 Prefix => New_Occurrence_Of (Rtyp, Loc),
|
|
|
1123 Attribute_Name => Name_Wide_Wide_Width)))))),
|
|
|
1124
|
|
|
1125 -- Lnn : Natural;
|
|
|
1126
|
|
|
1127 Make_Object_Declaration (Loc,
|
|
|
1128 Defining_Identifier => Lnn,
|
|
|
1129 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)),
|
|
|
1130
|
|
|
1131 -- String_To_Wide_Wide_String
|
|
|
1132 -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
|
|
|
1133
|
|
|
1134 Make_Procedure_Call_Statement (Loc,
|
|
|
1135 Name =>
|
|
|
1136 New_Occurrence_Of (RTE (RE_String_To_Wide_Wide_String), Loc),
|
|
|
1137
|
|
|
1138 Parameter_Associations => New_List (
|
|
|
1139 Make_Attribute_Reference (Loc,
|
|
|
1140 Prefix => Prefix (N),
|
|
|
1141 Attribute_Name => Name_Image,
|
|
|
1142 Expressions => Expressions (N)),
|
|
|
1143 New_Occurrence_Of (Rnn, Loc),
|
|
|
1144 New_Occurrence_Of (Lnn, Loc),
|
|
|
1145 Make_Integer_Literal (Loc,
|
|
|
1146 Intval => Int (Wide_Character_Encoding_Method))))),
|
|
|
1147
|
|
|
1148 -- Suppress checks because we know everything is properly in range
|
|
|
1149
|
|
|
1150 Suppress => All_Checks);
|
|
|
1151
|
|
|
1152 -- Final step is to rewrite the expression as a slice and analyze,
|
|
|
1153 -- again with no checks, since we are sure that everything is OK.
|
|
|
1154
|
|
|
1155 Rewrite (N,
|
|
|
1156 Make_Slice (Loc,
|
|
|
1157 Prefix => New_Occurrence_Of (Rnn, Loc),
|
|
|
1158 Discrete_Range =>
|
|
|
1159 Make_Range (Loc,
|
|
|
1160 Low_Bound => Make_Integer_Literal (Loc, 1),
|
|
|
1161 High_Bound => New_Occurrence_Of (Lnn, Loc))));
|
|
|
1162
|
|
|
1163 Analyze_And_Resolve
|
|
|
1164 (N, Standard_Wide_Wide_String, Suppress => All_Checks);
|
|
|
1165 end Expand_Wide_Wide_Image_Attribute;
|
|
|
1166
|
|
|
1167 ----------------------------
|
|
|
1168 -- Expand_Width_Attribute --
|
|
|
1169 ----------------------------
|
|
|
1170
|
|
|
1171 -- The processing here also handles the case of Wide_[Wide_]Width. With the
|
|
|
1172 -- exceptions noted, the processing is identical
|
|
|
1173
|
|
|
1174 -- For scalar types derived from Boolean, character and integer types
|
|
|
1175 -- in package Standard. Note that the Width attribute is computed at
|
|
|
1176 -- compile time for all cases except those involving non-static sub-
|
|
|
1177 -- types. For such subtypes, typ'[Wide_[Wide_]]Width expands into:
|
|
|
1178
|
|
|
1179 -- Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last)))
|
|
|
1180
|
|
|
1181 -- where
|
|
|
1182
|
|
|
1183 -- For types whose root type is Character
|
|
|
1184 -- xx = Width_Character
|
|
|
1185 -- yy = Character
|
|
|
1186
|
|
|
1187 -- For types whose root type is Wide_Character
|
|
|
1188 -- xx = Wide_Width_Character
|
|
|
1189 -- yy = Character
|
|
|
1190
|
|
|
1191 -- For types whose root type is Wide_Wide_Character
|
|
|
1192 -- xx = Wide_Wide_Width_Character
|
|
|
1193 -- yy = Character
|
|
|
1194
|
|
|
1195 -- For types whose root type is Boolean
|
|
|
1196 -- xx = Width_Boolean
|
|
|
1197 -- yy = Boolean
|
|
|
1198
|
|
|
1199 -- For signed integer types
|
|
|
1200 -- xx = Width_Long_Long_Integer
|
|
|
1201 -- yy = Long_Long_Integer
|
|
|
1202
|
|
|
1203 -- For modular integer types
|
|
|
1204 -- xx = Width_Long_Long_Unsigned
|
|
|
1205 -- yy = Long_Long_Unsigned
|
|
|
1206
|
|
|
1207 -- For types derived from Wide_Character, typ'Width expands into
|
|
|
1208
|
|
|
1209 -- Result_Type (Width_Wide_Character (
|
|
|
1210 -- Wide_Character (typ'First),
|
|
|
1211 -- Wide_Character (typ'Last),
|
|
|
1212
|
|
|
1213 -- and typ'Wide_Width expands into:
|
|
|
1214
|
|
|
1215 -- Result_Type (Wide_Width_Wide_Character (
|
|
|
1216 -- Wide_Character (typ'First),
|
|
|
1217 -- Wide_Character (typ'Last));
|
|
|
1218
|
|
|
1219 -- and typ'Wide_Wide_Width expands into
|
|
|
1220
|
|
|
1221 -- Result_Type (Wide_Wide_Width_Wide_Character (
|
|
|
1222 -- Wide_Character (typ'First),
|
|
|
1223 -- Wide_Character (typ'Last));
|
|
|
1224
|
|
|
1225 -- For types derived from Wide_Wide_Character, typ'Width expands into
|
|
|
1226
|
|
|
1227 -- Result_Type (Width_Wide_Wide_Character (
|
|
|
1228 -- Wide_Wide_Character (typ'First),
|
|
|
1229 -- Wide_Wide_Character (typ'Last),
|
|
|
1230
|
|
|
1231 -- and typ'Wide_Width expands into:
|
|
|
1232
|
|
|
1233 -- Result_Type (Wide_Width_Wide_Wide_Character (
|
|
|
1234 -- Wide_Wide_Character (typ'First),
|
|
|
1235 -- Wide_Wide_Character (typ'Last));
|
|
|
1236
|
|
|
1237 -- and typ'Wide_Wide_Width expands into
|
|
|
1238
|
|
|
1239 -- Result_Type (Wide_Wide_Width_Wide_Wide_Char (
|
|
|
1240 -- Wide_Wide_Character (typ'First),
|
|
|
1241 -- Wide_Wide_Character (typ'Last));
|
|
|
1242
|
|
|
1243 -- For real types, typ'Width and typ'Wide_[Wide_]Width expand into
|
|
|
1244
|
|
|
1245 -- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if
|
|
|
1246
|
|
|
1247 -- where btyp is the base type. This looks recursive but it isn't
|
|
|
1248 -- because the base type is always static, and hence the expression
|
|
|
1249 -- in the else is reduced to an integer literal.
|
|
|
1250
|
|
|
1251 -- For user-defined enumeration types, typ'Width expands into
|
|
|
1252
|
|
|
1253 -- Result_Type (Width_Enumeration_NN
|
|
|
1254 -- (typS,
|
|
|
1255 -- typI'Address,
|
|
|
1256 -- typ'Pos (typ'First),
|
|
|
1257 -- typ'Pos (Typ'Last)));
|
|
|
1258
|
|
|
1259 -- and typ'Wide_Width expands into:
|
|
|
1260
|
|
|
1261 -- Result_Type (Wide_Width_Enumeration_NN
|
|
|
1262 -- (typS,
|
|
|
1263 -- typI,
|
|
|
1264 -- typ'Pos (typ'First),
|
|
|
1265 -- typ'Pos (Typ'Last))
|
|
|
1266 -- Wide_Character_Encoding_Method);
|
|
|
1267
|
|
|
1268 -- and typ'Wide_Wide_Width expands into:
|
|
|
1269
|
|
|
1270 -- Result_Type (Wide_Wide_Width_Enumeration_NN
|
|
|
1271 -- (typS,
|
|
|
1272 -- typI,
|
|
|
1273 -- typ'Pos (typ'First),
|
|
|
1274 -- typ'Pos (Typ'Last))
|
|
|
1275 -- Wide_Character_Encoding_Method);
|
|
|
1276
|
|
|
1277 -- where typS and typI are the enumeration image strings and indexes
|
|
|
1278 -- table, as described in Build_Enumeration_Image_Tables. NN is 8/16/32
|
|
|
1279 -- for depending on the element type for typI.
|
|
|
1280
|
|
|
1281 -- Finally if Discard_Names is in effect for an enumeration type, then
|
|
|
1282 -- a special if expression is built that yields the space needed for the
|
|
|
1283 -- decimal representation of the largest pos value in the subtype. See
|
|
|
1284 -- code below for details.
|
|
|
1285
|
|
|
1286 procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal) is
|
|
|
1287 Loc : constant Source_Ptr := Sloc (N);
|
|
|
1288 Typ : constant Entity_Id := Etype (N);
|
|
|
1289 Pref : constant Node_Id := Prefix (N);
|
|
|
1290 Ptyp : constant Entity_Id := Etype (Pref);
|
|
|
1291 Rtyp : constant Entity_Id := Root_Type (Ptyp);
|
|
|
1292 Arglist : List_Id;
|
|
|
1293 Ttyp : Entity_Id;
|
|
|
1294 XX : RE_Id;
|
|
|
1295 YY : Entity_Id;
|
|
|
1296
|
|
|
1297 begin
|
|
|
1298 -- Types derived from Standard.Boolean
|
|
|
1299
|
|
|
1300 if Rtyp = Standard_Boolean then
|
|
|
1301 XX := RE_Width_Boolean;
|
|
|
1302 YY := Rtyp;
|
|
|
1303
|
|
|
1304 -- Types derived from Standard.Character
|
|
|
1305
|
|
|
1306 elsif Rtyp = Standard_Character then
|
|
|
1307 case Attr is
|
|
|
1308 when Normal => XX := RE_Width_Character;
|
|
|
1309 when Wide => XX := RE_Wide_Width_Character;
|
|
|
1310 when Wide_Wide => XX := RE_Wide_Wide_Width_Character;
|
|
|
1311 end case;
|
|
|
1312
|
|
|
1313 YY := Rtyp;
|
|
|
1314
|
|
|
1315 -- Types derived from Standard.Wide_Character
|
|
|
1316
|
|
|
1317 elsif Rtyp = Standard_Wide_Character then
|
|
|
1318 case Attr is
|
|
|
1319 when Normal => XX := RE_Width_Wide_Character;
|
|
|
1320 when Wide => XX := RE_Wide_Width_Wide_Character;
|
|
|
1321 when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Character;
|
|
|
1322 end case;
|
|
|
1323
|
|
|
1324 YY := Rtyp;
|
|
|
1325
|
|
|
1326 -- Types derived from Standard.Wide_Wide_Character
|
|
|
1327
|
|
|
1328 elsif Rtyp = Standard_Wide_Wide_Character then
|
|
|
1329 case Attr is
|
|
|
1330 when Normal => XX := RE_Width_Wide_Wide_Character;
|
|
|
1331 when Wide => XX := RE_Wide_Width_Wide_Wide_Character;
|
|
|
1332 when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Wide_Char;
|
|
|
1333 end case;
|
|
|
1334
|
|
|
1335 YY := Rtyp;
|
|
|
1336
|
|
|
1337 -- Signed integer types
|
|
|
1338
|
|
|
1339 elsif Is_Signed_Integer_Type (Rtyp) then
|
|
|
1340 XX := RE_Width_Long_Long_Integer;
|
|
|
1341 YY := Standard_Long_Long_Integer;
|
|
|
1342
|
|
|
1343 -- Modular integer types
|
|
|
1344
|
|
|
1345 elsif Is_Modular_Integer_Type (Rtyp) then
|
|
|
1346 XX := RE_Width_Long_Long_Unsigned;
|
|
|
1347 YY := RTE (RE_Long_Long_Unsigned);
|
|
|
1348
|
|
|
1349 -- Real types
|
|
|
1350
|
|
|
1351 elsif Is_Real_Type (Rtyp) then
|
|
|
1352 Rewrite (N,
|
|
|
1353 Make_If_Expression (Loc,
|
|
|
1354 Expressions => New_List (
|
|
|
1355
|
|
|
1356 Make_Op_Gt (Loc,
|
|
|
1357 Left_Opnd =>
|
|
|
1358 Make_Attribute_Reference (Loc,
|
|
|
1359 Prefix => New_Occurrence_Of (Ptyp, Loc),
|
|
|
1360 Attribute_Name => Name_First),
|
|
|
1361
|
|
|
1362 Right_Opnd =>
|
|
|
1363 Make_Attribute_Reference (Loc,
|
|
|
1364 Prefix => New_Occurrence_Of (Ptyp, Loc),
|
|
|
1365 Attribute_Name => Name_Last)),
|
|
|
1366
|
|
|
1367 Make_Integer_Literal (Loc, 0),
|
|
|
1368
|
|
|
1369 Make_Attribute_Reference (Loc,
|
|
|
1370 Prefix => New_Occurrence_Of (Base_Type (Ptyp), Loc),
|
|
|
1371 Attribute_Name => Name_Width))));
|
|
|
1372
|
|
|
1373 Analyze_And_Resolve (N, Typ);
|
|
|
1374 return;
|
|
|
1375
|
|
|
1376 -- User-defined enumeration types
|
|
|
1377
|
|
|
1378 else
|
|
|
1379 pragma Assert (Is_Enumeration_Type (Rtyp));
|
|
|
1380
|
|
|
1381 -- Whenever pragma Discard_Names is in effect, the value we need
|
|
|
1382 -- is the value needed to accommodate the largest integer pos value
|
|
|
1383 -- in the range of the subtype + 1 for the space at the start. We
|
|
|
1384 -- build:
|
|
|
1385
|
|
|
1386 -- Tnn : constant Integer := Rtyp'Pos (Ptyp'Last)
|
|
|
1387
|
|
|
1388 -- and replace the expression by
|
|
|
1389
|
|
|
1390 -- (if Ptyp'Range_Length = 0 then 0
|
|
|
1391 -- else (if Tnn < 10 then 2
|
|
|
1392 -- else (if Tnn < 100 then 3
|
|
|
1393 -- ...
|
|
|
1394 -- else n)))...
|
|
|
1395
|
|
|
1396 -- where n is equal to Rtyp'Pos (Ptyp'Last) + 1
|
|
|
1397
|
|
|
1398 -- Note: The above processing is in accordance with the intent of
|
|
|
1399 -- the RM, which is that Width should be related to the impl-defined
|
|
|
1400 -- behavior of Image. It is not clear what this means if Image is
|
|
|
1401 -- not defined (as in the configurable run-time case for GNAT) and
|
|
|
1402 -- gives an error at compile time.
|
|
|
1403
|
|
|
1404 -- We choose in this case to just go ahead and implement Width the
|
|
|
1405 -- same way, returning what Image would have returned if it has been
|
|
|
1406 -- available in the configurable run-time library.
|
|
|
1407
|
|
|
1408 if Discard_Names (Rtyp) then
|
|
|
1409 declare
|
|
|
1410 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T');
|
|
|
1411 Cexpr : Node_Id;
|
|
|
1412 P : Int;
|
|
|
1413 M : Int;
|
|
|
1414 K : Int;
|
|
|
1415
|
|
|
1416 begin
|
|
|
1417 Insert_Action (N,
|
|
|
1418 Make_Object_Declaration (Loc,
|
|
|
1419 Defining_Identifier => Tnn,
|
|
|
1420 Constant_Present => True,
|
|
|
1421 Object_Definition =>
|
|
|
1422 New_Occurrence_Of (Standard_Integer, Loc),
|
|
|
1423 Expression =>
|
|
|
1424 Make_Attribute_Reference (Loc,
|
|
|
1425 Prefix => New_Occurrence_Of (Rtyp, Loc),
|
|
|
1426 Attribute_Name => Name_Pos,
|
|
|
1427 Expressions => New_List (
|
|
|
1428 Convert_To (Rtyp,
|
|
|
1429 Make_Attribute_Reference (Loc,
|
|
|
1430 Prefix => New_Occurrence_Of (Ptyp, Loc),
|
|
|
1431 Attribute_Name => Name_Last))))));
|
|
|
1432
|
|
|
1433 -- OK, now we need to build the if expression. First get the
|
|
|
1434 -- value of M, the largest possible value needed.
|
|
|
1435
|
|
|
1436 P := UI_To_Int
|
|
|
1437 (Enumeration_Pos (Entity (Type_High_Bound (Rtyp))));
|
|
|
1438
|
|
|
1439 K := 1;
|
|
|
1440 M := 1;
|
|
|
1441 while M < P loop
|
|
|
1442 M := M * 10;
|
|
|
1443 K := K + 1;
|
|
|
1444 end loop;
|
|
|
1445
|
|
|
1446 -- Build inner else
|
|
|
1447
|
|
|
1448 Cexpr := Make_Integer_Literal (Loc, K);
|
|
|
1449
|
|
|
1450 -- Wrap in inner if's until counted down to 2
|
|
|
1451
|
|
|
1452 while K > 2 loop
|
|
|
1453 M := M / 10;
|
|
|
1454 K := K - 1;
|
|
|
1455
|
|
|
1456 Cexpr :=
|
|
|
1457 Make_If_Expression (Loc,
|
|
|
1458 Expressions => New_List (
|
|
|
1459 Make_Op_Lt (Loc,
|
|
|
1460 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
|
|
|
1461 Right_Opnd => Make_Integer_Literal (Loc, M)),
|
|
|
1462 Make_Integer_Literal (Loc, K),
|
|
|
1463 Cexpr));
|
|
|
1464 end loop;
|
|
|
1465
|
|
|
1466 -- Add initial comparison for null range and we are done, so
|
|
|
1467 -- rewrite the attribute occurrence with this expression.
|
|
|
1468
|
|
|
1469 Rewrite (N,
|
|
|
1470 Convert_To (Typ,
|
|
|
1471 Make_If_Expression (Loc,
|
|
|
1472 Expressions => New_List (
|
|
|
1473 Make_Op_Eq (Loc,
|
|
|
1474 Left_Opnd =>
|
|
|
1475 Make_Attribute_Reference (Loc,
|
|
|
1476 Prefix => New_Occurrence_Of (Ptyp, Loc),
|
|
|
1477 Attribute_Name => Name_Range_Length),
|
|
|
1478 Right_Opnd => Make_Integer_Literal (Loc, 0)),
|
|
|
1479 Make_Integer_Literal (Loc, 0),
|
|
|
1480 Cexpr))));
|
|
|
1481
|
|
|
1482 Analyze_And_Resolve (N, Typ);
|
|
|
1483 return;
|
|
|
1484 end;
|
|
|
1485 end if;
|
|
|
1486
|
|
|
1487 -- Normal case, not Discard_Names
|
|
|
1488
|
|
|
1489 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
|
|
|
1490
|
|
|
1491 case Attr is
|
|
|
1492 when Normal =>
|
|
|
1493 if Ttyp = Standard_Integer_8 then
|
|
|
1494 XX := RE_Width_Enumeration_8;
|
|
|
1495 elsif Ttyp = Standard_Integer_16 then
|
|
|
1496 XX := RE_Width_Enumeration_16;
|
|
|
1497 else
|
|
|
1498 XX := RE_Width_Enumeration_32;
|
|
|
1499 end if;
|
|
|
1500
|
|
|
1501 when Wide =>
|
|
|
1502 if Ttyp = Standard_Integer_8 then
|
|
|
1503 XX := RE_Wide_Width_Enumeration_8;
|
|
|
1504 elsif Ttyp = Standard_Integer_16 then
|
|
|
1505 XX := RE_Wide_Width_Enumeration_16;
|
|
|
1506 else
|
|
|
1507 XX := RE_Wide_Width_Enumeration_32;
|
|
|
1508 end if;
|
|
|
1509
|
|
|
1510 when Wide_Wide =>
|
|
|
1511 if Ttyp = Standard_Integer_8 then
|
|
|
1512 XX := RE_Wide_Wide_Width_Enumeration_8;
|
|
|
1513 elsif Ttyp = Standard_Integer_16 then
|
|
|
1514 XX := RE_Wide_Wide_Width_Enumeration_16;
|
|
|
1515 else
|
|
|
1516 XX := RE_Wide_Wide_Width_Enumeration_32;
|
|
|
1517 end if;
|
|
|
1518 end case;
|
|
|
1519
|
|
|
1520 Arglist :=
|
|
|
1521 New_List (
|
|
|
1522 New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
|
|
|
1523
|
|
|
1524 Make_Attribute_Reference (Loc,
|
|
|
1525 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
|
|
|
1526 Attribute_Name => Name_Address),
|
|
|
1527
|
|
|
1528 Make_Attribute_Reference (Loc,
|
|
|
1529 Prefix => New_Occurrence_Of (Ptyp, Loc),
|
|
|
1530 Attribute_Name => Name_Pos,
|
|
|
1531
|
|
|
1532 Expressions => New_List (
|
|
|
1533 Make_Attribute_Reference (Loc,
|
|
|
1534 Prefix => New_Occurrence_Of (Ptyp, Loc),
|
|
|
1535 Attribute_Name => Name_First))),
|
|
|
1536
|
|
|
1537 Make_Attribute_Reference (Loc,
|
|
|
1538 Prefix => New_Occurrence_Of (Ptyp, Loc),
|
|
|
1539 Attribute_Name => Name_Pos,
|
|
|
1540
|
|
|
1541 Expressions => New_List (
|
|
|
1542 Make_Attribute_Reference (Loc,
|
|
|
1543 Prefix => New_Occurrence_Of (Ptyp, Loc),
|
|
|
1544 Attribute_Name => Name_Last))));
|
|
|
1545
|
|
|
1546 Rewrite (N,
|
|
|
1547 Convert_To (Typ,
|
|
|
1548 Make_Function_Call (Loc,
|
|
|
1549 Name => New_Occurrence_Of (RTE (XX), Loc),
|
|
|
1550 Parameter_Associations => Arglist)));
|
|
|
1551
|
|
|
1552 Analyze_And_Resolve (N, Typ);
|
|
|
1553 return;
|
|
|
1554 end if;
|
|
|
1555
|
|
|
1556 -- If we fall through XX and YY are set
|
|
|
1557
|
|
|
1558 Arglist := New_List (
|
|
|
1559 Convert_To (YY,
|
|
|
1560 Make_Attribute_Reference (Loc,
|
|
|
1561 Prefix => New_Occurrence_Of (Ptyp, Loc),
|
|
|
1562 Attribute_Name => Name_First)),
|
|
|
1563
|
|
|
1564 Convert_To (YY,
|
|
|
1565 Make_Attribute_Reference (Loc,
|
|
|
1566 Prefix => New_Occurrence_Of (Ptyp, Loc),
|
|
|
1567 Attribute_Name => Name_Last)));
|
|
|
1568
|
|
|
1569 Rewrite (N,
|
|
|
1570 Convert_To (Typ,
|
|
|
1571 Make_Function_Call (Loc,
|
|
|
1572 Name => New_Occurrence_Of (RTE (XX), Loc),
|
|
|
1573 Parameter_Associations => Arglist)));
|
|
|
1574
|
|
|
1575 Analyze_And_Resolve (N, Typ);
|
|
|
1576 end Expand_Width_Attribute;
|
|
|
1577
|
|
|
1578 -----------------------
|
|
|
1579 -- Has_Decimal_Small --
|
|
|
1580 -----------------------
|
|
|
1581
|
|
|
1582 function Has_Decimal_Small (E : Entity_Id) return Boolean is
|
|
|
1583 begin
|
|
|
1584 return Is_Decimal_Fixed_Point_Type (E)
|
|
|
1585 or else
|
|
|
1586 (Is_Ordinary_Fixed_Point_Type (E)
|
|
|
1587 and then Ureal_10**Aft_Value (E) * Small_Value (E) = Ureal_1);
|
|
|
1588 end Has_Decimal_Small;
|
|
|
1589
|
|
|
1590 --------------------------
|
|
|
1591 -- Rewrite_Object_Image --
|
|
|
1592 --------------------------
|
|
|
1593
|
|
|
1594 procedure Rewrite_Object_Image
|
|
|
1595 (N : Node_Id;
|
|
|
1596 Pref : Entity_Id;
|
|
|
1597 Attr_Name : Name_Id;
|
|
|
1598 Str_Typ : Entity_Id)
|
|
|
1599 is
|
|
|
1600 begin
|
|
|
1601 Rewrite (N,
|
|
|
1602 Make_Attribute_Reference (Sloc (N),
|
|
|
1603 Prefix => New_Occurrence_Of (Etype (Pref), Sloc (N)),
|
|
|
1604 Attribute_Name => Attr_Name,
|
|
|
1605 Expressions => New_List (Relocate_Node (Pref))));
|
|
|
1606
|
|
|
1607 Analyze_And_Resolve (N, Str_Typ);
|
|
|
1608 end Rewrite_Object_Image;
|
|
|
1609 end Exp_Imgv;
|
