?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
c++: remove some xfails
[official-gcc.git] / gcc / ada / exp_imgv.adb
blob51f1195a8c674dce0b16abd13aa08a552bbaef19
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-2022, 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 Einfo.Entities; use Einfo.Entities;
31 with Einfo.Utils; use Einfo.Utils;
32 with Debug; use Debug;
33 with Exp_Put_Image;
34 with Exp_Util; use Exp_Util;
35 with Lib; use Lib;
36 with Namet; use Namet;
37 with Nmake; use Nmake;
38 with Nlists; use Nlists;
39 with Opt; use Opt;
40 with Restrict; use Restrict;
41 with Rident; use Rident;
42 with Rtsfind; use Rtsfind;
43 with Sem_Aux; use Sem_Aux;
44 with Sem_Res; use Sem_Res;
45 with Sem_Util; use Sem_Util;
46 with Sinfo; use Sinfo;
47 with Sinfo.Nodes; use Sinfo.Nodes;
48 with Sinfo.Utils; use Sinfo.Utils;
49 with Snames; use Snames;
50 with Stand; use Stand;
51 with Stringt; use Stringt;
52 with Targparm; use Targparm;
53 with Tbuild; use Tbuild;
54 with Ttypes; use Ttypes;
55 with Uintp; use Uintp;
56 with Urealp; use Urealp;
57
58 with System.Perfect_Hash_Generators;
59
60 package body Exp_Imgv is
61
62 procedure Rewrite_Object_Image
63 (N : Node_Id;
64 Pref : Entity_Id;
65 Attr_Name : Name_Id;
66 Str_Typ : Entity_Id);
67 -- AI12-0124: Rewrite attribute 'Image when it is applied to an object
68 -- reference as an attribute applied to a type. N denotes the node to be
69 -- rewritten, Pref denotes the prefix of the 'Image attribute, and Name
70 -- and Str_Typ specify which specific string type and 'Image attribute to
71 -- apply (e.g. Name_Wide_Image and Standard_Wide_String).
72
73 ------------------------------------
74 -- Build_Enumeration_Image_Tables --
75 ------------------------------------
76
77 procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is
78 Loc : constant Source_Ptr := Sloc (E);
79 In_Main_Unit : constant Boolean := In_Extended_Main_Code_Unit (Loc);
80
81 Act : List_Id;
82 Eind : Entity_Id;
83 Estr : Entity_Id;
84 H_Id : Entity_Id;
85 H_OK : Boolean;
86 H_Sp : Node_Id;
87 Ind : List_Id;
88 Ityp : Node_Id;
89 Len : Nat;
90 Lit : Entity_Id;
91 Nlit : Nat;
92 S_Id : Entity_Id;
93 S_N : Nat := 0;
94 Str : String_Id;
95
96 package SPHG renames System.Perfect_Hash_Generators;
97
98 Saved_SSO : constant Character := Opt.Default_SSO;
99 -- Used to save the current scalar storage order during the generation
100 -- of the literal lookup table.
101
102 Serial_Number_Budget : constant := 50;
103 -- We may want to compute a perfect hash function for use by the Value
104 -- attribute. However computing this function is costly and, therefore,
105 -- cannot be done when compiling every unit where the enumeration type
106 -- is referenced, so we do it only when compiling the unit where it is
107 -- declared. This means that we may need to control the internal serial
108 -- numbers of this unit, or else we would risk generating public symbols
109 -- with mismatched names later on. The strategy for this is to allocate
110 -- a fixed budget of serial numbers to be spent from a specified point
111 -- until the end of the processing and to make sure that it is always
112 -- exactly spent on all possible paths from this point.
113
114 Threshold : constant Nat :=
115 (if Is_Library_Level_Entity (E)
116 or else not Always_Compatible_Rep_On_Target
117 then 3
118 else Nat'Last);
119 -- Threshold above which we want to generate the hash function in the
120 -- default case. We avoid doing it if this would cause a trampoline to
121 -- be generated because the type is local and descriptors are not used.
122
123 Threshold_For_Size : constant Nat := Nat'Max (Threshold, 9);
124 -- But the function and its tables take a bit of space so the threshold
125 -- is raised when compiling for size.
126
127 procedure Append_Table_To
128 (L : List_Id;
129 E : Entity_Id;
130 UB : Nat;
131 Ctyp : Entity_Id;
132 V : List_Id);
133 -- Append to L the declaration of E as a constant array of range 0 .. UB
134 -- and component type Ctyp with initial value V.
135
136 ---------------------
137 -- Append_Table_To --
138 ---------------------
139
140 procedure Append_Table_To
141 (L : List_Id;
142 E : Entity_Id;
143 UB : Nat;
144 Ctyp : Entity_Id;
145 V : List_Id)
146 is
147 begin
148 Append_To (L,
149 Make_Object_Declaration (Loc,
150 Defining_Identifier => E,
151 Constant_Present => True,
152 Object_Definition =>
153 Make_Constrained_Array_Definition (Loc,
154 Discrete_Subtype_Definitions => New_List (
155 Make_Range (Loc,
156 Low_Bound => Make_Integer_Literal (Loc, 0),
157 High_Bound => Make_Integer_Literal (Loc, UB))),
158 Component_Definition =>
159 Make_Component_Definition (Loc,
160 Aliased_Present => False,
161 Subtype_Indication => New_Occurrence_Of (Ctyp, Loc))),
162 Expression => Make_Aggregate (Loc, Expressions => V,
163 Is_Enum_Array_Aggregate => True)));
164 end Append_Table_To;
165
166 -- Start of Build_Enumeration_Image_Tables
167
168 begin
169 -- Nothing to do for types other than a root enumeration type
170
171 if E /= Root_Type (E) then
172 return;
173
174 -- Nothing to do if pragma Discard_Names applies
175
176 elsif Discard_Names (E) then
177 return;
178 end if;
179
180 -- Otherwise tables need constructing
181
182 Start_String;
183 Ind := New_List;
184 Lit := First_Literal (E);
185 Len := 1;
186 Nlit := 0;
187 H_OK := False;
188
189 loop
190 Append_To (Ind, Make_Integer_Literal (Loc, UI_From_Int (Len)));
191
192 exit when No (Lit);
193 Nlit := Nlit + 1;
194
195 Get_Unqualified_Decoded_Name_String (Chars (Lit));
196
197 if Name_Buffer (1) /= ''' then
198 Set_Casing (All_Upper_Case);
199 end if;
200
201 Store_String_Chars (Name_Buffer (1 .. Name_Len));
202 if In_Main_Unit then
203 SPHG.Insert (Name_Buffer (1 .. Name_Len));
204 end if;
205 Len := Len + Int (Name_Len);
206 Next_Literal (Lit);
207 end loop;
208
209 if Len < Int (2 ** (8 - 1)) then
210 Ityp := Standard_Integer_8;
211 elsif Len < Int (2 ** (16 - 1)) then
212 Ityp := Standard_Integer_16;
213 else
214 Ityp := Standard_Integer_32;
215 end if;
216
217 Str := End_String;
218
219 Estr :=
220 Make_Defining_Identifier (Loc,
221 Chars => New_External_Name (Chars (E), 'S'));
222
223 Eind :=
224 Make_Defining_Identifier (Loc,
225 Chars => New_External_Name (Chars (E), 'N'));
226
227 Set_Lit_Strings (E, Estr);
228 Set_Lit_Indexes (E, Eind);
229
230 -- Temporarily set the current scalar storage order to the default
231 -- during the generation of the literals table, since both the Image and
232 -- Value attributes rely on runtime routines for interpreting table
233 -- values.
234
235 Opt.Default_SSO := ' ';
236
237 -- Generate literal table
238
239 Act :=
240 New_List (
241 Make_Object_Declaration (Loc,
242 Defining_Identifier => Estr,
243 Constant_Present => True,
244 Object_Definition =>
245 New_Occurrence_Of (Standard_String, Loc),
246 Expression =>
247 Make_String_Literal (Loc,
248 Strval => Str)));
249
250 -- Generate index table
251
252 Append_Table_To (Act, Eind, Nlit, Ityp, Ind);
253
254 -- If the number of literals is not greater than Threshold, then we are
255 -- done. Otherwise we generate a (perfect) hash function for use by the
256 -- Value attribute.
257
258 if Nlit > Threshold then
259 -- We start to count serial numbers from here
260
261 S_N := Increment_Serial_Number;
262
263 -- Generate specification of hash function
264
265 H_Id :=
266 Make_Defining_Identifier (Loc,
267 Chars => New_External_Name (Chars (E), 'H'));
268 Mutate_Ekind (H_Id, E_Function);
269 Set_Is_Internal (H_Id);
270
271 if not Debug_Generated_Code then
272 Set_Debug_Info_Off (H_Id);
273 end if;
274
275 Set_Lit_Hash (E, H_Id);
276
277 S_Id := Make_Temporary (Loc, 'S');
278
279 H_Sp := Make_Function_Specification (Loc,
280 Defining_Unit_Name => H_Id,
281 Parameter_Specifications => New_List (
282 Make_Parameter_Specification (Loc,
283 Defining_Identifier => S_Id,
284 Parameter_Type =>
285 New_Occurrence_Of (Standard_String, Loc))),
286 Result_Definition =>
287 New_Occurrence_Of (Standard_Natural, Loc));
288
289 -- If the unit where the type is declared is the main unit, and the
290 -- number of literals is greater than Threshold_For_Size when we are
291 -- optimizing for size, and the restriction No_Implicit_Loops is not
292 -- active, and -gnatd_h is not specified, and not GNAT_Mode, generate
293 -- the hash function.
294
295 if In_Main_Unit
296 and then (Optimize_Size = 0 or else Nlit > Threshold_For_Size)
297 and then not Restriction_Active (No_Implicit_Loops)
298 and then not Debug_Flag_Underscore_H
299 and then not GNAT_Mode
300 then
301 declare
302 LB : constant Positive := 2 * Positive (Nlit) + 1;
303 UB : constant Positive := LB + 24;
304
305 begin
306 -- Try at most 25 * 4 times to compute the hash function before
307 -- giving up and using a linear search for the Value attribute.
308
309 for V in LB .. UB loop
310 begin
311 SPHG.Initialize (4321, V, SPHG.Memory_Space, Tries => 4);
312 SPHG.Compute ("");
313 H_OK := True;
314 exit;
315 exception
316 when SPHG.Too_Many_Tries => null;
317 end;
318 end loop;
319 end;
320 end if;
321
322 -- If the hash function has been successfully computed, 4 more tables
323 -- named P, T1, T2 and G are needed. The hash function is of the form
324
325 -- function Hash (S : String) return Natural is
326 -- xxxP : constant array (0 .. X) of Natural = [...];
327 -- xxxT1 : constant array (0 .. Y) of Index_Type = [...];
328 -- xxxT2 : constant array (0 .. Y) of Index_Type = [...];
329 -- xxxG : constant array (0 .. Z) of Index_Type = [...];
330
331 -- F : constant Natural := S'First - 1;
332 -- L : constant Natural := S'Length;
333 -- A, B : Natural := 0;
334 -- J : Natural;
335
336 -- begin
337 -- for K in P'Range loop
338 -- exit when L < P (K);
339 -- J := Character'Pos (S (P (K) + F));
340 -- A := (A + Natural (T1 (K) * J)) mod N;
341 -- B := (B + Natural (T2 (K) * J)) mod N;
342 -- end loop;
343
344 -- return (Natural (G (A)) + Natural (G (B))) mod M;
345 -- end Hash;
346
347 -- where N is the length of G and M the number of literals. Note that
348 -- we declare the tables inside the function for two reasons: first,
349 -- their analysis creates array subtypes and thus their concatenation
350 -- operators which are homonyms of the concatenation operator and may
351 -- change the homonym number of user operators declared in the scope;
352 -- second, the code generator can fold the values in the tables when
353 -- they are small and avoid emitting them in the final object code.
354
355 if H_OK then
356 declare
357 Siz, L1, L2 : Natural;
358 I : Int;
359
360 Pos, T1, T2, G : List_Id;
361 EPos, ET1, ET2, EG : Entity_Id;
362
363 F, L, A, B, J, K : Entity_Id;
364 Body_Decls : List_Id;
365 Body_Stmts : List_Id;
366 Loop_Stmts : List_Id;
367
368 begin
369 Body_Decls := New_List;
370
371 -- Generate position table
372
373 SPHG.Define (SPHG.Character_Position, Siz, L1, L2);
374 Pos := New_List;
375 for J in 0 .. L1 - 1 loop
376 I := Int (SPHG.Value (SPHG.Character_Position, J));
377 Append_To (Pos, Make_Integer_Literal (Loc, UI_From_Int (I)));
378 end loop;
379
380 EPos :=
381 Make_Defining_Identifier (Loc,
382 Chars => New_External_Name (Chars (E), 'P'));
383
384 Append_Table_To
385 (Body_Decls, EPos, Nat (L1 - 1), Standard_Natural, Pos);
386
387 -- Generate function table 1
388
389 SPHG.Define (SPHG.Function_Table_1, Siz, L1, L2);
390 T1 := New_List;
391 for J in 0 .. L1 - 1 loop
392 I := Int (SPHG.Value (SPHG.Function_Table_1, J));
393 Append_To (T1, Make_Integer_Literal (Loc, UI_From_Int (I)));
394 end loop;
395
396 ET1 :=
397 Make_Defining_Identifier (Loc,
398 Chars => New_External_Name (Chars (E), "T1"));
399
400 Ityp :=
401 Small_Integer_Type_For (UI_From_Int (Int (Siz)), Uns => True);
402 Append_Table_To (Body_Decls, ET1, Nat (L1 - 1), Ityp, T1);
403
404 -- Generate function table 2
405
406 SPHG.Define (SPHG.Function_Table_2, Siz, L1, L2);
407 T2 := New_List;
408 for J in 0 .. L1 - 1 loop
409 I := Int (SPHG.Value (SPHG.Function_Table_2, J));
410 Append_To (T2, Make_Integer_Literal (Loc, UI_From_Int (I)));
411 end loop;
412
413 ET2 :=
414 Make_Defining_Identifier (Loc,
415 Chars => New_External_Name (Chars (E), "T2"));
416
417 Ityp :=
418 Small_Integer_Type_For (UI_From_Int (Int (Siz)), Uns => True);
419 Append_Table_To (Body_Decls, ET2, Nat (L1 - 1), Ityp, T2);
420
421 -- Generate graph table
422
423 SPHG.Define (SPHG.Graph_Table, Siz, L1, L2);
424 G := New_List;
425 for J in 0 .. L1 - 1 loop
426 I := Int (SPHG.Value (SPHG.Graph_Table, J));
427 Append_To (G, Make_Integer_Literal (Loc, UI_From_Int (I)));
428 end loop;
429
430 EG :=
431 Make_Defining_Identifier (Loc,
432 Chars => New_External_Name (Chars (E), 'G'));
433
434 Ityp :=
435 Small_Integer_Type_For (UI_From_Int (Int (Siz)), Uns => True);
436 Append_Table_To (Body_Decls, EG, Nat (L1 - 1), Ityp, G);
437
438 F := Make_Temporary (Loc, 'F');
439
440 Append_To (Body_Decls,
441 Make_Object_Declaration (Loc,
442 Defining_Identifier => F,
443 Object_Definition =>
444 New_Occurrence_Of (Standard_Natural, Loc),
445 Expression =>
446 Make_Op_Subtract (Loc,
447 Left_Opnd =>
448 Make_Attribute_Reference (Loc,
449 Prefix => New_Occurrence_Of (S_Id, Loc),
450 Attribute_Name => Name_First),
451 Right_Opnd =>
452 Make_Integer_Literal (Loc, 1))));
453
454 L := Make_Temporary (Loc, 'L');
455
456 Append_To (Body_Decls,
457 Make_Object_Declaration (Loc,
458 Defining_Identifier => L,
459 Object_Definition =>
460 New_Occurrence_Of (Standard_Natural, Loc),
461 Expression =>
462 Make_Attribute_Reference (Loc,
463 Prefix => New_Occurrence_Of (S_Id, Loc),
464 Attribute_Name => Name_Length)));
465
466 A := Make_Temporary (Loc, 'A');
467
468 Append_To (Body_Decls,
469 Make_Object_Declaration (Loc,
470 Defining_Identifier => A,
471 Object_Definition =>
472 New_Occurrence_Of (Standard_Natural, Loc),
473 Expression => Make_Integer_Literal (Loc, 0)));
474
475 B := Make_Temporary (Loc, 'B');
476
477 Append_To (Body_Decls,
478 Make_Object_Declaration (Loc,
479 Defining_Identifier => B,
480 Object_Definition =>
481 New_Occurrence_Of (Standard_Natural, Loc),
482 Expression => Make_Integer_Literal (Loc, 0)));
483
484 J := Make_Temporary (Loc, 'J');
485
486 Append_To (Body_Decls,
487 Make_Object_Declaration (Loc,
488 Defining_Identifier => J,
489 Object_Definition =>
490 New_Occurrence_Of (Standard_Natural, Loc)));
491
492 K := Make_Temporary (Loc, 'K');
493
494 -- Generate exit when L < P (K);
495
496 Loop_Stmts := New_List (
497 Make_Exit_Statement (Loc,
498 Condition =>
499 Make_Op_Lt (Loc,
500 Left_Opnd => New_Occurrence_Of (L, Loc),
501 Right_Opnd =>
502 Make_Indexed_Component (Loc,
503 Prefix => New_Occurrence_Of (EPos, Loc),
504 Expressions => New_List (
505 New_Occurrence_Of (K, Loc))))));
506
507 -- Generate J := Character'Pos (S (P (K) + F));
508
509 Append_To (Loop_Stmts,
510 Make_Assignment_Statement (Loc,
511 Name => New_Occurrence_Of (J, Loc),
512 Expression =>
513 Make_Attribute_Reference (Loc,
514 Prefix =>
515 New_Occurrence_Of (Standard_Character, Loc),
516 Attribute_Name => Name_Pos,
517 Expressions => New_List (
518 Make_Indexed_Component (Loc,
519 Prefix => New_Occurrence_Of (S_Id, Loc),
520 Expressions => New_List (
521 Make_Op_Add (Loc,
522 Left_Opnd =>
523 Make_Indexed_Component (Loc,
524 Prefix =>
525 New_Occurrence_Of (EPos, Loc),
526 Expressions => New_List (
527 New_Occurrence_Of (K, Loc))),
528 Right_Opnd =>
529 New_Occurrence_Of (F, Loc))))))));
530
531 -- Generate A := (A + Natural (T1 (K) * J)) mod N;
532
533 Append_To (Loop_Stmts,
534 Make_Assignment_Statement (Loc,
535 Name => New_Occurrence_Of (A, Loc),
536 Expression =>
537 Make_Op_Mod (Loc,
538 Left_Opnd =>
539 Make_Op_Add (Loc,
540 Left_Opnd => New_Occurrence_Of (A, Loc),
541 Right_Opnd =>
542 Make_Op_Multiply (Loc,
543 Left_Opnd =>
544 Convert_To (Standard_Natural,
545 Make_Indexed_Component (Loc,
546 Prefix =>
547 New_Occurrence_Of (ET1, Loc),
548 Expressions => New_List (
549 New_Occurrence_Of (K, Loc)))),
550 Right_Opnd => New_Occurrence_Of (J, Loc))),
551 Right_Opnd => Make_Integer_Literal (Loc, Int (L1)))));
552
553 -- Generate B := (B + Natural (T2 (K) * J)) mod N;
554
555 Append_To (Loop_Stmts,
556 Make_Assignment_Statement (Loc,
557 Name => New_Occurrence_Of (B, Loc),
558 Expression =>
559 Make_Op_Mod (Loc,
560 Left_Opnd =>
561 Make_Op_Add (Loc,
562 Left_Opnd => New_Occurrence_Of (B, Loc),
563 Right_Opnd =>
564 Make_Op_Multiply (Loc,
565 Left_Opnd =>
566 Convert_To (Standard_Natural,
567 Make_Indexed_Component (Loc,
568 Prefix =>
569 New_Occurrence_Of (ET2, Loc),
570 Expressions => New_List (
571 New_Occurrence_Of (K, Loc)))),
572 Right_Opnd => New_Occurrence_Of (J, Loc))),
573 Right_Opnd => Make_Integer_Literal (Loc, Int (L1)))));
574
575 -- Generate loop
576
577 Body_Stmts := New_List (
578 Make_Implicit_Loop_Statement (N,
579 Iteration_Scheme =>
580 Make_Iteration_Scheme (Loc,
581 Loop_Parameter_Specification =>
582 Make_Loop_Parameter_Specification (Loc,
583 Defining_Identifier => K,
584 Discrete_Subtype_Definition =>
585 Make_Attribute_Reference (Loc,
586 Prefix =>
587 New_Occurrence_Of (EPos, Loc),
588 Attribute_Name => Name_Range))),
589 Statements => Loop_Stmts));
590
591 -- Generate return (Natural (G (A)) + Natural (G (B))) mod M;
592
593 Append_To (Body_Stmts,
594 Make_Simple_Return_Statement (Loc,
595 Expression =>
596 Make_Op_Mod (Loc,
597 Left_Opnd =>
598 Make_Op_Add (Loc,
599 Left_Opnd =>
600 Convert_To (Standard_Natural,
601 Make_Indexed_Component (Loc,
602 Prefix =>
603 New_Occurrence_Of (EG, Loc),
604 Expressions => New_List (
605 New_Occurrence_Of (A, Loc)))),
606 Right_Opnd =>
607 Convert_To (Standard_Natural,
608 Make_Indexed_Component (Loc,
609 Prefix =>
610 New_Occurrence_Of (EG, Loc),
611 Expressions => New_List (
612 New_Occurrence_Of (B, Loc))))),
613 Right_Opnd => Make_Integer_Literal (Loc, Nlit))));
614
615 -- Generate final body
616
617 Append_To (Act,
618 Make_Subprogram_Body (Loc,
619 Specification => H_Sp,
620 Declarations => Body_Decls,
621 Handled_Statement_Sequence =>
622 Make_Handled_Sequence_Of_Statements (Loc, Body_Stmts)));
623 end;
624
625 -- If we chose not to or did not manage to compute the hash function,
626 -- we need to build a dummy function always returning Natural'Last
627 -- because other units reference it if they use the Value attribute.
628
629 elsif In_Main_Unit then
630 declare
631 Body_Stmts : List_Id;
632
633 begin
634 -- Generate return Natural'Last
635
636 Body_Stmts := New_List (
637 Make_Simple_Return_Statement (Loc,
638 Expression =>
639 Make_Attribute_Reference (Loc,
640 Prefix =>
641 New_Occurrence_Of (Standard_Natural, Loc),
642 Attribute_Name => Name_Last)));
643
644 -- Generate body
645
646 Append_To (Act,
647 Make_Subprogram_Body (Loc,
648 Specification => H_Sp,
649 Declarations => Empty_List,
650 Handled_Statement_Sequence =>
651 Make_Handled_Sequence_Of_Statements (Loc, Body_Stmts)));
652 end;
653
654 -- For the other units, just declare the function
655
656 else
657 Append_To (Act,
658 Make_Subprogram_Declaration (Loc, Specification => H_Sp));
659 end if;
660
661 else
662 Set_Lit_Hash (E, Empty);
663 end if;
664
665 if In_Main_Unit then
666 System.Perfect_Hash_Generators.Finalize;
667 end if;
668
669 Insert_Actions (N, Act, Suppress => All_Checks);
670
671 -- This is where we check that our budget of serial numbers has been
672 -- entirely spent, see the declaration of Serial_Number_Budget above.
673
674 if Nlit > Threshold then
675 Synchronize_Serial_Number (S_N + Serial_Number_Budget);
676 end if;
677
678 -- Reset the scalar storage order to the saved value
679
680 Opt.Default_SSO := Saved_SSO;
681 end Build_Enumeration_Image_Tables;
682
683 ----------------------------
684 -- Expand_Image_Attribute --
685 ----------------------------
686
687 -- For all cases other than user-defined enumeration types, the scheme
688 -- is as follows. First we insert the following code:
689
690 -- Snn : String (1 .. rt'Width);
691 -- Pnn : Natural;
692 -- Image_xx (tv, Snn, Pnn [,pm]);
693 --
694 -- and then Expr is replaced by Snn (1 .. Pnn)
695
696 -- In the above expansion:
697
698 -- rt is the root type of the expression
699 -- tv is the expression with the value, usually a type conversion
700 -- pm is an extra parameter present in some cases
701
702 -- The following table shows tv, xx, and (if used) pm for the various
703 -- possible types of the argument:
704
705 -- For types whose root type is Character
706 -- xx = Character
707 -- tv = Character (Expr)
708
709 -- For types whose root type is Boolean
710 -- xx = Boolean
711 -- tv = Boolean (Expr)
712
713 -- For signed integer types
714 -- xx = [Long_Long_[Long_]]Integer
715 -- tv = [Long_Long_[Long_]]Integer (Expr)
716
717 -- For modular types
718 -- xx = [Long_Long_[Long_]]Unsigned
719 -- tv = System.Unsigned_Types.[Long_Long_[Long_]]Unsigned (Expr)
720
721 -- For types whose root type is Wide_Character
722 -- xx = Wide_Character
723 -- tv = Wide_Character (Expr)
724 -- pm = Boolean, true if Ada 2005 mode, False otherwise
725
726 -- For types whose root type is Wide_Wide_Character
727 -- xx = Wide_Wide_Character
728 -- tv = Wide_Wide_Character (Expr)
729
730 -- For floating-point types
731 -- xx = Floating_Point
732 -- tv = [Long_[Long_]]Float (Expr)
733 -- pm = typ'Digits (typ = subtype of expression)
734
735 -- For decimal fixed-point types
736 -- xx = Decimal{32,64,128}
737 -- tv = Integer_{32,64,128} (Expr)? [convert with no scaling]
738 -- pm = typ'Scale (typ = subtype of expression)
739
740 -- For the most common ordinary fixed-point types
741 -- xx = Fixed{32,64,128}
742 -- tv = Integer_{32,64,128} (Expr) [convert with no scaling]
743 -- pm = numerator of typ'Small (typ = subtype of expression)
744 -- denominator of typ'Small
745 -- (Integer_{32,64,128} x typ'Small)'Fore
746 -- typ'Aft
747
748 -- For other ordinary fixed-point types
749 -- xx = Fixed
750 -- tv = Long_Float (Expr)
751 -- pm = typ'Aft (typ = subtype of expression)
752
753 -- For enumeration types other than those declared in package Standard
754 -- or System, Snn, Pnn, are expanded as above, but the call looks like:
755
756 -- Image_Enumeration_NN (rt'Pos (X), Snn, Pnn, typS, typI'Address)
757
758 -- where rt is the root type of the expression, and typS and typI are
759 -- the entities constructed as described in the spec for the procedure
760 -- Build_Enumeration_Image_Tables and NN is 32/16/8 depending on the
761 -- element type of Lit_Indexes. The rewriting of the expression to
762 -- Snn (1 .. Pnn) then occurs as in the other cases. A special case is
763 -- when pragma Discard_Names applies, in which case we replace expr by:
764
765 -- (rt'Pos (expr))'Img
766
767 -- So that the result is a space followed by the decimal value for the
768 -- position of the enumeration value in the enumeration type.
769
770 procedure Expand_Image_Attribute (N : Node_Id) is
771 Loc : constant Source_Ptr := Sloc (N);
772 Exprs : constant List_Id := Expressions (N);
773 Expr : constant Node_Id := Relocate_Node (First (Exprs));
774 Pref : constant Node_Id := Prefix (N);
775
776 procedure Expand_Standard_Boolean_Image;
777 -- Expand attribute 'Image in Standard.Boolean, avoiding string copy
778
779 procedure Expand_User_Defined_Enumeration_Image (Typ : Entity_Id);
780 -- Expand attribute 'Image in user-defined enumeration types, avoiding
781 -- string copy.
782
783 -----------------------------------
784 -- Expand_Standard_Boolean_Image --
785 -----------------------------------
786
787 procedure Expand_Standard_Boolean_Image is
788 Ins_List : constant List_Id := New_List;
789 S1_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
790 T_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
791 F_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
792 V_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
793
794 begin
795 -- We use a single 5-character string subtype throughout so that the
796 -- subtype of the string if-expression is constrained and, therefore,
797 -- does not force the creation of a temporary during analysis.
798
799 -- Generate:
800 -- subtype S1 is String (1 .. 5);
801
802 Append_To (Ins_List,
803 Make_Subtype_Declaration (Loc,
804 Defining_Identifier => S1_Id,
805 Subtype_Indication =>
806 Make_Subtype_Indication (Loc,
807 Subtype_Mark =>
808 New_Occurrence_Of (Standard_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 => Make_Integer_Literal (Loc, 5)))))));
815
816 -- Generate:
817 -- T : constant String (1 .. 5) := "TRUE ";
818
819 Start_String;
820 Store_String_Chars ("TRUE ");
821
822 Append_To (Ins_List,
823 Make_Object_Declaration (Loc,
824 Defining_Identifier => T_Id,
825 Object_Definition =>
826 New_Occurrence_Of (S1_Id, Loc),
827 Constant_Present => True,
828 Expression => Make_String_Literal (Loc, End_String)));
829
830 -- Generate:
831 -- F : constant String (1 .. 5) := "FALSE";
832
833 Start_String;
834 Store_String_Chars ("FALSE");
835
836 Append_To (Ins_List,
837 Make_Object_Declaration (Loc,
838 Defining_Identifier => F_Id,
839 Object_Definition =>
840 New_Occurrence_Of (S1_Id, Loc),
841 Constant_Present => True,
842 Expression => Make_String_Literal (Loc, End_String)));
843
844 -- Generate:
845 -- V : String (1 .. 5) renames (if Expr then T else F);
846
847 Append_To (Ins_List,
848 Make_Object_Renaming_Declaration (Loc,
849 Defining_Identifier => V_Id,
850 Subtype_Mark =>
851 New_Occurrence_Of (S1_Id, Loc),
852 Name =>
853 Make_If_Expression (Loc,
854 Expressions => New_List (
855 Duplicate_Subexpr (Expr),
856 New_Occurrence_Of (T_Id, Loc),
857 New_Occurrence_Of (F_Id, Loc)))));
858
859 -- Insert all the above declarations before N. We suppress checks
860 -- because everything is in range at this stage.
861
862 Insert_Actions (N, Ins_List, Suppress => All_Checks);
863
864 -- Final step is to rewrite the expression as a slice:
865 -- V (1 .. (if Expr then 4 else 5)) and analyze, again with no
866 -- checks, since we are sure that everything is OK.
867
868 Rewrite (N,
869 Make_Slice (Loc,
870 Prefix => New_Occurrence_Of (V_Id, Loc),
871 Discrete_Range =>
872 Make_Range (Loc,
873 Low_Bound => Make_Integer_Literal (Loc, 1),
874 High_Bound =>
875 Make_If_Expression (Loc,
876 Expressions => New_List (
877 Duplicate_Subexpr (Expr),
878 Make_Integer_Literal (Loc, 4),
879 Make_Integer_Literal (Loc, 5))))));
880
881 Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks);
882 end Expand_Standard_Boolean_Image;
883
884 -------------------------------------------
885 -- Expand_User_Defined_Enumeration_Image --
886 -------------------------------------------
887
888 procedure Expand_User_Defined_Enumeration_Image (Typ : Entity_Id) is
889 Ins_List : constant List_Id := New_List;
890 P1_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
891 P2_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
892 P3_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
893 P4_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
894 S1_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
895
896 begin
897 -- Apply a validity check, since it is a bit drastic to get a
898 -- completely junk image value for an invalid value.
899
900 if not Expr_Known_Valid (Expr) then
901 Insert_Valid_Check (Expr);
902 end if;
903
904 -- Generate:
905 -- P1 : constant Natural := Typ'Pos (Typ?(Expr));
906
907 Append_To (Ins_List,
908 Make_Object_Declaration (Loc,
909 Defining_Identifier => P1_Id,
910 Object_Definition =>
911 New_Occurrence_Of (Standard_Natural, Loc),
912 Constant_Present => True,
913 Expression =>
914 Convert_To (Standard_Natural,
915 Make_Attribute_Reference (Loc,
916 Attribute_Name => Name_Pos,
917 Prefix => New_Occurrence_Of (Typ, Loc),
918 Expressions => New_List (OK_Convert_To (Typ, Expr))))));
919
920 -- Compute the index of the string start, generating:
921 -- P2 : constant Natural := call_put_enumN (P1);
922
923 Append_To (Ins_List,
924 Make_Object_Declaration (Loc,
925 Defining_Identifier => P2_Id,
926 Object_Definition =>
927 New_Occurrence_Of (Standard_Natural, Loc),
928 Constant_Present => True,
929 Expression =>
930 Convert_To (Standard_Natural,
931 Make_Indexed_Component (Loc,
932 Prefix =>
933 New_Occurrence_Of (Lit_Indexes (Typ), Loc),
934 Expressions =>
935 New_List (New_Occurrence_Of (P1_Id, Loc))))));
936
937 -- Compute the index of the next value, generating:
938 -- P3 : constant Natural := call_put_enumN (P1 + 1);
939
940 declare
941 Add_Node : constant Node_Id := New_Op_Node (N_Op_Add, Loc);
942
943 begin
944 Set_Left_Opnd (Add_Node, New_Occurrence_Of (P1_Id, Loc));
945 Set_Right_Opnd (Add_Node, Make_Integer_Literal (Loc, 1));
946
947 Append_To (Ins_List,
948 Make_Object_Declaration (Loc,
949 Defining_Identifier => P3_Id,
950 Object_Definition =>
951 New_Occurrence_Of (Standard_Natural, Loc),
952 Constant_Present => True,
953 Expression =>
954 Convert_To (Standard_Natural,
955 Make_Indexed_Component (Loc,
956 Prefix =>
957 New_Occurrence_Of (Lit_Indexes (Typ), Loc),
958 Expressions =>
959 New_List (Add_Node)))));
960 end;
961
962 -- Generate:
963 -- P4 : String renames call_put_enumS (P2 .. P3 - 1);
964
965 declare
966 Sub_Node : constant Node_Id := New_Op_Node (N_Op_Subtract, Loc);
967
968 begin
969 Set_Left_Opnd (Sub_Node, New_Occurrence_Of (P3_Id, Loc));
970 Set_Right_Opnd (Sub_Node, Make_Integer_Literal (Loc, 1));
971
972 Append_To (Ins_List,
973 Make_Object_Renaming_Declaration (Loc,
974 Defining_Identifier => P4_Id,
975 Subtype_Mark =>
976 New_Occurrence_Of (Standard_String, Loc),
977 Name =>
978 Make_Slice (Loc,
979 Prefix =>
980 New_Occurrence_Of (Lit_Strings (Typ), Loc),
981 Discrete_Range =>
982 Make_Range (Loc,
983 Low_Bound => New_Occurrence_Of (P2_Id, Loc),
984 High_Bound => Sub_Node))));
985 end;
986
987 -- Generate:
988 -- subtype S1 is String (1 .. P3 - P2);
989
990 declare
991 HB : constant Node_Id := New_Op_Node (N_Op_Subtract, Loc);
992
993 begin
994 Set_Left_Opnd (HB, New_Occurrence_Of (P3_Id, Loc));
995 Set_Right_Opnd (HB, New_Occurrence_Of (P2_Id, Loc));
996
997 Append_To (Ins_List,
998 Make_Subtype_Declaration (Loc,
999 Defining_Identifier => S1_Id,
1000 Subtype_Indication =>
1001 Make_Subtype_Indication (Loc,
1002 Subtype_Mark =>
1003 New_Occurrence_Of (Standard_String, Loc),
1004 Constraint =>
1005 Make_Index_Or_Discriminant_Constraint (Loc,
1006 Constraints => New_List (
1007 Make_Range (Loc,
1008 Low_Bound => Make_Integer_Literal (Loc, 1),
1009 High_Bound => HB))))));
1010 end;
1011
1012 -- Insert all the above declarations before N. We suppress checks
1013 -- because everything is in range at this stage.
1014
1015 Insert_Actions (N, Ins_List, Suppress => All_Checks);
1016
1017 Rewrite (N,
1018 Unchecked_Convert_To (S1_Id, New_Occurrence_Of (P4_Id, Loc)));
1019
1020 Analyze_And_Resolve (N, Standard_String);
1021 end Expand_User_Defined_Enumeration_Image;
1022
1023 -- Local variables
1024
1025 Enum_Case : Boolean;
1026 Imid : RE_Id;
1027 Proc_Ent : Entity_Id;
1028 Ptyp : Entity_Id;
1029 Rtyp : Entity_Id;
1030 Tent : Entity_Id := Empty;
1031 Ttyp : Entity_Id;
1032
1033 Arg_List : List_Id;
1034 -- List of arguments for run-time procedure call
1035
1036 Ins_List : List_Id;
1037 -- List of actions to be inserted
1038
1039 Snn : constant Entity_Id := Make_Temporary (Loc, 'S');
1040 Pnn : constant Entity_Id := Make_Temporary (Loc, 'P');
1041
1042 -- Start of processing for Expand_Image_Attribute
1043
1044 begin
1045 if Is_Object_Image (Pref) then
1046 Rewrite_Object_Image (N, Pref, Name_Image, Standard_String);
1047 return;
1048 end if;
1049
1050 -- If Image should be transformed using Put_Image, then do so. See
1051 -- Exp_Put_Image for details.
1052
1053 if Exp_Put_Image.Image_Should_Call_Put_Image (N) then
1054 Rewrite (N, Exp_Put_Image.Build_Image_Call (N));
1055 Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks);
1056 return;
1057 end if;
1058
1059 Ptyp := Underlying_Type (Entity (Pref));
1060
1061 -- Ada 2022 allows 'Image on private types, so fetch the underlying
1062 -- type to obtain the structure of the type. We use the base type,
1063 -- not the root type for discrete types, to handle properly derived
1064 -- types, but we use the root type for enumeration types, because the
1065 -- literal map is attached to the root. Should be inherited ???
1066
1067 if Is_Real_Type (Ptyp) or else Is_Enumeration_Type (Ptyp) then
1068 Rtyp := Underlying_Type (Root_Type (Ptyp));
1069 else
1070 Rtyp := Underlying_Type (Base_Type (Ptyp));
1071 end if;
1072
1073 -- Set Imid (RE_Id of procedure to call), and Tent, target for the
1074 -- type conversion of the first argument for all possibilities.
1075
1076 Enum_Case := False;
1077
1078 if Rtyp = Standard_Boolean then
1079 -- Use inline expansion if the -gnatd_x switch is not passed to the
1080 -- compiler. Otherwise expand into a call to the runtime.
1081
1082 if not Debug_Flag_Underscore_X then
1083 Expand_Standard_Boolean_Image;
1084 return;
1085
1086 else
1087 Imid := RE_Image_Boolean;
1088 Tent := Rtyp;
1089 end if;
1090
1091 -- For standard character, we have to select the version which handles
1092 -- soft hyphen correctly, based on the version of Ada in use (this is
1093 -- ugly, but we have no choice).
1094
1095 elsif Rtyp = Standard_Character then
1096 if Ada_Version < Ada_2005 then
1097 Imid := RE_Image_Character;
1098 else
1099 Imid := RE_Image_Character_05;
1100 end if;
1101
1102 Tent := Rtyp;
1103
1104 elsif Rtyp = Standard_Wide_Character then
1105 Imid := RE_Image_Wide_Character;
1106 Tent := Rtyp;
1107
1108 elsif Rtyp = Standard_Wide_Wide_Character then
1109 Imid := RE_Image_Wide_Wide_Character;
1110 Tent := Rtyp;
1111
1112 elsif Is_Signed_Integer_Type (Rtyp) then
1113 if Esize (Rtyp) <= Standard_Integer_Size then
1114 Imid := RE_Image_Integer;
1115 Tent := Standard_Integer;
1116 elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then
1117 Imid := RE_Image_Long_Long_Integer;
1118 Tent := Standard_Long_Long_Integer;
1119 else
1120 Imid := RE_Image_Long_Long_Long_Integer;
1121 Tent := Standard_Long_Long_Long_Integer;
1122 end if;
1123
1124 elsif Is_Modular_Integer_Type (Rtyp) then
1125 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
1126 Imid := RE_Image_Unsigned;
1127 Tent := RTE (RE_Unsigned);
1128 elsif Modulus (Rtyp) <= Modulus (RTE (RE_Long_Long_Unsigned)) then
1129 Imid := RE_Image_Long_Long_Unsigned;
1130 Tent := RTE (RE_Long_Long_Unsigned);
1131 else
1132 Imid := RE_Image_Long_Long_Long_Unsigned;
1133 Tent := RTE (RE_Long_Long_Long_Unsigned);
1134 end if;
1135
1136 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
1137 if Esize (Rtyp) <= 32 then
1138 Imid := RE_Image_Decimal32;
1139 Tent := RTE (RE_Integer_32);
1140 elsif Esize (Rtyp) <= 64 then
1141 Imid := RE_Image_Decimal64;
1142 Tent := RTE (RE_Integer_64);
1143 else
1144 Imid := RE_Image_Decimal128;
1145 Tent := RTE (RE_Integer_128);
1146 end if;
1147
1148 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
1149 declare
1150 Num : constant Uint := Norm_Num (Small_Value (Rtyp));
1151 Den : constant Uint := Norm_Den (Small_Value (Rtyp));
1152 Max : constant Uint := UI_Max (Num, Den);
1153 Min : constant Uint := UI_Min (Num, Den);
1154 Siz : constant Uint := Esize (Rtyp);
1155
1156 begin
1157 -- Note that we do not use sharp bounds to speed things up
1158
1159 if Siz <= 32
1160 and then Max <= Uint_2 ** 31
1161 and then (Min = Uint_1
1162 or else (Num < Den and then Den <= Uint_2 ** 27)
1163 or else (Den < Num and then Num <= Uint_2 ** 25))
1164 then
1165 Imid := RE_Image_Fixed32;
1166 Tent := RTE (RE_Integer_32);
1167 elsif Siz <= 64
1168 and then Max <= Uint_2 ** 63
1169 and then (Min = Uint_1
1170 or else (Num < Den and then Den <= Uint_2 ** 59)
1171 or else (Den < Num and then Num <= Uint_2 ** 53))
1172 then
1173 Imid := RE_Image_Fixed64;
1174 Tent := RTE (RE_Integer_64);
1175 elsif System_Max_Integer_Size = 128
1176 and then Max <= Uint_2 ** 127
1177 and then (Min = Uint_1
1178 or else (Num < Den and then Den <= Uint_2 ** 123)
1179 or else (Den < Num and then Num <= Uint_2 ** 122))
1180 then
1181 Imid := RE_Image_Fixed128;
1182 Tent := RTE (RE_Integer_128);
1183 else
1184 Imid := RE_Image_Fixed;
1185 Tent := Standard_Long_Float;
1186 end if;
1187 end;
1188
1189 elsif Is_Floating_Point_Type (Rtyp) then
1190 -- Short_Float and Float are the same type for GNAT
1191
1192 if Rtyp = Standard_Short_Float or else Rtyp = Standard_Float then
1193 Imid := RE_Image_Float;
1194 Tent := Standard_Float;
1195
1196 elsif Rtyp = Standard_Long_Float then
1197 Imid := RE_Image_Long_Float;
1198 Tent := Standard_Long_Float;
1199
1200 else
1201 Imid := RE_Image_Long_Long_Float;
1202 Tent := Standard_Long_Long_Float;
1203 end if;
1204
1205 -- Only other possibility is user-defined enumeration type
1206
1207 else
1208 pragma Assert (Is_Enumeration_Type (Rtyp));
1209
1210 if Discard_Names (First_Subtype (Ptyp))
1211 or else No (Lit_Strings (Rtyp))
1212 then
1213 -- When pragma Discard_Names applies to the first subtype, build
1214 -- (Long_Long_Integer (Pref'Pos (Expr)))'Img. The conversion is
1215 -- there to avoid applying 'Img directly in Universal_Integer,
1216 -- which can be a very large type. See also the handling of 'Val.
1217
1218 Rewrite (N,
1219 Make_Attribute_Reference (Loc,
1220 Prefix =>
1221 Convert_To (Standard_Long_Long_Integer,
1222 Make_Attribute_Reference (Loc,
1223 Prefix => Pref,
1224 Attribute_Name => Name_Pos,
1225 Expressions => New_List (Expr))),
1226 Attribute_Name =>
1227 Name_Img));
1228 Analyze_And_Resolve (N, Standard_String);
1229 return;
1230
1231 -- Use inline expansion if the -gnatd_x switch is not passed to the
1232 -- compiler. Otherwise expand into a call to the runtime.
1233
1234 elsif not Debug_Flag_Underscore_X then
1235 Expand_User_Defined_Enumeration_Image (Rtyp);
1236 return;
1237
1238 else
1239 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
1240
1241 if Ttyp = Standard_Integer_8 then
1242 Imid := RE_Image_Enumeration_8;
1243
1244 elsif Ttyp = Standard_Integer_16 then
1245 Imid := RE_Image_Enumeration_16;
1246
1247 else
1248 Imid := RE_Image_Enumeration_32;
1249 end if;
1250
1251 -- Apply a validity check, since it is a bit drastic to get a
1252 -- completely junk image value for an invalid value.
1253
1254 if not Expr_Known_Valid (Expr) then
1255 Insert_Valid_Check (Expr);
1256 end if;
1257
1258 Enum_Case := True;
1259 end if;
1260 end if;
1261
1262 -- Build first argument for call
1263
1264 if Enum_Case then
1265 Arg_List := New_List (
1266 Make_Attribute_Reference (Loc,
1267 Attribute_Name => Name_Pos,
1268 Prefix => New_Occurrence_Of (Ptyp, Loc),
1269 Expressions => New_List (Expr)));
1270
1271 -- AI12-0020: Ada 2022 allows 'Image for all types, including private
1272 -- types. If the full type is not a fixed-point type, then it is enough
1273 -- to set the Conversion_OK flag. However, that would not work for
1274 -- fixed-point types, because that flag changes the run-time semantics
1275 -- of fixed-point type conversions; therefore, we must first convert to
1276 -- Rtyp, and then to Tent.
1277
1278 else
1279 declare
1280 Conv : Node_Id;
1281
1282 begin
1283 if Is_Private_Type (Etype (Expr)) then
1284 if Is_Fixed_Point_Type (Rtyp) then
1285 Conv := Convert_To (Tent, OK_Convert_To (Rtyp, Expr));
1286 else
1287 Conv := OK_Convert_To (Tent, Expr);
1288 end if;
1289 else
1290 Conv := Convert_To (Tent, Expr);
1291 end if;
1292
1293 Arg_List := New_List (Conv);
1294 end;
1295 end if;
1296
1297 -- Build declarations of Snn and Pnn to be inserted
1298
1299 Ins_List := New_List (
1300
1301 -- Snn : String (1 .. typ'Width);
1302
1303 Make_Object_Declaration (Loc,
1304 Defining_Identifier => Snn,
1305 Object_Definition =>
1306 Make_Subtype_Indication (Loc,
1307 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
1308 Constraint =>
1309 Make_Index_Or_Discriminant_Constraint (Loc,
1310 Constraints => New_List (
1311 Make_Range (Loc,
1312 Low_Bound => Make_Integer_Literal (Loc, 1),
1313 High_Bound =>
1314 Make_Attribute_Reference (Loc,
1315 Prefix => New_Occurrence_Of (Rtyp, Loc),
1316 Attribute_Name => Name_Width)))))),
1317
1318 -- Pnn : Natural;
1319
1320 Make_Object_Declaration (Loc,
1321 Defining_Identifier => Pnn,
1322 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)));
1323
1324 -- Append Snn, Pnn arguments
1325
1326 Append_To (Arg_List, New_Occurrence_Of (Snn, Loc));
1327 Append_To (Arg_List, New_Occurrence_Of (Pnn, Loc));
1328
1329 -- Get entity of procedure to call
1330
1331 Proc_Ent := RTE (Imid);
1332
1333 -- If the procedure entity is empty, that means we have a case in
1334 -- no run time mode where the operation is not allowed, and an
1335 -- appropriate diagnostic has already been issued.
1336
1337 if No (Proc_Ent) then
1338 return;
1339 end if;
1340
1341 -- Otherwise complete preparation of arguments for run-time call
1342
1343 -- Add extra arguments for Enumeration case
1344
1345 if Enum_Case then
1346 Append_To (Arg_List, New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
1347 Append_To (Arg_List,
1348 Make_Attribute_Reference (Loc,
1349 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
1350 Attribute_Name => Name_Address));
1351
1352 -- For floating-point types, append Digits argument
1353
1354 elsif Is_Floating_Point_Type (Rtyp) then
1355 Append_To (Arg_List,
1356 Make_Attribute_Reference (Loc,
1357 Prefix => New_Occurrence_Of (Ptyp, Loc),
1358 Attribute_Name => Name_Digits));
1359
1360 -- For decimal, append Scale and also set to do literal conversion
1361
1362 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
1363 Set_Conversion_OK (First (Arg_List));
1364
1365 Append_To (Arg_List, Make_Integer_Literal (Loc, Scale_Value (Ptyp)));
1366
1367 -- For ordinary fixed-point types, append Num, Den, Fore, Aft parameters
1368 -- and also set to do literal conversion.
1369
1370 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
1371 if Imid /= RE_Image_Fixed then
1372 Set_Conversion_OK (First (Arg_List));
1373
1374 Append_To (Arg_List,
1375 Make_Integer_Literal (Loc, -Norm_Num (Small_Value (Ptyp))));
1376
1377 Append_To (Arg_List,
1378 Make_Integer_Literal (Loc, -Norm_Den (Small_Value (Ptyp))));
1379
1380 -- We want to compute the Fore value for the fixed point type
1381 -- whose mantissa type is Tent and whose small is typ'Small.
1382
1383 declare
1384 T : Ureal := Uint_2 ** (Esize (Tent) - 1) * Small_Value (Ptyp);
1385 F : Nat := 2;
1386
1387 begin
1388 while T >= Ureal_10 loop
1389 F := F + 1;
1390 T := T / Ureal_10;
1391 end loop;
1392
1393 Append_To (Arg_List,
1394 Make_Integer_Literal (Loc, UI_From_Int (F)));
1395 end;
1396 end if;
1397
1398 Append_To (Arg_List, Make_Integer_Literal (Loc, Aft_Value (Ptyp)));
1399
1400 -- For Wide_Character, append Ada 2005 indication
1401
1402 elsif Rtyp = Standard_Wide_Character then
1403 Append_To (Arg_List,
1404 New_Occurrence_Of
1405 (Boolean_Literals (Ada_Version >= Ada_2005), Loc));
1406 end if;
1407
1408 -- Now append the procedure call to the insert list
1409
1410 Append_To (Ins_List,
1411 Make_Procedure_Call_Statement (Loc,
1412 Name => New_Occurrence_Of (Proc_Ent, Loc),
1413 Parameter_Associations => Arg_List));
1414
1415 -- Insert declarations of Snn, Pnn, and the procedure call. We suppress
1416 -- checks because we are sure that everything is in range at this stage.
1417
1418 Insert_Actions (N, Ins_List, Suppress => All_Checks);
1419
1420 -- Final step is to rewrite the expression as a slice and analyze,
1421 -- again with no checks, since we are sure that everything is OK.
1422
1423 Rewrite (N,
1424 Make_Slice (Loc,
1425 Prefix => New_Occurrence_Of (Snn, Loc),
1426 Discrete_Range =>
1427 Make_Range (Loc,
1428 Low_Bound => Make_Integer_Literal (Loc, 1),
1429 High_Bound => New_Occurrence_Of (Pnn, Loc))));
1430
1431 Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks);
1432 end Expand_Image_Attribute;
1433
1434 ----------------------------------
1435 -- Expand_Valid_Value_Attribute --
1436 ----------------------------------
1437
1438 procedure Expand_Valid_Value_Attribute (N : Node_Id) is
1439 Loc : constant Source_Ptr := Sloc (N);
1440 Btyp : constant Entity_Id := Base_Type (Entity (Prefix (N)));
1441 Rtyp : constant Entity_Id := Root_Type (Btyp);
1442 pragma Assert (Is_Enumeration_Type (Rtyp));
1443
1444 Args : constant List_Id := Expressions (N);
1445 Func : RE_Id;
1446 Ttyp : Entity_Id;
1447
1448 begin
1449 -- Generate:
1450
1451 -- Valid_Value_Enumeration_NN
1452 -- (typS, typN'Address, typH'Unrestricted_Access, Num, X)
1453
1454 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
1455
1456 if Ttyp = Standard_Integer_8 then
1457 Func := RE_Valid_Value_Enumeration_8;
1458 elsif Ttyp = Standard_Integer_16 then
1459 Func := RE_Valid_Value_Enumeration_16;
1460 else
1461 Func := RE_Valid_Value_Enumeration_32;
1462 end if;
1463
1464 Prepend_To (Args,
1465 Make_Attribute_Reference (Loc,
1466 Prefix => New_Occurrence_Of (Rtyp, Loc),
1467 Attribute_Name => Name_Pos,
1468 Expressions => New_List (
1469 Make_Attribute_Reference (Loc,
1470 Prefix => New_Occurrence_Of (Rtyp, Loc),
1471 Attribute_Name => Name_Last))));
1472
1473 if Present (Lit_Hash (Rtyp)) then
1474 Prepend_To (Args,
1475 Make_Attribute_Reference (Loc,
1476 Prefix => New_Occurrence_Of (Lit_Hash (Rtyp), Loc),
1477 Attribute_Name => Name_Unrestricted_Access));
1478 else
1479 Prepend_To (Args, Make_Null (Loc));
1480 end if;
1481
1482 Prepend_To (Args,
1483 Make_Attribute_Reference (Loc,
1484 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
1485 Attribute_Name => Name_Address));
1486
1487 Prepend_To (Args,
1488 New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
1489
1490 Rewrite (N,
1491 Make_Function_Call (Loc,
1492 Name =>
1493 New_Occurrence_Of (RTE (Func), Loc),
1494 Parameter_Associations => Args));
1495
1496 Analyze_And_Resolve (N, Standard_Boolean);
1497 end Expand_Valid_Value_Attribute;
1498
1499 ----------------------------
1500 -- Expand_Value_Attribute --
1501 ----------------------------
1502
1503 -- For scalar types derived from Boolean, Character and integer types
1504 -- in package Standard, typ'Value (X) expands into:
1505
1506 -- btyp (Value_xx (X))
1507
1508 -- where btyp is the base type of the prefix
1509
1510 -- For types whose root type is Character
1511 -- xx = Character
1512
1513 -- For types whose root type is Wide_Character
1514 -- xx = Wide_Character
1515
1516 -- For types whose root type is Wide_Wide_Character
1517 -- xx = Wide_Wide_Character
1518
1519 -- For types whose root type is Boolean
1520 -- xx = Boolean
1521
1522 -- For signed integer types
1523 -- xx = [Long_Long_[Long_]]Integer
1524
1525 -- For modular types
1526 -- xx = [Long_Long_[Long_]]Unsigned
1527
1528 -- For floating-point types
1529 -- xx = [Long_[Long_]]Float
1530
1531 -- For decimal fixed-point types, typ'Value (X) expands into
1532
1533 -- btyp?(Value_Decimal{32,64,128} (X, typ'Scale));
1534
1535 -- For the most common ordinary fixed-point types, it expands into
1536
1537 -- btyp?(Value_Fixed{32,64,128} (X, numerator of S, denominator of S));
1538 -- where S = typ'Small
1539
1540 -- For other ordinary fixed-point types, it expands into
1541
1542 -- btyp (Value_Long_Float (X))
1543
1544 -- For Wide_[Wide_]Character types, typ'Value (X) expands into
1545
1546 -- btyp (Value_xx (X, EM))
1547
1548 -- where btyp is the base type of the prefix, and EM is the encoding method
1549
1550 -- For enumeration types other than those derived from types Boolean,
1551 -- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
1552
1553 -- Enum'Val
1554 -- (Value_Enumeration_NN
1555 -- (typS, typN'Address, typH'Unrestricted_Access, Num, X))
1556
1557 -- where typS, typN and typH are the Lit_Strings, Lit_Indexes and Lit_Hash
1558 -- entities from T's root type entity, and Num is Enum'Pos (Enum'Last).
1559 -- The Value_Enumeration_NN function will search the tables looking for
1560 -- X and return the position number in the table if found which is
1561 -- used to provide the result of 'Value (using Enum'Val). If the
1562 -- value is not found Constraint_Error is raised. The suffix _NN
1563 -- depends on the element type of typN.
1564
1565 procedure Expand_Value_Attribute (N : Node_Id) is
1566 Loc : constant Source_Ptr := Sloc (N);
1567 Btyp : constant Entity_Id := Etype (N);
1568 pragma Assert (Is_Base_Type (Btyp));
1569 pragma Assert (Btyp = Base_Type (Entity (Prefix (N))));
1570 Rtyp : constant Entity_Id := Root_Type (Btyp);
1571
1572 Args : constant List_Id := Expressions (N);
1573 Ttyp : Entity_Id;
1574 Vid : RE_Id;
1575
1576 begin
1577 -- Fall through for all cases except user-defined enumeration type
1578 -- and decimal types, with Vid set to the Id of the entity for the
1579 -- Value routine and Args set to the list of parameters for the call.
1580
1581 if Rtyp = Standard_Boolean then
1582 Vid := RE_Value_Boolean;
1583
1584 elsif Rtyp = Standard_Character then
1585 Vid := RE_Value_Character;
1586
1587 elsif Rtyp = Standard_Wide_Character then
1588 Vid := RE_Value_Wide_Character;
1589
1590 Append_To (Args,
1591 Make_Integer_Literal (Loc,
1592 Intval => Int (Wide_Character_Encoding_Method)));
1593
1594 elsif Rtyp = Standard_Wide_Wide_Character then
1595 Vid := RE_Value_Wide_Wide_Character;
1596
1597 Append_To (Args,
1598 Make_Integer_Literal (Loc,
1599 Intval => Int (Wide_Character_Encoding_Method)));
1600
1601 elsif Is_Signed_Integer_Type (Rtyp) then
1602 if Esize (Rtyp) <= Standard_Integer_Size then
1603 Vid := RE_Value_Integer;
1604 elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then
1605 Vid := RE_Value_Long_Long_Integer;
1606 else
1607 Vid := RE_Value_Long_Long_Long_Integer;
1608 end if;
1609
1610 elsif Is_Modular_Integer_Type (Rtyp) then
1611 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
1612 Vid := RE_Value_Unsigned;
1613 elsif Modulus (Rtyp) <= Modulus (RTE (RE_Long_Long_Unsigned)) then
1614 Vid := RE_Value_Long_Long_Unsigned;
1615 else
1616 Vid := RE_Value_Long_Long_Long_Unsigned;
1617 end if;
1618
1619 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
1620 if Esize (Rtyp) <= 32 and then abs (Scale_Value (Rtyp)) <= 9 then
1621 Vid := RE_Value_Decimal32;
1622 elsif Esize (Rtyp) <= 64 and then abs (Scale_Value (Rtyp)) <= 18 then
1623 Vid := RE_Value_Decimal64;
1624 else
1625 Vid := RE_Value_Decimal128;
1626 end if;
1627
1628 Append_To (Args, Make_Integer_Literal (Loc, Scale_Value (Rtyp)));
1629
1630 Rewrite (N,
1631 OK_Convert_To (Btyp,
1632 Make_Function_Call (Loc,
1633 Name => New_Occurrence_Of (RTE (Vid), Loc),
1634 Parameter_Associations => Args)));
1635
1636 Set_Etype (N, Btyp);
1637 Analyze_And_Resolve (N, Btyp);
1638 return;
1639
1640 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
1641 declare
1642 Num : constant Uint := Norm_Num (Small_Value (Rtyp));
1643 Den : constant Uint := Norm_Den (Small_Value (Rtyp));
1644 Max : constant Uint := UI_Max (Num, Den);
1645 Min : constant Uint := UI_Min (Num, Den);
1646 Siz : constant Uint := Esize (Rtyp);
1647
1648 begin
1649 if Siz <= 32
1650 and then Max <= Uint_2 ** 31
1651 and then (Min = Uint_1 or else Max <= Uint_2 ** 27)
1652 then
1653 Vid := RE_Value_Fixed32;
1654 elsif Siz <= 64
1655 and then Max <= Uint_2 ** 63
1656 and then (Min = Uint_1 or else Max <= Uint_2 ** 59)
1657 then
1658 Vid := RE_Value_Fixed64;
1659 elsif System_Max_Integer_Size = 128
1660 and then Max <= Uint_2 ** 127
1661 and then (Min = Uint_1 or else Max <= Uint_2 ** 123)
1662 then
1663 Vid := RE_Value_Fixed128;
1664 else
1665 Vid := RE_Value_Long_Float;
1666 end if;
1667
1668 if Vid /= RE_Value_Long_Float then
1669 Append_To (Args,
1670 Make_Integer_Literal (Loc, -Norm_Num (Small_Value (Rtyp))));
1671
1672 Append_To (Args,
1673 Make_Integer_Literal (Loc, -Norm_Den (Small_Value (Rtyp))));
1674
1675 Rewrite (N,
1676 OK_Convert_To (Btyp,
1677 Make_Function_Call (Loc,
1678 Name => New_Occurrence_Of (RTE (Vid), Loc),
1679 Parameter_Associations => Args)));
1680
1681 Set_Etype (N, Btyp);
1682 Analyze_And_Resolve (N, Btyp);
1683 return;
1684 end if;
1685 end;
1686
1687 elsif Is_Floating_Point_Type (Rtyp) then
1688 -- Short_Float and Float are the same type for GNAT
1689
1690 if Rtyp = Standard_Short_Float or else Rtyp = Standard_Float then
1691 Vid := RE_Value_Float;
1692
1693 elsif Rtyp = Standard_Long_Float then
1694 Vid := RE_Value_Long_Float;
1695
1696 else
1697 Vid := RE_Value_Long_Long_Float;
1698 end if;
1699
1700 -- Only other possibility is user-defined enumeration type
1701
1702 else
1703 pragma Assert (Is_Enumeration_Type (Rtyp));
1704
1705 -- Case of pragma Discard_Names, transform the Value
1706 -- attribute to Btyp'Val (Long_Long_Integer'Value (Args))
1707
1708 if Discard_Names (First_Subtype (Btyp))
1709 or else No (Lit_Strings (Rtyp))
1710 then
1711 Rewrite (N,
1712 Make_Attribute_Reference (Loc,
1713 Prefix => New_Occurrence_Of (Btyp, Loc),
1714 Attribute_Name => Name_Val,
1715 Expressions => New_List (
1716 Make_Attribute_Reference (Loc,
1717 Prefix =>
1718 New_Occurrence_Of (Standard_Long_Long_Integer, Loc),
1719 Attribute_Name => Name_Value,
1720 Expressions => Args))));
1721
1722 Analyze_And_Resolve (N, Btyp);
1723
1724 -- Normal case where we have enumeration tables, build
1725
1726 -- T'Val
1727 -- (Value_Enumeration_NN
1728 -- (typS, typN'Address, typH'Unrestricted_Access, Num, X))
1729
1730 else
1731 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
1732
1733 if Ttyp = Standard_Integer_8 then
1734 Vid := RE_Value_Enumeration_8;
1735 elsif Ttyp = Standard_Integer_16 then
1736 Vid := RE_Value_Enumeration_16;
1737 else
1738 Vid := RE_Value_Enumeration_32;
1739 end if;
1740
1741 Prepend_To (Args,
1742 Make_Attribute_Reference (Loc,
1743 Prefix => New_Occurrence_Of (Rtyp, Loc),
1744 Attribute_Name => Name_Pos,
1745 Expressions => New_List (
1746 Make_Attribute_Reference (Loc,
1747 Prefix => New_Occurrence_Of (Rtyp, Loc),
1748 Attribute_Name => Name_Last))));
1749
1750 if Present (Lit_Hash (Rtyp)) then
1751 Prepend_To (Args,
1752 Make_Attribute_Reference (Loc,
1753 Prefix => New_Occurrence_Of (Lit_Hash (Rtyp), Loc),
1754 Attribute_Name => Name_Unrestricted_Access));
1755 else
1756 Prepend_To (Args, Make_Null (Loc));
1757 end if;
1758
1759 Prepend_To (Args,
1760 Make_Attribute_Reference (Loc,
1761 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
1762 Attribute_Name => Name_Address));
1763
1764 Prepend_To (Args,
1765 New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
1766
1767 Rewrite (N,
1768 Make_Attribute_Reference (Loc,
1769 Prefix => New_Occurrence_Of (Btyp, Loc),
1770 Attribute_Name => Name_Val,
1771 Expressions => New_List (
1772 Make_Function_Call (Loc,
1773 Name =>
1774 New_Occurrence_Of (RTE (Vid), Loc),
1775 Parameter_Associations => Args))));
1776
1777 Analyze_And_Resolve (N, Btyp);
1778 end if;
1779
1780 return;
1781 end if;
1782
1783 -- Compiling package Ada.Tags under No_Run_Time_Mode we disable the
1784 -- expansion of the attribute into the function call statement to avoid
1785 -- generating spurious errors caused by the use of Integer_Address'Value
1786 -- in our implementation of Ada.Tags.Internal_Tag.
1787
1788 if No_Run_Time_Mode
1789 and then Is_RTE (Rtyp, RE_Integer_Address)
1790 and then RTU_Loaded (Ada_Tags)
1791 and then Cunit_Entity (Current_Sem_Unit)
1792 = Body_Entity (RTU_Entity (Ada_Tags))
1793 then
1794 Rewrite (N,
1795 Unchecked_Convert_To (Rtyp,
1796 Make_Integer_Literal (Loc, Uint_0)));
1797
1798 else
1799 Rewrite (N,
1800 Convert_To (Btyp,
1801 Make_Function_Call (Loc,
1802 Name => New_Occurrence_Of (RTE (Vid), Loc),
1803 Parameter_Associations => Args)));
1804 end if;
1805
1806 Analyze_And_Resolve (N, Btyp);
1807 end Expand_Value_Attribute;
1808
1809 ---------------------------------
1810 -- Expand_Wide_Image_Attribute --
1811 ---------------------------------
1812
1813 -- We expand typ'Wide_Image (X) as follows. First we insert this code:
1814
1815 -- Rnn : Wide_String (1 .. rt'Wide_Width);
1816 -- Lnn : Natural;
1817 -- String_To_Wide_String
1818 -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
1819
1820 -- where rt is the root type of the prefix type
1821
1822 -- Now we replace the Wide_Image reference by
1823
1824 -- Rnn (1 .. Lnn)
1825
1826 -- This works in all cases because String_To_Wide_String converts any
1827 -- wide character escape sequences resulting from the Image call to the
1828 -- proper Wide_Character equivalent
1829
1830 -- not quite right for typ = Wide_Character ???
1831
1832 procedure Expand_Wide_Image_Attribute (N : Node_Id) is
1833 Loc : constant Source_Ptr := Sloc (N);
1834 Pref : constant Entity_Id := Prefix (N);
1835 Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
1836 Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
1837 Rtyp : Entity_Id;
1838
1839 begin
1840 if Is_Object_Image (Pref) then
1841 Rewrite_Object_Image (N, Pref, Name_Wide_Image, Standard_Wide_String);
1842 return;
1843 end if;
1844
1845 Rtyp := Root_Type (Entity (Pref));
1846
1847 Insert_Actions (N, New_List (
1848
1849 -- Rnn : Wide_String (1 .. base_typ'Width);
1850
1851 Make_Object_Declaration (Loc,
1852 Defining_Identifier => Rnn,
1853 Object_Definition =>
1854 Make_Subtype_Indication (Loc,
1855 Subtype_Mark =>
1856 New_Occurrence_Of (Standard_Wide_String, Loc),
1857 Constraint =>
1858 Make_Index_Or_Discriminant_Constraint (Loc,
1859 Constraints => New_List (
1860 Make_Range (Loc,
1861 Low_Bound => Make_Integer_Literal (Loc, 1),
1862 High_Bound =>
1863 Make_Attribute_Reference (Loc,
1864 Prefix => New_Occurrence_Of (Rtyp, Loc),
1865 Attribute_Name => Name_Wide_Width)))))),
1866
1867 -- Lnn : Natural;
1868
1869 Make_Object_Declaration (Loc,
1870 Defining_Identifier => Lnn,
1871 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)),
1872
1873 -- String_To_Wide_String
1874 -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
1875
1876 Make_Procedure_Call_Statement (Loc,
1877 Name =>
1878 New_Occurrence_Of (RTE (RE_String_To_Wide_String), Loc),
1879
1880 Parameter_Associations => New_List (
1881 Make_Attribute_Reference (Loc,
1882 Prefix => Prefix (N),
1883 Attribute_Name => Name_Image,
1884 Expressions => Expressions (N)),
1885 New_Occurrence_Of (Rnn, Loc),
1886 New_Occurrence_Of (Lnn, Loc),
1887 Make_Integer_Literal (Loc,
1888 Intval => Int (Wide_Character_Encoding_Method))))),
1889
1890 -- Suppress checks because we know everything is properly in range
1891
1892 Suppress => All_Checks);
1893
1894 -- Final step is to rewrite the expression as a slice and analyze,
1895 -- again with no checks, since we are sure that everything is OK.
1896
1897 Rewrite (N,
1898 Make_Slice (Loc,
1899 Prefix => New_Occurrence_Of (Rnn, Loc),
1900 Discrete_Range =>
1901 Make_Range (Loc,
1902 Low_Bound => Make_Integer_Literal (Loc, 1),
1903 High_Bound => New_Occurrence_Of (Lnn, Loc))));
1904
1905 Analyze_And_Resolve (N, Standard_Wide_String, Suppress => All_Checks);
1906 end Expand_Wide_Image_Attribute;
1907
1908 --------------------------------------
1909 -- Expand_Wide_Wide_Image_Attribute --
1910 --------------------------------------
1911
1912 -- We expand typ'Wide_Wide_Image (X) as follows. First we insert this code:
1913
1914 -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
1915 -- Lnn : Natural;
1916 -- String_To_Wide_Wide_String
1917 -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
1918
1919 -- where rt is the root type of the prefix type
1920
1921 -- Now we replace the Wide_Wide_Image reference by
1922
1923 -- Rnn (1 .. Lnn)
1924
1925 -- This works in all cases because String_To_Wide_Wide_String converts any
1926 -- wide character escape sequences resulting from the Image call to the
1927 -- proper Wide_Wide_Character equivalent
1928
1929 -- not quite right for typ = Wide_Wide_Character ???
1930
1931 procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is
1932 Loc : constant Source_Ptr := Sloc (N);
1933 Pref : constant Entity_Id := Prefix (N);
1934 Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
1935 Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
1936 Rtyp : Entity_Id;
1937
1938 begin
1939 if Is_Object_Image (Pref) then
1940 Rewrite_Object_Image
1941 (N, Pref, Name_Wide_Wide_Image, Standard_Wide_Wide_String);
1942 return;
1943 end if;
1944
1945 Rtyp := Root_Type (Entity (Pref));
1946
1947 Insert_Actions (N, New_List (
1948
1949 -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
1950
1951 Make_Object_Declaration (Loc,
1952 Defining_Identifier => Rnn,
1953 Object_Definition =>
1954 Make_Subtype_Indication (Loc,
1955 Subtype_Mark =>
1956 New_Occurrence_Of (Standard_Wide_Wide_String, Loc),
1957 Constraint =>
1958 Make_Index_Or_Discriminant_Constraint (Loc,
1959 Constraints => New_List (
1960 Make_Range (Loc,
1961 Low_Bound => Make_Integer_Literal (Loc, 1),
1962 High_Bound =>
1963 Make_Attribute_Reference (Loc,
1964 Prefix => New_Occurrence_Of (Rtyp, Loc),
1965 Attribute_Name => Name_Wide_Wide_Width)))))),
1966
1967 -- Lnn : Natural;
1968
1969 Make_Object_Declaration (Loc,
1970 Defining_Identifier => Lnn,
1971 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)),
1972
1973 -- String_To_Wide_Wide_String
1974 -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
1975
1976 Make_Procedure_Call_Statement (Loc,
1977 Name =>
1978 New_Occurrence_Of (RTE (RE_String_To_Wide_Wide_String), Loc),
1979
1980 Parameter_Associations => New_List (
1981 Make_Attribute_Reference (Loc,
1982 Prefix => Prefix (N),
1983 Attribute_Name => Name_Image,
1984 Expressions => Expressions (N)),
1985 New_Occurrence_Of (Rnn, Loc),
1986 New_Occurrence_Of (Lnn, Loc),
1987 Make_Integer_Literal (Loc,
1988 Intval => Int (Wide_Character_Encoding_Method))))),
1989
1990 -- Suppress checks because we know everything is properly in range
1991
1992 Suppress => All_Checks);
1993
1994 -- Final step is to rewrite the expression as a slice and analyze,
1995 -- again with no checks, since we are sure that everything is OK.
1996
1997 Rewrite (N,
1998 Make_Slice (Loc,
1999 Prefix => New_Occurrence_Of (Rnn, Loc),
2000 Discrete_Range =>
2001 Make_Range (Loc,
2002 Low_Bound => Make_Integer_Literal (Loc, 1),
2003 High_Bound => New_Occurrence_Of (Lnn, Loc))));
2004
2005 Analyze_And_Resolve
2006 (N, Standard_Wide_Wide_String, Suppress => All_Checks);
2007 end Expand_Wide_Wide_Image_Attribute;
2008
2009 ----------------------------
2010 -- Expand_Width_Attribute --
2011 ----------------------------
2012
2013 -- The processing here also handles the case of Wide_[Wide_]Width. With the
2014 -- exceptions noted, the processing is identical
2015
2016 -- For scalar types derived from Boolean, character and integer types
2017 -- in package Standard. Note that the Width attribute is computed at
2018 -- compile time for all cases except those involving non-static sub-
2019 -- types. For such subtypes, typ'[Wide_[Wide_]]Width expands into:
2020
2021 -- Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last)))
2022
2023 -- where
2024
2025 -- For types whose root type is Character
2026 -- xx = Width_Character
2027 -- yy = Character
2028
2029 -- For types whose root type is Wide_Character
2030 -- xx = Wide_Width_Character
2031 -- yy = Character
2032
2033 -- For types whose root type is Wide_Wide_Character
2034 -- xx = Wide_Wide_Width_Character
2035 -- yy = Character
2036
2037 -- For types whose root type is Boolean
2038 -- xx = Width_Boolean
2039 -- yy = Boolean
2040
2041 -- For signed integer types
2042 -- xx = Width_[Long_Long_[Long_]]Integer
2043 -- yy = [Long_Long_[Long_]]Integer
2044
2045 -- For modular integer types
2046 -- xx = Width_[Long_Long_[Long_]]Unsigned
2047 -- yy = [Long_Long_[Long_]]Unsigned
2048
2049 -- For types derived from Wide_Character, typ'Width expands into
2050
2051 -- Result_Type (Width_Wide_Character (
2052 -- Wide_Character (typ'First),
2053 -- Wide_Character (typ'Last),
2054
2055 -- and typ'Wide_Width expands into:
2056
2057 -- Result_Type (Wide_Width_Wide_Character (
2058 -- Wide_Character (typ'First),
2059 -- Wide_Character (typ'Last));
2060
2061 -- and typ'Wide_Wide_Width expands into
2062
2063 -- Result_Type (Wide_Wide_Width_Wide_Character (
2064 -- Wide_Character (typ'First),
2065 -- Wide_Character (typ'Last));
2066
2067 -- For types derived from Wide_Wide_Character, typ'Width expands into
2068
2069 -- Result_Type (Width_Wide_Wide_Character (
2070 -- Wide_Wide_Character (typ'First),
2071 -- Wide_Wide_Character (typ'Last),
2072
2073 -- and typ'Wide_Width expands into:
2074
2075 -- Result_Type (Wide_Width_Wide_Wide_Character (
2076 -- Wide_Wide_Character (typ'First),
2077 -- Wide_Wide_Character (typ'Last));
2078
2079 -- and typ'Wide_Wide_Width expands into
2080
2081 -- Result_Type (Wide_Wide_Width_Wide_Wide_Char (
2082 -- Wide_Wide_Character (typ'First),
2083 -- Wide_Wide_Character (typ'Last));
2084
2085 -- For fixed point types, typ'Width and typ'Wide_[Wide_]Width expand into
2086
2087 -- if Ptyp'First > Ptyp'Last then 0 else Ptyp'Fore + 1 + Ptyp'Aft end if
2088
2089 -- and for floating point types, they expand into
2090
2091 -- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if
2092
2093 -- where btyp is the base type. This looks recursive but it isn't
2094 -- because the base type is always static, and hence the expression
2095 -- in the else is reduced to an integer literal.
2096
2097 -- For user-defined enumeration types, typ'Width expands into
2098
2099 -- Result_Type (Width_Enumeration_NN
2100 -- (typS,
2101 -- typI'Address,
2102 -- typ'Pos (typ'First),
2103 -- typ'Pos (Typ'Last)));
2104
2105 -- and typ'Wide_Width expands into:
2106
2107 -- Result_Type (Wide_Width_Enumeration_NN
2108 -- (typS,
2109 -- typI,
2110 -- typ'Pos (typ'First),
2111 -- typ'Pos (Typ'Last))
2112 -- Wide_Character_Encoding_Method);
2113
2114 -- and typ'Wide_Wide_Width expands into:
2115
2116 -- Result_Type (Wide_Wide_Width_Enumeration_NN
2117 -- (typS,
2118 -- typI,
2119 -- typ'Pos (typ'First),
2120 -- typ'Pos (Typ'Last))
2121 -- Wide_Character_Encoding_Method);
2122
2123 -- where typS and typI are the enumeration image strings and indexes
2124 -- table, as described in Build_Enumeration_Image_Tables. NN is 8/16/32
2125 -- for depending on the element type for typI.
2126
2127 -- Finally if Discard_Names is in effect for an enumeration type, then
2128 -- a special if expression is built that yields the space needed for the
2129 -- decimal representation of the largest pos value in the subtype. See
2130 -- code below for details.
2131
2132 procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal) is
2133 Loc : constant Source_Ptr := Sloc (N);
2134 Typ : constant Entity_Id := Etype (N);
2135 Pref : constant Node_Id := Prefix (N);
2136 Ptyp : constant Entity_Id := Etype (Pref);
2137 Rtyp : constant Entity_Id := Root_Type (Ptyp);
2138 Arglist : List_Id;
2139 Ttyp : Entity_Id;
2140 XX : RE_Id;
2141 YY : Entity_Id;
2142
2143 begin
2144 -- Types derived from Standard.Boolean
2145
2146 if Rtyp = Standard_Boolean then
2147 XX := RE_Width_Boolean;
2148 YY := Rtyp;
2149
2150 -- Types derived from Standard.Character
2151
2152 elsif Rtyp = Standard_Character then
2153 case Attr is
2154 when Normal => XX := RE_Width_Character;
2155 when Wide => XX := RE_Wide_Width_Character;
2156 when Wide_Wide => XX := RE_Wide_Wide_Width_Character;
2157 end case;
2158
2159 YY := Rtyp;
2160
2161 -- Types derived from Standard.Wide_Character
2162
2163 elsif Rtyp = Standard_Wide_Character then
2164 case Attr is
2165 when Normal => XX := RE_Width_Wide_Character;
2166 when Wide => XX := RE_Wide_Width_Wide_Character;
2167 when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Character;
2168 end case;
2169
2170 YY := Rtyp;
2171
2172 -- Types derived from Standard.Wide_Wide_Character
2173
2174 elsif Rtyp = Standard_Wide_Wide_Character then
2175 case Attr is
2176 when Normal => XX := RE_Width_Wide_Wide_Character;
2177 when Wide => XX := RE_Wide_Width_Wide_Wide_Character;
2178 when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Wide_Char;
2179 end case;
2180
2181 YY := Rtyp;
2182
2183 -- Signed integer types
2184
2185 elsif Is_Signed_Integer_Type (Rtyp) then
2186 if Esize (Rtyp) <= Standard_Integer_Size then
2187 XX := RE_Width_Integer;
2188 YY := Standard_Integer;
2189 elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then
2190 XX := RE_Width_Long_Long_Integer;
2191 YY := Standard_Long_Long_Integer;
2192 else
2193 XX := RE_Width_Long_Long_Long_Integer;
2194 YY := Standard_Long_Long_Long_Integer;
2195 end if;
2196
2197 -- Modular integer types
2198
2199 elsif Is_Modular_Integer_Type (Rtyp) then
2200 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
2201 XX := RE_Width_Unsigned;
2202 YY := RTE (RE_Unsigned);
2203 elsif Modulus (Rtyp) <= Modulus (RTE (RE_Long_Long_Unsigned)) then
2204 XX := RE_Width_Long_Long_Unsigned;
2205 YY := RTE (RE_Long_Long_Unsigned);
2206 else
2207 XX := RE_Width_Long_Long_Long_Unsigned;
2208 YY := RTE (RE_Long_Long_Long_Unsigned);
2209 end if;
2210
2211 -- Fixed point types
2212
2213 elsif Is_Fixed_Point_Type (Rtyp) then
2214 Rewrite (N,
2215 Make_If_Expression (Loc,
2216 Expressions => New_List (
2217
2218 Make_Op_Gt (Loc,
2219 Left_Opnd =>
2220 Make_Attribute_Reference (Loc,
2221 Prefix => New_Occurrence_Of (Ptyp, Loc),
2222 Attribute_Name => Name_First),
2223
2224 Right_Opnd =>
2225 Make_Attribute_Reference (Loc,
2226 Prefix => New_Occurrence_Of (Ptyp, Loc),
2227 Attribute_Name => Name_Last)),
2228
2229 Make_Integer_Literal (Loc, 0),
2230
2231 Make_Op_Add (Loc,
2232 Make_Attribute_Reference (Loc,
2233 Prefix => New_Occurrence_Of (Ptyp, Loc),
2234 Attribute_Name => Name_Fore),
2235
2236 Make_Op_Add (Loc,
2237 Make_Integer_Literal (Loc, 1),
2238 Make_Integer_Literal (Loc, Aft_Value (Ptyp)))))));
2239
2240 Analyze_And_Resolve (N, Typ);
2241 return;
2242
2243 -- Floating point types
2244
2245 elsif Is_Floating_Point_Type (Rtyp) then
2246 Rewrite (N,
2247 Make_If_Expression (Loc,
2248 Expressions => New_List (
2249
2250 Make_Op_Gt (Loc,
2251 Left_Opnd =>
2252 Make_Attribute_Reference (Loc,
2253 Prefix => New_Occurrence_Of (Ptyp, Loc),
2254 Attribute_Name => Name_First),
2255
2256 Right_Opnd =>
2257 Make_Attribute_Reference (Loc,
2258 Prefix => New_Occurrence_Of (Ptyp, Loc),
2259 Attribute_Name => Name_Last)),
2260
2261 Make_Integer_Literal (Loc, 0),
2262
2263 Make_Attribute_Reference (Loc,
2264 Prefix => New_Occurrence_Of (Base_Type (Ptyp), Loc),
2265 Attribute_Name => Name_Width))));
2266
2267 Analyze_And_Resolve (N, Typ);
2268 return;
2269
2270 -- User-defined enumeration types
2271
2272 else
2273 pragma Assert (Is_Enumeration_Type (Rtyp));
2274
2275 -- Whenever pragma Discard_Names is in effect, the value we need
2276 -- is the value needed to accommodate the largest integer pos value
2277 -- in the range of the subtype + 1 for the space at the start. We
2278 -- build:
2279
2280 -- Tnn : constant Integer := Rtyp'Pos (Ptyp'Last)
2281
2282 -- and replace the expression by
2283
2284 -- (if Ptyp'Range_Length = 0 then 0
2285 -- else (if Tnn < 10 then 2
2286 -- else (if Tnn < 100 then 3
2287 -- ...
2288 -- else n)))...
2289
2290 -- where n is equal to Rtyp'Pos (Ptyp'Last) + 1
2291
2292 -- Note: The above processing is in accordance with the intent of
2293 -- the RM, which is that Width should be related to the impl-defined
2294 -- behavior of Image. It is not clear what this means if Image is
2295 -- not defined (as in the configurable run-time case for GNAT) and
2296 -- gives an error at compile time.
2297
2298 -- We choose in this case to just go ahead and implement Width the
2299 -- same way, returning what Image would have returned if it has been
2300 -- available in the configurable run-time library.
2301
2302 if Discard_Names (Rtyp) then
2303 declare
2304 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T');
2305 Cexpr : Node_Id;
2306 P : Int;
2307 M : Int;
2308 K : Int;
2309
2310 begin
2311 Insert_Action (N,
2312 Make_Object_Declaration (Loc,
2313 Defining_Identifier => Tnn,
2314 Constant_Present => True,
2315 Object_Definition =>
2316 New_Occurrence_Of (Standard_Integer, Loc),
2317 Expression =>
2318 Make_Attribute_Reference (Loc,
2319 Prefix => New_Occurrence_Of (Rtyp, Loc),
2320 Attribute_Name => Name_Pos,
2321 Expressions => New_List (
2322 Convert_To (Rtyp,
2323 Make_Attribute_Reference (Loc,
2324 Prefix => New_Occurrence_Of (Ptyp, Loc),
2325 Attribute_Name => Name_Last))))));
2326
2327 -- OK, now we need to build the if expression. First get the
2328 -- value of M, the largest possible value needed.
2329
2330 P := UI_To_Int
2331 (Enumeration_Pos (Entity (Type_High_Bound (Rtyp))));
2332
2333 K := 1;
2334 M := 1;
2335 while M < P loop
2336 M := M * 10;
2337 K := K + 1;
2338 end loop;
2339
2340 -- Build inner else
2341
2342 Cexpr := Make_Integer_Literal (Loc, K);
2343
2344 -- Wrap in inner if's until counted down to 2
2345
2346 while K > 2 loop
2347 M := M / 10;
2348 K := K - 1;
2349
2350 Cexpr :=
2351 Make_If_Expression (Loc,
2352 Expressions => New_List (
2353 Make_Op_Lt (Loc,
2354 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
2355 Right_Opnd => Make_Integer_Literal (Loc, M)),
2356 Make_Integer_Literal (Loc, K),
2357 Cexpr));
2358 end loop;
2359
2360 -- Add initial comparison for null range and we are done, so
2361 -- rewrite the attribute occurrence with this expression.
2362
2363 Rewrite (N,
2364 Convert_To (Typ,
2365 Make_If_Expression (Loc,
2366 Expressions => New_List (
2367 Make_Op_Eq (Loc,
2368 Left_Opnd =>
2369 Make_Attribute_Reference (Loc,
2370 Prefix => New_Occurrence_Of (Ptyp, Loc),
2371 Attribute_Name => Name_Range_Length),
2372 Right_Opnd => Make_Integer_Literal (Loc, 0)),
2373 Make_Integer_Literal (Loc, 0),
2374 Cexpr))));
2375
2376 Analyze_And_Resolve (N, Typ);
2377 return;
2378 end;
2379 end if;
2380
2381 -- Normal case, not Discard_Names
2382
2383 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
2384
2385 case Attr is
2386 when Normal =>
2387 if Ttyp = Standard_Integer_8 then
2388 XX := RE_Width_Enumeration_8;
2389 elsif Ttyp = Standard_Integer_16 then
2390 XX := RE_Width_Enumeration_16;
2391 else
2392 XX := RE_Width_Enumeration_32;
2393 end if;
2394
2395 when Wide =>
2396 if Ttyp = Standard_Integer_8 then
2397 XX := RE_Wide_Width_Enumeration_8;
2398 elsif Ttyp = Standard_Integer_16 then
2399 XX := RE_Wide_Width_Enumeration_16;
2400 else
2401 XX := RE_Wide_Width_Enumeration_32;
2402 end if;
2403
2404 when Wide_Wide =>
2405 if Ttyp = Standard_Integer_8 then
2406 XX := RE_Wide_Wide_Width_Enumeration_8;
2407 elsif Ttyp = Standard_Integer_16 then
2408 XX := RE_Wide_Wide_Width_Enumeration_16;
2409 else
2410 XX := RE_Wide_Wide_Width_Enumeration_32;
2411 end if;
2412 end case;
2413
2414 Arglist :=
2415 New_List (
2416 New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
2417
2418 Make_Attribute_Reference (Loc,
2419 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
2420 Attribute_Name => Name_Address),
2421
2422 Make_Attribute_Reference (Loc,
2423 Prefix => New_Occurrence_Of (Ptyp, Loc),
2424 Attribute_Name => Name_Pos,
2425
2426 Expressions => New_List (
2427 Make_Attribute_Reference (Loc,
2428 Prefix => New_Occurrence_Of (Ptyp, Loc),
2429 Attribute_Name => Name_First))),
2430
2431 Make_Attribute_Reference (Loc,
2432 Prefix => New_Occurrence_Of (Ptyp, Loc),
2433 Attribute_Name => Name_Pos,
2434
2435 Expressions => New_List (
2436 Make_Attribute_Reference (Loc,
2437 Prefix => New_Occurrence_Of (Ptyp, Loc),
2438 Attribute_Name => Name_Last))));
2439
2440 Rewrite (N,
2441 Convert_To (Typ,
2442 Make_Function_Call (Loc,
2443 Name => New_Occurrence_Of (RTE (XX), Loc),
2444 Parameter_Associations => Arglist)));
2445
2446 Analyze_And_Resolve (N, Typ);
2447 return;
2448 end if;
2449
2450 -- If we fall through XX and YY are set
2451
2452 Arglist := New_List (
2453 Convert_To (YY,
2454 Make_Attribute_Reference (Loc,
2455 Prefix => New_Occurrence_Of (Ptyp, Loc),
2456 Attribute_Name => Name_First)),
2457
2458 Convert_To (YY,
2459 Make_Attribute_Reference (Loc,
2460 Prefix => New_Occurrence_Of (Ptyp, Loc),
2461 Attribute_Name => Name_Last)));
2462
2463 Rewrite (N,
2464 Convert_To (Typ,
2465 Make_Function_Call (Loc,
2466 Name => New_Occurrence_Of (RTE (XX), Loc),
2467 Parameter_Associations => Arglist)));
2468
2469 Analyze_And_Resolve (N, Typ);
2470 end Expand_Width_Attribute;
2471
2472 --------------------------
2473 -- Rewrite_Object_Image --
2474 --------------------------
2475
2476 procedure Rewrite_Object_Image
2477 (N : Node_Id;
2478 Pref : Entity_Id;
2479 Attr_Name : Name_Id;
2480 Str_Typ : Entity_Id)
2481 is
2482 begin
2483 Rewrite (N,
2484 Make_Attribute_Reference (Sloc (N),
2485 Prefix => New_Occurrence_Of (Etype (Pref), Sloc (N)),
2486 Attribute_Name => Attr_Name,
2487 Expressions => New_List (Relocate_Node (Pref))));
2488
2489 Analyze_And_Resolve (N, Str_Typ);
2490 end Rewrite_Object_Image;
2491 end Exp_Imgv;
Mirror of the offical gcc git repository hosted at gcc.gnu.org