File : a-wtedit.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- A D A . W I D E _ T E X T _ I O . E D I T I N G --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2013, 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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 with Ada.Strings.Fixed;
33 with Ada.Strings.Wide_Fixed;
34
35 package body Ada.Wide_Text_IO.Editing is
36
37 package Strings renames Ada.Strings;
38 package Strings_Fixed renames Ada.Strings.Fixed;
39 package Strings_Wide_Fixed renames Ada.Strings.Wide_Fixed;
40 package Wide_Text_IO renames Ada.Wide_Text_IO;
41
42 -----------------------
43 -- Local_Subprograms --
44 -----------------------
45
46 function To_Wide (C : Character) return Wide_Character;
47 pragma Inline (To_Wide);
48 -- Convert Character to corresponding Wide_Character
49
50 ---------------------
51 -- Blank_When_Zero --
52 ---------------------
53
54 function Blank_When_Zero (Pic : Picture) return Boolean is
55 begin
56 return Pic.Contents.Original_BWZ;
57 end Blank_When_Zero;
58
59 --------------------
60 -- Decimal_Output --
61 --------------------
62
63 package body Decimal_Output is
64
65 -----------
66 -- Image --
67 -----------
68
69 function Image
70 (Item : Num;
71 Pic : Picture;
72 Currency : Wide_String := Default_Currency;
73 Fill : Wide_Character := Default_Fill;
74 Separator : Wide_Character := Default_Separator;
75 Radix_Mark : Wide_Character := Default_Radix_Mark) return Wide_String
76 is
77 begin
78 return Format_Number
79 (Pic.Contents, Num'Image (Item),
80 Currency, Fill, Separator, Radix_Mark);
81 end Image;
82
83 ------------
84 -- Length --
85 ------------
86
87 function Length
88 (Pic : Picture;
89 Currency : Wide_String := Default_Currency) return Natural
90 is
91 Picstr : constant String := Pic_String (Pic);
92 V_Adjust : Integer := 0;
93 Cur_Adjust : Integer := 0;
94
95 begin
96 -- Check if Picstr has 'V' or '$'
97
98 -- If 'V', then length is 1 less than otherwise
99
100 -- If '$', then length is Currency'Length-1 more than otherwise
101
102 -- This should use the string handling package ???
103
104 for J in Picstr'Range loop
105 if Picstr (J) = 'V' then
106 V_Adjust := -1;
107
108 elsif Picstr (J) = '$' then
109 Cur_Adjust := Currency'Length - 1;
110 end if;
111 end loop;
112
113 return Picstr'Length - V_Adjust + Cur_Adjust;
114 end Length;
115
116 ---------
117 -- Put --
118 ---------
119
120 procedure Put
121 (File : Wide_Text_IO.File_Type;
122 Item : Num;
123 Pic : Picture;
124 Currency : Wide_String := Default_Currency;
125 Fill : Wide_Character := Default_Fill;
126 Separator : Wide_Character := Default_Separator;
127 Radix_Mark : Wide_Character := Default_Radix_Mark)
128 is
129 begin
130 Wide_Text_IO.Put (File, Image (Item, Pic,
131 Currency, Fill, Separator, Radix_Mark));
132 end Put;
133
134 procedure Put
135 (Item : Num;
136 Pic : Picture;
137 Currency : Wide_String := Default_Currency;
138 Fill : Wide_Character := Default_Fill;
139 Separator : Wide_Character := Default_Separator;
140 Radix_Mark : Wide_Character := Default_Radix_Mark)
141 is
142 begin
143 Wide_Text_IO.Put (Image (Item, Pic,
144 Currency, Fill, Separator, Radix_Mark));
145 end Put;
146
147 procedure Put
148 (To : out Wide_String;
149 Item : Num;
150 Pic : Picture;
151 Currency : Wide_String := Default_Currency;
152 Fill : Wide_Character := Default_Fill;
153 Separator : Wide_Character := Default_Separator;
154 Radix_Mark : Wide_Character := Default_Radix_Mark)
155 is
156 Result : constant Wide_String :=
157 Image (Item, Pic, Currency, Fill, Separator, Radix_Mark);
158
159 begin
160 if Result'Length > To'Length then
161 raise Wide_Text_IO.Layout_Error;
162 else
163 Strings_Wide_Fixed.Move (Source => Result, Target => To,
164 Justify => Strings.Right);
165 end if;
166 end Put;
167
168 -----------
169 -- Valid --
170 -----------
171
172 function Valid
173 (Item : Num;
174 Pic : Picture;
175 Currency : Wide_String := Default_Currency) return Boolean
176 is
177 begin
178 declare
179 Temp : constant Wide_String := Image (Item, Pic, Currency);
180 pragma Warnings (Off, Temp);
181 begin
182 return True;
183 end;
184
185 exception
186 when Layout_Error => return False;
187
188 end Valid;
189 end Decimal_Output;
190
191 ------------
192 -- Expand --
193 ------------
194
195 function Expand (Picture : String) return String is
196 Result : String (1 .. MAX_PICSIZE);
197 Picture_Index : Integer := Picture'First;
198 Result_Index : Integer := Result'First;
199 Count : Natural;
200 Last : Integer;
201
202 begin
203 if Picture'Length < 1 then
204 raise Picture_Error;
205 end if;
206
207 if Picture (Picture'First) = '(' then
208 raise Picture_Error;
209 end if;
210
211 loop
212 case Picture (Picture_Index) is
213
214 when '(' =>
215
216 -- We now need to scan out the count after a left paren. In
217 -- the non-wide version we used Integer_IO.Get, but that is
218 -- not convenient here, since we don't want to drag in normal
219 -- Text_IO just for this purpose. So we do the scan ourselves,
220 -- with the normal validity checks.
221
222 Last := Picture_Index + 1;
223 Count := 0;
224
225 if Picture (Last) not in '0' .. '9' then
226 raise Picture_Error;
227 end if;
228
229 Count := Character'Pos (Picture (Last)) - Character'Pos ('0');
230 Last := Last + 1;
231
232 loop
233 if Last > Picture'Last then
234 raise Picture_Error;
235 end if;
236
237 if Picture (Last) = '_' then
238 if Picture (Last - 1) = '_' then
239 raise Picture_Error;
240 end if;
241
242 elsif Picture (Last) = ')' then
243 exit;
244
245 elsif Picture (Last) not in '0' .. '9' then
246 raise Picture_Error;
247
248 else
249 Count := Count * 10
250 + Character'Pos (Picture (Last)) -
251 Character'Pos ('0');
252 end if;
253
254 Last := Last + 1;
255 end loop;
256
257 -- In what follows note that one copy of the repeated
258 -- character has already been made, so a count of one is
259 -- no-op, and a count of zero erases a character.
260
261 for J in 2 .. Count loop
262 Result (Result_Index + J - 2) := Picture (Picture_Index - 1);
263 end loop;
264
265 Result_Index := Result_Index + Count - 1;
266
267 -- Last was a ')' throw it away too
268
269 Picture_Index := Last + 1;
270
271 when ')' =>
272 raise Picture_Error;
273
274 when others =>
275 Result (Result_Index) := Picture (Picture_Index);
276 Picture_Index := Picture_Index + 1;
277 Result_Index := Result_Index + 1;
278
279 end case;
280
281 exit when Picture_Index > Picture'Last;
282 end loop;
283
284 return Result (1 .. Result_Index - 1);
285
286 exception
287 when others =>
288 raise Picture_Error;
289 end Expand;
290
291 -------------------
292 -- Format_Number --
293 -------------------
294
295 function Format_Number
296 (Pic : Format_Record;
297 Number : String;
298 Currency_Symbol : Wide_String;
299 Fill_Character : Wide_Character;
300 Separator_Character : Wide_Character;
301 Radix_Point : Wide_Character) return Wide_String
302 is
303 Attrs : Number_Attributes := Parse_Number_String (Number);
304 Position : Integer;
305 Rounded : String := Number;
306
307 Sign_Position : Integer := Pic.Sign_Position; -- may float.
308
309 Answer : Wide_String (1 .. Pic.Picture.Length);
310 Last : Integer;
311 Currency_Pos : Integer := Pic.Start_Currency;
312
313 Dollar : Boolean := False;
314 -- Overridden immediately if necessary
315
316 Zero : Boolean := True;
317 -- Set to False when a non-zero digit is output
318
319 begin
320
321 -- If the picture has fewer decimal places than the number, the image
322 -- must be rounded according to the usual rules.
323
324 if Attrs.Has_Fraction then
325 declare
326 R : constant Integer :=
327 (Attrs.End_Of_Fraction - Attrs.Start_Of_Fraction + 1)
328 - Pic.Max_Trailing_Digits;
329 R_Pos : Integer;
330
331 begin
332 if R > 0 then
333 R_Pos := Rounded'Length - R;
334
335 if Rounded (R_Pos + 1) > '4' then
336
337 if Rounded (R_Pos) = '.' then
338 R_Pos := R_Pos - 1;
339 end if;
340
341 if Rounded (R_Pos) /= '9' then
342 Rounded (R_Pos) := Character'Succ (Rounded (R_Pos));
343 else
344 Rounded (R_Pos) := '0';
345 R_Pos := R_Pos - 1;
346
347 while R_Pos > 1 loop
348 if Rounded (R_Pos) = '.' then
349 R_Pos := R_Pos - 1;
350 end if;
351
352 if Rounded (R_Pos) /= '9' then
353 Rounded (R_Pos) := Character'Succ (Rounded (R_Pos));
354 exit;
355 else
356 Rounded (R_Pos) := '0';
357 R_Pos := R_Pos - 1;
358 end if;
359 end loop;
360
361 -- The rounding may add a digit in front. Either the
362 -- leading blank or the sign (already captured) can be
363 -- overwritten.
364
365 if R_Pos = 1 then
366 Rounded (R_Pos) := '1';
367 Attrs.Start_Of_Int := Attrs.Start_Of_Int - 1;
368 end if;
369 end if;
370 end if;
371 end if;
372 end;
373 end if;
374
375 for J in Answer'Range loop
376 Answer (J) := To_Wide (Pic.Picture.Expanded (J));
377 end loop;
378
379 if Pic.Start_Currency /= Invalid_Position then
380 Dollar := Answer (Pic.Start_Currency) = '$';
381 end if;
382
383 -- Fix up "direct inserts" outside the playing field. Set up as one
384 -- loop to do the beginning, one (reverse) loop to do the end.
385
386 Last := 1;
387 loop
388 exit when Last = Pic.Start_Float;
389 exit when Last = Pic.Radix_Position;
390 exit when Answer (Last) = '9';
391
392 case Answer (Last) is
393
394 when '_' =>
395 Answer (Last) := Separator_Character;
396
397 when 'b' =>
398 Answer (Last) := ' ';
399
400 when others =>
401 null;
402
403 end case;
404
405 exit when Last = Answer'Last;
406
407 Last := Last + 1;
408 end loop;
409
410 -- Now for the end...
411
412 for J in reverse Last .. Answer'Last loop
413 exit when J = Pic.Radix_Position;
414
415 -- Do this test First, Separator_Character can equal Pic.Floater
416
417 if Answer (J) = Pic.Floater then
418 exit;
419 end if;
420
421 case Answer (J) is
422
423 when '_' =>
424 Answer (J) := Separator_Character;
425
426 when 'b' =>
427 Answer (J) := ' ';
428
429 when '9' =>
430 exit;
431
432 when others =>
433 null;
434
435 end case;
436 end loop;
437
438 -- Non-floating sign
439
440 if Pic.Start_Currency /= -1
441 and then Answer (Pic.Start_Currency) = '#'
442 and then Pic.Floater /= '#'
443 then
444 if Currency_Symbol'Length >
445 Pic.End_Currency - Pic.Start_Currency + 1
446 then
447 raise Picture_Error;
448
449 elsif Currency_Symbol'Length =
450 Pic.End_Currency - Pic.Start_Currency + 1
451 then
452 Answer (Pic.Start_Currency .. Pic.End_Currency) :=
453 Currency_Symbol;
454
455 elsif Pic.Radix_Position = Invalid_Position
456 or else Pic.Start_Currency < Pic.Radix_Position
457 then
458 Answer (Pic.Start_Currency .. Pic.End_Currency) :=
459 (others => ' ');
460 Answer (Pic.End_Currency - Currency_Symbol'Length + 1 ..
461 Pic.End_Currency) := Currency_Symbol;
462
463 else
464 Answer (Pic.Start_Currency .. Pic.End_Currency) :=
465 (others => ' ');
466 Answer (Pic.Start_Currency ..
467 Pic.Start_Currency + Currency_Symbol'Length - 1) :=
468 Currency_Symbol;
469 end if;
470 end if;
471
472 -- Fill in leading digits
473
474 if Attrs.End_Of_Int - Attrs.Start_Of_Int + 1 >
475 Pic.Max_Leading_Digits
476 then
477 raise Layout_Error;
478 end if;
479
480 Position :=
481 (if Pic.Radix_Position = Invalid_Position then Answer'Last
482 else Pic.Radix_Position - 1);
483
484 for J in reverse Attrs.Start_Of_Int .. Attrs.End_Of_Int loop
485 while Answer (Position) /= '9'
486 and then
487 Answer (Position) /= Pic.Floater
488 loop
489 if Answer (Position) = '_' then
490 Answer (Position) := Separator_Character;
491 elsif Answer (Position) = 'b' then
492 Answer (Position) := ' ';
493 end if;
494
495 Position := Position - 1;
496 end loop;
497
498 Answer (Position) := To_Wide (Rounded (J));
499
500 if Rounded (J) /= '0' then
501 Zero := False;
502 end if;
503
504 Position := Position - 1;
505 end loop;
506
507 -- Do lead float
508
509 if Pic.Start_Float = Invalid_Position then
510
511 -- No leading floats, but need to change '9' to '0', '_' to
512 -- Separator_Character and 'b' to ' '.
513
514 for J in Last .. Position loop
515
516 -- Last set when fixing the "uninteresting" leaders above.
517 -- Don't duplicate the work.
518
519 if Answer (J) = '9' then
520 Answer (J) := '0';
521
522 elsif Answer (J) = '_' then
523 Answer (J) := Separator_Character;
524
525 elsif Answer (J) = 'b' then
526 Answer (J) := ' ';
527
528 end if;
529
530 end loop;
531
532 elsif Pic.Floater = '<'
533 or else
534 Pic.Floater = '+'
535 or else
536 Pic.Floater = '-'
537 then
538 for J in Pic.End_Float .. Position loop -- May be null range
539 if Answer (J) = '9' then
540 Answer (J) := '0';
541
542 elsif Answer (J) = '_' then
543 Answer (J) := Separator_Character;
544
545 elsif Answer (J) = 'b' then
546 Answer (J) := ' ';
547
548 end if;
549 end loop;
550
551 if Position > Pic.End_Float then
552 Position := Pic.End_Float;
553 end if;
554
555 for J in Pic.Start_Float .. Position - 1 loop
556 Answer (J) := ' ';
557 end loop;
558
559 Answer (Position) := Pic.Floater;
560 Sign_Position := Position;
561
562 elsif Pic.Floater = '$' then
563
564 for J in Pic.End_Float .. Position loop -- May be null range
565 if Answer (J) = '9' then
566 Answer (J) := '0';
567
568 elsif Answer (J) = '_' then
569 Answer (J) := ' '; -- no separator before leftmost digit
570
571 elsif Answer (J) = 'b' then
572 Answer (J) := ' ';
573 end if;
574 end loop;
575
576 if Position > Pic.End_Float then
577 Position := Pic.End_Float;
578 end if;
579
580 for J in Pic.Start_Float .. Position - 1 loop
581 Answer (J) := ' ';
582 end loop;
583
584 Answer (Position) := Pic.Floater;
585 Currency_Pos := Position;
586
587 elsif Pic.Floater = '*' then
588
589 for J in Pic.End_Float .. Position loop -- May be null range
590 if Answer (J) = '9' then
591 Answer (J) := '0';
592
593 elsif Answer (J) = '_' then
594 Answer (J) := Separator_Character;
595
596 elsif Answer (J) = 'b' then
597 Answer (J) := '*';
598 end if;
599 end loop;
600
601 if Position > Pic.End_Float then
602 Position := Pic.End_Float;
603 end if;
604
605 for J in Pic.Start_Float .. Position loop
606 Answer (J) := '*';
607 end loop;
608
609 else
610 if Pic.Floater = '#' then
611 Currency_Pos := Currency_Symbol'Length;
612 end if;
613
614 for J in reverse Pic.Start_Float .. Position loop
615 case Answer (J) is
616
617 when '*' =>
618 Answer (J) := Fill_Character;
619
620 when 'Z' | 'b' | '/' | '0' =>
621 Answer (J) := ' ';
622
623 when '9' =>
624 Answer (J) := '0';
625
626 when '.' | 'V' | 'v' | '<' | '$' | '+' | '-' =>
627 null;
628
629 when '#' =>
630 if Currency_Pos = 0 then
631 Answer (J) := ' ';
632 else
633 Answer (J) := Currency_Symbol (Currency_Pos);
634 Currency_Pos := Currency_Pos - 1;
635 end if;
636
637 when '_' =>
638
639 case Pic.Floater is
640
641 when '*' =>
642 Answer (J) := Fill_Character;
643
644 when 'Z' | 'b' =>
645 Answer (J) := ' ';
646
647 when '#' =>
648 if Currency_Pos = 0 then
649 Answer (J) := ' ';
650
651 else
652 Answer (J) := Currency_Symbol (Currency_Pos);
653 Currency_Pos := Currency_Pos - 1;
654 end if;
655
656 when others =>
657 null;
658
659 end case;
660
661 when others =>
662 null;
663
664 end case;
665 end loop;
666
667 if Pic.Floater = '#' and then Currency_Pos /= 0 then
668 raise Layout_Error;
669 end if;
670 end if;
671
672 -- Do sign
673
674 if Sign_Position = Invalid_Position then
675 if Attrs.Negative then
676 raise Layout_Error;
677 end if;
678
679 else
680 if Attrs.Negative then
681 case Answer (Sign_Position) is
682 when 'C' | 'D' | '-' =>
683 null;
684
685 when '+' =>
686 Answer (Sign_Position) := '-';
687
688 when '<' =>
689 Answer (Sign_Position) := '(';
690 Answer (Pic.Second_Sign) := ')';
691
692 when others =>
693 raise Picture_Error;
694
695 end case;
696
697 else -- positive
698
699 case Answer (Sign_Position) is
700
701 when '-' =>
702 Answer (Sign_Position) := ' ';
703
704 when '<' | 'C' | 'D' =>
705 Answer (Sign_Position) := ' ';
706 Answer (Pic.Second_Sign) := ' ';
707
708 when '+' =>
709 null;
710
711 when others =>
712 raise Picture_Error;
713
714 end case;
715 end if;
716 end if;
717
718 -- Fill in trailing digits
719
720 if Pic.Max_Trailing_Digits > 0 then
721
722 if Attrs.Has_Fraction then
723 Position := Attrs.Start_Of_Fraction;
724 Last := Pic.Radix_Position + 1;
725
726 for J in Last .. Answer'Last loop
727
728 if Answer (J) = '9' or else Answer (J) = Pic.Floater then
729 Answer (J) := To_Wide (Rounded (Position));
730
731 if Rounded (Position) /= '0' then
732 Zero := False;
733 end if;
734
735 Position := Position + 1;
736 Last := J + 1;
737
738 -- Used up fraction but remember place in Answer
739
740 exit when Position > Attrs.End_Of_Fraction;
741
742 elsif Answer (J) = 'b' then
743 Answer (J) := ' ';
744
745 elsif Answer (J) = '_' then
746 Answer (J) := Separator_Character;
747
748 end if;
749
750 Last := J + 1;
751 end loop;
752
753 Position := Last;
754
755 else
756 Position := Pic.Radix_Position + 1;
757 end if;
758
759 -- Now fill remaining 9's with zeros and _ with separators
760
761 Last := Answer'Last;
762
763 for J in Position .. Last loop
764 if Answer (J) = '9' then
765 Answer (J) := '0';
766
767 elsif Answer (J) = Pic.Floater then
768 Answer (J) := '0';
769
770 elsif Answer (J) = '_' then
771 Answer (J) := Separator_Character;
772
773 elsif Answer (J) = 'b' then
774 Answer (J) := ' ';
775
776 end if;
777 end loop;
778
779 Position := Last + 1;
780
781 else
782 if Pic.Floater = '#' and then Currency_Pos /= 0 then
783 raise Layout_Error;
784 end if;
785
786 -- No trailing digits, but now J may need to stick in a currency
787 -- symbol or sign.
788
789 Position :=
790 (if Pic.Start_Currency = Invalid_Position then Answer'Last + 1
791 else Pic.Start_Currency);
792 end if;
793
794 for J in Position .. Answer'Last loop
795 if Pic.Start_Currency /= Invalid_Position
796 and then Answer (Pic.Start_Currency) = '#'
797 then
798 Currency_Pos := 1;
799 end if;
800
801 -- Note: There are some weird cases J can imagine with 'b' or '#' in
802 -- currency strings where the following code will cause glitches. The
803 -- trick is to tell when the character in the answer should be
804 -- checked, and when to look at the original string. Some other time.
805 -- RIE 11/26/96 ???
806
807 case Answer (J) is
808 when '*' =>
809 Answer (J) := Fill_Character;
810
811 when 'b' =>
812 Answer (J) := ' ';
813
814 when '#' =>
815 if Currency_Pos > Currency_Symbol'Length then
816 Answer (J) := ' ';
817
818 else
819 Answer (J) := Currency_Symbol (Currency_Pos);
820 Currency_Pos := Currency_Pos + 1;
821 end if;
822
823 when '_' =>
824
825 case Pic.Floater is
826
827 when '*' =>
828 Answer (J) := Fill_Character;
829
830 when 'Z' | 'z' =>
831 Answer (J) := ' ';
832
833 when '#' =>
834 if Currency_Pos > Currency_Symbol'Length then
835 Answer (J) := ' ';
836 else
837 Answer (J) := Currency_Symbol (Currency_Pos);
838 Currency_Pos := Currency_Pos + 1;
839 end if;
840
841 when others =>
842 null;
843
844 end case;
845
846 when others =>
847 exit;
848
849 end case;
850 end loop;
851
852 -- Now get rid of Blank_when_Zero and complete Star fill
853
854 if Zero and then Pic.Blank_When_Zero then
855
856 -- Value is zero, and blank it
857
858 Last := Answer'Last;
859
860 if Dollar then
861 Last := Last - 1 + Currency_Symbol'Length;
862 end if;
863
864 if Pic.Radix_Position /= Invalid_Position
865 and then Answer (Pic.Radix_Position) = 'V'
866 then
867 Last := Last - 1;
868 end if;
869
870 return Wide_String'(1 .. Last => ' ');
871
872 elsif Zero and then Pic.Star_Fill then
873 Last := Answer'Last;
874
875 if Dollar then
876 Last := Last - 1 + Currency_Symbol'Length;
877 end if;
878
879 if Pic.Radix_Position /= Invalid_Position then
880
881 if Answer (Pic.Radix_Position) = 'V' then
882 Last := Last - 1;
883
884 elsif Dollar then
885 if Pic.Radix_Position > Pic.Start_Currency then
886 return Wide_String'(1 .. Pic.Radix_Position - 1 => '*') &
887 Radix_Point &
888 Wide_String'(Pic.Radix_Position + 1 .. Last => '*');
889
890 else
891 return
892 Wide_String'
893 (1 ..
894 Pic.Radix_Position + Currency_Symbol'Length - 2
895 => '*') &
896 Radix_Point &
897 Wide_String'
898 (Pic.Radix_Position + Currency_Symbol'Length .. Last
899 => '*');
900 end if;
901
902 else
903 return
904 Wide_String'(1 .. Pic.Radix_Position - 1 => '*') &
905 Radix_Point &
906 Wide_String'(Pic.Radix_Position + 1 .. Last => '*');
907 end if;
908 end if;
909
910 return Wide_String'(1 .. Last => '*');
911 end if;
912
913 -- This was once a simple return statement, now there are nine
914 -- different return cases. Not to mention the five above to deal
915 -- with zeros. Why not split things out?
916
917 -- Processing the radix and sign expansion separately would require
918 -- lots of copying--the string and some of its indexes--without
919 -- really simplifying the logic. The cases are:
920
921 -- 1) Expand $, replace '.' with Radix_Point
922 -- 2) No currency expansion, replace '.' with Radix_Point
923 -- 3) Expand $, radix blanked
924 -- 4) No currency expansion, radix blanked
925 -- 5) Elide V
926 -- 6) Expand $, Elide V
927 -- 7) Elide V, Expand $ (Two cases depending on order.)
928 -- 8) No radix, expand $
929 -- 9) No radix, no currency expansion
930
931 if Pic.Radix_Position /= Invalid_Position then
932
933 if Answer (Pic.Radix_Position) = '.' then
934 Answer (Pic.Radix_Position) := Radix_Point;
935
936 if Dollar then
937
938 -- 1) Expand $, replace '.' with Radix_Point
939
940 return
941 Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
942 Answer (Currency_Pos + 1 .. Answer'Last);
943
944 else
945 -- 2) No currency expansion, replace '.' with Radix_Point
946
947 return Answer;
948 end if;
949
950 elsif Answer (Pic.Radix_Position) = ' ' then -- blanked radix.
951 if Dollar then
952
953 -- 3) Expand $, radix blanked
954
955 return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
956 Answer (Currency_Pos + 1 .. Answer'Last);
957
958 else
959 -- 4) No expansion, radix blanked
960
961 return Answer;
962 end if;
963
964 -- V cases
965
966 else
967 if not Dollar then
968
969 -- 5) Elide V
970
971 return Answer (1 .. Pic.Radix_Position - 1) &
972 Answer (Pic.Radix_Position + 1 .. Answer'Last);
973
974 elsif Currency_Pos < Pic.Radix_Position then
975
976 -- 6) Expand $, Elide V
977
978 return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
979 Answer (Currency_Pos + 1 .. Pic.Radix_Position - 1) &
980 Answer (Pic.Radix_Position + 1 .. Answer'Last);
981
982 else
983 -- 7) Elide V, Expand $
984
985 return Answer (1 .. Pic.Radix_Position - 1) &
986 Answer (Pic.Radix_Position + 1 .. Currency_Pos - 1) &
987 Currency_Symbol &
988 Answer (Currency_Pos + 1 .. Answer'Last);
989 end if;
990 end if;
991
992 elsif Dollar then
993
994 -- 8) No radix, expand $
995
996 return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
997 Answer (Currency_Pos + 1 .. Answer'Last);
998
999 else
1000 -- 9) No radix, no currency expansion
1001
1002 return Answer;
1003 end if;
1004 end Format_Number;
1005
1006 -------------------------
1007 -- Parse_Number_String --
1008 -------------------------
1009
1010 function Parse_Number_String (Str : String) return Number_Attributes is
1011 Answer : Number_Attributes;
1012
1013 begin
1014 for J in Str'Range loop
1015 case Str (J) is
1016
1017 when ' ' =>
1018 null; -- ignore
1019
1020 when '1' .. '9' =>
1021
1022 -- Decide if this is the start of a number.
1023 -- If so, figure out which one...
1024
1025 if Answer.Has_Fraction then
1026 Answer.End_Of_Fraction := J;
1027 else
1028 if Answer.Start_Of_Int = Invalid_Position then
1029 -- start integer
1030 Answer.Start_Of_Int := J;
1031 end if;
1032 Answer.End_Of_Int := J;
1033 end if;
1034
1035 when '0' =>
1036
1037 -- Only count a zero before the decimal point if it follows a
1038 -- non-zero digit. After the decimal point, zeros will be
1039 -- counted if followed by a non-zero digit.
1040
1041 if not Answer.Has_Fraction then
1042 if Answer.Start_Of_Int /= Invalid_Position then
1043 Answer.End_Of_Int := J;
1044 end if;
1045 end if;
1046
1047 when '-' =>
1048
1049 -- Set negative
1050
1051 Answer.Negative := True;
1052
1053 when '.' =>
1054
1055 -- Close integer, start fraction
1056
1057 if Answer.Has_Fraction then
1058 raise Picture_Error;
1059 end if;
1060
1061 -- Two decimal points is a no-no
1062
1063 Answer.Has_Fraction := True;
1064 Answer.End_Of_Fraction := J;
1065
1066 -- Could leave this at Invalid_Position, but this seems the
1067 -- right way to indicate a null range...
1068
1069 Answer.Start_Of_Fraction := J + 1;
1070 Answer.End_Of_Int := J - 1;
1071
1072 when others =>
1073 raise Picture_Error; -- can this happen? probably not
1074 end case;
1075 end loop;
1076
1077 if Answer.Start_Of_Int = Invalid_Position then
1078 Answer.Start_Of_Int := Answer.End_Of_Int + 1;
1079 end if;
1080
1081 -- No significant (intger) digits needs a null range
1082
1083 return Answer;
1084 end Parse_Number_String;
1085
1086 ----------------
1087 -- Pic_String --
1088 ----------------
1089
1090 -- The following ensures that we return B and not b being careful not
1091 -- to break things which expect lower case b for blank. See CXF3A02.
1092
1093 function Pic_String (Pic : Picture) return String is
1094 Temp : String (1 .. Pic.Contents.Picture.Length) :=
1095 Pic.Contents.Picture.Expanded;
1096 begin
1097 for J in Temp'Range loop
1098 if Temp (J) = 'b' then
1099 Temp (J) := 'B';
1100 end if;
1101 end loop;
1102
1103 return Temp;
1104 end Pic_String;
1105
1106 ------------------
1107 -- Precalculate --
1108 ------------------
1109
1110 procedure Precalculate (Pic : in out Format_Record) is
1111
1112 Computed_BWZ : Boolean := True;
1113
1114 type Legality is (Okay, Reject);
1115 State : Legality := Reject;
1116 -- Start in reject, which will reject null strings
1117
1118 Index : Pic_Index := Pic.Picture.Expanded'First;
1119
1120 function At_End return Boolean;
1121 pragma Inline (At_End);
1122
1123 procedure Set_State (L : Legality);
1124 pragma Inline (Set_State);
1125
1126 function Look return Character;
1127 pragma Inline (Look);
1128
1129 function Is_Insert return Boolean;
1130 pragma Inline (Is_Insert);
1131
1132 procedure Skip;
1133 pragma Inline (Skip);
1134
1135 procedure Trailing_Currency;
1136 procedure Trailing_Bracket;
1137 procedure Number_Fraction;
1138 procedure Number_Completion;
1139 procedure Number_Fraction_Or_Bracket;
1140 procedure Number_Fraction_Or_Z_Fill;
1141 procedure Zero_Suppression;
1142 procedure Floating_Bracket;
1143 procedure Number_Fraction_Or_Star_Fill;
1144 procedure Star_Suppression;
1145 procedure Number_Fraction_Or_Dollar;
1146 procedure Leading_Dollar;
1147 procedure Number_Fraction_Or_Pound;
1148 procedure Leading_Pound;
1149 procedure Picture;
1150 procedure Floating_Plus;
1151 procedure Floating_Minus;
1152 procedure Picture_Plus;
1153 procedure Picture_Minus;
1154 procedure Picture_Bracket;
1155 procedure Number;
1156 procedure Optional_RHS_Sign;
1157 procedure Picture_String;
1158
1159 ------------
1160 -- At_End --
1161 ------------
1162
1163 function At_End return Boolean is
1164 begin
1165 return Index > Pic.Picture.Length;
1166 end At_End;
1167
1168 ----------------------
1169 -- Floating_Bracket --
1170 ----------------------
1171
1172 -- Note that Floating_Bracket is only called with an acceptable
1173 -- prefix. But we don't set Okay, because we must end with a '>'.
1174
1175 procedure Floating_Bracket is
1176 begin
1177 Pic.Floater := '<';
1178 Pic.End_Float := Index;
1179 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1180
1181 -- First bracket wasn't counted...
1182
1183 Skip; -- known '<'
1184
1185 loop
1186 if At_End then
1187 return;
1188 end if;
1189
1190 case Look is
1191
1192 when '_' | '0' | '/' =>
1193 Pic.End_Float := Index;
1194 Skip;
1195
1196 when 'B' | 'b' =>
1197 Pic.End_Float := Index;
1198 Pic.Picture.Expanded (Index) := 'b';
1199 Skip;
1200
1201 when '<' =>
1202 Pic.End_Float := Index;
1203 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1204 Skip;
1205
1206 when '9' =>
1207 Number_Completion;
1208
1209 when '$' =>
1210 Leading_Dollar;
1211
1212 when '#' =>
1213 Leading_Pound;
1214
1215 when 'V' | 'v' | '.' =>
1216 Pic.Radix_Position := Index;
1217 Skip;
1218 Number_Fraction_Or_Bracket;
1219 return;
1220
1221 when others =>
1222 return;
1223 end case;
1224 end loop;
1225 end Floating_Bracket;
1226
1227 --------------------
1228 -- Floating_Minus --
1229 --------------------
1230
1231 procedure Floating_Minus is
1232 begin
1233 loop
1234 if At_End then
1235 return;
1236 end if;
1237
1238 case Look is
1239 when '_' | '0' | '/' =>
1240 Pic.End_Float := Index;
1241 Skip;
1242
1243 when 'B' | 'b' =>
1244 Pic.End_Float := Index;
1245 Pic.Picture.Expanded (Index) := 'b';
1246 Skip;
1247
1248 when '-' =>
1249 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1250 Pic.End_Float := Index;
1251 Skip;
1252
1253 when '9' =>
1254 Number_Completion;
1255 return;
1256
1257 when '.' | 'V' | 'v' =>
1258 Pic.Radix_Position := Index;
1259 Skip; -- Radix
1260
1261 while Is_Insert loop
1262 Skip;
1263 end loop;
1264
1265 if At_End then
1266 return;
1267 end if;
1268
1269 if Look = '-' then
1270 loop
1271 if At_End then
1272 return;
1273 end if;
1274
1275 case Look is
1276
1277 when '-' =>
1278 Pic.Max_Trailing_Digits :=
1279 Pic.Max_Trailing_Digits + 1;
1280 Pic.End_Float := Index;
1281 Skip;
1282
1283 when '_' | '0' | '/' =>
1284 Skip;
1285
1286 when 'B' | 'b' =>
1287 Pic.Picture.Expanded (Index) := 'b';
1288 Skip;
1289
1290 when others =>
1291 return;
1292
1293 end case;
1294 end loop;
1295
1296 else
1297 Number_Completion;
1298 end if;
1299
1300 return;
1301
1302 when others =>
1303 return;
1304 end case;
1305 end loop;
1306 end Floating_Minus;
1307
1308 -------------------
1309 -- Floating_Plus --
1310 -------------------
1311
1312 procedure Floating_Plus is
1313 begin
1314 loop
1315 if At_End then
1316 return;
1317 end if;
1318
1319 case Look is
1320 when '_' | '0' | '/' =>
1321 Pic.End_Float := Index;
1322 Skip;
1323
1324 when 'B' | 'b' =>
1325 Pic.End_Float := Index;
1326 Pic.Picture.Expanded (Index) := 'b';
1327 Skip;
1328
1329 when '+' =>
1330 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1331 Pic.End_Float := Index;
1332 Skip;
1333
1334 when '9' =>
1335 Number_Completion;
1336 return;
1337
1338 when '.' | 'V' | 'v' =>
1339 Pic.Radix_Position := Index;
1340 Skip; -- Radix
1341
1342 while Is_Insert loop
1343 Skip;
1344 end loop;
1345
1346 if At_End then
1347 return;
1348 end if;
1349
1350 if Look = '+' then
1351 loop
1352 if At_End then
1353 return;
1354 end if;
1355
1356 case Look is
1357
1358 when '+' =>
1359 Pic.Max_Trailing_Digits :=
1360 Pic.Max_Trailing_Digits + 1;
1361 Pic.End_Float := Index;
1362 Skip;
1363
1364 when '_' | '0' | '/' =>
1365 Skip;
1366
1367 when 'B' | 'b' =>
1368 Pic.Picture.Expanded (Index) := 'b';
1369 Skip;
1370
1371 when others =>
1372 return;
1373
1374 end case;
1375 end loop;
1376
1377 else
1378 Number_Completion;
1379 end if;
1380
1381 return;
1382
1383 when others =>
1384 return;
1385
1386 end case;
1387 end loop;
1388 end Floating_Plus;
1389
1390 ---------------
1391 -- Is_Insert --
1392 ---------------
1393
1394 function Is_Insert return Boolean is
1395 begin
1396 if At_End then
1397 return False;
1398 end if;
1399
1400 case Pic.Picture.Expanded (Index) is
1401
1402 when '_' | '0' | '/' => return True;
1403
1404 when 'B' | 'b' =>
1405 Pic.Picture.Expanded (Index) := 'b'; -- canonical
1406 return True;
1407
1408 when others => return False;
1409 end case;
1410 end Is_Insert;
1411
1412 --------------------
1413 -- Leading_Dollar --
1414 --------------------
1415
1416 -- Note that Leading_Dollar can be called in either State.
1417 -- It will set state to Okay only if a 9 or (second) $ is encountered.
1418
1419 -- Also notice the tricky bit with State and Zero_Suppression.
1420 -- Zero_Suppression is Picture_Error if a '$' or a '9' has been
1421 -- encountered, exactly the cases where State has been set.
1422
1423 procedure Leading_Dollar is
1424 begin
1425 -- Treat as a floating dollar, and unwind otherwise
1426
1427 Pic.Floater := '$';
1428 Pic.Start_Currency := Index;
1429 Pic.End_Currency := Index;
1430 Pic.Start_Float := Index;
1431 Pic.End_Float := Index;
1432
1433 -- Don't increment Pic.Max_Leading_Digits, we need one "real"
1434 -- currency place.
1435
1436 Skip; -- known '$'
1437
1438 loop
1439 if At_End then
1440 return;
1441 end if;
1442
1443 case Look is
1444
1445 when '_' | '0' | '/' =>
1446 Pic.End_Float := Index;
1447 Skip;
1448
1449 -- A trailing insertion character is not part of the
1450 -- floating currency, so need to look ahead.
1451
1452 if Look /= '$' then
1453 Pic.End_Float := Pic.End_Float - 1;
1454 end if;
1455
1456 when 'B' | 'b' =>
1457 Pic.End_Float := Index;
1458 Pic.Picture.Expanded (Index) := 'b';
1459 Skip;
1460
1461 when 'Z' | 'z' =>
1462 Pic.Picture.Expanded (Index) := 'Z'; -- consistency
1463
1464 if State = Okay then
1465 raise Picture_Error;
1466 else
1467 -- Will overwrite Floater and Start_Float
1468
1469 Zero_Suppression;
1470 end if;
1471
1472 when '*' =>
1473 if State = Okay then
1474 raise Picture_Error;
1475 else
1476 -- Will overwrite Floater and Start_Float
1477
1478 Star_Suppression;
1479 end if;
1480
1481 when '$' =>
1482 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1483 Pic.End_Float := Index;
1484 Pic.End_Currency := Index;
1485 Set_State (Okay); Skip;
1486
1487 when '9' =>
1488 if State /= Okay then
1489 Pic.Floater := '!';
1490 Pic.Start_Float := Invalid_Position;
1491 Pic.End_Float := Invalid_Position;
1492 end if;
1493
1494 -- A single dollar does not a floating make
1495
1496 Number_Completion;
1497 return;
1498
1499 when 'V' | 'v' | '.' =>
1500 if State /= Okay then
1501 Pic.Floater := '!';
1502 Pic.Start_Float := Invalid_Position;
1503 Pic.End_Float := Invalid_Position;
1504 end if;
1505
1506 -- Only one dollar before the sign is okay, but doesn't
1507 -- float.
1508
1509 Pic.Radix_Position := Index;
1510 Skip;
1511 Number_Fraction_Or_Dollar;
1512 return;
1513
1514 when others =>
1515 return;
1516
1517 end case;
1518 end loop;
1519 end Leading_Dollar;
1520
1521 -------------------
1522 -- Leading_Pound --
1523 -------------------
1524
1525 -- This one is complex. A Leading_Pound can be fixed or floating,
1526 -- but in some cases the decision has to be deferred until we leave
1527 -- this procedure. Also note that Leading_Pound can be called in
1528 -- either State.
1529
1530 -- It will set state to Okay only if a 9 or (second) # is
1531 -- encountered.
1532
1533 -- One Last note: In ambiguous cases, the currency is treated as
1534 -- floating unless there is only one '#'.
1535
1536 procedure Leading_Pound is
1537
1538 Inserts : Boolean := False;
1539 -- Set to True if a '_', '0', '/', 'B', or 'b' is encountered
1540
1541 Must_Float : Boolean := False;
1542 -- Set to true if a '#' occurs after an insert
1543
1544 begin
1545 -- Treat as a floating currency. If it isn't, this will be
1546 -- overwritten later.
1547
1548 Pic.Floater := '#';
1549
1550 Pic.Start_Currency := Index;
1551 Pic.End_Currency := Index;
1552 Pic.Start_Float := Index;
1553 Pic.End_Float := Index;
1554
1555 -- Don't increment Pic.Max_Leading_Digits, we need one "real"
1556 -- currency place.
1557
1558 Pic.Max_Currency_Digits := 1; -- we've seen one.
1559
1560 Skip; -- known '#'
1561
1562 loop
1563 if At_End then
1564 return;
1565 end if;
1566
1567 case Look is
1568
1569 when '_' | '0' | '/' =>
1570 Pic.End_Float := Index;
1571 Inserts := True;
1572 Skip;
1573
1574 when 'B' | 'b' =>
1575 Pic.Picture.Expanded (Index) := 'b';
1576 Pic.End_Float := Index;
1577 Inserts := True;
1578 Skip;
1579
1580 when 'Z' | 'z' =>
1581 Pic.Picture.Expanded (Index) := 'Z'; -- consistency
1582
1583 if Must_Float then
1584 raise Picture_Error;
1585 else
1586 Pic.Max_Leading_Digits := 0;
1587
1588 -- Will overwrite Floater and Start_Float
1589
1590 Zero_Suppression;
1591 end if;
1592
1593 when '*' =>
1594 if Must_Float then
1595 raise Picture_Error;
1596 else
1597 Pic.Max_Leading_Digits := 0;
1598
1599 -- Will overwrite Floater and Start_Float
1600
1601 Star_Suppression;
1602 end if;
1603
1604 when '#' =>
1605 if Inserts then
1606 Must_Float := True;
1607 end if;
1608
1609 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1610 Pic.End_Float := Index;
1611 Pic.End_Currency := Index;
1612 Set_State (Okay);
1613 Skip;
1614
1615 when '9' =>
1616 if State /= Okay then
1617
1618 -- A single '#' doesn't float
1619
1620 Pic.Floater := '!';
1621 Pic.Start_Float := Invalid_Position;
1622 Pic.End_Float := Invalid_Position;
1623 end if;
1624
1625 Number_Completion;
1626 return;
1627
1628 when 'V' | 'v' | '.' =>
1629 if State /= Okay then
1630 Pic.Floater := '!';
1631 Pic.Start_Float := Invalid_Position;
1632 Pic.End_Float := Invalid_Position;
1633 end if;
1634
1635 -- Only one pound before the sign is okay, but doesn't
1636 -- float.
1637
1638 Pic.Radix_Position := Index;
1639 Skip;
1640 Number_Fraction_Or_Pound;
1641 return;
1642
1643 when others =>
1644 return;
1645 end case;
1646 end loop;
1647 end Leading_Pound;
1648
1649 ----------
1650 -- Look --
1651 ----------
1652
1653 function Look return Character is
1654 begin
1655 if At_End then
1656 raise Picture_Error;
1657 end if;
1658
1659 return Pic.Picture.Expanded (Index);
1660 end Look;
1661
1662 ------------
1663 -- Number --
1664 ------------
1665
1666 procedure Number is
1667 begin
1668 loop
1669
1670 case Look is
1671 when '_' | '0' | '/' =>
1672 Skip;
1673
1674 when 'B' | 'b' =>
1675 Pic.Picture.Expanded (Index) := 'b';
1676 Skip;
1677
1678 when '9' =>
1679 Computed_BWZ := False;
1680 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1681 Set_State (Okay);
1682 Skip;
1683
1684 when '.' | 'V' | 'v' =>
1685 Pic.Radix_Position := Index;
1686 Skip;
1687 Number_Fraction;
1688 return;
1689
1690 when others =>
1691 return;
1692
1693 end case;
1694
1695 if At_End then
1696 return;
1697 end if;
1698
1699 -- Will return in Okay state if a '9' was seen
1700
1701 end loop;
1702 end Number;
1703
1704 -----------------------
1705 -- Number_Completion --
1706 -----------------------
1707
1708 procedure Number_Completion is
1709 begin
1710 while not At_End loop
1711 case Look is
1712
1713 when '_' | '0' | '/' =>
1714 Skip;
1715
1716 when 'B' | 'b' =>
1717 Pic.Picture.Expanded (Index) := 'b';
1718 Skip;
1719
1720 when '9' =>
1721 Computed_BWZ := False;
1722 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1723 Set_State (Okay);
1724 Skip;
1725
1726 when 'V' | 'v' | '.' =>
1727 Pic.Radix_Position := Index;
1728 Skip;
1729 Number_Fraction;
1730 return;
1731
1732 when others =>
1733 return;
1734 end case;
1735 end loop;
1736 end Number_Completion;
1737
1738 ---------------------
1739 -- Number_Fraction --
1740 ---------------------
1741
1742 procedure Number_Fraction is
1743 begin
1744 -- Note that number fraction can be called in either State.
1745 -- It will set state to Valid only if a 9 is encountered.
1746
1747 loop
1748 if At_End then
1749 return;
1750 end if;
1751
1752 case Look is
1753 when '_' | '0' | '/' =>
1754 Skip;
1755
1756 when 'B' | 'b' =>
1757 Pic.Picture.Expanded (Index) := 'b';
1758 Skip;
1759
1760 when '9' =>
1761 Computed_BWZ := False;
1762 Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1763 Set_State (Okay); Skip;
1764
1765 when others =>
1766 return;
1767 end case;
1768 end loop;
1769 end Number_Fraction;
1770
1771 --------------------------------
1772 -- Number_Fraction_Or_Bracket --
1773 --------------------------------
1774
1775 procedure Number_Fraction_Or_Bracket is
1776 begin
1777 loop
1778 if At_End then
1779 return;
1780 end if;
1781
1782 case Look is
1783
1784 when '_' | '0' | '/' => Skip;
1785
1786 when 'B' | 'b' =>
1787 Pic.Picture.Expanded (Index) := 'b';
1788 Skip;
1789
1790 when '<' =>
1791 Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1792 Pic.End_Float := Index;
1793 Skip;
1794
1795 loop
1796 if At_End then
1797 return;
1798 end if;
1799
1800 case Look is
1801 when '_' | '0' | '/' =>
1802 Skip;
1803
1804 when 'B' | 'b' =>
1805 Pic.Picture.Expanded (Index) := 'b';
1806 Skip;
1807
1808 when '<' =>
1809 Pic.Max_Trailing_Digits :=
1810 Pic.Max_Trailing_Digits + 1;
1811 Pic.End_Float := Index;
1812 Skip;
1813
1814 when others =>
1815 return;
1816 end case;
1817 end loop;
1818
1819 when others =>
1820 Number_Fraction;
1821 return;
1822 end case;
1823 end loop;
1824 end Number_Fraction_Or_Bracket;
1825
1826 -------------------------------
1827 -- Number_Fraction_Or_Dollar --
1828 -------------------------------
1829
1830 procedure Number_Fraction_Or_Dollar is
1831 begin
1832 loop
1833 if At_End then
1834 return;
1835 end if;
1836
1837 case Look is
1838 when '_' | '0' | '/' =>
1839 Skip;
1840
1841 when 'B' | 'b' =>
1842 Pic.Picture.Expanded (Index) := 'b';
1843 Skip;
1844
1845 when '$' =>
1846 Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1847 Pic.End_Float := Index;
1848 Skip;
1849
1850 loop
1851 if At_End then
1852 return;
1853 end if;
1854
1855 case Look is
1856 when '_' | '0' | '/' =>
1857 Skip;
1858
1859 when 'B' | 'b' =>
1860 Pic.Picture.Expanded (Index) := 'b';
1861 Skip;
1862
1863 when '$' =>
1864 Pic.Max_Trailing_Digits :=
1865 Pic.Max_Trailing_Digits + 1;
1866 Pic.End_Float := Index;
1867 Skip;
1868
1869 when others =>
1870 return;
1871 end case;
1872 end loop;
1873
1874 when others =>
1875 Number_Fraction;
1876 return;
1877 end case;
1878 end loop;
1879 end Number_Fraction_Or_Dollar;
1880
1881 ------------------------------
1882 -- Number_Fraction_Or_Pound --
1883 ------------------------------
1884
1885 procedure Number_Fraction_Or_Pound is
1886 begin
1887 loop
1888 if At_End then
1889 return;
1890 end if;
1891
1892 case Look is
1893
1894 when '_' | '0' | '/' =>
1895 Skip;
1896
1897 when 'B' | 'b' =>
1898 Pic.Picture.Expanded (Index) := 'b';
1899 Skip;
1900
1901 when '#' =>
1902 Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1903 Pic.End_Float := Index;
1904 Skip;
1905
1906 loop
1907 if At_End then
1908 return;
1909 end if;
1910
1911 case Look is
1912
1913 when '_' | '0' | '/' =>
1914 Skip;
1915
1916 when 'B' | 'b' =>
1917 Pic.Picture.Expanded (Index) := 'b';
1918 Skip;
1919
1920 when '#' =>
1921 Pic.Max_Trailing_Digits :=
1922 Pic.Max_Trailing_Digits + 1;
1923 Pic.End_Float := Index;
1924 Skip;
1925
1926 when others =>
1927 return;
1928
1929 end case;
1930 end loop;
1931
1932 when others =>
1933 Number_Fraction;
1934 return;
1935
1936 end case;
1937 end loop;
1938 end Number_Fraction_Or_Pound;
1939
1940 ----------------------------------
1941 -- Number_Fraction_Or_Star_Fill --
1942 ----------------------------------
1943
1944 procedure Number_Fraction_Or_Star_Fill is
1945 begin
1946 loop
1947 if At_End then
1948 return;
1949 end if;
1950
1951 case Look is
1952
1953 when '_' | '0' | '/' =>
1954 Skip;
1955
1956 when 'B' | 'b' =>
1957 Pic.Picture.Expanded (Index) := 'b';
1958 Skip;
1959
1960 when '*' =>
1961 Pic.Star_Fill := True;
1962 Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1963 Pic.End_Float := Index;
1964 Skip;
1965
1966 loop
1967 if At_End then
1968 return;
1969 end if;
1970
1971 case Look is
1972
1973 when '_' | '0' | '/' =>
1974 Skip;
1975
1976 when 'B' | 'b' =>
1977 Pic.Picture.Expanded (Index) := 'b';
1978 Skip;
1979
1980 when '*' =>
1981 Pic.Star_Fill := True;
1982 Pic.Max_Trailing_Digits :=
1983 Pic.Max_Trailing_Digits + 1;
1984 Pic.End_Float := Index;
1985 Skip;
1986
1987 when others =>
1988 return;
1989 end case;
1990 end loop;
1991
1992 when others =>
1993 Number_Fraction;
1994 return;
1995
1996 end case;
1997 end loop;
1998 end Number_Fraction_Or_Star_Fill;
1999
2000 -------------------------------
2001 -- Number_Fraction_Or_Z_Fill --
2002 -------------------------------
2003
2004 procedure Number_Fraction_Or_Z_Fill is
2005 begin
2006 loop
2007 if At_End then
2008 return;
2009 end if;
2010
2011 case Look is
2012
2013 when '_' | '0' | '/' =>
2014 Skip;
2015
2016 when 'B' | 'b' =>
2017 Pic.Picture.Expanded (Index) := 'b';
2018 Skip;
2019
2020 when 'Z' | 'z' =>
2021 Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
2022 Pic.End_Float := Index;
2023 Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2024
2025 Skip;
2026
2027 loop
2028 if At_End then
2029 return;
2030 end if;
2031
2032 case Look is
2033
2034 when '_' | '0' | '/' =>
2035 Skip;
2036
2037 when 'B' | 'b' =>
2038 Pic.Picture.Expanded (Index) := 'b';
2039 Skip;
2040
2041 when 'Z' | 'z' =>
2042 Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2043
2044 Pic.Max_Trailing_Digits :=
2045 Pic.Max_Trailing_Digits + 1;
2046 Pic.End_Float := Index;
2047 Skip;
2048
2049 when others =>
2050 return;
2051 end case;
2052 end loop;
2053
2054 when others =>
2055 Number_Fraction;
2056 return;
2057 end case;
2058 end loop;
2059 end Number_Fraction_Or_Z_Fill;
2060
2061 -----------------------
2062 -- Optional_RHS_Sign --
2063 -----------------------
2064
2065 procedure Optional_RHS_Sign is
2066 begin
2067 if At_End then
2068 return;
2069 end if;
2070
2071 case Look is
2072
2073 when '+' | '-' =>
2074 Pic.Sign_Position := Index;
2075 Skip;
2076 return;
2077
2078 when 'C' | 'c' =>
2079 Pic.Sign_Position := Index;
2080 Pic.Picture.Expanded (Index) := 'C';
2081 Skip;
2082
2083 if Look = 'R' or else Look = 'r' then
2084 Pic.Second_Sign := Index;
2085 Pic.Picture.Expanded (Index) := 'R';
2086 Skip;
2087
2088 else
2089 raise Picture_Error;
2090 end if;
2091
2092 return;
2093
2094 when 'D' | 'd' =>
2095 Pic.Sign_Position := Index;
2096 Pic.Picture.Expanded (Index) := 'D';
2097 Skip;
2098
2099 if Look = 'B' or else Look = 'b' then
2100 Pic.Second_Sign := Index;
2101 Pic.Picture.Expanded (Index) := 'B';
2102 Skip;
2103
2104 else
2105 raise Picture_Error;
2106 end if;
2107
2108 return;
2109
2110 when '>' =>
2111 if Pic.Picture.Expanded (Pic.Sign_Position) = '<' then
2112 Pic.Second_Sign := Index;
2113 Skip;
2114
2115 else
2116 raise Picture_Error;
2117 end if;
2118
2119 when others =>
2120 return;
2121
2122 end case;
2123 end Optional_RHS_Sign;
2124
2125 -------------
2126 -- Picture --
2127 -------------
2128
2129 -- Note that Picture can be called in either State
2130
2131 -- It will set state to Valid only if a 9 is encountered or floating
2132 -- currency is called.
2133
2134 procedure Picture is
2135 begin
2136 loop
2137 if At_End then
2138 return;
2139 end if;
2140
2141 case Look is
2142
2143 when '_' | '0' | '/' =>
2144 Skip;
2145
2146 when 'B' | 'b' =>
2147 Pic.Picture.Expanded (Index) := 'b';
2148 Skip;
2149
2150 when '$' =>
2151 Leading_Dollar;
2152 return;
2153
2154 when '#' =>
2155 Leading_Pound;
2156 return;
2157
2158 when '9' =>
2159 Computed_BWZ := False;
2160 Set_State (Okay);
2161 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2162 Skip;
2163
2164 when 'V' | 'v' | '.' =>
2165 Pic.Radix_Position := Index;
2166 Skip;
2167 Number_Fraction;
2168 Trailing_Currency;
2169 return;
2170
2171 when others =>
2172 return;
2173
2174 end case;
2175 end loop;
2176 end Picture;
2177
2178 ---------------------
2179 -- Picture_Bracket --
2180 ---------------------
2181
2182 procedure Picture_Bracket is
2183 begin
2184 Pic.Sign_Position := Index;
2185 Pic.Sign_Position := Index;
2186
2187 -- Treat as a floating sign, and unwind otherwise
2188
2189 Pic.Floater := '<';
2190 Pic.Start_Float := Index;
2191 Pic.End_Float := Index;
2192
2193 -- Don't increment Pic.Max_Leading_Digits, we need one "real"
2194 -- sign place.
2195
2196 Skip; -- Known Bracket
2197
2198 loop
2199 case Look is
2200
2201 when '_' | '0' | '/' =>
2202 Pic.End_Float := Index;
2203 Skip;
2204
2205 when 'B' | 'b' =>
2206 Pic.End_Float := Index;
2207 Pic.Picture.Expanded (Index) := 'b';
2208 Skip;
2209
2210 when '<' =>
2211 Set_State (Okay); -- "<<>" is enough.
2212 Floating_Bracket;
2213 Trailing_Currency;
2214 Trailing_Bracket;
2215 return;
2216
2217 when '$' | '#' | '9' | '*' =>
2218 if State /= Okay then
2219 Pic.Floater := '!';
2220 Pic.Start_Float := Invalid_Position;
2221 Pic.End_Float := Invalid_Position;
2222 end if;
2223
2224 Picture;
2225 Trailing_Bracket;
2226 Set_State (Okay);
2227 return;
2228
2229 when '.' | 'V' | 'v' =>
2230 if State /= Okay then
2231 Pic.Floater := '!';
2232 Pic.Start_Float := Invalid_Position;
2233 Pic.End_Float := Invalid_Position;
2234 end if;
2235
2236 -- Don't assume that state is okay, haven't seen a digit
2237
2238 Picture;
2239 Trailing_Bracket;
2240 return;
2241
2242 when others =>
2243 raise Picture_Error;
2244
2245 end case;
2246 end loop;
2247 end Picture_Bracket;
2248
2249 -------------------
2250 -- Picture_Minus --
2251 -------------------
2252
2253 procedure Picture_Minus is
2254 begin
2255 Pic.Sign_Position := Index;
2256
2257 -- Treat as a floating sign, and unwind otherwise
2258
2259 Pic.Floater := '-';
2260 Pic.Start_Float := Index;
2261 Pic.End_Float := Index;
2262
2263 -- Don't increment Pic.Max_Leading_Digits, we need one "real"
2264 -- sign place.
2265
2266 Skip; -- Known Minus
2267
2268 loop
2269 case Look is
2270
2271 when '_' | '0' | '/' =>
2272 Pic.End_Float := Index;
2273 Skip;
2274
2275 when 'B' | 'b' =>
2276 Pic.End_Float := Index;
2277 Pic.Picture.Expanded (Index) := 'b';
2278 Skip;
2279
2280 when '-' =>
2281 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2282 Pic.End_Float := Index;
2283 Skip;
2284 Set_State (Okay); -- "-- " is enough
2285 Floating_Minus;
2286 Trailing_Currency;
2287 return;
2288
2289 when '$' | '#' | '9' | '*' =>
2290 if State /= Okay then
2291 Pic.Floater := '!';
2292 Pic.Start_Float := Invalid_Position;
2293 Pic.End_Float := Invalid_Position;
2294 end if;
2295
2296 Picture;
2297 Set_State (Okay);
2298 return;
2299
2300 when 'Z' | 'z' =>
2301
2302 -- Can't have Z and a floating sign
2303
2304 if State = Okay then
2305 Set_State (Reject);
2306 end if;
2307
2308 Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2309 Zero_Suppression;
2310 Trailing_Currency;
2311 Optional_RHS_Sign;
2312 return;
2313
2314 when '.' | 'V' | 'v' =>
2315 if State /= Okay then
2316 Pic.Floater := '!';
2317 Pic.Start_Float := Invalid_Position;
2318 Pic.End_Float := Invalid_Position;
2319 end if;
2320
2321 -- Don't assume that state is okay, haven't seen a digit
2322
2323 Picture;
2324 return;
2325
2326 when others =>
2327 return;
2328
2329 end case;
2330 end loop;
2331 end Picture_Minus;
2332
2333 ------------------
2334 -- Picture_Plus --
2335 ------------------
2336
2337 procedure Picture_Plus is
2338 begin
2339 Pic.Sign_Position := Index;
2340
2341 -- Treat as a floating sign, and unwind otherwise
2342
2343 Pic.Floater := '+';
2344 Pic.Start_Float := Index;
2345 Pic.End_Float := Index;
2346
2347 -- Don't increment Pic.Max_Leading_Digits, we need one "real"
2348 -- sign place.
2349
2350 Skip; -- Known Plus
2351
2352 loop
2353 case Look is
2354
2355 when '_' | '0' | '/' =>
2356 Pic.End_Float := Index;
2357 Skip;
2358
2359 when 'B' | 'b' =>
2360 Pic.End_Float := Index;
2361 Pic.Picture.Expanded (Index) := 'b';
2362 Skip;
2363
2364 when '+' =>
2365 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2366 Pic.End_Float := Index;
2367 Skip;
2368 Set_State (Okay); -- "++" is enough
2369 Floating_Plus;
2370 Trailing_Currency;
2371 return;
2372
2373 when '$' | '#' | '9' | '*' =>
2374 if State /= Okay then
2375 Pic.Floater := '!';
2376 Pic.Start_Float := Invalid_Position;
2377 Pic.End_Float := Invalid_Position;
2378 end if;
2379
2380 Picture;
2381 Set_State (Okay);
2382 return;
2383
2384 when 'Z' | 'z' =>
2385 if State = Okay then
2386 Set_State (Reject);
2387 end if;
2388
2389 -- Can't have Z and a floating sign
2390
2391 Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2392
2393 -- '+Z' is acceptable
2394
2395 Set_State (Okay);
2396
2397 Zero_Suppression;
2398 Trailing_Currency;
2399 Optional_RHS_Sign;
2400 return;
2401
2402 when '.' | 'V' | 'v' =>
2403 if State /= Okay then
2404 Pic.Floater := '!';
2405 Pic.Start_Float := Invalid_Position;
2406 Pic.End_Float := Invalid_Position;
2407 end if;
2408
2409 -- Don't assume that state is okay, haven't seen a digit
2410
2411 Picture;
2412 return;
2413
2414 when others =>
2415 return;
2416
2417 end case;
2418 end loop;
2419 end Picture_Plus;
2420
2421 --------------------
2422 -- Picture_String --
2423 --------------------
2424
2425 procedure Picture_String is
2426 begin
2427 while Is_Insert loop
2428 Skip;
2429 end loop;
2430
2431 case Look is
2432
2433 when '$' | '#' =>
2434 Picture;
2435 Optional_RHS_Sign;
2436
2437 when '+' =>
2438 Picture_Plus;
2439
2440 when '-' =>
2441 Picture_Minus;
2442
2443 when '<' =>
2444 Picture_Bracket;
2445
2446 when 'Z' | 'z' =>
2447 Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2448 Zero_Suppression;
2449 Trailing_Currency;
2450 Optional_RHS_Sign;
2451
2452 when '*' =>
2453 Star_Suppression;
2454 Trailing_Currency;
2455 Optional_RHS_Sign;
2456
2457 when '9' | '.' | 'V' | 'v' =>
2458 Number;
2459 Trailing_Currency;
2460 Optional_RHS_Sign;
2461
2462 when others =>
2463 raise Picture_Error;
2464
2465 end case;
2466
2467 -- Blank when zero either if the PIC does not contain a '9' or if
2468 -- requested by the user and no '*'.
2469
2470 Pic.Blank_When_Zero :=
2471 (Computed_BWZ or else Pic.Blank_When_Zero)
2472 and then not Pic.Star_Fill;
2473
2474 -- Star fill if '*' and no '9'
2475
2476 Pic.Star_Fill := Pic.Star_Fill and then Computed_BWZ;
2477
2478 if not At_End then
2479 Set_State (Reject);
2480 end if;
2481
2482 end Picture_String;
2483
2484 ---------------
2485 -- Set_State --
2486 ---------------
2487
2488 procedure Set_State (L : Legality) is
2489 begin
2490 State := L;
2491 end Set_State;
2492
2493 ----------
2494 -- Skip --
2495 ----------
2496
2497 procedure Skip is
2498 begin
2499 Index := Index + 1;
2500 end Skip;
2501
2502 ----------------------
2503 -- Star_Suppression --
2504 ----------------------
2505
2506 procedure Star_Suppression is
2507 begin
2508 Pic.Floater := '*';
2509 Pic.Start_Float := Index;
2510 Pic.End_Float := Index;
2511 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2512 Set_State (Okay);
2513
2514 -- Even a single * is a valid picture
2515
2516 Pic.Star_Fill := True;
2517 Skip; -- Known *
2518
2519 loop
2520 if At_End then
2521 return;
2522 end if;
2523
2524 case Look is
2525
2526 when '_' | '0' | '/' =>
2527 Pic.End_Float := Index;
2528 Skip;
2529
2530 when 'B' | 'b' =>
2531 Pic.End_Float := Index;
2532 Pic.Picture.Expanded (Index) := 'b';
2533 Skip;
2534
2535 when '*' =>
2536 Pic.End_Float := Index;
2537 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2538 Set_State (Okay); Skip;
2539
2540 when '9' =>
2541 Set_State (Okay);
2542 Number_Completion;
2543 return;
2544
2545 when '.' | 'V' | 'v' =>
2546 Pic.Radix_Position := Index;
2547 Skip;
2548 Number_Fraction_Or_Star_Fill;
2549 return;
2550
2551 when '#' | '$' =>
2552 Trailing_Currency;
2553 Set_State (Okay);
2554 return;
2555
2556 when others => raise Picture_Error;
2557 end case;
2558 end loop;
2559 end Star_Suppression;
2560
2561 ----------------------
2562 -- Trailing_Bracket --
2563 ----------------------
2564
2565 procedure Trailing_Bracket is
2566 begin
2567 if Look = '>' then
2568 Pic.Second_Sign := Index;
2569 Skip;
2570 else
2571 raise Picture_Error;
2572 end if;
2573 end Trailing_Bracket;
2574
2575 -----------------------
2576 -- Trailing_Currency --
2577 -----------------------
2578
2579 procedure Trailing_Currency is
2580 begin
2581 if At_End then
2582 return;
2583 end if;
2584
2585 if Look = '$' then
2586 Pic.Start_Currency := Index;
2587 Pic.End_Currency := Index;
2588 Skip;
2589
2590 else
2591 while not At_End and then Look = '#' loop
2592 if Pic.Start_Currency = Invalid_Position then
2593 Pic.Start_Currency := Index;
2594 end if;
2595
2596 Pic.End_Currency := Index;
2597 Skip;
2598 end loop;
2599 end if;
2600
2601 loop
2602 if At_End then
2603 return;
2604 end if;
2605
2606 case Look is
2607 when '_' | '0' | '/' => Skip;
2608
2609 when 'B' | 'b' =>
2610 Pic.Picture.Expanded (Index) := 'b';
2611 Skip;
2612
2613 when others => return;
2614 end case;
2615 end loop;
2616 end Trailing_Currency;
2617
2618 ----------------------
2619 -- Zero_Suppression --
2620 ----------------------
2621
2622 procedure Zero_Suppression is
2623 begin
2624 Pic.Floater := 'Z';
2625 Pic.Start_Float := Index;
2626 Pic.End_Float := Index;
2627 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2628 Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2629
2630 Skip; -- Known Z
2631
2632 loop
2633 -- Even a single Z is a valid picture
2634
2635 if At_End then
2636 Set_State (Okay);
2637 return;
2638 end if;
2639
2640 case Look is
2641 when '_' | '0' | '/' =>
2642 Pic.End_Float := Index;
2643 Skip;
2644
2645 when 'B' | 'b' =>
2646 Pic.End_Float := Index;
2647 Pic.Picture.Expanded (Index) := 'b';
2648 Skip;
2649
2650 when 'Z' | 'z' =>
2651 Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2652
2653 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2654 Pic.End_Float := Index;
2655 Set_State (Okay);
2656 Skip;
2657
2658 when '9' =>
2659 Set_State (Okay);
2660 Number_Completion;
2661 return;
2662
2663 when '.' | 'V' | 'v' =>
2664 Pic.Radix_Position := Index;
2665 Skip;
2666 Number_Fraction_Or_Z_Fill;
2667 return;
2668
2669 when '#' | '$' =>
2670 Trailing_Currency;
2671 Set_State (Okay);
2672 return;
2673
2674 when others =>
2675 return;
2676 end case;
2677 end loop;
2678 end Zero_Suppression;
2679
2680 -- Start of processing for Precalculate
2681
2682 begin
2683 Picture_String;
2684
2685 if State = Reject then
2686 raise Picture_Error;
2687 end if;
2688
2689 exception
2690
2691 when Constraint_Error =>
2692
2693 -- To deal with special cases like null strings
2694
2695 raise Picture_Error;
2696
2697 end Precalculate;
2698
2699 ----------------
2700 -- To_Picture --
2701 ----------------
2702
2703 function To_Picture
2704 (Pic_String : String;
2705 Blank_When_Zero : Boolean := False) return Picture
2706 is
2707 Result : Picture;
2708
2709 begin
2710 declare
2711 Item : constant String := Expand (Pic_String);
2712
2713 begin
2714 Result.Contents.Picture := (Item'Length, Item);
2715 Result.Contents.Original_BWZ := Blank_When_Zero;
2716 Result.Contents.Blank_When_Zero := Blank_When_Zero;
2717 Precalculate (Result.Contents);
2718 return Result;
2719 end;
2720
2721 exception
2722 when others =>
2723 raise Picture_Error;
2724
2725 end To_Picture;
2726
2727 -------------
2728 -- To_Wide --
2729 -------------
2730
2731 function To_Wide (C : Character) return Wide_Character is
2732 begin
2733 return Wide_Character'Val (Character'Pos (C));
2734 end To_Wide;
2735
2736 -----------
2737 -- Valid --
2738 -----------
2739
2740 function Valid
2741 (Pic_String : String;
2742 Blank_When_Zero : Boolean := False) return Boolean
2743 is
2744 begin
2745 declare
2746 Expanded_Pic : constant String := Expand (Pic_String);
2747 -- Raises Picture_Error if Item not well-formed
2748
2749 Format_Rec : Format_Record;
2750
2751 begin
2752 Format_Rec.Picture := (Expanded_Pic'Length, Expanded_Pic);
2753 Format_Rec.Blank_When_Zero := Blank_When_Zero;
2754 Format_Rec.Original_BWZ := Blank_When_Zero;
2755 Precalculate (Format_Rec);
2756
2757 -- False only if Blank_When_0 is True but the pic string has a '*'
2758
2759 return not Blank_When_Zero
2760 or else Strings_Fixed.Index (Expanded_Pic, "*") = 0;
2761 end;
2762
2763 exception
2764 when others => return False;
2765 end Valid;
2766
2767 end Ada.Wide_Text_IO.Editing;