?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Merge from mainline (167278:168000).
[official-gcc/graphite-test-results.git] / gcc / ada / exp_imgv.adb
blob78d9b006abc9226d55918a65bf63d8dea917d7ab
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-2010, 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 -- Missing ???
249
250 procedure Expand_Image_Attribute (N : Node_Id) is
251 Loc : constant Source_Ptr := Sloc (N);
252 Exprs : constant List_Id := Expressions (N);
253 Pref : constant Node_Id := Prefix (N);
254 Ptyp : constant Entity_Id := Entity (Pref);
255 Rtyp : constant Entity_Id := Root_Type (Ptyp);
256 Expr : constant Node_Id := Relocate_Node (First (Exprs));
257 Imid : RE_Id;
258 Tent : Entity_Id;
259 Ttyp : Entity_Id;
260 Proc_Ent : Entity_Id;
261 Enum_Case : Boolean;
262
263 Arg_List : List_Id;
264 -- List of arguments for run-time procedure call
265
266 Ins_List : List_Id;
267 -- List of actions to be inserted
268
269 Snn : constant Entity_Id := Make_Temporary (Loc, 'S');
270 Pnn : constant Entity_Id := Make_Temporary (Loc, 'P');
271
272 begin
273 -- Build declarations of Snn and Pnn to be inserted
274
275 Ins_List := New_List (
276
277 -- Snn : String (1 .. typ'Width);
278
279 Make_Object_Declaration (Loc,
280 Defining_Identifier => Snn,
281 Object_Definition =>
282 Make_Subtype_Indication (Loc,
283 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
284 Constraint =>
285 Make_Index_Or_Discriminant_Constraint (Loc,
286 Constraints => New_List (
287 Make_Range (Loc,
288 Low_Bound => Make_Integer_Literal (Loc, 1),
289 High_Bound =>
290 Make_Attribute_Reference (Loc,
291 Prefix => New_Occurrence_Of (Rtyp, Loc),
292 Attribute_Name => Name_Width)))))),
293
294 -- Pnn : Natural;
295
296 Make_Object_Declaration (Loc,
297 Defining_Identifier => Pnn,
298 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)));
299
300 -- Set Imid (RE_Id of procedure to call), and Tent, target for the
301 -- type conversion of the first argument for all possibilities.
302
303 Enum_Case := False;
304
305 if Rtyp = Standard_Boolean then
306 Imid := RE_Image_Boolean;
307 Tent := Rtyp;
308
309 -- For standard character, we have to select the version which handles
310 -- soft hyphen correctly, based on the version of Ada in use (ugly!)
311
312 elsif Rtyp = Standard_Character then
313 if Ada_Version < Ada_2005 then
314 Imid := RE_Image_Character;
315 else
316 Imid := RE_Image_Character_05;
317 end if;
318
319 Tent := Rtyp;
320
321 elsif Rtyp = Standard_Wide_Character then
322 Imid := RE_Image_Wide_Character;
323 Tent := Rtyp;
324
325 elsif Rtyp = Standard_Wide_Wide_Character then
326 Imid := RE_Image_Wide_Wide_Character;
327 Tent := Rtyp;
328
329 elsif Is_Signed_Integer_Type (Rtyp) then
330 if Esize (Rtyp) <= Esize (Standard_Integer) then
331 Imid := RE_Image_Integer;
332 Tent := Standard_Integer;
333 else
334 Imid := RE_Image_Long_Long_Integer;
335 Tent := Standard_Long_Long_Integer;
336 end if;
337
338 elsif Is_Modular_Integer_Type (Rtyp) then
339 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
340 Imid := RE_Image_Unsigned;
341 Tent := RTE (RE_Unsigned);
342 else
343 Imid := RE_Image_Long_Long_Unsigned;
344 Tent := RTE (RE_Long_Long_Unsigned);
345 end if;
346
347 elsif Is_Fixed_Point_Type (Rtyp) and then Has_Decimal_Small (Rtyp) then
348 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
349 Imid := RE_Image_Decimal;
350 Tent := Standard_Integer;
351 else
352 Imid := RE_Image_Long_Long_Decimal;
353 Tent := Standard_Long_Long_Integer;
354 end if;
355
356 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
357 Imid := RE_Image_Ordinary_Fixed_Point;
358 Tent := Standard_Long_Long_Float;
359
360 elsif Is_Floating_Point_Type (Rtyp) then
361 Imid := RE_Image_Floating_Point;
362 Tent := Standard_Long_Long_Float;
363
364 -- Only other possibility is user defined enumeration type
365
366 else
367 if Discard_Names (First_Subtype (Ptyp))
368 or else No (Lit_Strings (Root_Type (Ptyp)))
369 then
370 -- When pragma Discard_Names applies to the first subtype, build
371 -- (Pref'Pos)'Img.
372
373 Rewrite (N,
374 Make_Attribute_Reference (Loc,
375 Prefix =>
376 Make_Attribute_Reference (Loc,
377 Prefix => Pref,
378 Attribute_Name => Name_Pos,
379 Expressions => New_List (Expr)),
380 Attribute_Name =>
381 Name_Img));
382 Analyze_And_Resolve (N, Standard_String);
383 return;
384
385 else
386 -- Here for enumeration type case
387
388 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
389
390 if Ttyp = Standard_Integer_8 then
391 Imid := RE_Image_Enumeration_8;
392
393 elsif Ttyp = Standard_Integer_16 then
394 Imid := RE_Image_Enumeration_16;
395
396 else
397 Imid := RE_Image_Enumeration_32;
398 end if;
399
400 -- Apply a validity check, since it is a bit drastic to get a
401 -- completely junk image value for an invalid value.
402
403 if not Expr_Known_Valid (Expr) then
404 Insert_Valid_Check (Expr);
405 end if;
406
407 Enum_Case := True;
408 end if;
409 end if;
410
411 -- Build first argument for call
412
413 if Enum_Case then
414 Arg_List := New_List (
415 Make_Attribute_Reference (Loc,
416 Attribute_Name => Name_Pos,
417 Prefix => New_Occurrence_Of (Ptyp, Loc),
418 Expressions => New_List (Expr)));
419
420 else
421 Arg_List := New_List (Convert_To (Tent, Expr));
422 end if;
423
424 -- Append Snn, Pnn arguments
425
426 Append_To (Arg_List, New_Occurrence_Of (Snn, Loc));
427 Append_To (Arg_List, New_Occurrence_Of (Pnn, Loc));
428
429 -- Get entity of procedure to call
430
431 Proc_Ent := RTE (Imid);
432
433 -- If the procedure entity is empty, that means we have a case in
434 -- no run time mode where the operation is not allowed, and an
435 -- appropriate diagnostic has already been issued.
436
437 if No (Proc_Ent) then
438 return;
439 end if;
440
441 -- Otherwise complete preparation of arguments for run-time call
442
443 -- Add extra arguments for Enumeration case
444
445 if Enum_Case then
446 Append_To (Arg_List, New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
447 Append_To (Arg_List,
448 Make_Attribute_Reference (Loc,
449 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
450 Attribute_Name => Name_Address));
451
452 -- For floating-point types, append Digits argument
453
454 elsif Is_Floating_Point_Type (Rtyp) then
455 Append_To (Arg_List,
456 Make_Attribute_Reference (Loc,
457 Prefix => New_Reference_To (Ptyp, Loc),
458 Attribute_Name => Name_Digits));
459
460 -- For ordinary fixed-point types, append Aft parameter
461
462 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
463 Append_To (Arg_List,
464 Make_Attribute_Reference (Loc,
465 Prefix => New_Reference_To (Ptyp, Loc),
466 Attribute_Name => Name_Aft));
467
468 if Has_Decimal_Small (Rtyp) then
469 Set_Conversion_OK (First (Arg_List));
470 Set_Etype (First (Arg_List), Tent);
471 end if;
472
473 -- For decimal, append Scale and also set to do literal conversion
474
475 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
476 Append_To (Arg_List,
477 Make_Attribute_Reference (Loc,
478 Prefix => New_Reference_To (Ptyp, Loc),
479 Attribute_Name => Name_Scale));
480
481 Set_Conversion_OK (First (Arg_List));
482 Set_Etype (First (Arg_List), Tent);
483
484 -- For Wide_Character, append Ada 2005 indication
485
486 elsif Rtyp = Standard_Wide_Character then
487 Append_To (Arg_List,
488 New_Reference_To (Boolean_Literals (Ada_Version >= Ada_2005), Loc));
489 end if;
490
491 -- Now append the procedure call to the insert list
492
493 Append_To (Ins_List,
494 Make_Procedure_Call_Statement (Loc,
495 Name => New_Reference_To (Proc_Ent, Loc),
496 Parameter_Associations => Arg_List));
497
498 -- Insert declarations of Snn, Pnn, and the procedure call. We suppress
499 -- checks because we are sure that everything is in range at this stage.
500
501 Insert_Actions (N, Ins_List, Suppress => All_Checks);
502
503 -- Final step is to rewrite the expression as a slice and analyze,
504 -- again with no checks, since we are sure that everything is OK.
505
506 Rewrite (N,
507 Make_Slice (Loc,
508 Prefix => New_Occurrence_Of (Snn, Loc),
509 Discrete_Range =>
510 Make_Range (Loc,
511 Low_Bound => Make_Integer_Literal (Loc, 1),
512 High_Bound => New_Occurrence_Of (Pnn, Loc))));
513
514 Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks);
515 end Expand_Image_Attribute;
516
517 ----------------------------
518 -- Expand_Value_Attribute --
519 ----------------------------
520
521 -- For scalar types derived from Boolean, Character and integer types
522 -- in package Standard, typ'Value (X) expands into:
523
524 -- btyp (Value_xx (X))
525
526 -- where btyp is he base type of the prefix
527
528 -- For types whose root type is Character
529 -- xx = Character
530
531 -- For types whose root type is Wide_Character
532 -- xx = Wide_Character
533
534 -- For types whose root type is Wide_Wide_Character
535 -- xx = Wide_Wide_Character
536
537 -- For types whose root type is Boolean
538 -- xx = Boolean
539
540 -- For signed integer types with size <= Integer'Size
541 -- xx = Integer
542
543 -- For other signed integer types
544 -- xx = Long_Long_Integer
545
546 -- For modular types with modulus <= System.Unsigned_Types.Unsigned
547 -- xx = Unsigned
548
549 -- For other modular integer types
550 -- xx = Long_Long_Unsigned
551
552 -- For floating-point types and ordinary fixed-point types
553 -- xx = Real
554
555 -- For Wide_[Wide_]Character types, typ'Value (X) expands into:
556
557 -- btyp (Value_xx (X, EM))
558
559 -- where btyp is the base type of the prefix, and EM is the encoding method
560
561 -- For decimal types with size <= Integer'Size, typ'Value (X)
562 -- expands into
563
564 -- btyp?(Value_Decimal (X, typ'Scale));
565
566 -- For all other decimal types, typ'Value (X) expands into
567
568 -- btyp?(Value_Long_Long_Decimal (X, typ'Scale))
569
570 -- For enumeration types other than those derived from types Boolean,
571 -- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
572
573 -- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
574
575 -- where typS and typI and the Lit_Strings and Lit_Indexes entities
576 -- from T's root type entity, and Num is Enum'Pos (Enum'Last). The
577 -- Value_Enumeration_NN function will search the tables looking for
578 -- X and return the position number in the table if found which is
579 -- used to provide the result of 'Value (using Enum'Val). If the
580 -- value is not found Constraint_Error is raised. The suffix _NN
581 -- depends on the element type of typI.
582
583 procedure Expand_Value_Attribute (N : Node_Id) is
584 Loc : constant Source_Ptr := Sloc (N);
585 Typ : constant Entity_Id := Etype (N);
586 Btyp : constant Entity_Id := Base_Type (Typ);
587 Rtyp : constant Entity_Id := Root_Type (Typ);
588 Exprs : constant List_Id := Expressions (N);
589 Vid : RE_Id;
590 Args : List_Id;
591 Func : RE_Id;
592 Ttyp : Entity_Id;
593
594 begin
595 Args := Exprs;
596
597 if Rtyp = Standard_Character then
598 Vid := RE_Value_Character;
599
600 elsif Rtyp = Standard_Boolean then
601 Vid := RE_Value_Boolean;
602
603 elsif Rtyp = Standard_Wide_Character then
604 Vid := RE_Value_Wide_Character;
605
606 Append_To (Args,
607 Make_Integer_Literal (Loc,
608 Intval => Int (Wide_Character_Encoding_Method)));
609
610 elsif Rtyp = Standard_Wide_Wide_Character then
611 Vid := RE_Value_Wide_Wide_Character;
612
613 Append_To (Args,
614 Make_Integer_Literal (Loc,
615 Intval => Int (Wide_Character_Encoding_Method)));
616
617 elsif Rtyp = Base_Type (Standard_Short_Short_Integer)
618 or else Rtyp = Base_Type (Standard_Short_Integer)
619 or else Rtyp = Base_Type (Standard_Integer)
620 then
621 Vid := RE_Value_Integer;
622
623 elsif Is_Signed_Integer_Type (Rtyp) then
624 Vid := RE_Value_Long_Long_Integer;
625
626 elsif Is_Modular_Integer_Type (Rtyp) then
627 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
628 Vid := RE_Value_Unsigned;
629 else
630 Vid := RE_Value_Long_Long_Unsigned;
631 end if;
632
633 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
634 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
635 Vid := RE_Value_Decimal;
636 else
637 Vid := RE_Value_Long_Long_Decimal;
638 end if;
639
640 Append_To (Args,
641 Make_Attribute_Reference (Loc,
642 Prefix => New_Reference_To (Typ, Loc),
643 Attribute_Name => Name_Scale));
644
645 Rewrite (N,
646 OK_Convert_To (Btyp,
647 Make_Function_Call (Loc,
648 Name => New_Reference_To (RTE (Vid), Loc),
649 Parameter_Associations => Args)));
650
651 Set_Etype (N, Btyp);
652 Analyze_And_Resolve (N, Btyp);
653 return;
654
655 elsif Is_Real_Type (Rtyp) then
656 Vid := RE_Value_Real;
657
658 -- Only other possibility is user defined enumeration type
659
660 else
661 pragma Assert (Is_Enumeration_Type (Rtyp));
662
663 -- Case of pragma Discard_Names, transform the Value
664 -- attribute to Btyp'Val (Long_Long_Integer'Value (Args))
665
666 if Discard_Names (First_Subtype (Typ))
667 or else No (Lit_Strings (Rtyp))
668 then
669 Rewrite (N,
670 Make_Attribute_Reference (Loc,
671 Prefix => New_Reference_To (Btyp, Loc),
672 Attribute_Name => Name_Val,
673 Expressions => New_List (
674 Make_Attribute_Reference (Loc,
675 Prefix =>
676 New_Occurrence_Of (Standard_Long_Long_Integer, Loc),
677 Attribute_Name => Name_Value,
678 Expressions => Args))));
679
680 Analyze_And_Resolve (N, Btyp);
681
682 -- Here for normal case where we have enumeration tables, this
683 -- is where we build
684
685 -- T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
686
687 else
688 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
689
690 if Ttyp = Standard_Integer_8 then
691 Func := RE_Value_Enumeration_8;
692 elsif Ttyp = Standard_Integer_16 then
693 Func := RE_Value_Enumeration_16;
694 else
695 Func := RE_Value_Enumeration_32;
696 end if;
697
698 Prepend_To (Args,
699 Make_Attribute_Reference (Loc,
700 Prefix => New_Occurrence_Of (Rtyp, Loc),
701 Attribute_Name => Name_Pos,
702 Expressions => New_List (
703 Make_Attribute_Reference (Loc,
704 Prefix => New_Occurrence_Of (Rtyp, Loc),
705 Attribute_Name => Name_Last))));
706
707 Prepend_To (Args,
708 Make_Attribute_Reference (Loc,
709 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
710 Attribute_Name => Name_Address));
711
712 Prepend_To (Args,
713 New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
714
715 Rewrite (N,
716 Make_Attribute_Reference (Loc,
717 Prefix => New_Reference_To (Typ, Loc),
718 Attribute_Name => Name_Val,
719 Expressions => New_List (
720 Make_Function_Call (Loc,
721 Name =>
722 New_Reference_To (RTE (Func), Loc),
723 Parameter_Associations => Args))));
724
725 Analyze_And_Resolve (N, Btyp);
726 end if;
727
728 return;
729 end if;
730
731 -- Fall through for all cases except user defined enumeration type
732 -- and decimal types, with Vid set to the Id of the entity for the
733 -- Value routine and Args set to the list of parameters for the call.
734
735 -- Compiling package Ada.Tags under No_Run_Time_Mode we disable the
736 -- expansion of the attribute into the function call statement to avoid
737 -- generating spurious errors caused by the use of Integer_Address'Value
738 -- in our implementation of Ada.Tags.Internal_Tag
739
740 -- Seems like a bit of a kludge, there should be a better way ???
741
742 -- There is a better way, you should also test RTE_Available ???
743
744 if No_Run_Time_Mode
745 and then Rtyp = RTE (RE_Integer_Address)
746 and then RTU_Loaded (Ada_Tags)
747 and then Cunit_Entity (Current_Sem_Unit)
748 = Body_Entity (RTU_Entity (Ada_Tags))
749 then
750 Rewrite (N,
751 Unchecked_Convert_To (Rtyp,
752 Make_Integer_Literal (Loc, Uint_0)));
753 else
754 Rewrite (N,
755 Convert_To (Btyp,
756 Make_Function_Call (Loc,
757 Name => New_Reference_To (RTE (Vid), Loc),
758 Parameter_Associations => Args)));
759 end if;
760
761 Analyze_And_Resolve (N, Btyp);
762 end Expand_Value_Attribute;
763
764 ---------------------------------
765 -- Expand_Wide_Image_Attribute --
766 ---------------------------------
767
768 -- We expand typ'Wide_Image (X) as follows. First we insert this code:
769
770 -- Rnn : Wide_String (1 .. rt'Wide_Width);
771 -- Lnn : Natural;
772 -- String_To_Wide_String
773 -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
774
775 -- where rt is the root type of the prefix type
776
777 -- Now we replace the Wide_Image reference by
778
779 -- Rnn (1 .. Lnn)
780
781 -- This works in all cases because String_To_Wide_String converts any
782 -- wide character escape sequences resulting from the Image call to the
783 -- proper Wide_Character equivalent
784
785 -- not quite right for typ = Wide_Character ???
786
787 procedure Expand_Wide_Image_Attribute (N : Node_Id) is
788 Loc : constant Source_Ptr := Sloc (N);
789 Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N)));
790 Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
791 Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
792
793 begin
794 Insert_Actions (N, New_List (
795
796 -- Rnn : Wide_String (1 .. base_typ'Width);
797
798 Make_Object_Declaration (Loc,
799 Defining_Identifier => Rnn,
800 Object_Definition =>
801 Make_Subtype_Indication (Loc,
802 Subtype_Mark =>
803 New_Occurrence_Of (Standard_Wide_String, Loc),
804 Constraint =>
805 Make_Index_Or_Discriminant_Constraint (Loc,
806 Constraints => New_List (
807 Make_Range (Loc,
808 Low_Bound => Make_Integer_Literal (Loc, 1),
809 High_Bound =>
810 Make_Attribute_Reference (Loc,
811 Prefix => New_Occurrence_Of (Rtyp, Loc),
812 Attribute_Name => Name_Wide_Width)))))),
813
814 -- Lnn : Natural;
815
816 Make_Object_Declaration (Loc,
817 Defining_Identifier => Lnn,
818 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)),
819
820 -- String_To_Wide_String
821 -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
822
823 Make_Procedure_Call_Statement (Loc,
824 Name =>
825 New_Reference_To (RTE (RE_String_To_Wide_String), Loc),
826
827 Parameter_Associations => New_List (
828 Make_Attribute_Reference (Loc,
829 Prefix => Prefix (N),
830 Attribute_Name => Name_Image,
831 Expressions => Expressions (N)),
832 New_Reference_To (Rnn, Loc),
833 New_Reference_To (Lnn, Loc),
834 Make_Integer_Literal (Loc,
835 Intval => Int (Wide_Character_Encoding_Method))))),
836
837 -- Suppress checks because we know everything is properly in range
838
839 Suppress => All_Checks);
840
841 -- Final step is to rewrite the expression as a slice and analyze,
842 -- again with no checks, since we are sure that everything is OK.
843
844 Rewrite (N,
845 Make_Slice (Loc,
846 Prefix => New_Occurrence_Of (Rnn, Loc),
847 Discrete_Range =>
848 Make_Range (Loc,
849 Low_Bound => Make_Integer_Literal (Loc, 1),
850 High_Bound => New_Occurrence_Of (Lnn, Loc))));
851
852 Analyze_And_Resolve (N, Standard_Wide_String, Suppress => All_Checks);
853 end Expand_Wide_Image_Attribute;
854
855 --------------------------------------
856 -- Expand_Wide_Wide_Image_Attribute --
857 --------------------------------------
858
859 -- We expand typ'Wide_Wide_Image (X) as follows. First we insert this code:
860
861 -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
862 -- Lnn : Natural;
863 -- String_To_Wide_Wide_String
864 -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
865
866 -- where rt is the root type of the prefix type
867
868 -- Now we replace the Wide_Wide_Image reference by
869
870 -- Rnn (1 .. Lnn)
871
872 -- This works in all cases because String_To_Wide_Wide_String converts any
873 -- wide character escape sequences resulting from the Image call to the
874 -- proper Wide_Wide_Character equivalent
875
876 -- not quite right for typ = Wide_Wide_Character ???
877
878 procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is
879 Loc : constant Source_Ptr := Sloc (N);
880 Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N)));
881
882 Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
883 Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
884
885 begin
886 Insert_Actions (N, New_List (
887
888 -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
889
890 Make_Object_Declaration (Loc,
891 Defining_Identifier => Rnn,
892 Object_Definition =>
893 Make_Subtype_Indication (Loc,
894 Subtype_Mark =>
895 New_Occurrence_Of (Standard_Wide_Wide_String, Loc),
896 Constraint =>
897 Make_Index_Or_Discriminant_Constraint (Loc,
898 Constraints => New_List (
899 Make_Range (Loc,
900 Low_Bound => Make_Integer_Literal (Loc, 1),
901 High_Bound =>
902 Make_Attribute_Reference (Loc,
903 Prefix => New_Occurrence_Of (Rtyp, Loc),
904 Attribute_Name => Name_Wide_Wide_Width)))))),
905
906 -- Lnn : Natural;
907
908 Make_Object_Declaration (Loc,
909 Defining_Identifier => Lnn,
910 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)),
911
912 -- String_To_Wide_Wide_String
913 -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
914
915 Make_Procedure_Call_Statement (Loc,
916 Name =>
917 New_Reference_To (RTE (RE_String_To_Wide_Wide_String), Loc),
918
919 Parameter_Associations => New_List (
920 Make_Attribute_Reference (Loc,
921 Prefix => Prefix (N),
922 Attribute_Name => Name_Image,
923 Expressions => Expressions (N)),
924 New_Reference_To (Rnn, Loc),
925 New_Reference_To (Lnn, Loc),
926 Make_Integer_Literal (Loc,
927 Intval => Int (Wide_Character_Encoding_Method))))),
928
929 -- Suppress checks because we know everything is properly in range
930
931 Suppress => All_Checks);
932
933 -- Final step is to rewrite the expression as a slice and analyze,
934 -- again with no checks, since we are sure that everything is OK.
935
936 Rewrite (N,
937 Make_Slice (Loc,
938 Prefix => New_Occurrence_Of (Rnn, Loc),
939 Discrete_Range =>
940 Make_Range (Loc,
941 Low_Bound => Make_Integer_Literal (Loc, 1),
942 High_Bound => New_Occurrence_Of (Lnn, Loc))));
943
944 Analyze_And_Resolve
945 (N, Standard_Wide_Wide_String, Suppress => All_Checks);
946 end Expand_Wide_Wide_Image_Attribute;
947
948 ----------------------------
949 -- Expand_Width_Attribute --
950 ----------------------------
951
952 -- The processing here also handles the case of Wide_[Wide_]Width. With the
953 -- exceptions noted, the processing is identical
954
955 -- For scalar types derived from Boolean, character and integer types
956 -- in package Standard. Note that the Width attribute is computed at
957 -- compile time for all cases except those involving non-static sub-
958 -- types. For such subtypes, typ'[Wide_[Wide_]]Width expands into:
959
960 -- Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last)))
961
962 -- where
963
964 -- For types whose root type is Character
965 -- xx = Width_Character
966 -- yy = Character
967
968 -- For types whose root type is Wide_Character
969 -- xx = Wide_Width_Character
970 -- yy = Character
971
972 -- For types whose root type is Wide_Wide_Character
973 -- xx = Wide_Wide_Width_Character
974 -- yy = Character
975
976 -- For types whose root type is Boolean
977 -- xx = Width_Boolean
978 -- yy = Boolean
979
980 -- For signed integer types
981 -- xx = Width_Long_Long_Integer
982 -- yy = Long_Long_Integer
983
984 -- For modular integer types
985 -- xx = Width_Long_Long_Unsigned
986 -- yy = Long_Long_Unsigned
987
988 -- For types derived from Wide_Character, typ'Width expands into
989
990 -- Result_Type (Width_Wide_Character (
991 -- Wide_Character (typ'First),
992 -- Wide_Character (typ'Last),
993
994 -- and typ'Wide_Width expands into:
995
996 -- Result_Type (Wide_Width_Wide_Character (
997 -- Wide_Character (typ'First),
998 -- Wide_Character (typ'Last));
999
1000 -- and typ'Wide_Wide_Width expands into
1001
1002 -- Result_Type (Wide_Wide_Width_Wide_Character (
1003 -- Wide_Character (typ'First),
1004 -- Wide_Character (typ'Last));
1005
1006 -- For types derived from Wide_Wide_Character, typ'Width expands into
1007
1008 -- Result_Type (Width_Wide_Wide_Character (
1009 -- Wide_Wide_Character (typ'First),
1010 -- Wide_Wide_Character (typ'Last),
1011
1012 -- and typ'Wide_Width expands into:
1013
1014 -- Result_Type (Wide_Width_Wide_Wide_Character (
1015 -- Wide_Wide_Character (typ'First),
1016 -- Wide_Wide_Character (typ'Last));
1017
1018 -- and typ'Wide_Wide_Width expands into
1019
1020 -- Result_Type (Wide_Wide_Width_Wide_Wide_Char (
1021 -- Wide_Wide_Character (typ'First),
1022 -- Wide_Wide_Character (typ'Last));
1023
1024 -- For real types, typ'Width and typ'Wide_[Wide_]Width expand into
1025
1026 -- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if
1027
1028 -- where btyp is the base type. This looks recursive but it isn't
1029 -- because the base type is always static, and hence the expression
1030 -- in the else is reduced to an integer literal.
1031
1032 -- For user defined enumeration types, typ'Width expands into
1033
1034 -- Result_Type (Width_Enumeration_NN
1035 -- (typS,
1036 -- typI'Address,
1037 -- typ'Pos (typ'First),
1038 -- typ'Pos (Typ'Last)));
1039
1040 -- and typ'Wide_Width expands into:
1041
1042 -- Result_Type (Wide_Width_Enumeration_NN
1043 -- (typS,
1044 -- typI,
1045 -- typ'Pos (typ'First),
1046 -- typ'Pos (Typ'Last))
1047 -- Wide_Character_Encoding_Method);
1048
1049 -- and typ'Wide_Wide_Width expands into:
1050
1051 -- Result_Type (Wide_Wide_Width_Enumeration_NN
1052 -- (typS,
1053 -- typI,
1054 -- typ'Pos (typ'First),
1055 -- typ'Pos (Typ'Last))
1056 -- Wide_Character_Encoding_Method);
1057
1058 -- where typS and typI are the enumeration image strings and
1059 -- indexes table, as described in Build_Enumeration_Image_Tables.
1060 -- NN is 8/16/32 for depending on the element type for typI.
1061
1062 procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal) is
1063 Loc : constant Source_Ptr := Sloc (N);
1064 Typ : constant Entity_Id := Etype (N);
1065 Pref : constant Node_Id := Prefix (N);
1066 Ptyp : constant Entity_Id := Etype (Pref);
1067 Rtyp : constant Entity_Id := Root_Type (Ptyp);
1068 XX : RE_Id;
1069 YY : Entity_Id;
1070 Arglist : List_Id;
1071 Ttyp : Entity_Id;
1072
1073 begin
1074 -- Types derived from Standard.Boolean
1075
1076 if Rtyp = Standard_Boolean then
1077 XX := RE_Width_Boolean;
1078 YY := Rtyp;
1079
1080 -- Types derived from Standard.Character
1081
1082 elsif Rtyp = Standard_Character then
1083 case Attr is
1084 when Normal => XX := RE_Width_Character;
1085 when Wide => XX := RE_Wide_Width_Character;
1086 when Wide_Wide => XX := RE_Wide_Wide_Width_Character;
1087 end case;
1088
1089 YY := Rtyp;
1090
1091 -- Types derived from Standard.Wide_Character
1092
1093 elsif Rtyp = Standard_Wide_Character then
1094 case Attr is
1095 when Normal => XX := RE_Width_Wide_Character;
1096 when Wide => XX := RE_Wide_Width_Wide_Character;
1097 when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Character;
1098 end case;
1099
1100 YY := Rtyp;
1101
1102 -- Types derived from Standard.Wide_Wide_Character
1103
1104 elsif Rtyp = Standard_Wide_Wide_Character then
1105 case Attr is
1106 when Normal => XX := RE_Width_Wide_Wide_Character;
1107 when Wide => XX := RE_Wide_Width_Wide_Wide_Character;
1108 when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Wide_Char;
1109 end case;
1110
1111 YY := Rtyp;
1112
1113 -- Signed integer types
1114
1115 elsif Is_Signed_Integer_Type (Rtyp) then
1116 XX := RE_Width_Long_Long_Integer;
1117 YY := Standard_Long_Long_Integer;
1118
1119 -- Modular integer types
1120
1121 elsif Is_Modular_Integer_Type (Rtyp) then
1122 XX := RE_Width_Long_Long_Unsigned;
1123 YY := RTE (RE_Long_Long_Unsigned);
1124
1125 -- Real types
1126
1127 elsif Is_Real_Type (Rtyp) then
1128
1129 Rewrite (N,
1130 Make_Conditional_Expression (Loc,
1131 Expressions => New_List (
1132
1133 Make_Op_Gt (Loc,
1134 Left_Opnd =>
1135 Make_Attribute_Reference (Loc,
1136 Prefix => New_Reference_To (Ptyp, Loc),
1137 Attribute_Name => Name_First),
1138
1139 Right_Opnd =>
1140 Make_Attribute_Reference (Loc,
1141 Prefix => New_Reference_To (Ptyp, Loc),
1142 Attribute_Name => Name_Last)),
1143
1144 Make_Integer_Literal (Loc, 0),
1145
1146 Make_Attribute_Reference (Loc,
1147 Prefix => New_Reference_To (Base_Type (Ptyp), Loc),
1148 Attribute_Name => Name_Width))));
1149
1150 Analyze_And_Resolve (N, Typ);
1151 return;
1152
1153 -- User defined enumeration types
1154
1155 else
1156 pragma Assert (Is_Enumeration_Type (Rtyp));
1157
1158 if Discard_Names (Rtyp) then
1159
1160 -- This is a configurable run-time, or else a restriction is in
1161 -- effect. In either case the attribute cannot be supported. Force
1162 -- a load error from Rtsfind to generate an appropriate message,
1163 -- as is done with other ZFP violations.
1164
1165 declare
1166 Discard : constant Entity_Id := RTE (RE_Null);
1167 pragma Unreferenced (Discard);
1168 begin
1169 return;
1170 end;
1171 end if;
1172
1173 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
1174
1175 case Attr is
1176 when Normal =>
1177 if Ttyp = Standard_Integer_8 then
1178 XX := RE_Width_Enumeration_8;
1179 elsif Ttyp = Standard_Integer_16 then
1180 XX := RE_Width_Enumeration_16;
1181 else
1182 XX := RE_Width_Enumeration_32;
1183 end if;
1184
1185 when Wide =>
1186 if Ttyp = Standard_Integer_8 then
1187 XX := RE_Wide_Width_Enumeration_8;
1188 elsif Ttyp = Standard_Integer_16 then
1189 XX := RE_Wide_Width_Enumeration_16;
1190 else
1191 XX := RE_Wide_Width_Enumeration_32;
1192 end if;
1193
1194 when Wide_Wide =>
1195 if Ttyp = Standard_Integer_8 then
1196 XX := RE_Wide_Wide_Width_Enumeration_8;
1197 elsif Ttyp = Standard_Integer_16 then
1198 XX := RE_Wide_Wide_Width_Enumeration_16;
1199 else
1200 XX := RE_Wide_Wide_Width_Enumeration_32;
1201 end if;
1202 end case;
1203
1204 Arglist :=
1205 New_List (
1206 New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
1207
1208 Make_Attribute_Reference (Loc,
1209 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
1210 Attribute_Name => Name_Address),
1211
1212 Make_Attribute_Reference (Loc,
1213 Prefix => New_Reference_To (Ptyp, Loc),
1214 Attribute_Name => Name_Pos,
1215
1216 Expressions => New_List (
1217 Make_Attribute_Reference (Loc,
1218 Prefix => New_Reference_To (Ptyp, Loc),
1219 Attribute_Name => Name_First))),
1220
1221 Make_Attribute_Reference (Loc,
1222 Prefix => New_Reference_To (Ptyp, Loc),
1223 Attribute_Name => Name_Pos,
1224
1225 Expressions => New_List (
1226 Make_Attribute_Reference (Loc,
1227 Prefix => New_Reference_To (Ptyp, Loc),
1228 Attribute_Name => Name_Last))));
1229
1230 Rewrite (N,
1231 Convert_To (Typ,
1232 Make_Function_Call (Loc,
1233 Name => New_Reference_To (RTE (XX), Loc),
1234 Parameter_Associations => Arglist)));
1235
1236 Analyze_And_Resolve (N, Typ);
1237 return;
1238 end if;
1239
1240 -- If we fall through XX and YY are set
1241
1242 Arglist := New_List (
1243 Convert_To (YY,
1244 Make_Attribute_Reference (Loc,
1245 Prefix => New_Reference_To (Ptyp, Loc),
1246 Attribute_Name => Name_First)),
1247
1248 Convert_To (YY,
1249 Make_Attribute_Reference (Loc,
1250 Prefix => New_Reference_To (Ptyp, Loc),
1251 Attribute_Name => Name_Last)));
1252
1253 Rewrite (N,
1254 Convert_To (Typ,
1255 Make_Function_Call (Loc,
1256 Name => New_Reference_To (RTE (XX), Loc),
1257 Parameter_Associations => Arglist)));
1258
1259 Analyze_And_Resolve (N, Typ);
1260 end Expand_Width_Attribute;
1261
1262 -----------------------
1263 -- Has_Decimal_Small --
1264 -----------------------
1265
1266 function Has_Decimal_Small (E : Entity_Id) return Boolean is
1267 begin
1268 return Is_Decimal_Fixed_Point_Type (E)
1269 or else
1270 (Is_Ordinary_Fixed_Point_Type (E)
1271 and then Ureal_10**Aft_Value (E) * Small_Value (E) = Ureal_1);
1272 end Has_Decimal_Small;
1273
1274 end Exp_Imgv;
GCC graphite test results