]>
Commit | Line | Data |
---|---|---|
70482933 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- E X P _ I M G V -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
fbf5a39b | 9 | -- Copyright (C) 2001-2003 Free Software Foundation, Inc. -- |
70482933 RK |
10 | -- -- |
11 | -- GNAT is free software; you can redistribute it and/or modify it under -- | |
12 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
13 | -- ware Foundation; either version 2, 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 COPYING. If not, write -- | |
19 | -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- | |
20 | -- MA 02111-1307, USA. -- | |
21 | -- -- | |
22 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 23 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
70482933 RK |
24 | -- -- |
25 | ------------------------------------------------------------------------------ | |
26 | ||
27 | with Atree; use Atree; | |
28 | with Casing; use Casing; | |
29 | with Checks; use Checks; | |
30 | with Einfo; use Einfo; | |
31 | with Exp_Util; use Exp_Util; | |
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_Res; use Sem_Res; | |
38 | with Sinfo; use Sinfo; | |
39 | with Snames; use Snames; | |
40 | with Stand; use Stand; | |
41 | with Stringt; use Stringt; | |
42 | with Tbuild; use Tbuild; | |
43 | with Ttypes; use Ttypes; | |
44 | with Uintp; use Uintp; | |
45 | ||
46 | package body Exp_Imgv is | |
47 | ||
48 | ------------------------------------ | |
49 | -- Build_Enumeration_Image_Tables -- | |
50 | ------------------------------------ | |
51 | ||
52 | procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is | |
53 | Loc : constant Source_Ptr := Sloc (E); | |
54 | Str : String_Id; | |
55 | Ind : List_Id; | |
56 | Lit : Entity_Id; | |
57 | Nlit : Nat; | |
58 | Len : Nat; | |
59 | Estr : Entity_Id; | |
60 | Eind : Entity_Id; | |
61 | Ityp : Node_Id; | |
62 | ||
63 | begin | |
64 | -- Nothing to do for other than a root enumeration type | |
65 | ||
66 | if E /= Root_Type (E) then | |
67 | return; | |
68 | ||
69 | -- Nothing to do if pragma Discard_Names applies | |
70 | ||
71 | elsif Discard_Names (E) then | |
72 | return; | |
73 | end if; | |
74 | ||
75 | -- Otherwise tables need constructing | |
76 | ||
77 | Start_String; | |
78 | Ind := New_List; | |
79 | Lit := First_Literal (E); | |
80 | Len := 1; | |
81 | Nlit := 0; | |
82 | ||
83 | loop | |
84 | Append_To (Ind, | |
85 | Make_Integer_Literal (Loc, UI_From_Int (Len))); | |
86 | ||
87 | exit when No (Lit); | |
88 | Nlit := Nlit + 1; | |
89 | ||
90 | Get_Unqualified_Decoded_Name_String (Chars (Lit)); | |
91 | ||
92 | if Name_Buffer (1) /= ''' then | |
93 | Set_Casing (All_Upper_Case); | |
94 | end if; | |
95 | ||
96 | Store_String_Chars (Name_Buffer (1 .. Name_Len)); | |
97 | Len := Len + Int (Name_Len); | |
98 | Next_Literal (Lit); | |
99 | end loop; | |
100 | ||
101 | if Len < Int (2 ** (8 - 1)) then | |
102 | Ityp := Standard_Integer_8; | |
103 | elsif Len < Int (2 ** (16 - 1)) then | |
104 | Ityp := Standard_Integer_16; | |
105 | else | |
106 | Ityp := Standard_Integer_32; | |
107 | end if; | |
108 | ||
109 | Str := End_String; | |
110 | ||
111 | Estr := | |
112 | Make_Defining_Identifier (Loc, | |
113 | Chars => New_External_Name (Chars (E), 'S')); | |
114 | ||
115 | Eind := | |
116 | Make_Defining_Identifier (Loc, | |
fbf5a39b | 117 | Chars => New_External_Name (Chars (E), 'N')); |
70482933 RK |
118 | |
119 | Set_Lit_Strings (E, Estr); | |
120 | Set_Lit_Indexes (E, Eind); | |
121 | ||
122 | Insert_Actions (N, | |
123 | New_List ( | |
124 | Make_Object_Declaration (Loc, | |
125 | Defining_Identifier => Estr, | |
126 | Constant_Present => True, | |
127 | Object_Definition => | |
128 | New_Occurrence_Of (Standard_String, Loc), | |
129 | Expression => | |
130 | Make_String_Literal (Loc, | |
131 | Strval => Str)), | |
132 | ||
133 | Make_Object_Declaration (Loc, | |
134 | Defining_Identifier => Eind, | |
135 | Constant_Present => True, | |
136 | ||
137 | Object_Definition => | |
138 | Make_Constrained_Array_Definition (Loc, | |
139 | Discrete_Subtype_Definitions => New_List ( | |
140 | Make_Range (Loc, | |
141 | Low_Bound => Make_Integer_Literal (Loc, 0), | |
142 | High_Bound => Make_Integer_Literal (Loc, Nlit))), | |
143 | Subtype_Indication => New_Occurrence_Of (Ityp, Loc)), | |
144 | ||
145 | Expression => | |
146 | Make_Aggregate (Loc, | |
147 | Expressions => Ind))), | |
148 | Suppress => All_Checks); | |
149 | ||
150 | end Build_Enumeration_Image_Tables; | |
151 | ||
152 | ---------------------------- | |
153 | -- Expand_Image_Attribute -- | |
154 | ---------------------------- | |
155 | ||
156 | -- For all non-enumeration types, and for enumeration types declared | |
157 | -- in packages Standard or System, typ'Image (Val) expands into: | |
158 | ||
159 | -- Image_xx (tp (Expr) [, pm]) | |
160 | ||
161 | -- The name xx and type conversion tp (Expr) (called tv below) depend on | |
162 | -- the root type of Expr. The argument pm is an extra type dependent | |
163 | -- parameter only used in some cases as follows: | |
164 | ||
165 | -- For types whose root type is Character | |
166 | -- xx = Character | |
167 | -- tv = Character (Expr) | |
168 | ||
169 | -- For types whose root type is Boolean | |
170 | -- xx = Boolean | |
171 | -- tv = Boolean (Expr) | |
172 | ||
173 | -- For signed integer types with size <= Integer'Size | |
174 | -- xx = Integer | |
175 | -- tv = Integer (Expr) | |
176 | ||
177 | -- For other signed integer types | |
178 | -- xx = Long_Long_Integer | |
179 | -- tv = Long_Long_Integer (Expr) | |
180 | ||
181 | -- For modular types with modulus <= System.Unsigned_Types.Unsigned | |
182 | -- xx = Unsigned | |
183 | -- tv = System.Unsigned_Types.Unsigned (Expr) | |
184 | ||
185 | -- For other modular integer types | |
186 | -- xx = Long_Long_Unsigned | |
187 | -- tv = System.Unsigned_Types.Long_Long_Unsigned (Expr) | |
188 | ||
189 | -- For types whose root type is Wide_Character | |
190 | -- xx = Wide_Character | |
191 | -- tv = Wide_Character (Expr) | |
192 | -- pm = Wide_Character_Encoding_Method | |
193 | ||
194 | -- For floating-point types | |
195 | -- xx = Floating_Point | |
196 | -- tv = Long_Long_Float (Expr) | |
197 | -- pm = typ'Digits | |
198 | ||
199 | -- For ordinary fixed-point types | |
200 | -- xx = Ordinary_Fixed_Point | |
201 | -- tv = Long_Long_Float (Expr) | |
202 | -- pm = typ'Aft | |
203 | ||
204 | -- For decimal fixed-point types with size = Integer'Size | |
205 | -- xx = Decimal | |
206 | -- tv = Integer (Expr) | |
207 | -- pm = typ'Scale | |
208 | ||
209 | -- For decimal fixed-point types with size > Integer'Size | |
210 | -- xx = Long_Long_Decimal | |
211 | -- tv = Long_Long_Integer (Expr) | |
212 | -- pm = typ'Scale | |
213 | ||
214 | -- Note: for the decimal fixed-point type cases, the conversion is | |
215 | -- done literally without scaling (i.e. the actual expression that | |
216 | -- is generated is Image_xx (tp?(Expr) [, pm]) | |
217 | ||
218 | -- For enumeration types other than those declared packages Standard | |
219 | -- or System, typ'Image (X) expands into: | |
220 | ||
221 | -- Image_Enumeration_NN (typ'Pos (X), typS, typI'Address) | |
222 | ||
223 | -- where typS and typI are the entities constructed as described in | |
224 | -- the spec for the procedure Build_Enumeration_Image_Tables and NN | |
225 | -- is 32/16/8 depending on the element type of Lit_Indexes. | |
226 | ||
227 | procedure Expand_Image_Attribute (N : Node_Id) is | |
a7fb206d RD |
228 | Loc : constant Source_Ptr := Sloc (N); |
229 | Exprs : constant List_Id := Expressions (N); | |
230 | Pref : constant Node_Id := Prefix (N); | |
231 | Ptyp : constant Entity_Id := Entity (Pref); | |
232 | Rtyp : constant Entity_Id := Root_Type (Ptyp); | |
233 | Expr : constant Node_Id := Relocate_Node (First (Exprs)); | |
234 | Imid : RE_Id; | |
235 | Tent : Entity_Id; | |
236 | Arglist : List_Id; | |
237 | Func : RE_Id; | |
238 | Ttyp : Entity_Id; | |
239 | Func_Ent : Entity_Id; | |
70482933 RK |
240 | |
241 | begin | |
242 | if Rtyp = Standard_Boolean then | |
243 | Imid := RE_Image_Boolean; | |
244 | Tent := Rtyp; | |
245 | ||
246 | elsif Rtyp = Standard_Character then | |
247 | Imid := RE_Image_Character; | |
248 | Tent := Rtyp; | |
249 | ||
250 | elsif Rtyp = Standard_Wide_Character then | |
251 | Imid := RE_Image_Wide_Character; | |
252 | Tent := Rtyp; | |
253 | ||
254 | elsif Is_Signed_Integer_Type (Rtyp) then | |
255 | if Esize (Rtyp) <= Esize (Standard_Integer) then | |
256 | Imid := RE_Image_Integer; | |
257 | Tent := Standard_Integer; | |
258 | else | |
259 | Imid := RE_Image_Long_Long_Integer; | |
260 | Tent := Standard_Long_Long_Integer; | |
261 | end if; | |
262 | ||
263 | elsif Is_Modular_Integer_Type (Rtyp) then | |
264 | if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then | |
265 | Imid := RE_Image_Unsigned; | |
266 | Tent := RTE (RE_Unsigned); | |
267 | else | |
268 | Imid := RE_Image_Long_Long_Unsigned; | |
269 | Tent := RTE (RE_Long_Long_Unsigned); | |
270 | end if; | |
271 | ||
272 | elsif Is_Decimal_Fixed_Point_Type (Rtyp) then | |
273 | if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then | |
274 | Imid := RE_Image_Decimal; | |
275 | Tent := Standard_Integer; | |
276 | else | |
277 | Imid := RE_Image_Long_Long_Decimal; | |
278 | Tent := Standard_Long_Long_Integer; | |
279 | end if; | |
280 | ||
281 | elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then | |
282 | Imid := RE_Image_Ordinary_Fixed_Point; | |
283 | Tent := Standard_Long_Long_Float; | |
284 | ||
285 | elsif Is_Floating_Point_Type (Rtyp) then | |
286 | Imid := RE_Image_Floating_Point; | |
287 | Tent := Standard_Long_Long_Float; | |
288 | ||
289 | -- Only other possibility is user defined enumeration type | |
290 | ||
291 | else | |
292 | if Discard_Names (First_Subtype (Ptyp)) | |
293 | or else No (Lit_Strings (Root_Type (Ptyp))) | |
294 | then | |
295 | -- When pragma Discard_Names applies to the first subtype, | |
296 | -- then build (Pref'Pos)'Img. | |
297 | ||
298 | Rewrite (N, | |
299 | Make_Attribute_Reference (Loc, | |
300 | Prefix => | |
301 | Make_Attribute_Reference (Loc, | |
302 | Prefix => Pref, | |
303 | Attribute_Name => Name_Pos, | |
304 | Expressions => New_List (Expr)), | |
305 | Attribute_Name => | |
306 | Name_Img)); | |
307 | Analyze_And_Resolve (N, Standard_String); | |
308 | ||
309 | else | |
310 | -- Here we get the Image of an enumeration type | |
311 | ||
312 | Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); | |
313 | ||
314 | if Ttyp = Standard_Integer_8 then | |
315 | Func := RE_Image_Enumeration_8; | |
316 | elsif Ttyp = Standard_Integer_16 then | |
317 | Func := RE_Image_Enumeration_16; | |
318 | else | |
319 | Func := RE_Image_Enumeration_32; | |
320 | end if; | |
321 | ||
322 | -- Apply a validity check, since it is a bit drastic to | |
323 | -- get a completely junk image value for an invalid value. | |
324 | ||
325 | if not Expr_Known_Valid (Expr) then | |
326 | Insert_Valid_Check (Expr); | |
327 | end if; | |
328 | ||
329 | Rewrite (N, | |
330 | Make_Function_Call (Loc, | |
331 | Name => New_Occurrence_Of (RTE (Func), Loc), | |
332 | Parameter_Associations => New_List ( | |
333 | Make_Attribute_Reference (Loc, | |
334 | Attribute_Name => Name_Pos, | |
335 | Prefix => New_Occurrence_Of (Ptyp, Loc), | |
336 | Expressions => New_List (Expr)), | |
337 | New_Occurrence_Of (Lit_Strings (Rtyp), Loc), | |
338 | Make_Attribute_Reference (Loc, | |
339 | Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), | |
340 | Attribute_Name => Name_Address)))); | |
341 | ||
342 | Analyze_And_Resolve (N, Standard_String); | |
343 | end if; | |
344 | ||
345 | return; | |
346 | end if; | |
347 | ||
348 | -- If we fall through, we have one of the cases that is handled by | |
a7fb206d RD |
349 | -- calling one of the System.Img_xx routines and Imid is set to the |
350 | -- RE_Id for the function to be called. | |
351 | ||
352 | Func_Ent := RTE (Imid); | |
353 | ||
354 | -- If the function entity is empty, that means we have a case in | |
355 | -- no run time mode where the operation is not allowed, and an | |
356 | -- appropriate diagnostic has already been issued. | |
357 | ||
358 | if No (Func_Ent) then | |
359 | return; | |
360 | end if; | |
361 | ||
362 | -- Otherwise prepare arguments for run-time call | |
70482933 RK |
363 | |
364 | Arglist := New_List (Convert_To (Tent, Relocate_Node (Expr))); | |
365 | ||
366 | -- For floating-point types, append Digits argument | |
367 | ||
368 | if Is_Floating_Point_Type (Rtyp) then | |
369 | Append_To (Arglist, | |
370 | Make_Attribute_Reference (Loc, | |
371 | Prefix => New_Reference_To (Ptyp, Loc), | |
372 | Attribute_Name => Name_Digits)); | |
373 | ||
374 | -- For ordinary fixed-point types, append Aft parameter | |
375 | ||
376 | elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then | |
377 | Append_To (Arglist, | |
378 | Make_Attribute_Reference (Loc, | |
379 | Prefix => New_Reference_To (Ptyp, Loc), | |
380 | Attribute_Name => Name_Aft)); | |
381 | ||
382 | -- For wide character, append encoding method | |
383 | ||
384 | elsif Rtyp = Standard_Wide_Character then | |
385 | Append_To (Arglist, | |
386 | Make_Integer_Literal (Loc, | |
387 | Intval => Int (Wide_Character_Encoding_Method))); | |
388 | ||
389 | -- For decimal, append Scale and also set to do literal conversion | |
390 | ||
391 | elsif Is_Decimal_Fixed_Point_Type (Rtyp) then | |
392 | Append_To (Arglist, | |
393 | Make_Attribute_Reference (Loc, | |
394 | Prefix => New_Reference_To (Ptyp, Loc), | |
395 | Attribute_Name => Name_Scale)); | |
396 | ||
397 | Set_Conversion_OK (First (Arglist)); | |
398 | Set_Etype (First (Arglist), Tent); | |
399 | end if; | |
400 | ||
401 | Rewrite (N, | |
402 | Make_Function_Call (Loc, | |
a7fb206d | 403 | Name => New_Reference_To (Func_Ent, Loc), |
70482933 RK |
404 | Parameter_Associations => Arglist)); |
405 | ||
406 | Analyze_And_Resolve (N, Standard_String); | |
407 | end Expand_Image_Attribute; | |
408 | ||
409 | ---------------------------- | |
410 | -- Expand_Value_Attribute -- | |
411 | ---------------------------- | |
412 | ||
413 | -- For scalar types derived from Boolean, Character and integer types | |
414 | -- in package Standard, typ'Value (X) expands into: | |
415 | ||
416 | -- btyp (Value_xx (X)) | |
417 | ||
418 | -- where btyp is he base type of the prefix, and | |
419 | ||
420 | -- For types whose root type is Character | |
421 | -- xx = Character | |
422 | ||
423 | -- For types whose root type is Boolean | |
424 | -- xx = Boolean | |
425 | ||
426 | -- For signed integer types with size <= Integer'Size | |
427 | -- xx = Integer | |
428 | ||
429 | -- For other signed integer types | |
430 | -- xx = Long_Long_Integer | |
431 | ||
432 | -- For modular types with modulus <= System.Unsigned_Types.Unsigned | |
433 | -- xx = Unsigned | |
434 | ||
435 | -- For other modular integer types | |
436 | -- xx = Long_Long_Unsigned | |
437 | ||
438 | -- For floating-point types and ordinary fixed-point types | |
439 | -- xx = Real | |
440 | ||
441 | -- For types derived from Wide_Character, typ'Value (X) expands into | |
442 | ||
443 | -- Value_Wide_Character (X, Wide_Character_Encoding_Method) | |
444 | ||
445 | -- For decimal types with size <= Integer'Size, typ'Value (X) | |
446 | -- expands into | |
447 | ||
448 | -- btyp?(Value_Decimal (X, typ'Scale)); | |
449 | ||
450 | -- For all other decimal types, typ'Value (X) expands into | |
451 | ||
452 | -- btyp?(Value_Long_Long_Decimal (X, typ'Scale)) | |
453 | ||
454 | -- For enumeration types other than those derived from types Boolean, | |
455 | -- Character, and Wide_Character in Standard, typ'Value (X) expands to: | |
456 | ||
457 | -- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X)) | |
458 | ||
459 | -- where typS and typI and the Lit_Strings and Lit_Indexes entities | |
460 | -- from T's root type entitym and Num is Enum'Pos (Enum'Last). The | |
461 | -- Value_Enumeration_NN function will search the tables looking for | |
462 | -- X and return the position number in the table if found which is | |
463 | -- used to provide the result of 'Value (using Enum'Val). If the | |
464 | -- value is not found Constraint_Error is raised. The suffix _NN | |
465 | -- depends on the element type of typI. | |
466 | ||
467 | procedure Expand_Value_Attribute (N : Node_Id) is | |
468 | Loc : constant Source_Ptr := Sloc (N); | |
469 | Typ : constant Entity_Id := Etype (N); | |
470 | Btyp : constant Entity_Id := Base_Type (Typ); | |
471 | Rtyp : constant Entity_Id := Root_Type (Typ); | |
472 | Exprs : constant List_Id := Expressions (N); | |
473 | Vid : RE_Id; | |
474 | Args : List_Id; | |
475 | Func : RE_Id; | |
476 | Ttyp : Entity_Id; | |
477 | ||
478 | begin | |
479 | Args := Exprs; | |
480 | ||
481 | if Rtyp = Standard_Character then | |
482 | Vid := RE_Value_Character; | |
483 | ||
484 | elsif Rtyp = Standard_Boolean then | |
485 | Vid := RE_Value_Boolean; | |
486 | ||
487 | elsif Rtyp = Standard_Wide_Character then | |
488 | Vid := RE_Value_Wide_Character; | |
489 | Append_To (Args, | |
490 | Make_Integer_Literal (Loc, | |
491 | Intval => Int (Wide_Character_Encoding_Method))); | |
492 | ||
493 | elsif Rtyp = Base_Type (Standard_Short_Short_Integer) | |
494 | or else Rtyp = Base_Type (Standard_Short_Integer) | |
495 | or else Rtyp = Base_Type (Standard_Integer) | |
496 | then | |
497 | Vid := RE_Value_Integer; | |
498 | ||
499 | elsif Is_Signed_Integer_Type (Rtyp) then | |
500 | Vid := RE_Value_Long_Long_Integer; | |
501 | ||
502 | elsif Is_Modular_Integer_Type (Rtyp) then | |
503 | if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then | |
504 | Vid := RE_Value_Unsigned; | |
505 | else | |
506 | Vid := RE_Value_Long_Long_Unsigned; | |
507 | end if; | |
508 | ||
509 | elsif Is_Decimal_Fixed_Point_Type (Rtyp) then | |
510 | if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then | |
511 | Vid := RE_Value_Decimal; | |
512 | else | |
513 | Vid := RE_Value_Long_Long_Decimal; | |
514 | end if; | |
515 | ||
516 | Append_To (Args, | |
517 | Make_Attribute_Reference (Loc, | |
518 | Prefix => New_Reference_To (Typ, Loc), | |
519 | Attribute_Name => Name_Scale)); | |
520 | ||
521 | Rewrite (N, | |
522 | OK_Convert_To (Btyp, | |
523 | Make_Function_Call (Loc, | |
524 | Name => New_Reference_To (RTE (Vid), Loc), | |
525 | Parameter_Associations => Args))); | |
526 | ||
527 | Set_Etype (N, Btyp); | |
528 | Analyze_And_Resolve (N, Btyp); | |
529 | return; | |
530 | ||
531 | elsif Is_Real_Type (Rtyp) then | |
532 | Vid := RE_Value_Real; | |
533 | ||
534 | -- Only other possibility is user defined enumeration type | |
535 | ||
536 | else | |
537 | pragma Assert (Is_Enumeration_Type (Rtyp)); | |
538 | ||
539 | -- Case of pragma Discard_Names, transform the Value | |
540 | -- attribute to Btyp'Val (Long_Long_Integer'Value (Args)) | |
541 | ||
542 | if Discard_Names (First_Subtype (Typ)) | |
543 | or else No (Lit_Strings (Rtyp)) | |
544 | then | |
545 | Rewrite (N, | |
546 | Make_Attribute_Reference (Loc, | |
547 | Prefix => New_Reference_To (Btyp, Loc), | |
548 | Attribute_Name => Name_Val, | |
549 | Expressions => New_List ( | |
550 | Make_Attribute_Reference (Loc, | |
551 | Prefix => | |
552 | New_Occurrence_Of (Standard_Long_Long_Integer, Loc), | |
553 | Attribute_Name => Name_Value, | |
554 | Expressions => Args)))); | |
555 | ||
556 | Analyze_And_Resolve (N, Btyp); | |
557 | ||
558 | -- Here for normal case where we have enumeration tables, this | |
559 | -- is where we build | |
560 | ||
561 | -- T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X)) | |
562 | ||
563 | else | |
564 | Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); | |
565 | ||
566 | if Ttyp = Standard_Integer_8 then | |
567 | Func := RE_Value_Enumeration_8; | |
568 | elsif Ttyp = Standard_Integer_16 then | |
569 | Func := RE_Value_Enumeration_16; | |
570 | else | |
571 | Func := RE_Value_Enumeration_32; | |
572 | end if; | |
573 | ||
574 | Prepend_To (Args, | |
575 | Make_Attribute_Reference (Loc, | |
576 | Prefix => New_Occurrence_Of (Rtyp, Loc), | |
577 | Attribute_Name => Name_Pos, | |
578 | Expressions => New_List ( | |
579 | Make_Attribute_Reference (Loc, | |
580 | Prefix => New_Occurrence_Of (Rtyp, Loc), | |
581 | Attribute_Name => Name_Last)))); | |
582 | ||
583 | Prepend_To (Args, | |
584 | Make_Attribute_Reference (Loc, | |
585 | Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), | |
586 | Attribute_Name => Name_Address)); | |
587 | ||
588 | Prepend_To (Args, | |
589 | New_Occurrence_Of (Lit_Strings (Rtyp), Loc)); | |
590 | ||
591 | Rewrite (N, | |
592 | Make_Attribute_Reference (Loc, | |
593 | Prefix => New_Reference_To (Typ, Loc), | |
594 | Attribute_Name => Name_Val, | |
595 | Expressions => New_List ( | |
596 | Make_Function_Call (Loc, | |
597 | Name => | |
598 | New_Reference_To (RTE (Func), Loc), | |
599 | Parameter_Associations => Args)))); | |
600 | ||
601 | Analyze_And_Resolve (N, Btyp); | |
602 | end if; | |
603 | ||
604 | return; | |
605 | end if; | |
606 | ||
607 | -- Fall through for all cases except user defined enumeration type | |
608 | -- and decimal types, with Vid set to the Id of the entity for the | |
609 | -- Value routine and Args set to the list of parameters for the call. | |
610 | ||
611 | Rewrite (N, | |
612 | Convert_To (Btyp, | |
613 | Make_Function_Call (Loc, | |
614 | Name => New_Reference_To (RTE (Vid), Loc), | |
615 | Parameter_Associations => Args))); | |
616 | ||
617 | Analyze_And_Resolve (N, Btyp); | |
618 | end Expand_Value_Attribute; | |
619 | ||
620 | ---------------------------- | |
621 | -- Expand_Width_Attribute -- | |
622 | ---------------------------- | |
623 | ||
624 | -- The processing here also handles the case of Wide_Width. With the | |
625 | -- exceptions noted, the processing is identical | |
626 | ||
627 | -- For scalar types derived from Boolean, character and integer types | |
628 | -- in package Standard. Note that the Width attribute is computed at | |
629 | -- compile time for all cases except those involving non-static sub- | |
630 | -- types. For such subtypes, typ'Width and typ'Wide_Width expands into: | |
631 | ||
632 | -- Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last))) | |
633 | ||
634 | -- where | |
635 | ||
636 | -- For types whose root type is Character | |
637 | -- xx = Width_Character (Wide_Width_Character for Wide_Width case) | |
638 | -- yy = Character | |
639 | ||
640 | -- For types whose root type is Boolean | |
641 | -- xx = Width_Boolean | |
642 | -- yy = Boolean | |
643 | ||
644 | -- For signed integer types | |
645 | -- xx = Width_Long_Long_Integer | |
646 | -- yy = Long_Long_Integer | |
647 | ||
648 | -- For modular integer types | |
649 | -- xx = Width_Long_Long_Unsigned | |
650 | -- yy = Long_Long_Unsigned | |
651 | ||
652 | -- For types derived from Wide_Character, typ'Width expands into | |
653 | ||
654 | -- Result_Type (Width_Wide_Character ( | |
655 | -- Wide_Character (typ'First), | |
656 | -- Wide_Character (typ'Last), | |
657 | -- Wide_Character_Encoding_Method); | |
658 | ||
659 | -- and typ'Wide_Width expands into: | |
660 | ||
661 | -- Result_Type (Wide_Width_Wide_Character ( | |
662 | -- Wide_Character (typ'First), | |
663 | -- Wide_Character (typ'Last)); | |
664 | ||
665 | -- For real types, typ'Width and typ'Wide_Width expand into | |
666 | ||
667 | -- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if | |
668 | ||
669 | -- where btyp is the base type. This looks recursive but it isn't | |
670 | -- because the base type is always static, and hence the expression | |
671 | -- in the else is reduced to an integer literal. | |
672 | ||
673 | -- For user defined enumeration types, typ'Width expands into | |
674 | ||
675 | -- Result_Type (Width_Enumeration_NN | |
676 | -- (typS, | |
677 | -- typI'Address, | |
678 | -- typ'Pos (typ'First), | |
679 | -- typ'Pos (Typ'Last))); | |
680 | ||
681 | -- and typ'Wide_Width expands into: | |
682 | ||
683 | -- Result_Type (Wide_Width_Enumeration_NN | |
684 | -- (typS, | |
685 | -- typI, | |
686 | -- typ'Pos (typ'First), | |
687 | -- typ'Pos (Typ'Last)) | |
688 | -- Wide_Character_Encoding_Method); | |
689 | ||
690 | -- where typS and typI are the enumeration image strings and | |
691 | -- indexes table, as described in Build_Enumeration_Image_Tables. | |
692 | -- NN is 8/16/32 for depending on the element type for typI. | |
693 | ||
694 | procedure Expand_Width_Attribute (N : Node_Id; Wide : Boolean) is | |
695 | Loc : constant Source_Ptr := Sloc (N); | |
696 | Typ : constant Entity_Id := Etype (N); | |
697 | Pref : constant Node_Id := Prefix (N); | |
698 | Ptyp : constant Entity_Id := Etype (Pref); | |
699 | Rtyp : constant Entity_Id := Root_Type (Ptyp); | |
700 | XX : RE_Id; | |
701 | YY : Entity_Id; | |
702 | Arglist : List_Id; | |
703 | Ttyp : Entity_Id; | |
704 | ||
705 | begin | |
706 | -- Types derived from Standard.Boolean | |
707 | ||
708 | if Rtyp = Standard_Boolean then | |
709 | XX := RE_Width_Boolean; | |
710 | YY := Rtyp; | |
711 | ||
712 | -- Types derived from Standard.Character | |
713 | ||
714 | elsif Rtyp = Standard_Character then | |
715 | if not Wide then | |
716 | XX := RE_Width_Character; | |
717 | else | |
718 | XX := RE_Wide_Width_Character; | |
719 | end if; | |
720 | ||
721 | YY := Rtyp; | |
722 | ||
723 | -- Types derived from Standard.Wide_Character | |
724 | ||
725 | elsif Rtyp = Standard_Wide_Character then | |
726 | if not Wide then | |
727 | XX := RE_Width_Wide_Character; | |
728 | else | |
729 | XX := RE_Wide_Width_Wide_Character; | |
730 | end if; | |
731 | ||
732 | YY := Rtyp; | |
733 | ||
734 | -- Signed integer types | |
735 | ||
736 | elsif Is_Signed_Integer_Type (Rtyp) then | |
737 | XX := RE_Width_Long_Long_Integer; | |
738 | YY := Standard_Long_Long_Integer; | |
739 | ||
740 | -- Modular integer types | |
741 | ||
742 | elsif Is_Modular_Integer_Type (Rtyp) then | |
743 | XX := RE_Width_Long_Long_Unsigned; | |
744 | YY := RTE (RE_Long_Long_Unsigned); | |
745 | ||
746 | -- Real types | |
747 | ||
748 | elsif Is_Real_Type (Rtyp) then | |
749 | ||
750 | Rewrite (N, | |
751 | Make_Conditional_Expression (Loc, | |
752 | Expressions => New_List ( | |
753 | ||
754 | Make_Op_Gt (Loc, | |
755 | Left_Opnd => | |
756 | Make_Attribute_Reference (Loc, | |
757 | Prefix => New_Reference_To (Ptyp, Loc), | |
758 | Attribute_Name => Name_First), | |
759 | ||
760 | Right_Opnd => | |
761 | Make_Attribute_Reference (Loc, | |
762 | Prefix => New_Reference_To (Ptyp, Loc), | |
763 | Attribute_Name => Name_Last)), | |
764 | ||
765 | Make_Integer_Literal (Loc, 0), | |
766 | ||
767 | Make_Attribute_Reference (Loc, | |
768 | Prefix => New_Reference_To (Base_Type (Ptyp), Loc), | |
769 | Attribute_Name => Name_Width)))); | |
770 | ||
771 | Analyze_And_Resolve (N, Typ); | |
772 | return; | |
773 | ||
774 | -- User defined enumeration types | |
775 | ||
776 | else | |
777 | pragma Assert (Is_Enumeration_Type (Rtyp)); | |
778 | ||
779 | Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); | |
780 | ||
781 | if not Wide then | |
782 | if Ttyp = Standard_Integer_8 then | |
783 | XX := RE_Width_Enumeration_8; | |
784 | elsif Ttyp = Standard_Integer_16 then | |
785 | XX := RE_Width_Enumeration_16; | |
786 | else | |
787 | XX := RE_Width_Enumeration_32; | |
788 | end if; | |
789 | ||
790 | else | |
791 | if Ttyp = Standard_Integer_8 then | |
792 | XX := RE_Wide_Width_Enumeration_8; | |
793 | elsif Ttyp = Standard_Integer_16 then | |
794 | XX := RE_Wide_Width_Enumeration_16; | |
795 | else | |
796 | XX := RE_Wide_Width_Enumeration_32; | |
797 | end if; | |
798 | end if; | |
799 | ||
800 | Arglist := | |
801 | New_List ( | |
802 | New_Occurrence_Of (Lit_Strings (Rtyp), Loc), | |
803 | ||
804 | Make_Attribute_Reference (Loc, | |
805 | Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), | |
806 | Attribute_Name => Name_Address), | |
807 | ||
808 | Make_Attribute_Reference (Loc, | |
809 | Prefix => New_Reference_To (Ptyp, Loc), | |
810 | Attribute_Name => Name_Pos, | |
811 | ||
812 | Expressions => New_List ( | |
813 | Make_Attribute_Reference (Loc, | |
814 | Prefix => New_Reference_To (Ptyp, Loc), | |
815 | Attribute_Name => Name_First))), | |
816 | ||
817 | Make_Attribute_Reference (Loc, | |
818 | Prefix => New_Reference_To (Ptyp, Loc), | |
819 | Attribute_Name => Name_Pos, | |
820 | ||
821 | Expressions => New_List ( | |
822 | Make_Attribute_Reference (Loc, | |
823 | Prefix => New_Reference_To (Ptyp, Loc), | |
824 | Attribute_Name => Name_Last)))); | |
825 | ||
826 | -- For enumeration'Wide_Width, add encoding method parameter | |
827 | ||
828 | if Wide then | |
829 | Append_To (Arglist, | |
830 | Make_Integer_Literal (Loc, | |
831 | Intval => Int (Wide_Character_Encoding_Method))); | |
832 | end if; | |
833 | ||
834 | Rewrite (N, | |
835 | Convert_To (Typ, | |
836 | Make_Function_Call (Loc, | |
837 | Name => New_Reference_To (RTE (XX), Loc), | |
838 | Parameter_Associations => Arglist))); | |
839 | ||
840 | Analyze_And_Resolve (N, Typ); | |
841 | return; | |
842 | end if; | |
843 | ||
844 | -- If we fall through XX and YY are set | |
845 | ||
846 | Arglist := New_List ( | |
847 | Convert_To (YY, | |
848 | Make_Attribute_Reference (Loc, | |
849 | Prefix => New_Reference_To (Ptyp, Loc), | |
850 | Attribute_Name => Name_First)), | |
851 | ||
852 | Convert_To (YY, | |
853 | Make_Attribute_Reference (Loc, | |
854 | Prefix => New_Reference_To (Ptyp, Loc), | |
855 | Attribute_Name => Name_Last))); | |
856 | ||
857 | -- For Wide_Character'Width, add encoding method parameter | |
858 | ||
859 | if Rtyp = Standard_Wide_Character and then Wide then | |
860 | Append_To (Arglist, | |
861 | Make_Integer_Literal (Loc, | |
862 | Intval => Int (Wide_Character_Encoding_Method))); | |
863 | end if; | |
864 | ||
865 | Rewrite (N, | |
866 | Convert_To (Typ, | |
867 | Make_Function_Call (Loc, | |
868 | Name => New_Reference_To (RTE (XX), Loc), | |
869 | Parameter_Associations => Arglist))); | |
870 | ||
871 | Analyze_And_Resolve (N, Typ); | |
872 | end Expand_Width_Attribute; | |
873 | ||
874 | end Exp_Imgv; |