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