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