1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- A D A . T E X T _ I O . E D I T I N G --
9 -- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
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 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with Ada
.Strings
.Fixed
;
35 package body Ada
.Text_IO
.Editing
is
37 package Strings
renames Ada
.Strings
;
38 package Strings_Fixed
renames Ada
.Strings
.Fixed
;
39 package Text_IO
renames Ada
.Text_IO
;
45 function Blank_When_Zero
(Pic
: in Picture
) return Boolean is
47 return Pic
.Contents
.Original_BWZ
;
54 function Expand
(Picture
: in String) return String is
55 Result
: String (1 .. MAX_PICSIZE
);
56 Picture_Index
: Integer := Picture
'First;
57 Result_Index
: Integer := Result
'First;
61 package Int_IO
is new Ada
.Text_IO
.Integer_IO
(Integer);
64 if Picture
'Length < 1 then
68 if Picture
(Picture
'First) = '(' then
73 case Picture
(Picture_Index
) is
76 Int_IO
.Get
(Picture
(Picture_Index
+ 1 .. Picture
'Last),
79 if Picture
(Last
+ 1) /= ')' then
83 -- In what follows note that one copy of the repeated
84 -- character has already been made, so a count of one is a
85 -- no-op, and a count of zero erases a character.
87 for J
in 2 .. Count
loop
88 Result
(Result_Index
+ J
- 2) := Picture
(Picture_Index
- 1);
91 Result_Index
:= Result_Index
+ Count
- 1;
93 -- Last + 1 was a ')' throw it away too
95 Picture_Index
:= Last
+ 2;
101 Result
(Result_Index
) := Picture
(Picture_Index
);
102 Picture_Index
:= Picture_Index
+ 1;
103 Result_Index
:= Result_Index
+ 1;
107 exit when Picture_Index
> Picture
'Last;
110 return Result
(1 .. Result_Index
- 1);
121 function Format_Number
122 (Pic
: Format_Record
;
124 Currency_Symbol
: String;
125 Fill_Character
: Character;
126 Separator_Character
: Character;
127 Radix_Point
: Character)
130 Attrs
: Number_Attributes
:= Parse_Number_String
(Number
);
132 Rounded
: String := Number
;
134 Sign_Position
: Integer := Pic
.Sign_Position
; -- may float.
136 Answer
: String (1 .. Pic
.Picture
.Length
) := Pic
.Picture
.Expanded
;
138 Currency_Pos
: Integer := Pic
.Start_Currency
;
139 In_Currency
: Boolean := False;
141 Dollar
: Boolean := False;
142 -- Overridden immediately if necessary
144 Zero
: Boolean := True;
145 -- Set to False when a non-zero digit is output
149 -- If the picture has fewer decimal places than the number, the image
150 -- must be rounded according to the usual rules.
152 if Attrs
.Has_Fraction
then
154 R
: constant Integer :=
155 (Attrs
.End_Of_Fraction
- Attrs
.Start_Of_Fraction
+ 1)
156 - Pic
.Max_Trailing_Digits
;
161 R_Pos
:= Attrs
.End_Of_Fraction
- R
;
163 if Rounded
(R_Pos
+ 1) > '4' then
165 if Rounded
(R_Pos
) = '.' then
169 if Rounded
(R_Pos
) /= '9' then
170 Rounded
(R_Pos
) := Character'Succ (Rounded
(R_Pos
));
172 Rounded
(R_Pos
) := '0';
176 if Rounded
(R_Pos
) = '.' then
180 if Rounded
(R_Pos
) /= '9' then
181 Rounded
(R_Pos
) := Character'Succ (Rounded
(R_Pos
));
184 Rounded
(R_Pos
) := '0';
189 -- The rounding may add a digit in front. Either the
190 -- leading blank or the sign (already captured) can
194 Rounded
(R_Pos
) := '1';
195 Attrs
.Start_Of_Int
:= Attrs
.Start_Of_Int
- 1;
203 if Pic
.Start_Currency
/= Invalid_Position
then
204 Dollar
:= Answer
(Pic
.Start_Currency
) = '$';
207 -- Fix up "direct inserts" outside the playing field. Set up as one
208 -- loop to do the beginning, one (reverse) loop to do the end.
212 exit when Last
= Pic
.Start_Float
;
213 exit when Last
= Pic
.Radix_Position
;
214 exit when Answer
(Last
) = '9';
216 case Answer
(Last
) is
219 Answer
(Last
) := Separator_Character
;
222 Answer
(Last
) := ' ';
229 exit when Last
= Answer
'Last;
234 -- Now for the end...
236 for J
in reverse Last
.. Answer
'Last loop
237 exit when J
= Pic
.Radix_Position
;
239 -- Do this test First, Separator_Character can equal Pic.Floater
241 if Answer
(J
) = Pic
.Floater
then
248 Answer
(J
) := Separator_Character
;
264 if Pic
.Start_Currency
/= -1
265 and then Answer
(Pic
.Start_Currency
) = '#'
266 and then Pic
.Floater
/= '#'
268 if Currency_Symbol
'Length >
269 Pic
.End_Currency
- Pic
.Start_Currency
+ 1
273 elsif Currency_Symbol
'Length =
274 Pic
.End_Currency
- Pic
.Start_Currency
+ 1
276 Answer
(Pic
.Start_Currency
.. Pic
.End_Currency
) :=
279 elsif Pic
.Radix_Position
= Invalid_Position
280 or else Pic
.Start_Currency
< Pic
.Radix_Position
282 Answer
(Pic
.Start_Currency
.. Pic
.End_Currency
) :=
284 Answer
(Pic
.End_Currency
- Currency_Symbol
'Length + 1 ..
285 Pic
.End_Currency
) := Currency_Symbol
;
288 Answer
(Pic
.Start_Currency
.. Pic
.End_Currency
) :=
290 Answer
(Pic
.Start_Currency
..
291 Pic
.Start_Currency
+ Currency_Symbol
'Length - 1) :=
296 -- Fill in leading digits
298 if Attrs
.End_Of_Int
- Attrs
.Start_Of_Int
+ 1 >
299 Pic
.Max_Leading_Digits
301 raise Ada
.Text_IO
.Layout_Error
;
304 if Pic
.Radix_Position
= Invalid_Position
then
305 Position
:= Answer
'Last;
307 Position
:= Pic
.Radix_Position
- 1;
310 for J
in reverse Attrs
.Start_Of_Int
.. Attrs
.End_Of_Int
loop
312 while Answer
(Position
) /= '9'
313 and Answer
(Position
) /= Pic
.Floater
315 if Answer
(Position
) = '_' then
316 Answer
(Position
) := Separator_Character
;
318 elsif Answer
(Position
) = 'b' then
319 Answer
(Position
) := ' ';
322 Position
:= Position
- 1;
325 Answer
(Position
) := Rounded
(J
);
327 if Rounded
(J
) /= '0' then
331 Position
:= Position
- 1;
336 if Pic
.Start_Float
= Invalid_Position
then
338 -- No leading floats, but need to change '9' to '0', '_' to
339 -- Separator_Character and 'b' to ' '.
341 for J
in Last
.. Position
loop
343 -- Last set when fixing the "uninteresting" leaders above.
344 -- Don't duplicate the work.
346 if Answer
(J
) = '9' then
349 elsif Answer
(J
) = '_' then
350 Answer
(J
) := Separator_Character
;
352 elsif Answer
(J
) = 'b' then
357 elsif Pic
.Floater
= '<'
363 for J
in Pic
.End_Float
.. Position
loop -- May be null range.
364 if Answer
(J
) = '9' then
367 elsif Answer
(J
) = '_' then
368 Answer
(J
) := Separator_Character
;
370 elsif Answer
(J
) = 'b' then
375 if Position
> Pic
.End_Float
then
376 Position
:= Pic
.End_Float
;
379 for J
in Pic
.Start_Float
.. Position
- 1 loop
383 Answer
(Position
) := Pic
.Floater
;
384 Sign_Position
:= Position
;
386 elsif Pic
.Floater
= '$' then
388 for J
in Pic
.End_Float
.. Position
loop -- May be null range.
389 if Answer
(J
) = '9' then
392 elsif Answer
(J
) = '_' then
393 Answer
(J
) := ' '; -- no separators before leftmost digit.
395 elsif Answer
(J
) = 'b' then
400 if Position
> Pic
.End_Float
then
401 Position
:= Pic
.End_Float
;
404 for J
in Pic
.Start_Float
.. Position
- 1 loop
408 Answer
(Position
) := Pic
.Floater
;
409 Currency_Pos
:= Position
;
411 elsif Pic
.Floater
= '*' then
413 for J
in Pic
.End_Float
.. Position
loop -- May be null range.
414 if Answer
(J
) = '9' then
417 elsif Answer
(J
) = '_' then
418 Answer
(J
) := Separator_Character
;
420 elsif Answer
(J
) = 'b' then
425 if Position
> Pic
.End_Float
then
426 Position
:= Pic
.End_Float
;
429 for J
in Pic
.Start_Float
.. Position
loop
434 if Pic
.Floater
= '#' then
435 Currency_Pos
:= Currency_Symbol
'Length;
439 for J
in reverse Pic
.Start_Float
.. Position
loop
443 Answer
(J
) := Fill_Character
;
446 if In_Currency
and then Currency_Pos
> 0 then
447 Answer
(J
) := Currency_Symbol
(Currency_Pos
);
448 Currency_Pos
:= Currency_Pos
- 1;
459 when '.' |
'V' |
'v' |
'<' |
'$' |
'+' |
'-' =>
463 if Currency_Pos
= 0 then
466 Answer
(J
) := Currency_Symbol
(Currency_Pos
);
467 Currency_Pos
:= Currency_Pos
- 1;
475 Answer
(J
) := Fill_Character
;
481 if Currency_Pos
= 0 then
485 Answer
(J
) := Currency_Symbol
(Currency_Pos
);
486 Currency_Pos
:= Currency_Pos
- 1;
500 if Pic
.Floater
= '#' and then Currency_Pos
/= 0 then
501 raise Ada
.Text_IO
.Layout_Error
;
507 if Sign_Position
= Invalid_Position
then
508 if Attrs
.Negative
then
509 raise Ada
.Text_IO
.Layout_Error
;
513 if Attrs
.Negative
then
514 case Answer
(Sign_Position
) is
515 when 'C' |
'D' |
'-' =>
519 Answer
(Sign_Position
) := '-';
522 Answer
(Sign_Position
) := '(';
523 Answer
(Pic
.Second_Sign
) := ')';
532 case Answer
(Sign_Position
) is
535 Answer
(Sign_Position
) := ' ';
537 when '<' |
'C' |
'D' =>
538 Answer
(Sign_Position
) := ' ';
539 Answer
(Pic
.Second_Sign
) := ' ';
551 -- Fill in trailing digits
553 if Pic
.Max_Trailing_Digits
> 0 then
555 if Attrs
.Has_Fraction
then
556 Position
:= Attrs
.Start_Of_Fraction
;
557 Last
:= Pic
.Radix_Position
+ 1;
559 for J
in Last
.. Answer
'Last loop
561 if Answer
(J
) = '9' or Answer
(J
) = Pic
.Floater
then
562 Answer
(J
) := Rounded
(Position
);
564 if Rounded
(Position
) /= '0' then
568 Position
:= Position
+ 1;
571 -- Used up fraction but remember place in Answer
573 exit when Position
> Attrs
.End_Of_Fraction
;
575 elsif Answer
(J
) = 'b' then
578 elsif Answer
(J
) = '_' then
579 Answer
(J
) := Separator_Character
;
589 Position
:= Pic
.Radix_Position
+ 1;
592 -- Now fill remaining 9's with zeros and _ with separators
596 for J
in Position
.. Last
loop
597 if Answer
(J
) = '9' then
600 elsif Answer
(J
) = Pic
.Floater
then
603 elsif Answer
(J
) = '_' then
604 Answer
(J
) := Separator_Character
;
606 elsif Answer
(J
) = 'b' then
612 Position
:= Last
+ 1;
615 if Pic
.Floater
= '#' and then Currency_Pos
/= 0 then
616 raise Ada
.Text_IO
.Layout_Error
;
619 -- No trailing digits, but now J may need to stick in a currency
622 if Pic
.Start_Currency
= Invalid_Position
then
623 Position
:= Answer
'Last + 1;
625 Position
:= Pic
.Start_Currency
;
629 for J
in Position
.. Answer
'Last loop
631 if Pic
.Start_Currency
/= Invalid_Position
and then
632 Answer
(Pic
.Start_Currency
) = '#' then
638 Answer
(J
) := Fill_Character
;
642 Answer
(J
) := Currency_Symbol
(Currency_Pos
);
643 Currency_Pos
:= Currency_Pos
+ 1;
645 if Currency_Pos
> Currency_Symbol
'Length then
646 In_Currency
:= False;
651 if Currency_Pos
> Currency_Symbol
'Length then
656 Answer
(J
) := Currency_Symbol
(Currency_Pos
);
657 Currency_Pos
:= Currency_Pos
+ 1;
659 if Currency_Pos
> Currency_Symbol
'Length then
660 In_Currency
:= False;
665 Answer
(J
) := Currency_Symbol
(Currency_Pos
);
666 Currency_Pos
:= Currency_Pos
+ 1;
671 Answer
(J
) := Fill_Character
;
677 if Currency_Pos
> Currency_Symbol
'Length then
680 Answer
(J
) := Currency_Symbol
(Currency_Pos
);
681 Currency_Pos
:= Currency_Pos
+ 1;
695 -- Now get rid of Blank_when_Zero and complete Star fill
697 if Zero
and Pic
.Blank_When_Zero
then
699 -- Value is zero, and blank it
704 Last
:= Last
- 1 + Currency_Symbol
'Length;
707 if Pic
.Radix_Position
/= Invalid_Position
and then
708 Answer
(Pic
.Radix_Position
) = 'V' then
712 return String'(1 .. Last => ' ');
714 elsif Zero and Pic.Star_Fill then
718 Last := Last - 1 + Currency_Symbol'Length;
721 if Pic.Radix_Position /= Invalid_Position then
723 if Answer (Pic.Radix_Position) = 'V
' then
727 if Pic.Radix_Position > Pic.Start_Currency then
728 return String'(1 .. Pic
.Radix_Position
- 1 => '*') &
730 String'(Pic.Radix_Position + 1 .. Last => '*');
736 Pic
.Radix_Position
+ Currency_Symbol
'Length - 2 =>
739 (Pic.Radix_Position + Currency_Symbol'Length .. Last
744 return String'(1 .. Pic
.Radix_Position
- 1 => '*') &
746 String'(Pic.Radix_Position + 1 .. Last => '*');
750 return String'(1 .. Last
=> '*');
753 -- This was once a simple return statement, now there are nine
754 -- different return cases. Not to mention the five above to deal
755 -- with zeros. Why not split things out?
757 -- Processing the radix and sign expansion separately
758 -- would require lots of copying--the string and some of its
759 -- indicies--without really simplifying the logic. The cases are:
761 -- 1) Expand $, replace '.' with Radix_Point
762 -- 2) No currency expansion, replace '.' with Radix_Point
763 -- 3) Expand $, radix blanked
764 -- 4) No currency expansion, radix blanked
766 -- 6) Expand $, Elide V
767 -- 7) Elide V, Expand $ (Two cases depending on order.)
768 -- 8) No radix, expand $
769 -- 9) No radix, no currency expansion
771 if Pic
.Radix_Position
/= Invalid_Position
then
773 if Answer
(Pic
.Radix_Position
) = '.' then
774 Answer
(Pic
.Radix_Position
) := Radix_Point
;
778 -- 1) Expand $, replace '.' with Radix_Point
780 return Answer
(1 .. Currency_Pos
- 1) & Currency_Symbol
&
781 Answer
(Currency_Pos
+ 1 .. Answer
'Last);
784 -- 2) No currency expansion, replace '.' with Radix_Point
789 elsif Answer
(Pic
.Radix_Position
) = ' ' then -- blanked radix.
792 -- 3) Expand $, radix blanked
794 return Answer
(1 .. Currency_Pos
- 1) & Currency_Symbol
&
795 Answer
(Currency_Pos
+ 1 .. Answer
'Last);
798 -- 4) No expansion, radix blanked
810 return Answer
(1 .. Pic
.Radix_Position
- 1) &
811 Answer
(Pic
.Radix_Position
+ 1 .. Answer
'Last);
813 elsif Currency_Pos
< Pic
.Radix_Position
then
815 -- 6) Expand $, Elide V
817 return Answer
(1 .. Currency_Pos
- 1) & Currency_Symbol
&
818 Answer
(Currency_Pos
+ 1 .. Pic
.Radix_Position
- 1) &
819 Answer
(Pic
.Radix_Position
+ 1 .. Answer
'Last);
822 -- 7) Elide V, Expand $
824 return Answer
(1 .. Pic
.Radix_Position
- 1) &
825 Answer
(Pic
.Radix_Position
+ 1 .. Currency_Pos
- 1) &
827 Answer
(Currency_Pos
+ 1 .. Answer
'Last);
833 -- 8) No radix, expand $
835 return Answer
(1 .. Currency_Pos
- 1) & Currency_Symbol
&
836 Answer
(Currency_Pos
+ 1 .. Answer
'Last);
839 -- 9) No radix, no currency expansion
845 -------------------------
846 -- Parse_Number_String --
847 -------------------------
849 function Parse_Number_String
(Str
: String) return Number_Attributes
is
850 Answer
: Number_Attributes
;
853 for J
in Str
'Range loop
861 -- Decide if this is the start of a number.
862 -- If so, figure out which one...
864 if Answer
.Has_Fraction
then
865 Answer
.End_Of_Fraction
:= J
;
867 if Answer
.Start_Of_Int
= Invalid_Position
then
869 Answer
.Start_Of_Int
:= J
;
871 Answer
.End_Of_Int
:= J
;
876 -- Only count a zero before the decimal point if it follows a
877 -- non-zero digit. After the decimal point, zeros will be
878 -- counted if followed by a non-zero digit.
880 if not Answer
.Has_Fraction
then
881 if Answer
.Start_Of_Int
/= Invalid_Position
then
882 Answer
.End_Of_Int
:= J
;
890 Answer
.Negative
:= True;
894 -- Close integer, start fraction
896 if Answer
.Has_Fraction
then
900 -- Two decimal points is a no-no
902 Answer
.Has_Fraction
:= True;
903 Answer
.End_Of_Fraction
:= J
;
905 -- Could leave this at Invalid_Position, but this seems the
906 -- right way to indicate a null range...
908 Answer
.Start_Of_Fraction
:= J
+ 1;
909 Answer
.End_Of_Int
:= J
- 1;
912 raise Picture_Error
; -- can this happen? probably not!
916 if Answer
.Start_Of_Int
= Invalid_Position
then
917 Answer
.Start_Of_Int
:= Answer
.End_Of_Int
+ 1;
920 -- No significant (integer) digits needs a null range
923 end Parse_Number_String
;
929 -- The following ensures that we return B and not b being careful not
930 -- to break things which expect lower case b for blank. See CXF3A02.
932 function Pic_String
(Pic
: in Picture
) return String is
933 Temp
: String (1 .. Pic
.Contents
.Picture
.Length
) :=
934 Pic
.Contents
.Picture
.Expanded
;
936 for J
in Temp
'Range loop
937 if Temp
(J
) = 'b' then Temp
(J
) := 'B'; end if;
947 procedure Precalculate
(Pic
: in out Format_Record
) is
948 Debug
: constant Boolean := False;
949 -- Set True to generate debug output
951 Computed_BWZ
: Boolean := True;
953 type Legality
is (Okay
, Reject
);
955 State
: Legality
:= Reject
;
956 -- Start in reject, which will reject null strings
958 Index
: Pic_Index
:= Pic
.Picture
.Expanded
'First;
960 function At_End
return Boolean;
961 pragma Inline
(At_End
);
963 procedure Set_State
(L
: Legality
);
964 pragma Inline
(Set_State
);
966 function Look
return Character;
967 pragma Inline
(Look
);
969 function Is_Insert
return Boolean;
970 pragma Inline
(Is_Insert
);
973 pragma Inline
(Skip
);
975 procedure Debug_Start
(Name
: String);
976 pragma Inline
(Debug_Start
);
978 procedure Debug_Integer
(Value
: in Integer; S
: String);
979 pragma Inline
(Debug_Integer
);
981 procedure Trailing_Currency
;
982 procedure Trailing_Bracket
;
983 procedure Number_Fraction
;
984 procedure Number_Completion
;
985 procedure Number_Fraction_Or_Bracket
;
986 procedure Number_Fraction_Or_Z_Fill
;
987 procedure Zero_Suppression
;
988 procedure Floating_Bracket
;
989 procedure Number_Fraction_Or_Star_Fill
;
990 procedure Star_Suppression
;
991 procedure Number_Fraction_Or_Dollar
;
992 procedure Leading_Dollar
;
993 procedure Number_Fraction_Or_Pound
;
994 procedure Leading_Pound
;
996 procedure Floating_Plus
;
997 procedure Floating_Minus
;
998 procedure Picture_Plus
;
999 procedure Picture_Minus
;
1000 procedure Picture_Bracket
;
1002 procedure Optional_RHS_Sign
;
1003 procedure Picture_String
;
1004 procedure Set_Debug
;
1010 function At_End
return Boolean is
1012 Debug_Start
("At_End");
1013 return Index
> Pic
.Picture
.Length
;
1020 -- Needed to have a procedure to pass to pragma Debug
1022 procedure Set_Debug
is
1024 -- Uncomment this line and make Debug a variable to enable debug
1035 procedure Debug_Integer
(Value
: in Integer; S
: String) is
1036 use Ada
.Text_IO
; -- needed for >
1039 if Debug
and then Value
> 0 then
1040 if Ada
.Text_IO
.Col
> 70 - S
'Length then
1041 Ada
.Text_IO
.New_Line
;
1044 Ada
.Text_IO
.Put
(' ' & S
& Integer'Image (Value
) & ',');
1052 procedure Debug_Start
(Name
: String) is
1055 Ada
.Text_IO
.Put_Line
(" In " & Name
& '.');
1059 ----------------------
1060 -- Floating_Bracket --
1061 ----------------------
1063 -- Note that Floating_Bracket is only called with an acceptable
1064 -- prefix. But we don't set Okay, because we must end with a '>'.
1066 procedure Floating_Bracket
is
1068 Debug_Start
("Floating_Bracket");
1070 -- Two different floats not allowed
1072 if Pic
.Floater
/= '!' and then Pic
.Floater
/= '<' then
1073 raise Picture_Error
;
1079 Pic
.End_Float
:= Index
;
1080 Pic
.Max_Leading_Digits
:= Pic
.Max_Leading_Digits
+ 1;
1082 -- First bracket wasn't counted...
1093 when '_' |
'0' |
'/' =>
1094 Pic
.End_Float
:= Index
;
1098 Pic
.End_Float
:= Index
;
1099 Pic
.Picture
.Expanded
(Index
) := 'b';
1103 Pic
.End_Float
:= Index
;
1104 Pic
.Max_Leading_Digits
:= Pic
.Max_Leading_Digits
+ 1;
1116 when 'V' |
'v' |
'.' =>
1117 Pic
.Radix_Position
:= Index
;
1119 Number_Fraction_Or_Bracket
;
1126 end Floating_Bracket
;
1128 --------------------
1129 -- Floating_Minus --
1130 --------------------
1132 procedure Floating_Minus
is
1134 Debug_Start
("Floating_Minus");
1142 when '_' |
'0' |
'/' =>
1143 Pic
.End_Float
:= Index
;
1147 Pic
.End_Float
:= Index
;
1148 Pic
.Picture
.Expanded
(Index
) := 'b';
1152 Pic
.Max_Leading_Digits
:= Pic
.Max_Leading_Digits
+ 1;
1153 Pic
.End_Float
:= Index
;
1160 when '.' |
'V' |
'v' =>
1161 Pic
.Radix_Position
:= Index
;
1164 while Is_Insert
loop
1181 Pic
.Max_Trailing_Digits
:=
1182 Pic
.Max_Trailing_Digits
+ 1;
1183 Pic
.End_Float
:= Index
;
1186 when '_' |
'0' |
'/' =>
1190 Pic
.Picture
.Expanded
(Index
) := 'b';
1215 procedure Floating_Plus
is
1217 Debug_Start
("Floating_Plus");
1225 when '_' |
'0' |
'/' =>
1226 Pic
.End_Float
:= Index
;
1230 Pic
.End_Float
:= Index
;
1231 Pic
.Picture
.Expanded
(Index
) := 'b';
1235 Pic
.Max_Leading_Digits
:= Pic
.Max_Leading_Digits
+ 1;
1236 Pic
.End_Float
:= Index
;
1243 when '.' |
'V' |
'v' =>
1244 Pic
.Radix_Position
:= Index
;
1247 while Is_Insert
loop
1264 Pic
.Max_Trailing_Digits
:=
1265 Pic
.Max_Trailing_Digits
+ 1;
1266 Pic
.End_Float
:= Index
;
1269 when '_' |
'0' |
'/' =>
1273 Pic
.Picture
.Expanded
(Index
) := 'b';
1299 function Is_Insert
return Boolean is
1305 case Pic
.Picture
.Expanded
(Index
) is
1307 when '_' |
'0' |
'/' => return True;
1310 Pic
.Picture
.Expanded
(Index
) := 'b'; -- canonical
1313 when others => return False;
1317 --------------------
1318 -- Leading_Dollar --
1319 --------------------
1321 -- Note that Leading_Dollar can be called in either State.
1322 -- It will set state to Okay only if a 9 or (second) $
1325 -- Also notice the tricky bit with State and Zero_Suppression.
1326 -- Zero_Suppression is Picture_Error if a '$' or a '9' has been
1327 -- encountered, exactly the cases where State has been set.
1329 procedure Leading_Dollar
is
1331 Debug_Start
("Leading_Dollar");
1333 -- Treat as a floating dollar, and unwind otherwise
1335 if Pic
.Floater
/= '!' and then Pic
.Floater
/= '$' then
1337 -- Two floats not allowed
1339 raise Picture_Error
;
1345 Pic
.Start_Currency
:= Index
;
1346 Pic
.End_Currency
:= Index
;
1347 Pic
.Start_Float
:= Index
;
1348 Pic
.End_Float
:= Index
;
1350 -- Don't increment Pic.Max_Leading_Digits, we need one "real"
1362 when '_' |
'0' |
'/' =>
1363 Pic
.End_Float
:= Index
;
1366 -- A trailing insertion character is not part of the
1367 -- floating currency, so need to look ahead.
1370 Pic
.End_Float
:= Pic
.End_Float
- 1;
1374 Pic
.End_Float
:= Index
;
1375 Pic
.Picture
.Expanded
(Index
) := 'b';
1379 Pic
.Picture
.Expanded
(Index
) := 'Z'; -- consistency
1381 if State
= Okay
then
1382 raise Picture_Error
;
1384 -- Overwrite Floater and Start_Float
1387 Pic
.Start_Float
:= Index
;
1392 if State
= Okay
then
1393 raise Picture_Error
;
1395 -- Overwrite Floater and Start_Float
1398 Pic
.Start_Float
:= Index
;
1403 Pic
.Max_Leading_Digits
:= Pic
.Max_Leading_Digits
+ 1;
1404 Pic
.End_Float
:= Index
;
1405 Pic
.End_Currency
:= Index
;
1406 Set_State
(Okay
); Skip
;
1409 if State
/= Okay
then
1411 Pic
.Start_Float
:= Invalid_Position
;
1412 Pic
.End_Float
:= Invalid_Position
;
1415 -- A single dollar does not a floating make
1420 when 'V' |
'v' |
'.' =>
1421 if State
/= Okay
then
1423 Pic
.Start_Float
:= Invalid_Position
;
1424 Pic
.End_Float
:= Invalid_Position
;
1427 -- Only one dollar before the sign is okay, but doesn't
1430 Pic
.Radix_Position
:= Index
;
1432 Number_Fraction_Or_Dollar
;
1446 -- This one is complex! A Leading_Pound can be fixed or floating,
1447 -- but in some cases the decision has to be deferred until we leave
1448 -- this procedure. Also note that Leading_Pound can be called in
1451 -- It will set state to Okay only if a 9 or (second) # is
1454 -- One Last note: In ambiguous cases, the currency is treated as
1455 -- floating unless there is only one '#'.
1457 procedure Leading_Pound
is
1459 Inserts
: Boolean := False;
1460 -- Set to True if a '_', '0', '/', 'B', or 'b' is encountered
1462 Must_Float
: Boolean := False;
1463 -- Set to true if a '#' occurs after an insert
1466 Debug_Start
("Leading_Pound");
1468 -- Treat as a floating currency. If it isn't, this will be
1469 -- overwritten later.
1471 if Pic
.Floater
/= '!' and then Pic
.Floater
/= '#' then
1473 -- Two floats not allowed
1475 raise Picture_Error
;
1481 Pic
.Start_Currency
:= Index
;
1482 Pic
.End_Currency
:= Index
;
1483 Pic
.Start_Float
:= Index
;
1484 Pic
.End_Float
:= Index
;
1486 -- Don't increment Pic.Max_Leading_Digits, we need one "real"
1489 Pic
.Max_Currency_Digits
:= 1; -- we've seen one.
1500 when '_' |
'0' |
'/' =>
1501 Pic
.End_Float
:= Index
;
1506 Pic
.Picture
.Expanded
(Index
) := 'b';
1507 Pic
.End_Float
:= Index
;
1512 Pic
.Picture
.Expanded
(Index
) := 'Z'; -- consistency
1515 raise Picture_Error
;
1517 Pic
.Max_Leading_Digits
:= 0;
1519 -- Overwrite Floater and Start_Float
1522 Pic
.Start_Float
:= Index
;
1528 raise Picture_Error
;
1530 Pic
.Max_Leading_Digits
:= 0;
1532 -- Overwrite Floater and Start_Float
1534 Pic
.Start_Float
:= Index
;
1543 Pic
.Max_Leading_Digits
:= Pic
.Max_Leading_Digits
+ 1;
1544 Pic
.End_Float
:= Index
;
1545 Pic
.End_Currency
:= Index
;
1550 if State
/= Okay
then
1552 -- A single '#' doesn't float
1555 Pic
.Start_Float
:= Invalid_Position
;
1556 Pic
.End_Float
:= Invalid_Position
;
1562 when 'V' |
'v' |
'.' =>
1563 if State
/= Okay
then
1565 Pic
.Start_Float
:= Invalid_Position
;
1566 Pic
.End_Float
:= Invalid_Position
;
1569 -- Only one pound before the sign is okay, but doesn't
1572 Pic
.Radix_Position
:= Index
;
1574 Number_Fraction_Or_Pound
;
1587 function Look
return Character is
1590 raise Picture_Error
;
1593 return Pic
.Picture
.Expanded
(Index
);
1602 Debug_Start
("Number");
1607 when '_' |
'0' |
'/' =>
1611 Pic
.Picture
.Expanded
(Index
) := 'b';
1615 Computed_BWZ
:= False;
1616 Pic
.Max_Leading_Digits
:= Pic
.Max_Leading_Digits
+ 1;
1620 when '.' |
'V' |
'v' =>
1621 Pic
.Radix_Position
:= Index
;
1635 -- Will return in Okay state if a '9' was seen
1640 -----------------------
1641 -- Number_Completion --
1642 -----------------------
1644 procedure Number_Completion
is
1646 Debug_Start
("Number_Completion");
1648 while not At_End
loop
1651 when '_' |
'0' |
'/' =>
1655 Pic
.Picture
.Expanded
(Index
) := 'b';
1659 Computed_BWZ
:= False;
1660 Pic
.Max_Leading_Digits
:= Pic
.Max_Leading_Digits
+ 1;
1664 when 'V' |
'v' |
'.' =>
1665 Pic
.Radix_Position
:= Index
;
1674 end Number_Completion
;
1676 ---------------------
1677 -- Number_Fraction --
1678 ---------------------
1680 procedure Number_Fraction
is
1682 -- Note that number fraction can be called in either State.
1683 -- It will set state to Valid only if a 9 is encountered.
1685 Debug_Start
("Number_Fraction");
1693 when '_' |
'0' |
'/' =>
1697 Pic
.Picture
.Expanded
(Index
) := 'b';
1701 Computed_BWZ
:= False;
1702 Pic
.Max_Trailing_Digits
:= Pic
.Max_Trailing_Digits
+ 1;
1703 Set_State
(Okay
); Skip
;
1709 end Number_Fraction
;
1711 --------------------------------
1712 -- Number_Fraction_Or_Bracket --
1713 --------------------------------
1715 procedure Number_Fraction_Or_Bracket
is
1717 Debug_Start
("Number_Fraction_Or_Bracket");
1726 when '_' |
'0' |
'/' => Skip
;
1729 Pic
.Picture
.Expanded
(Index
) := 'b';
1733 Pic
.Max_Trailing_Digits
:= Pic
.Max_Trailing_Digits
+ 1;
1734 Pic
.End_Float
:= Index
;
1743 when '_' |
'0' |
'/' =>
1747 Pic
.Picture
.Expanded
(Index
) := 'b';
1751 Pic
.Max_Trailing_Digits
:=
1752 Pic
.Max_Trailing_Digits
+ 1;
1753 Pic
.End_Float
:= Index
;
1766 end Number_Fraction_Or_Bracket
;
1768 -------------------------------
1769 -- Number_Fraction_Or_Dollar --
1770 -------------------------------
1772 procedure Number_Fraction_Or_Dollar
is
1774 Debug_Start
("Number_Fraction_Or_Dollar");
1782 when '_' |
'0' |
'/' =>
1786 Pic
.Picture
.Expanded
(Index
) := 'b';
1790 Pic
.Max_Trailing_Digits
:= Pic
.Max_Trailing_Digits
+ 1;
1791 Pic
.End_Float
:= Index
;
1800 when '_' |
'0' |
'/' =>
1804 Pic
.Picture
.Expanded
(Index
) := 'b';
1808 Pic
.Max_Trailing_Digits
:=
1809 Pic
.Max_Trailing_Digits
+ 1;
1810 Pic
.End_Float
:= Index
;
1823 end Number_Fraction_Or_Dollar
;
1825 ------------------------------
1826 -- Number_Fraction_Or_Pound --
1827 ------------------------------
1829 procedure Number_Fraction_Or_Pound
is
1838 when '_' |
'0' |
'/' =>
1842 Pic
.Picture
.Expanded
(Index
) := 'b';
1846 Pic
.Max_Trailing_Digits
:= Pic
.Max_Trailing_Digits
+ 1;
1847 Pic
.End_Float
:= Index
;
1857 when '_' |
'0' |
'/' =>
1861 Pic
.Picture
.Expanded
(Index
) := 'b';
1865 Pic
.Max_Trailing_Digits
:=
1866 Pic
.Max_Trailing_Digits
+ 1;
1867 Pic
.End_Float
:= Index
;
1882 end Number_Fraction_Or_Pound
;
1884 ----------------------------------
1885 -- Number_Fraction_Or_Star_Fill --
1886 ----------------------------------
1888 procedure Number_Fraction_Or_Star_Fill
is
1890 Debug_Start
("Number_Fraction_Or_Star_Fill");
1899 when '_' |
'0' |
'/' =>
1903 Pic
.Picture
.Expanded
(Index
) := 'b';
1907 Pic
.Star_Fill
:= True;
1908 Pic
.Max_Trailing_Digits
:= Pic
.Max_Trailing_Digits
+ 1;
1909 Pic
.End_Float
:= Index
;
1919 when '_' |
'0' |
'/' =>
1923 Pic
.Picture
.Expanded
(Index
) := 'b';
1927 Pic
.Star_Fill
:= True;
1928 Pic
.Max_Trailing_Digits
:=
1929 Pic
.Max_Trailing_Digits
+ 1;
1930 Pic
.End_Float
:= Index
;
1944 end Number_Fraction_Or_Star_Fill
;
1946 -------------------------------
1947 -- Number_Fraction_Or_Z_Fill --
1948 -------------------------------
1950 procedure Number_Fraction_Or_Z_Fill
is
1952 Debug_Start
("Number_Fraction_Or_Z_Fill");
1961 when '_' |
'0' |
'/' =>
1965 Pic
.Picture
.Expanded
(Index
) := 'b';
1969 Pic
.Max_Trailing_Digits
:= Pic
.Max_Trailing_Digits
+ 1;
1970 Pic
.End_Float
:= Index
;
1971 Pic
.Picture
.Expanded
(Index
) := 'Z'; -- consistency
1982 when '_' |
'0' |
'/' =>
1986 Pic
.Picture
.Expanded
(Index
) := 'b';
1990 Pic
.Picture
.Expanded
(Index
) := 'Z'; -- consistency
1992 Pic
.Max_Trailing_Digits
:=
1993 Pic
.Max_Trailing_Digits
+ 1;
1994 Pic
.End_Float
:= Index
;
2007 end Number_Fraction_Or_Z_Fill
;
2009 -----------------------
2010 -- Optional_RHS_Sign --
2011 -----------------------
2013 procedure Optional_RHS_Sign
is
2015 Debug_Start
("Optional_RHS_Sign");
2024 Pic
.Sign_Position
:= Index
;
2029 Pic
.Sign_Position
:= Index
;
2030 Pic
.Picture
.Expanded
(Index
) := 'C';
2033 if Look
= 'R' or Look
= 'r' then
2034 Pic
.Second_Sign
:= Index
;
2035 Pic
.Picture
.Expanded
(Index
) := 'R';
2039 raise Picture_Error
;
2045 Pic
.Sign_Position
:= Index
;
2046 Pic
.Picture
.Expanded
(Index
) := 'D';
2049 if Look
= 'B' or Look
= 'b' then
2050 Pic
.Second_Sign
:= Index
;
2051 Pic
.Picture
.Expanded
(Index
) := 'B';
2055 raise Picture_Error
;
2061 if Pic
.Picture
.Expanded
(Pic
.Sign_Position
) = '<' then
2062 Pic
.Second_Sign
:= Index
;
2066 raise Picture_Error
;
2073 end Optional_RHS_Sign
;
2079 -- Note that Picture can be called in either State
2081 -- It will set state to Valid only if a 9 is encountered or floating
2082 -- currency is called.
2084 procedure Picture
is
2086 Debug_Start
("Picture");
2095 when '_' |
'0' |
'/' =>
2099 Pic
.Picture
.Expanded
(Index
) := 'b';
2111 Computed_BWZ
:= False;
2113 Pic
.Max_Leading_Digits
:= Pic
.Max_Leading_Digits
+ 1;
2116 when 'V' |
'v' |
'.' =>
2117 Pic
.Radix_Position
:= Index
;
2130 ---------------------
2131 -- Picture_Bracket --
2132 ---------------------
2134 procedure Picture_Bracket
is
2136 Pic
.Sign_Position
:= Index
;
2137 Debug_Start
("Picture_Bracket");
2138 Pic
.Sign_Position
:= Index
;
2140 -- Treat as a floating sign, and unwind otherwise
2143 Pic
.Start_Float
:= Index
;
2144 Pic
.End_Float
:= Index
;
2146 -- Don't increment Pic.Max_Leading_Digits, we need one "real"
2149 Skip
; -- Known Bracket
2154 when '_' |
'0' |
'/' =>
2155 Pic
.End_Float
:= Index
;
2159 Pic
.End_Float
:= Index
;
2160 Pic
.Picture
.Expanded
(Index
) := 'b';
2164 Set_State
(Okay
); -- "<<>" is enough.
2170 when '$' |
'#' |
'9' |
'*' =>
2171 if State
/= Okay
then
2173 Pic
.Start_Float
:= Invalid_Position
;
2174 Pic
.End_Float
:= Invalid_Position
;
2182 when '.' |
'V' |
'v' =>
2183 if State
/= Okay
then
2185 Pic
.Start_Float
:= Invalid_Position
;
2186 Pic
.End_Float
:= Invalid_Position
;
2189 -- Don't assume that state is okay, haven't seen a digit
2196 raise Picture_Error
;
2200 end Picture_Bracket
;
2206 procedure Picture_Minus
is
2208 Debug_Start
("Picture_Minus");
2210 Pic
.Sign_Position
:= Index
;
2212 -- Treat as a floating sign, and unwind otherwise
2215 Pic
.Start_Float
:= Index
;
2216 Pic
.End_Float
:= Index
;
2218 -- Don't increment Pic.Max_Leading_Digits, we need one "real"
2221 Skip
; -- Known Minus
2226 when '_' |
'0' |
'/' =>
2227 Pic
.End_Float
:= Index
;
2231 Pic
.End_Float
:= Index
;
2232 Pic
.Picture
.Expanded
(Index
) := 'b';
2236 Pic
.Max_Leading_Digits
:= Pic
.Max_Leading_Digits
+ 1;
2237 Pic
.End_Float
:= Index
;
2239 Set_State
(Okay
); -- "-- " is enough.
2244 when '$' |
'#' |
'9' |
'*' =>
2245 if State
/= Okay
then
2247 Pic
.Start_Float
:= Invalid_Position
;
2248 Pic
.End_Float
:= Invalid_Position
;
2257 -- Can't have Z and a floating sign
2259 if State
= Okay
then
2263 Pic
.Picture
.Expanded
(Index
) := 'Z'; -- consistency
2269 when '.' |
'V' |
'v' =>
2270 if State
/= Okay
then
2272 Pic
.Start_Float
:= Invalid_Position
;
2273 Pic
.End_Float
:= Invalid_Position
;
2276 -- Don't assume that state is okay, haven't seen a digit
2292 procedure Picture_Plus
is
2294 Debug_Start
("Picture_Plus");
2295 Pic
.Sign_Position
:= Index
;
2297 -- Treat as a floating sign, and unwind otherwise
2300 Pic
.Start_Float
:= Index
;
2301 Pic
.End_Float
:= Index
;
2303 -- Don't increment Pic.Max_Leading_Digits, we need one "real"
2311 when '_' |
'0' |
'/' =>
2312 Pic
.End_Float
:= Index
;
2316 Pic
.End_Float
:= Index
;
2317 Pic
.Picture
.Expanded
(Index
) := 'b';
2321 Pic
.Max_Leading_Digits
:= Pic
.Max_Leading_Digits
+ 1;
2322 Pic
.End_Float
:= Index
;
2324 Set_State
(Okay
); -- "++" is enough
2329 when '$' |
'#' |
'9' |
'*' =>
2330 if State
/= Okay
then
2332 Pic
.Start_Float
:= Invalid_Position
;
2333 Pic
.End_Float
:= Invalid_Position
;
2341 if State
= Okay
then
2345 -- Can't have Z and a floating sign
2347 Pic
.Picture
.Expanded
(Index
) := 'Z'; -- consistency
2349 -- '+Z' is acceptable
2353 -- Overwrite Floater and Start_Float
2356 Pic
.Start_Float
:= Index
;
2363 when '.' |
'V' |
'v' =>
2364 if State
/= Okay
then
2366 Pic
.Start_Float
:= Invalid_Position
;
2367 Pic
.End_Float
:= Invalid_Position
;
2370 -- Don't assume that state is okay, haven't seen a digit
2382 --------------------
2383 -- Picture_String --
2384 --------------------
2386 procedure Picture_String
is
2388 Debug_Start
("Picture_String");
2390 while Is_Insert
loop
2410 Pic
.Picture
.Expanded
(Index
) := 'Z'; -- consistency
2420 when '9' |
'.' |
'V' |
'v' =>
2426 raise Picture_Error
;
2430 -- Blank when zero either if the PIC does not contain a '9' or if
2431 -- requested by the user and no '*'.
2433 Pic
.Blank_When_Zero
:=
2434 (Computed_BWZ
or Pic
.Blank_When_Zero
) and not Pic
.Star_Fill
;
2436 -- Star fill if '*' and no '9'
2438 Pic
.Star_Fill
:= Pic
.Star_Fill
and Computed_BWZ
;
2450 procedure Set_State
(L
: Legality
) is
2452 if Debug
then Ada
.Text_IO
.Put_Line
2453 (" Set state from " & Legality
'Image (State
) &
2454 " to " & Legality
'Image (L
));
2466 if Debug
then Ada
.Text_IO
.Put_Line
2467 (" Skip " & Pic
.Picture
.Expanded
(Index
));
2473 ----------------------
2474 -- Star_Suppression --
2475 ----------------------
2477 procedure Star_Suppression
is
2479 Debug_Start
("Star_Suppression");
2481 if Pic
.Floater
/= '!' and then Pic
.Floater
/= '*' then
2483 -- Two floats not allowed
2485 raise Picture_Error
;
2491 Pic
.Start_Float
:= Index
;
2492 Pic
.End_Float
:= Index
;
2493 Pic
.Max_Leading_Digits
:= Pic
.Max_Leading_Digits
+ 1;
2496 -- Even a single * is a valid picture
2498 Pic
.Star_Fill
:= True;
2508 when '_' |
'0' |
'/' =>
2509 Pic
.End_Float
:= Index
;
2513 Pic
.End_Float
:= Index
;
2514 Pic
.Picture
.Expanded
(Index
) := 'b';
2518 Pic
.End_Float
:= Index
;
2519 Pic
.Max_Leading_Digits
:= Pic
.Max_Leading_Digits
+ 1;
2520 Set_State
(Okay
); Skip
;
2527 when '.' |
'V' |
'v' =>
2528 Pic
.Radix_Position
:= Index
;
2530 Number_Fraction_Or_Star_Fill
;
2534 if Pic
.Max_Currency_Digits
> 0 then
2535 raise Picture_Error
;
2538 -- Cannot have leading and trailing currency
2544 when others => raise Picture_Error
;
2547 end Star_Suppression
;
2549 ----------------------
2550 -- Trailing_Bracket --
2551 ----------------------
2553 procedure Trailing_Bracket
is
2555 Debug_Start
("Trailing_Bracket");
2558 Pic
.Second_Sign
:= Index
;
2561 raise Picture_Error
;
2563 end Trailing_Bracket
;
2565 -----------------------
2566 -- Trailing_Currency --
2567 -----------------------
2569 procedure Trailing_Currency
is
2571 Debug_Start
("Trailing_Currency");
2578 Pic
.Start_Currency
:= Index
;
2579 Pic
.End_Currency
:= Index
;
2583 while not At_End
and then Look
= '#' loop
2584 if Pic
.Start_Currency
= Invalid_Position
then
2585 Pic
.Start_Currency
:= Index
;
2588 Pic
.End_Currency
:= Index
;
2599 when '_' |
'0' |
'/' => Skip
;
2602 Pic
.Picture
.Expanded
(Index
) := 'b';
2605 when others => return;
2608 end Trailing_Currency
;
2610 ----------------------
2611 -- Zero_Suppression --
2612 ----------------------
2614 procedure Zero_Suppression
is
2616 Debug_Start
("Zero_Suppression");
2619 Pic
.Start_Float
:= Index
;
2620 Pic
.End_Float
:= Index
;
2621 Pic
.Max_Leading_Digits
:= Pic
.Max_Leading_Digits
+ 1;
2622 Pic
.Picture
.Expanded
(Index
) := 'Z'; -- consistency
2627 -- Even a single Z is a valid picture
2635 when '_' |
'0' |
'/' =>
2636 Pic
.End_Float
:= Index
;
2640 Pic
.End_Float
:= Index
;
2641 Pic
.Picture
.Expanded
(Index
) := 'b';
2645 Pic
.Picture
.Expanded
(Index
) := 'Z'; -- consistency
2647 Pic
.Max_Leading_Digits
:= Pic
.Max_Leading_Digits
+ 1;
2648 Pic
.End_Float
:= Index
;
2657 when '.' |
'V' |
'v' =>
2658 Pic
.Radix_Position
:= Index
;
2660 Number_Fraction_Or_Z_Fill
;
2672 end Zero_Suppression
;
2674 -- Start of processing for Precalculate
2677 pragma Debug
(Set_Debug
);
2682 Ada
.Text_IO
.New_Line
;
2683 Ada
.Text_IO
.Put
(" Picture : """ &
2684 Pic
.Picture
.Expanded
(1 .. Pic
.Picture
.Length
) & """,");
2685 Ada
.Text_IO
.Put
(" Floater : '" & Pic
.Floater
& "',");
2688 if State
= Reject
then
2689 raise Picture_Error
;
2692 Debug_Integer
(Pic
.Radix_Position
, "Radix Positon : ");
2693 Debug_Integer
(Pic
.Sign_Position
, "Sign Positon : ");
2694 Debug_Integer
(Pic
.Second_Sign
, "Second Sign : ");
2695 Debug_Integer
(Pic
.Start_Float
, "Start Float : ");
2696 Debug_Integer
(Pic
.End_Float
, "End Float : ");
2697 Debug_Integer
(Pic
.Start_Currency
, "Start Currency : ");
2698 Debug_Integer
(Pic
.End_Currency
, "End Currency : ");
2699 Debug_Integer
(Pic
.Max_Leading_Digits
, "Max Leading Digits : ");
2700 Debug_Integer
(Pic
.Max_Trailing_Digits
, "Max Trailing Digits : ");
2703 Ada
.Text_IO
.New_Line
;
2708 when Constraint_Error
=>
2710 -- To deal with special cases like null strings
2712 raise Picture_Error
;
2720 (Pic_String
: in String;
2721 Blank_When_Zero
: in Boolean := False)
2728 Item
: constant String := Expand
(Pic_String
);
2731 Result
.Contents
.Picture
:= (Item
'Length, Item
);
2732 Result
.Contents
.Original_BWZ
:= Blank_When_Zero
;
2733 Result
.Contents
.Blank_When_Zero
:= Blank_When_Zero
;
2734 Precalculate
(Result
.Contents
);
2740 raise Picture_Error
;
2748 (Pic_String
: in String;
2749 Blank_When_Zero
: in Boolean := False)
2754 Expanded_Pic
: constant String := Expand
(Pic_String
);
2755 -- Raises Picture_Error if Item not well-formed
2757 Format_Rec
: Format_Record
;
2760 Format_Rec
.Picture
:= (Expanded_Pic
'Length, Expanded_Pic
);
2761 Format_Rec
.Blank_When_Zero
:= Blank_When_Zero
;
2762 Format_Rec
.Original_BWZ
:= Blank_When_Zero
;
2763 Precalculate
(Format_Rec
);
2765 -- False only if Blank_When_Zero is True but the pic string has a '*'
2767 return not Blank_When_Zero
or
2768 Strings_Fixed
.Index
(Expanded_Pic
, "*") = 0;
2772 when others => return False;
2775 --------------------
2776 -- Decimal_Output --
2777 --------------------
2779 package body Decimal_Output
is
2788 Currency
: in String := Default_Currency
;
2789 Fill
: in Character := Default_Fill
;
2790 Separator
: in Character := Default_Separator
;
2791 Radix_Mark
: in Character := Default_Radix_Mark
)
2795 return Format_Number
2796 (Pic
.Contents
, Num
'Image (Item
),
2797 Currency
, Fill
, Separator
, Radix_Mark
);
2806 Currency
: in String := Default_Currency
)
2809 Picstr
: constant String := Pic_String
(Pic
);
2810 V_Adjust
: Integer := 0;
2811 Cur_Adjust
: Integer := 0;
2814 -- Check if Picstr has 'V' or '$'
2816 -- If 'V', then length is 1 less than otherwise
2818 -- If '$', then length is Currency'Length-1 more than otherwise
2820 -- This should use the string handling package ???
2822 for J
in Picstr
'Range loop
2823 if Picstr
(J
) = 'V' then
2826 elsif Picstr
(J
) = '$' then
2827 Cur_Adjust
:= Currency
'Length - 1;
2831 return Picstr
'Length - V_Adjust
+ Cur_Adjust
;
2839 (File
: in Text_IO
.File_Type
;
2842 Currency
: in String := Default_Currency
;
2843 Fill
: in Character := Default_Fill
;
2844 Separator
: in Character := Default_Separator
;
2845 Radix_Mark
: in Character := Default_Radix_Mark
)
2848 Text_IO
.Put
(File
, Image
(Item
, Pic
,
2849 Currency
, Fill
, Separator
, Radix_Mark
));
2855 Currency
: in String := Default_Currency
;
2856 Fill
: in Character := Default_Fill
;
2857 Separator
: in Character := Default_Separator
;
2858 Radix_Mark
: in Character := Default_Radix_Mark
)
2861 Text_IO
.Put
(Image
(Item
, Pic
,
2862 Currency
, Fill
, Separator
, Radix_Mark
));
2869 Currency
: in String := Default_Currency
;
2870 Fill
: in Character := Default_Fill
;
2871 Separator
: in Character := Default_Separator
;
2872 Radix_Mark
: in Character := Default_Radix_Mark
)
2874 Result
: constant String :=
2875 Image
(Item
, Pic
, Currency
, Fill
, Separator
, Radix_Mark
);
2878 if Result
'Length > To
'Length then
2879 raise Ada
.Text_IO
.Layout_Error
;
2881 Strings_Fixed
.Move
(Source
=> Result
, Target
=> To
,
2882 Justify
=> Strings
.Right
);
2893 Currency
: in String := Default_Currency
)
2898 Temp
: constant String := Image
(Item
, Pic
, Currency
);
2899 pragma Warnings
(Off
, Temp
);
2905 when Ada
.Text_IO
.Layout_Error
=> return False;
2910 end Ada
.Text_IO
.Editing
;