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