Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/exp_imgv.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 ------------------------------------------------------------------------------
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-2017, 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 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;
439 Tent : Entity_Id;
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;