?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
PR27116, Spelling errors found by Debian style checker
[official-gcc.git] / gcc / ada / exp_imgv.adb
blob6bcfec667a9ea091f0416aa785870f790fb42a32
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-2023, 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 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))'Image
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 :=
942 Make_Op_Add (Loc,
943 Left_Opnd => New_Occurrence_Of (P1_Id, Loc),
944 Right_Opnd => Make_Integer_Literal (Loc, Uint_1));
945
946 begin
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 :=
967 Make_Op_Subtract (Loc,
968 Left_Opnd => New_Occurrence_Of (P3_Id, Loc),
969 Right_Opnd => Make_Integer_Literal (Loc, Uint_1));
970
971 begin
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 :=
992 Make_Op_Subtract (Loc,
993 Left_Opnd => New_Occurrence_Of (P3_Id, Loc),
994 Right_Opnd => New_Occurrence_Of (P2_Id, Loc));
995
996 begin
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)))'Image. The conversion is
1215 -- there to avoid applying 'Image 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 => Name_Image));
1227 Analyze_And_Resolve (N, Standard_String);
1228 return;
1229
1230 -- Use inline expansion if the -gnatd_x switch is not passed to the
1231 -- compiler. Otherwise expand into a call to the runtime.
1232
1233 elsif not Debug_Flag_Underscore_X then
1234 Expand_User_Defined_Enumeration_Image (Rtyp);
1235 return;
1236
1237 else
1238 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
1239
1240 if Ttyp = Standard_Integer_8 then
1241 Imid := RE_Image_Enumeration_8;
1242
1243 elsif Ttyp = Standard_Integer_16 then
1244 Imid := RE_Image_Enumeration_16;
1245
1246 else
1247 Imid := RE_Image_Enumeration_32;
1248 end if;
1249
1250 -- Apply a validity check, since it is a bit drastic to get a
1251 -- completely junk image value for an invalid value.
1252
1253 if not Expr_Known_Valid (Expr) then
1254 Insert_Valid_Check (Expr);
1255 end if;
1256
1257 Enum_Case := True;
1258 end if;
1259 end if;
1260
1261 -- Build first argument for call
1262
1263 if Enum_Case then
1264 Arg_List := New_List (
1265 Make_Attribute_Reference (Loc,
1266 Attribute_Name => Name_Pos,
1267 Prefix => New_Occurrence_Of (Ptyp, Loc),
1268 Expressions => New_List (Expr)));
1269
1270 -- AI12-0020: Ada 2022 allows 'Image for all types, including private
1271 -- types. If the full type is not a fixed-point type, then it is enough
1272 -- to set the Conversion_OK flag. However, that would not work for
1273 -- fixed-point types, because that flag changes the run-time semantics
1274 -- of fixed-point type conversions; therefore, we must first convert to
1275 -- Rtyp, and then to Tent.
1276
1277 else
1278 declare
1279 Conv : Node_Id;
1280
1281 begin
1282 if Is_Private_Type (Etype (Expr)) then
1283 if Is_Fixed_Point_Type (Rtyp) then
1284 Conv := Convert_To (Tent, OK_Convert_To (Rtyp, Expr));
1285 else
1286 Conv := OK_Convert_To (Tent, Expr);
1287 end if;
1288 else
1289 Conv := Convert_To (Tent, Expr);
1290 end if;
1291
1292 Arg_List := New_List (Conv);
1293 end;
1294 end if;
1295
1296 -- Build declarations of Snn and Pnn to be inserted
1297
1298 Ins_List := New_List (
1299
1300 -- Snn : String (1 .. typ'Width);
1301
1302 Make_Object_Declaration (Loc,
1303 Defining_Identifier => Snn,
1304 Object_Definition =>
1305 Make_Subtype_Indication (Loc,
1306 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
1307 Constraint =>
1308 Make_Index_Or_Discriminant_Constraint (Loc,
1309 Constraints => New_List (
1310 Make_Range (Loc,
1311 Low_Bound => Make_Integer_Literal (Loc, 1),
1312 High_Bound =>
1313 Make_Attribute_Reference (Loc,
1314 Prefix => New_Occurrence_Of (Rtyp, Loc),
1315 Attribute_Name => Name_Width)))))),
1316
1317 -- Pnn : Natural;
1318
1319 Make_Object_Declaration (Loc,
1320 Defining_Identifier => Pnn,
1321 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)));
1322
1323 -- Append Snn, Pnn arguments
1324
1325 Append_To (Arg_List, New_Occurrence_Of (Snn, Loc));
1326 Append_To (Arg_List, New_Occurrence_Of (Pnn, Loc));
1327
1328 -- Get entity of procedure to call
1329
1330 Proc_Ent := RTE (Imid);
1331
1332 -- If the procedure entity is empty, that means we have a case in
1333 -- no run time mode where the operation is not allowed, and an
1334 -- appropriate diagnostic has already been issued.
1335
1336 if No (Proc_Ent) then
1337 return;
1338 end if;
1339
1340 -- Otherwise complete preparation of arguments for run-time call
1341
1342 -- Add extra arguments for Enumeration case
1343
1344 if Enum_Case then
1345 Append_To (Arg_List, New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
1346 Append_To (Arg_List,
1347 Make_Attribute_Reference (Loc,
1348 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
1349 Attribute_Name => Name_Address));
1350
1351 -- For floating-point types, append Digits argument
1352
1353 elsif Is_Floating_Point_Type (Rtyp) then
1354 Append_To (Arg_List,
1355 Make_Attribute_Reference (Loc,
1356 Prefix => New_Occurrence_Of (Ptyp, Loc),
1357 Attribute_Name => Name_Digits));
1358
1359 -- For decimal, append Scale and also set to do literal conversion
1360
1361 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
1362 Set_Conversion_OK (First (Arg_List));
1363
1364 Append_To (Arg_List, Make_Integer_Literal (Loc, Scale_Value (Ptyp)));
1365
1366 -- For ordinary fixed-point types, append Num, Den, Fore, Aft parameters
1367 -- and also set to do literal conversion.
1368
1369 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
1370 if Imid /= RE_Image_Fixed then
1371 Set_Conversion_OK (First (Arg_List));
1372
1373 Append_To (Arg_List,
1374 Make_Integer_Literal (Loc, -Norm_Num (Small_Value (Ptyp))));
1375
1376 Append_To (Arg_List,
1377 Make_Integer_Literal (Loc, -Norm_Den (Small_Value (Ptyp))));
1378
1379 -- We want to compute the Fore value for the fixed point type
1380 -- whose mantissa type is Tent and whose small is typ'Small.
1381
1382 declare
1383 T : Ureal := Uint_2 ** (Esize (Tent) - 1) * Small_Value (Ptyp);
1384 F : Nat := 2;
1385
1386 begin
1387 while T >= Ureal_10 loop
1388 F := F + 1;
1389 T := T / Ureal_10;
1390 end loop;
1391
1392 Append_To (Arg_List,
1393 Make_Integer_Literal (Loc, UI_From_Int (F)));
1394 end;
1395 end if;
1396
1397 Append_To (Arg_List, Make_Integer_Literal (Loc, Aft_Value (Ptyp)));
1398
1399 -- For Wide_Character, append Ada 2005 indication
1400
1401 elsif Rtyp = Standard_Wide_Character then
1402 Append_To (Arg_List,
1403 New_Occurrence_Of
1404 (Boolean_Literals (Ada_Version >= Ada_2005), Loc));
1405 end if;
1406
1407 -- Now append the procedure call to the insert list
1408
1409 Append_To (Ins_List,
1410 Make_Procedure_Call_Statement (Loc,
1411 Name => New_Occurrence_Of (Proc_Ent, Loc),
1412 Parameter_Associations => Arg_List));
1413
1414 -- Insert declarations of Snn, Pnn, and the procedure call. We suppress
1415 -- checks because we are sure that everything is in range at this stage.
1416
1417 Insert_Actions (N, Ins_List, Suppress => All_Checks);
1418
1419 -- Final step is to rewrite the expression as a slice and analyze,
1420 -- again with no checks, since we are sure that everything is OK.
1421
1422 Rewrite (N,
1423 Make_Slice (Loc,
1424 Prefix => New_Occurrence_Of (Snn, Loc),
1425 Discrete_Range =>
1426 Make_Range (Loc,
1427 Low_Bound => Make_Integer_Literal (Loc, 1),
1428 High_Bound => New_Occurrence_Of (Pnn, Loc))));
1429
1430 Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks);
1431 end Expand_Image_Attribute;
1432
1433 ----------------------------------
1434 -- Expand_Valid_Value_Attribute --
1435 ----------------------------------
1436
1437 procedure Expand_Valid_Value_Attribute (N : Node_Id) is
1438 Loc : constant Source_Ptr := Sloc (N);
1439 Btyp : constant Entity_Id := Base_Type (Entity (Prefix (N)));
1440 Rtyp : constant Entity_Id := Root_Type (Btyp);
1441 pragma Assert (Is_Enumeration_Type (Rtyp));
1442
1443 Args : constant List_Id := Expressions (N);
1444 Func : RE_Id;
1445 Ttyp : Entity_Id;
1446
1447 begin
1448 -- Generate:
1449
1450 -- Valid_Value_Enumeration_NN
1451 -- (typS, typN'Address, typH'Unrestricted_Access, Num, X)
1452
1453 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
1454
1455 if Ttyp = Standard_Integer_8 then
1456 Func := RE_Valid_Value_Enumeration_8;
1457 elsif Ttyp = Standard_Integer_16 then
1458 Func := RE_Valid_Value_Enumeration_16;
1459 else
1460 Func := RE_Valid_Value_Enumeration_32;
1461 end if;
1462
1463 Prepend_To (Args,
1464 Make_Attribute_Reference (Loc,
1465 Prefix => New_Occurrence_Of (Rtyp, Loc),
1466 Attribute_Name => Name_Pos,
1467 Expressions => New_List (
1468 Make_Attribute_Reference (Loc,
1469 Prefix => New_Occurrence_Of (Rtyp, Loc),
1470 Attribute_Name => Name_Last))));
1471
1472 if Present (Lit_Hash (Rtyp)) then
1473 Prepend_To (Args,
1474 Make_Attribute_Reference (Loc,
1475 Prefix => New_Occurrence_Of (Lit_Hash (Rtyp), Loc),
1476 Attribute_Name => Name_Unrestricted_Access));
1477 else
1478 Prepend_To (Args, Make_Null (Loc));
1479 end if;
1480
1481 Prepend_To (Args,
1482 Make_Attribute_Reference (Loc,
1483 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
1484 Attribute_Name => Name_Address));
1485
1486 Prepend_To (Args,
1487 New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
1488
1489 Rewrite (N,
1490 Make_Function_Call (Loc,
1491 Name =>
1492 New_Occurrence_Of (RTE (Func), Loc),
1493 Parameter_Associations => Args));
1494
1495 Analyze_And_Resolve (N, Standard_Boolean);
1496 end Expand_Valid_Value_Attribute;
1497
1498 ----------------------------
1499 -- Expand_Value_Attribute --
1500 ----------------------------
1501
1502 -- For scalar types derived from Boolean, Character and integer types
1503 -- in package Standard, typ'Value (X) expands into:
1504
1505 -- btyp (Value_xx (X))
1506
1507 -- where btyp is the base type of the prefix
1508
1509 -- For types whose root type is Character
1510 -- xx = Character
1511
1512 -- For types whose root type is Wide_Character
1513 -- xx = Wide_Character
1514
1515 -- For types whose root type is Wide_Wide_Character
1516 -- xx = Wide_Wide_Character
1517
1518 -- For types whose root type is Boolean
1519 -- xx = Boolean
1520
1521 -- For signed integer types
1522 -- xx = [Long_Long_[Long_]]Integer
1523
1524 -- For modular types
1525 -- xx = [Long_Long_[Long_]]Unsigned
1526
1527 -- For floating-point types
1528 -- xx = [Long_[Long_]]Float
1529
1530 -- For decimal fixed-point types, typ'Value (X) expands into
1531
1532 -- btyp?(Value_Decimal{32,64,128} (X, typ'Scale));
1533
1534 -- For the most common ordinary fixed-point types, it expands into
1535
1536 -- btyp?(Value_Fixed{32,64,128} (X, numerator of S, denominator of S));
1537 -- where S = typ'Small
1538
1539 -- For other ordinary fixed-point types, it expands into
1540
1541 -- btyp (Value_Long_Float (X))
1542
1543 -- For Wide_[Wide_]Character types, typ'Value (X) expands into
1544
1545 -- btyp (Value_xx (X, EM))
1546
1547 -- where btyp is the base type of the prefix, and EM is the encoding method
1548
1549 -- For enumeration types other than those derived from types Boolean,
1550 -- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
1551
1552 -- Enum'Val
1553 -- (Value_Enumeration_NN
1554 -- (typS, typN'Address, typH'Unrestricted_Access, Num, X))
1555
1556 -- where typS, typN and typH are the Lit_Strings, Lit_Indexes and Lit_Hash
1557 -- entities from T's root type entity, and Num is Enum'Pos (Enum'Last).
1558 -- The Value_Enumeration_NN function will search the tables looking for
1559 -- X and return the position number in the table if found which is
1560 -- used to provide the result of 'Value (using Enum'Val). If the
1561 -- value is not found Constraint_Error is raised. The suffix _NN
1562 -- depends on the element type of typN.
1563
1564 procedure Expand_Value_Attribute (N : Node_Id) is
1565 Loc : constant Source_Ptr := Sloc (N);
1566 Btyp : constant Entity_Id := Etype (N);
1567 pragma Assert (Is_Base_Type (Btyp));
1568 pragma Assert (Btyp = Base_Type (Entity (Prefix (N))));
1569 Rtyp : constant Entity_Id := Root_Type (Btyp);
1570
1571 Args : constant List_Id := Expressions (N);
1572 Ttyp : Entity_Id;
1573 Vid : RE_Id;
1574
1575 begin
1576 -- Fall through for all cases except user-defined enumeration type
1577 -- and decimal types, with Vid set to the Id of the entity for the
1578 -- Value routine and Args set to the list of parameters for the call.
1579
1580 if Rtyp = Standard_Boolean then
1581 Vid := RE_Value_Boolean;
1582
1583 elsif Rtyp = Standard_Character then
1584 Vid := RE_Value_Character;
1585
1586 elsif Rtyp = Standard_Wide_Character then
1587 Vid := RE_Value_Wide_Character;
1588
1589 Append_To (Args,
1590 Make_Integer_Literal (Loc,
1591 Intval => Int (Wide_Character_Encoding_Method)));
1592
1593 elsif Rtyp = Standard_Wide_Wide_Character then
1594 Vid := RE_Value_Wide_Wide_Character;
1595
1596 Append_To (Args,
1597 Make_Integer_Literal (Loc,
1598 Intval => Int (Wide_Character_Encoding_Method)));
1599
1600 elsif Is_Signed_Integer_Type (Rtyp) then
1601 if Esize (Rtyp) <= Standard_Integer_Size then
1602 Vid := RE_Value_Integer;
1603 elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then
1604 Vid := RE_Value_Long_Long_Integer;
1605 else
1606 Vid := RE_Value_Long_Long_Long_Integer;
1607 end if;
1608
1609 elsif Is_Modular_Integer_Type (Rtyp) then
1610 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
1611 Vid := RE_Value_Unsigned;
1612 elsif Modulus (Rtyp) <= Modulus (RTE (RE_Long_Long_Unsigned)) then
1613 Vid := RE_Value_Long_Long_Unsigned;
1614 else
1615 Vid := RE_Value_Long_Long_Long_Unsigned;
1616 end if;
1617
1618 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
1619 if Esize (Rtyp) <= 32 and then abs (Scale_Value (Rtyp)) <= 9 then
1620 Vid := RE_Value_Decimal32;
1621 elsif Esize (Rtyp) <= 64 and then abs (Scale_Value (Rtyp)) <= 18 then
1622 Vid := RE_Value_Decimal64;
1623 else
1624 Vid := RE_Value_Decimal128;
1625 end if;
1626
1627 Append_To (Args, Make_Integer_Literal (Loc, Scale_Value (Rtyp)));
1628
1629 Rewrite (N,
1630 OK_Convert_To (Btyp,
1631 Make_Function_Call (Loc,
1632 Name => New_Occurrence_Of (RTE (Vid), Loc),
1633 Parameter_Associations => Args)));
1634
1635 Set_Etype (N, Btyp);
1636 Analyze_And_Resolve (N, Btyp);
1637 return;
1638
1639 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
1640 declare
1641 Num : constant Uint := Norm_Num (Small_Value (Rtyp));
1642 Den : constant Uint := Norm_Den (Small_Value (Rtyp));
1643 Max : constant Uint := UI_Max (Num, Den);
1644 Min : constant Uint := UI_Min (Num, Den);
1645 Siz : constant Uint := Esize (Rtyp);
1646
1647 begin
1648 if Siz <= 32
1649 and then Max <= Uint_2 ** 31
1650 and then (Min = Uint_1 or else Max <= Uint_2 ** 27)
1651 then
1652 Vid := RE_Value_Fixed32;
1653 elsif Siz <= 64
1654 and then Max <= Uint_2 ** 63
1655 and then (Min = Uint_1 or else Max <= Uint_2 ** 59)
1656 then
1657 Vid := RE_Value_Fixed64;
1658 elsif System_Max_Integer_Size = 128
1659 and then Max <= Uint_2 ** 127
1660 and then (Min = Uint_1 or else Max <= Uint_2 ** 123)
1661 then
1662 Vid := RE_Value_Fixed128;
1663 else
1664 Vid := RE_Value_Long_Float;
1665 end if;
1666
1667 if Vid /= RE_Value_Long_Float then
1668 Append_To (Args,
1669 Make_Integer_Literal (Loc, -Norm_Num (Small_Value (Rtyp))));
1670
1671 Append_To (Args,
1672 Make_Integer_Literal (Loc, -Norm_Den (Small_Value (Rtyp))));
1673
1674 Rewrite (N,
1675 OK_Convert_To (Btyp,
1676 Make_Function_Call (Loc,
1677 Name => New_Occurrence_Of (RTE (Vid), Loc),
1678 Parameter_Associations => Args)));
1679
1680 Set_Etype (N, Btyp);
1681 Analyze_And_Resolve (N, Btyp);
1682 return;
1683 end if;
1684 end;
1685
1686 elsif Is_Floating_Point_Type (Rtyp) then
1687 -- Short_Float and Float are the same type for GNAT
1688
1689 if Rtyp = Standard_Short_Float or else Rtyp = Standard_Float then
1690 Vid := RE_Value_Float;
1691
1692 elsif Rtyp = Standard_Long_Float then
1693 Vid := RE_Value_Long_Float;
1694
1695 else
1696 Vid := RE_Value_Long_Long_Float;
1697 end if;
1698
1699 -- Only other possibility is user-defined enumeration type
1700
1701 else
1702 pragma Assert (Is_Enumeration_Type (Rtyp));
1703
1704 -- Case of pragma Discard_Names, transform the Value
1705 -- attribute to Btyp'Val (Long_Long_Integer'Value (Args))
1706
1707 if Discard_Names (First_Subtype (Btyp))
1708 or else No (Lit_Strings (Rtyp))
1709 then
1710 Rewrite (N,
1711 Make_Attribute_Reference (Loc,
1712 Prefix => New_Occurrence_Of (Btyp, Loc),
1713 Attribute_Name => Name_Val,
1714 Expressions => New_List (
1715 Make_Attribute_Reference (Loc,
1716 Prefix =>
1717 New_Occurrence_Of (Standard_Long_Long_Integer, Loc),
1718 Attribute_Name => Name_Value,
1719 Expressions => Args))));
1720
1721 Analyze_And_Resolve (N, Btyp);
1722
1723 -- Normal case where we have enumeration tables, build
1724
1725 -- T'Val
1726 -- (Value_Enumeration_NN
1727 -- (typS, typN'Address, typH'Unrestricted_Access, Num, X))
1728
1729 else
1730 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
1731
1732 if Ttyp = Standard_Integer_8 then
1733 Vid := RE_Value_Enumeration_8;
1734 elsif Ttyp = Standard_Integer_16 then
1735 Vid := RE_Value_Enumeration_16;
1736 else
1737 Vid := RE_Value_Enumeration_32;
1738 end if;
1739
1740 Prepend_To (Args,
1741 Make_Attribute_Reference (Loc,
1742 Prefix => New_Occurrence_Of (Rtyp, Loc),
1743 Attribute_Name => Name_Pos,
1744 Expressions => New_List (
1745 Make_Attribute_Reference (Loc,
1746 Prefix => New_Occurrence_Of (Rtyp, Loc),
1747 Attribute_Name => Name_Last))));
1748
1749 if Present (Lit_Hash (Rtyp)) then
1750 Prepend_To (Args,
1751 Make_Attribute_Reference (Loc,
1752 Prefix => New_Occurrence_Of (Lit_Hash (Rtyp), Loc),
1753 Attribute_Name => Name_Unrestricted_Access));
1754 else
1755 Prepend_To (Args, Make_Null (Loc));
1756 end if;
1757
1758 Prepend_To (Args,
1759 Make_Attribute_Reference (Loc,
1760 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
1761 Attribute_Name => Name_Address));
1762
1763 Prepend_To (Args,
1764 New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
1765
1766 Rewrite (N,
1767 Make_Attribute_Reference (Loc,
1768 Prefix => New_Occurrence_Of (Btyp, Loc),
1769 Attribute_Name => Name_Val,
1770 Expressions => New_List (
1771 Make_Function_Call (Loc,
1772 Name =>
1773 New_Occurrence_Of (RTE (Vid), Loc),
1774 Parameter_Associations => Args))));
1775
1776 Analyze_And_Resolve (N, Btyp);
1777 end if;
1778
1779 return;
1780 end if;
1781
1782 -- Compiling package Ada.Tags under No_Run_Time_Mode we disable the
1783 -- expansion of the attribute into the function call statement to avoid
1784 -- generating spurious errors caused by the use of Integer_Address'Value
1785 -- in our implementation of Ada.Tags.Internal_Tag.
1786
1787 if No_Run_Time_Mode
1788 and then Is_RTE (Rtyp, RE_Integer_Address)
1789 and then RTU_Loaded (Ada_Tags)
1790 and then Cunit_Entity (Current_Sem_Unit)
1791 = Body_Entity (RTU_Entity (Ada_Tags))
1792 then
1793 Rewrite (N,
1794 Unchecked_Convert_To (Rtyp,
1795 Make_Integer_Literal (Loc, Uint_0)));
1796
1797 else
1798 Rewrite (N,
1799 Convert_To (Btyp,
1800 Make_Function_Call (Loc,
1801 Name => New_Occurrence_Of (RTE (Vid), Loc),
1802 Parameter_Associations => Args)));
1803 end if;
1804
1805 Analyze_And_Resolve (N, Btyp);
1806 end Expand_Value_Attribute;
1807
1808 ---------------------------------
1809 -- Expand_Wide_Image_Attribute --
1810 ---------------------------------
1811
1812 -- We expand typ'Wide_Image (X) as follows. First we insert this code:
1813
1814 -- Rnn : Wide_String (1 .. rt'Wide_Width);
1815 -- Lnn : Natural;
1816 -- String_To_Wide_String
1817 -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
1818
1819 -- where rt is the root type of the prefix type
1820
1821 -- Now we replace the Wide_Image reference by
1822
1823 -- Rnn (1 .. Lnn)
1824
1825 -- This works in all cases because String_To_Wide_String converts any
1826 -- wide character escape sequences resulting from the Image call to the
1827 -- proper Wide_Character equivalent
1828
1829 -- not quite right for typ = Wide_Character ???
1830
1831 procedure Expand_Wide_Image_Attribute (N : Node_Id) is
1832 Loc : constant Source_Ptr := Sloc (N);
1833 Pref : constant Node_Id := Prefix (N);
1834 Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
1835 Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
1836 Rtyp : Entity_Id;
1837
1838 begin
1839 if Is_Object_Image (Pref) then
1840 Rewrite_Object_Image (N, Pref, Name_Wide_Image, Standard_Wide_String);
1841 return;
1842 end if;
1843
1844 -- If Image should be transformed using Put_Image, then do so. See
1845 -- Exp_Put_Image for details.
1846
1847 if Exp_Put_Image.Image_Should_Call_Put_Image (N) then
1848 Rewrite (N, Exp_Put_Image.Build_Image_Call (N));
1849 Analyze_And_Resolve (N, Standard_Wide_String, Suppress => All_Checks);
1850 return;
1851 end if;
1852
1853 Rtyp := Root_Type (Entity (Pref));
1854
1855 Insert_Actions (N, New_List (
1856
1857 -- Rnn : Wide_String (1 .. base_typ'Width);
1858
1859 Make_Object_Declaration (Loc,
1860 Defining_Identifier => Rnn,
1861 Object_Definition =>
1862 Make_Subtype_Indication (Loc,
1863 Subtype_Mark =>
1864 New_Occurrence_Of (Standard_Wide_String, Loc),
1865 Constraint =>
1866 Make_Index_Or_Discriminant_Constraint (Loc,
1867 Constraints => New_List (
1868 Make_Range (Loc,
1869 Low_Bound => Make_Integer_Literal (Loc, 1),
1870 High_Bound =>
1871 Make_Attribute_Reference (Loc,
1872 Prefix => New_Occurrence_Of (Rtyp, Loc),
1873 Attribute_Name => Name_Wide_Width)))))),
1874
1875 -- Lnn : Natural;
1876
1877 Make_Object_Declaration (Loc,
1878 Defining_Identifier => Lnn,
1879 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)),
1880
1881 -- String_To_Wide_String
1882 -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
1883
1884 Make_Procedure_Call_Statement (Loc,
1885 Name =>
1886 New_Occurrence_Of (RTE (RE_String_To_Wide_String), Loc),
1887
1888 Parameter_Associations => New_List (
1889 Make_Attribute_Reference (Loc,
1890 Prefix => Prefix (N),
1891 Attribute_Name => Name_Image,
1892 Expressions => Expressions (N)),
1893 New_Occurrence_Of (Rnn, Loc),
1894 New_Occurrence_Of (Lnn, Loc),
1895 Make_Integer_Literal (Loc,
1896 Intval => Int (Wide_Character_Encoding_Method))))),
1897
1898 -- Suppress checks because we know everything is properly in range
1899
1900 Suppress => All_Checks);
1901
1902 -- Final step is to rewrite the expression as a slice and analyze,
1903 -- again with no checks, since we are sure that everything is OK.
1904
1905 Rewrite (N,
1906 Make_Slice (Loc,
1907 Prefix => New_Occurrence_Of (Rnn, Loc),
1908 Discrete_Range =>
1909 Make_Range (Loc,
1910 Low_Bound => Make_Integer_Literal (Loc, 1),
1911 High_Bound => New_Occurrence_Of (Lnn, Loc))));
1912
1913 Analyze_And_Resolve (N, Standard_Wide_String, Suppress => All_Checks);
1914 end Expand_Wide_Image_Attribute;
1915
1916 --------------------------------------
1917 -- Expand_Wide_Wide_Image_Attribute --
1918 --------------------------------------
1919
1920 -- We expand typ'Wide_Wide_Image (X) as follows. First we insert this code:
1921
1922 -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
1923 -- Lnn : Natural;
1924 -- String_To_Wide_Wide_String
1925 -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
1926
1927 -- where rt is the root type of the prefix type
1928
1929 -- Now we replace the Wide_Wide_Image reference by
1930
1931 -- Rnn (1 .. Lnn)
1932
1933 -- This works in all cases because String_To_Wide_Wide_String converts any
1934 -- wide character escape sequences resulting from the Image call to the
1935 -- proper Wide_Wide_Character equivalent
1936
1937 -- not quite right for typ = Wide_Wide_Character ???
1938
1939 procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is
1940 Loc : constant Source_Ptr := Sloc (N);
1941 Pref : constant Node_Id := Prefix (N);
1942 Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
1943 Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
1944 Rtyp : Entity_Id;
1945
1946 begin
1947 if Is_Object_Image (Pref) then
1948 Rewrite_Object_Image
1949 (N, Pref, Name_Wide_Wide_Image, Standard_Wide_Wide_String);
1950 return;
1951 end if;
1952
1953 -- If Image should be transformed using Put_Image, then do so. See
1954 -- Exp_Put_Image for details.
1955
1956 if Exp_Put_Image.Image_Should_Call_Put_Image (N) then
1957 Rewrite (N, Exp_Put_Image.Build_Image_Call (N));
1958 Analyze_And_Resolve
1959 (N, Standard_Wide_Wide_String, Suppress => All_Checks);
1960 return;
1961 end if;
1962
1963 Rtyp := Root_Type (Entity (Pref));
1964
1965 Insert_Actions (N, New_List (
1966
1967 -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
1968
1969 Make_Object_Declaration (Loc,
1970 Defining_Identifier => Rnn,
1971 Object_Definition =>
1972 Make_Subtype_Indication (Loc,
1973 Subtype_Mark =>
1974 New_Occurrence_Of (Standard_Wide_Wide_String, Loc),
1975 Constraint =>
1976 Make_Index_Or_Discriminant_Constraint (Loc,
1977 Constraints => New_List (
1978 Make_Range (Loc,
1979 Low_Bound => Make_Integer_Literal (Loc, 1),
1980 High_Bound =>
1981 Make_Attribute_Reference (Loc,
1982 Prefix => New_Occurrence_Of (Rtyp, Loc),
1983 Attribute_Name => Name_Wide_Wide_Width)))))),
1984
1985 -- Lnn : Natural;
1986
1987 Make_Object_Declaration (Loc,
1988 Defining_Identifier => Lnn,
1989 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)),
1990
1991 -- String_To_Wide_Wide_String
1992 -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
1993
1994 Make_Procedure_Call_Statement (Loc,
1995 Name =>
1996 New_Occurrence_Of (RTE (RE_String_To_Wide_Wide_String), Loc),
1997
1998 Parameter_Associations => New_List (
1999 Make_Attribute_Reference (Loc,
2000 Prefix => Prefix (N),
2001 Attribute_Name => Name_Image,
2002 Expressions => Expressions (N)),
2003 New_Occurrence_Of (Rnn, Loc),
2004 New_Occurrence_Of (Lnn, Loc),
2005 Make_Integer_Literal (Loc,
2006 Intval => Int (Wide_Character_Encoding_Method))))),
2007
2008 -- Suppress checks because we know everything is properly in range
2009
2010 Suppress => All_Checks);
2011
2012 -- Final step is to rewrite the expression as a slice and analyze,
2013 -- again with no checks, since we are sure that everything is OK.
2014
2015 Rewrite (N,
2016 Make_Slice (Loc,
2017 Prefix => New_Occurrence_Of (Rnn, Loc),
2018 Discrete_Range =>
2019 Make_Range (Loc,
2020 Low_Bound => Make_Integer_Literal (Loc, 1),
2021 High_Bound => New_Occurrence_Of (Lnn, Loc))));
2022
2023 Analyze_And_Resolve
2024 (N, Standard_Wide_Wide_String, Suppress => All_Checks);
2025 end Expand_Wide_Wide_Image_Attribute;
2026
2027 ----------------------------
2028 -- Expand_Width_Attribute --
2029 ----------------------------
2030
2031 -- The processing here also handles the case of Wide_[Wide_]Width. With the
2032 -- exceptions noted, the processing is identical
2033
2034 -- For scalar types derived from Boolean, character and integer types
2035 -- in package Standard. Note that the Width attribute is computed at
2036 -- compile time for all cases except those involving non-static sub-
2037 -- types. For such subtypes, typ'[Wide_[Wide_]]Width expands into:
2038
2039 -- Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last)))
2040
2041 -- where
2042
2043 -- For types whose root type is Character
2044 -- xx = Width_Character
2045 -- yy = Character
2046
2047 -- For types whose root type is Wide_Character
2048 -- xx = Wide_Width_Character
2049 -- yy = Character
2050
2051 -- For types whose root type is Wide_Wide_Character
2052 -- xx = Wide_Wide_Width_Character
2053 -- yy = Character
2054
2055 -- For types whose root type is Boolean
2056 -- xx = Width_Boolean
2057 -- yy = Boolean
2058
2059 -- For signed integer types
2060 -- xx = Width_[Long_Long_[Long_]]Integer
2061 -- yy = [Long_Long_[Long_]]Integer
2062
2063 -- For modular integer types
2064 -- xx = Width_[Long_Long_[Long_]]Unsigned
2065 -- yy = [Long_Long_[Long_]]Unsigned
2066
2067 -- For types derived from Wide_Character, typ'Width expands into
2068
2069 -- Result_Type (Width_Wide_Character (
2070 -- Wide_Character (typ'First),
2071 -- Wide_Character (typ'Last),
2072
2073 -- and typ'Wide_Width expands into:
2074
2075 -- Result_Type (Wide_Width_Wide_Character (
2076 -- Wide_Character (typ'First),
2077 -- Wide_Character (typ'Last));
2078
2079 -- and typ'Wide_Wide_Width expands into
2080
2081 -- Result_Type (Wide_Wide_Width_Wide_Character (
2082 -- Wide_Character (typ'First),
2083 -- Wide_Character (typ'Last));
2084
2085 -- For types derived from Wide_Wide_Character, typ'Width expands into
2086
2087 -- Result_Type (Width_Wide_Wide_Character (
2088 -- Wide_Wide_Character (typ'First),
2089 -- Wide_Wide_Character (typ'Last),
2090
2091 -- and typ'Wide_Width expands into:
2092
2093 -- Result_Type (Wide_Width_Wide_Wide_Character (
2094 -- Wide_Wide_Character (typ'First),
2095 -- Wide_Wide_Character (typ'Last));
2096
2097 -- and typ'Wide_Wide_Width expands into
2098
2099 -- Result_Type (Wide_Wide_Width_Wide_Wide_Char (
2100 -- Wide_Wide_Character (typ'First),
2101 -- Wide_Wide_Character (typ'Last));
2102
2103 -- For fixed point types, typ'Width and typ'Wide_[Wide_]Width expand into
2104
2105 -- if Ptyp'First > Ptyp'Last then 0 else Ptyp'Fore + 1 + Ptyp'Aft end if
2106
2107 -- and for floating point types, they expand into
2108
2109 -- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if
2110
2111 -- where btyp is the base type. This looks recursive but it isn't
2112 -- because the base type is always static, and hence the expression
2113 -- in the else is reduced to an integer literal.
2114
2115 -- For user-defined enumeration types, typ'Width expands into
2116
2117 -- Result_Type (Width_Enumeration_NN
2118 -- (typS,
2119 -- typI'Address,
2120 -- typ'Pos (typ'First),
2121 -- typ'Pos (Typ'Last)));
2122
2123 -- and typ'Wide_Width expands into:
2124
2125 -- Result_Type (Wide_Width_Enumeration_NN
2126 -- (typS,
2127 -- typI,
2128 -- typ'Pos (typ'First),
2129 -- typ'Pos (Typ'Last))
2130 -- Wide_Character_Encoding_Method);
2131
2132 -- and typ'Wide_Wide_Width expands into:
2133
2134 -- Result_Type (Wide_Wide_Width_Enumeration_NN
2135 -- (typS,
2136 -- typI,
2137 -- typ'Pos (typ'First),
2138 -- typ'Pos (Typ'Last))
2139 -- Wide_Character_Encoding_Method);
2140
2141 -- where typS and typI are the enumeration image strings and indexes
2142 -- table, as described in Build_Enumeration_Image_Tables. NN is 8/16/32
2143 -- for depending on the element type for typI.
2144
2145 -- Finally if Discard_Names is in effect for an enumeration type, then
2146 -- a special if expression is built that yields the space needed for the
2147 -- decimal representation of the largest pos value in the subtype. See
2148 -- code below for details.
2149
2150 procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal) is
2151 Loc : constant Source_Ptr := Sloc (N);
2152 Typ : constant Entity_Id := Etype (N);
2153 Pref : constant Node_Id := Prefix (N);
2154 Ptyp : constant Entity_Id := Etype (Pref);
2155 Rtyp : constant Entity_Id := Root_Type (Ptyp);
2156 Arglist : List_Id;
2157 Ttyp : Entity_Id;
2158 XX : RE_Id;
2159 YY : Entity_Id;
2160
2161 begin
2162 -- Types derived from Standard.Boolean
2163
2164 if Rtyp = Standard_Boolean then
2165 XX := RE_Width_Boolean;
2166 YY := Rtyp;
2167
2168 -- Types derived from Standard.Character
2169
2170 elsif Rtyp = Standard_Character then
2171 case Attr is
2172 when Normal => XX := RE_Width_Character;
2173 when Wide => XX := RE_Wide_Width_Character;
2174 when Wide_Wide => XX := RE_Wide_Wide_Width_Character;
2175 end case;
2176
2177 YY := Rtyp;
2178
2179 -- Types derived from Standard.Wide_Character
2180
2181 elsif Rtyp = Standard_Wide_Character then
2182 case Attr is
2183 when Normal => XX := RE_Width_Wide_Character;
2184 when Wide => XX := RE_Wide_Width_Wide_Character;
2185 when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Character;
2186 end case;
2187
2188 YY := Rtyp;
2189
2190 -- Types derived from Standard.Wide_Wide_Character
2191
2192 elsif Rtyp = Standard_Wide_Wide_Character then
2193 case Attr is
2194 when Normal => XX := RE_Width_Wide_Wide_Character;
2195 when Wide => XX := RE_Wide_Width_Wide_Wide_Character;
2196 when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Wide_Char;
2197 end case;
2198
2199 YY := Rtyp;
2200
2201 -- Signed integer types
2202
2203 elsif Is_Signed_Integer_Type (Rtyp) then
2204 if Esize (Rtyp) <= Standard_Integer_Size then
2205 XX := RE_Width_Integer;
2206 YY := Standard_Integer;
2207 elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then
2208 XX := RE_Width_Long_Long_Integer;
2209 YY := Standard_Long_Long_Integer;
2210 else
2211 XX := RE_Width_Long_Long_Long_Integer;
2212 YY := Standard_Long_Long_Long_Integer;
2213 end if;
2214
2215 -- Modular integer types
2216
2217 elsif Is_Modular_Integer_Type (Rtyp) then
2218 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
2219 XX := RE_Width_Unsigned;
2220 YY := RTE (RE_Unsigned);
2221 elsif Modulus (Rtyp) <= Modulus (RTE (RE_Long_Long_Unsigned)) then
2222 XX := RE_Width_Long_Long_Unsigned;
2223 YY := RTE (RE_Long_Long_Unsigned);
2224 else
2225 XX := RE_Width_Long_Long_Long_Unsigned;
2226 YY := RTE (RE_Long_Long_Long_Unsigned);
2227 end if;
2228
2229 -- Fixed point types
2230
2231 elsif Is_Fixed_Point_Type (Rtyp) then
2232 Rewrite (N,
2233 Make_If_Expression (Loc,
2234 Expressions => New_List (
2235
2236 Make_Op_Gt (Loc,
2237 Left_Opnd =>
2238 Make_Attribute_Reference (Loc,
2239 Prefix => New_Occurrence_Of (Ptyp, Loc),
2240 Attribute_Name => Name_First),
2241
2242 Right_Opnd =>
2243 Make_Attribute_Reference (Loc,
2244 Prefix => New_Occurrence_Of (Ptyp, Loc),
2245 Attribute_Name => Name_Last)),
2246
2247 Make_Integer_Literal (Loc, 0),
2248
2249 Make_Op_Add (Loc,
2250 Make_Attribute_Reference (Loc,
2251 Prefix => New_Occurrence_Of (Ptyp, Loc),
2252 Attribute_Name => Name_Fore),
2253
2254 Make_Op_Add (Loc,
2255 Make_Integer_Literal (Loc, 1),
2256 Make_Integer_Literal (Loc, Aft_Value (Ptyp)))))));
2257
2258 Analyze_And_Resolve (N, Typ);
2259 return;
2260
2261 -- Floating point types
2262
2263 elsif Is_Floating_Point_Type (Rtyp) then
2264 Rewrite (N,
2265 Make_If_Expression (Loc,
2266 Expressions => New_List (
2267
2268 Make_Op_Gt (Loc,
2269 Left_Opnd =>
2270 Make_Attribute_Reference (Loc,
2271 Prefix => New_Occurrence_Of (Ptyp, Loc),
2272 Attribute_Name => Name_First),
2273
2274 Right_Opnd =>
2275 Make_Attribute_Reference (Loc,
2276 Prefix => New_Occurrence_Of (Ptyp, Loc),
2277 Attribute_Name => Name_Last)),
2278
2279 Make_Integer_Literal (Loc, 0),
2280
2281 Make_Attribute_Reference (Loc,
2282 Prefix => New_Occurrence_Of (Base_Type (Ptyp), Loc),
2283 Attribute_Name => Name_Width))));
2284
2285 Analyze_And_Resolve (N, Typ);
2286 return;
2287
2288 -- User-defined enumeration types
2289
2290 else
2291 pragma Assert (Is_Enumeration_Type (Rtyp));
2292
2293 -- Whenever pragma Discard_Names is in effect, the value we need
2294 -- is the value needed to accommodate the largest integer pos value
2295 -- in the range of the subtype + 1 for the space at the start. We
2296 -- build:
2297
2298 -- Tnn : constant Integer := Rtyp'Pos (Ptyp'Last)
2299
2300 -- and replace the expression by
2301
2302 -- (if Ptyp'Range_Length = 0 then 0
2303 -- else (if Tnn < 10 then 2
2304 -- else (if Tnn < 100 then 3
2305 -- ...
2306 -- else n)))...
2307
2308 -- where n is equal to Rtyp'Pos (Ptyp'Last) + 1
2309
2310 -- Note: The above processing is in accordance with the intent of
2311 -- the RM, which is that Width should be related to the impl-defined
2312 -- behavior of Image. It is not clear what this means if Image is
2313 -- not defined (as in the configurable run-time case for GNAT) and
2314 -- gives an error at compile time.
2315
2316 -- We choose in this case to just go ahead and implement Width the
2317 -- same way, returning what Image would have returned if it has been
2318 -- available in the configurable run-time library.
2319
2320 if Discard_Names (Rtyp) then
2321 declare
2322 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T');
2323 Cexpr : Node_Id;
2324 P : Int;
2325 M : Int;
2326 K : Int;
2327
2328 begin
2329 Insert_Action (N,
2330 Make_Object_Declaration (Loc,
2331 Defining_Identifier => Tnn,
2332 Constant_Present => True,
2333 Object_Definition =>
2334 New_Occurrence_Of (Standard_Integer, Loc),
2335 Expression =>
2336 Make_Attribute_Reference (Loc,
2337 Prefix => New_Occurrence_Of (Rtyp, Loc),
2338 Attribute_Name => Name_Pos,
2339 Expressions => New_List (
2340 Convert_To (Rtyp,
2341 Make_Attribute_Reference (Loc,
2342 Prefix => New_Occurrence_Of (Ptyp, Loc),
2343 Attribute_Name => Name_Last))))));
2344
2345 -- OK, now we need to build the if expression. First get the
2346 -- value of M, the largest possible value needed.
2347
2348 P := UI_To_Int
2349 (Enumeration_Pos (Entity (Type_High_Bound (Rtyp))));
2350
2351 K := 1;
2352 M := 1;
2353 while M < P loop
2354 M := M * 10;
2355 K := K + 1;
2356 end loop;
2357
2358 -- Build inner else
2359
2360 Cexpr := Make_Integer_Literal (Loc, K);
2361
2362 -- Wrap in inner if's until counted down to 2
2363
2364 while K > 2 loop
2365 M := M / 10;
2366 K := K - 1;
2367
2368 Cexpr :=
2369 Make_If_Expression (Loc,
2370 Expressions => New_List (
2371 Make_Op_Lt (Loc,
2372 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
2373 Right_Opnd => Make_Integer_Literal (Loc, M)),
2374 Make_Integer_Literal (Loc, K),
2375 Cexpr));
2376 end loop;
2377
2378 -- Add initial comparison for null range and we are done, so
2379 -- rewrite the attribute occurrence with this expression.
2380
2381 Rewrite (N,
2382 Convert_To (Typ,
2383 Make_If_Expression (Loc,
2384 Expressions => New_List (
2385 Make_Op_Eq (Loc,
2386 Left_Opnd =>
2387 Make_Attribute_Reference (Loc,
2388 Prefix => New_Occurrence_Of (Ptyp, Loc),
2389 Attribute_Name => Name_Range_Length),
2390 Right_Opnd => Make_Integer_Literal (Loc, 0)),
2391 Make_Integer_Literal (Loc, 0),
2392 Cexpr))));
2393
2394 Analyze_And_Resolve (N, Typ);
2395 return;
2396 end;
2397 end if;
2398
2399 -- Normal case, not Discard_Names
2400
2401 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
2402
2403 case Attr is
2404 when Normal =>
2405 if Ttyp = Standard_Integer_8 then
2406 XX := RE_Width_Enumeration_8;
2407 elsif Ttyp = Standard_Integer_16 then
2408 XX := RE_Width_Enumeration_16;
2409 else
2410 XX := RE_Width_Enumeration_32;
2411 end if;
2412
2413 when Wide =>
2414 if Ttyp = Standard_Integer_8 then
2415 XX := RE_Wide_Width_Enumeration_8;
2416 elsif Ttyp = Standard_Integer_16 then
2417 XX := RE_Wide_Width_Enumeration_16;
2418 else
2419 XX := RE_Wide_Width_Enumeration_32;
2420 end if;
2421
2422 when Wide_Wide =>
2423 if Ttyp = Standard_Integer_8 then
2424 XX := RE_Wide_Wide_Width_Enumeration_8;
2425 elsif Ttyp = Standard_Integer_16 then
2426 XX := RE_Wide_Wide_Width_Enumeration_16;
2427 else
2428 XX := RE_Wide_Wide_Width_Enumeration_32;
2429 end if;
2430 end case;
2431
2432 Arglist :=
2433 New_List (
2434 New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
2435
2436 Make_Attribute_Reference (Loc,
2437 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
2438 Attribute_Name => Name_Address),
2439
2440 Make_Attribute_Reference (Loc,
2441 Prefix => New_Occurrence_Of (Ptyp, Loc),
2442 Attribute_Name => Name_Pos,
2443
2444 Expressions => New_List (
2445 Make_Attribute_Reference (Loc,
2446 Prefix => New_Occurrence_Of (Ptyp, Loc),
2447 Attribute_Name => Name_First))),
2448
2449 Make_Attribute_Reference (Loc,
2450 Prefix => New_Occurrence_Of (Ptyp, Loc),
2451 Attribute_Name => Name_Pos,
2452
2453 Expressions => New_List (
2454 Make_Attribute_Reference (Loc,
2455 Prefix => New_Occurrence_Of (Ptyp, Loc),
2456 Attribute_Name => Name_Last))));
2457
2458 Rewrite (N,
2459 Convert_To (Typ,
2460 Make_Function_Call (Loc,
2461 Name => New_Occurrence_Of (RTE (XX), Loc),
2462 Parameter_Associations => Arglist)));
2463
2464 Analyze_And_Resolve (N, Typ);
2465 return;
2466 end if;
2467
2468 -- If we fall through XX and YY are set
2469
2470 Arglist := New_List (
2471 Convert_To (YY,
2472 Make_Attribute_Reference (Loc,
2473 Prefix => New_Occurrence_Of (Ptyp, Loc),
2474 Attribute_Name => Name_First)),
2475
2476 Convert_To (YY,
2477 Make_Attribute_Reference (Loc,
2478 Prefix => New_Occurrence_Of (Ptyp, Loc),
2479 Attribute_Name => Name_Last)));
2480
2481 Rewrite (N,
2482 Convert_To (Typ,
2483 Make_Function_Call (Loc,
2484 Name => New_Occurrence_Of (RTE (XX), Loc),
2485 Parameter_Associations => Arglist)));
2486
2487 Analyze_And_Resolve (N, Typ);
2488 end Expand_Width_Attribute;
2489
2490 --------------------------
2491 -- Rewrite_Object_Image --
2492 --------------------------
2493
2494 procedure Rewrite_Object_Image
2495 (N : Node_Id;
2496 Pref : Node_Id;
2497 Attr_Name : Name_Id;
2498 Str_Typ : Entity_Id)
2499 is
2500 Ptyp : Entity_Id;
2501
2502 begin
2503 Ptyp := Etype (Pref);
2504
2505 -- If the prefix is a component that depends on a discriminant, then
2506 -- create an actual subtype for it.
2507
2508 if Nkind (Pref) = N_Selected_Component then
2509 declare
2510 Decl : constant Node_Id :=
2511 Build_Actual_Subtype_Of_Component (Ptyp, Pref);
2512 begin
2513 if Present (Decl) then
2514 Insert_Action (N, Decl);
2515 Ptyp := Defining_Identifier (Decl);
2516 end if;
2517 end;
2518 end if;
2519
2520 Rewrite (N,
2521 Make_Attribute_Reference (Sloc (N),
2522 Prefix => New_Occurrence_Of (Ptyp, Sloc (N)),
2523 Attribute_Name => Attr_Name,
2524 Expressions => New_List (Unchecked_Convert_To (Ptyp, Pref))));
2525
2526 Analyze_And_Resolve (N, Str_Typ);
2527 end Rewrite_Object_Image;
2528 end Exp_Imgv;
Mirror of the offical gcc git repository hosted at gcc.gnu.org