diff options
Diffstat (limited to 'gcc/ada/a-ztedit.adb')
| -rw-r--r-- | gcc/ada/a-ztedit.adb | 2712 |
1 files changed, 0 insertions, 2712 deletions
diff --git a/gcc/ada/a-ztedit.adb b/gcc/ada/a-ztedit.adb deleted file mode 100644 index bc759e0..0000000 --- a/gcc/ada/a-ztedit.adb +++ /dev/null @@ -1,2712 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . E D I T I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Fixed; -with Ada.Strings.Wide_Wide_Fixed; - -package body Ada.Wide_Wide_Text_IO.Editing is - - package Strings renames Ada.Strings; - package Strings_Fixed renames Ada.Strings.Fixed; - package Strings_Wide_Wide_Fixed renames Ada.Strings.Wide_Wide_Fixed; - package Wide_Wide_Text_IO renames Ada.Wide_Wide_Text_IO; - - ----------------------- - -- Local_Subprograms -- - ----------------------- - - function To_Wide (C : Character) return Wide_Wide_Character; - pragma Inline (To_Wide); - -- Convert Character to corresponding Wide_Wide_Character - - --------------------- - -- Blank_When_Zero -- - --------------------- - - function Blank_When_Zero (Pic : Picture) return Boolean is - begin - return Pic.Contents.Original_BWZ; - end Blank_When_Zero; - - -------------------- - -- Decimal_Output -- - -------------------- - - package body Decimal_Output is - - ----------- - -- Image -- - ----------- - - function Image - (Item : Num; - Pic : Picture; - Currency : Wide_Wide_String := Default_Currency; - Fill : Wide_Wide_Character := Default_Fill; - Separator : Wide_Wide_Character := Default_Separator; - Radix_Mark : Wide_Wide_Character := Default_Radix_Mark) - return Wide_Wide_String - is - begin - return Format_Number - (Pic.Contents, Num'Image (Item), - Currency, Fill, Separator, Radix_Mark); - end Image; - - ------------ - -- Length -- - ------------ - - function Length - (Pic : Picture; - Currency : Wide_Wide_String := Default_Currency) return Natural - is - Picstr : constant String := Pic_String (Pic); - V_Adjust : Integer := 0; - Cur_Adjust : Integer := 0; - - begin - -- Check if Picstr has 'V' or '$' - - -- If 'V', then length is 1 less than otherwise - - -- If '$', then length is Currency'Length-1 more than otherwise - - -- This should use the string handling package ??? - - for J in Picstr'Range loop - if Picstr (J) = 'V' then - V_Adjust := -1; - - elsif Picstr (J) = '$' then - Cur_Adjust := Currency'Length - 1; - end if; - end loop; - - return Picstr'Length - V_Adjust + Cur_Adjust; - end Length; - - --------- - -- Put -- - --------- - - procedure Put - (File : Wide_Wide_Text_IO.File_Type; - Item : Num; - Pic : Picture; - Currency : Wide_Wide_String := Default_Currency; - Fill : Wide_Wide_Character := Default_Fill; - Separator : Wide_Wide_Character := Default_Separator; - Radix_Mark : Wide_Wide_Character := Default_Radix_Mark) - is - begin - Wide_Wide_Text_IO.Put (File, Image (Item, Pic, - Currency, Fill, Separator, Radix_Mark)); - end Put; - - procedure Put - (Item : Num; - Pic : Picture; - Currency : Wide_Wide_String := Default_Currency; - Fill : Wide_Wide_Character := Default_Fill; - Separator : Wide_Wide_Character := Default_Separator; - Radix_Mark : Wide_Wide_Character := Default_Radix_Mark) - is - begin - Wide_Wide_Text_IO.Put (Image (Item, Pic, - Currency, Fill, Separator, Radix_Mark)); - end Put; - - procedure Put - (To : out Wide_Wide_String; - Item : Num; - Pic : Picture; - Currency : Wide_Wide_String := Default_Currency; - Fill : Wide_Wide_Character := Default_Fill; - Separator : Wide_Wide_Character := Default_Separator; - Radix_Mark : Wide_Wide_Character := Default_Radix_Mark) - is - Result : constant Wide_Wide_String := - Image (Item, Pic, Currency, Fill, Separator, Radix_Mark); - - begin - if Result'Length > To'Length then - raise Wide_Wide_Text_IO.Layout_Error; - else - Strings_Wide_Wide_Fixed.Move (Source => Result, Target => To, - Justify => Strings.Right); - end if; - end Put; - - ----------- - -- Valid -- - ----------- - - function Valid - (Item : Num; - Pic : Picture; - Currency : Wide_Wide_String := Default_Currency) return Boolean - is - begin - declare - Temp : constant Wide_Wide_String := Image (Item, Pic, Currency); - pragma Warnings (Off, Temp); - begin - return True; - end; - - exception - when Layout_Error => return False; - - end Valid; - end Decimal_Output; - - ------------ - -- Expand -- - ------------ - - function Expand (Picture : String) return String is - Result : String (1 .. MAX_PICSIZE); - Picture_Index : Integer := Picture'First; - Result_Index : Integer := Result'First; - Count : Natural; - Last : Integer; - - begin - if Picture'Length < 1 then - raise Picture_Error; - end if; - - if Picture (Picture'First) = '(' then - raise Picture_Error; - end if; - - loop - case Picture (Picture_Index) is - when '(' => - - -- We now need to scan out the count after a left paren. In - -- the non-wide version we used Integer_IO.Get, but that is - -- not convenient here, since we don't want to drag in normal - -- Text_IO just for this purpose. So we do the scan ourselves, - -- with the normal validity checks. - - Last := Picture_Index + 1; - Count := 0; - - if Picture (Last) not in '0' .. '9' then - raise Picture_Error; - end if; - - Count := Character'Pos (Picture (Last)) - Character'Pos ('0'); - Last := Last + 1; - - loop - if Last > Picture'Last then - raise Picture_Error; - end if; - - if Picture (Last) = '_' then - if Picture (Last - 1) = '_' then - raise Picture_Error; - end if; - - elsif Picture (Last) = ')' then - exit; - - elsif Picture (Last) not in '0' .. '9' then - raise Picture_Error; - - else - Count := Count * 10 - + Character'Pos (Picture (Last)) - - Character'Pos ('0'); - end if; - - Last := Last + 1; - end loop; - - -- In what follows note that one copy of the repeated - -- character has already been made, so a count of one is - -- no-op, and a count of zero erases a character. - - for J in 2 .. Count loop - Result (Result_Index + J - 2) := Picture (Picture_Index - 1); - end loop; - - Result_Index := Result_Index + Count - 1; - - -- Last was a ')' throw it away too - - Picture_Index := Last + 1; - - when ')' => - raise Picture_Error; - - when others => - Result (Result_Index) := Picture (Picture_Index); - Picture_Index := Picture_Index + 1; - Result_Index := Result_Index + 1; - end case; - - exit when Picture_Index > Picture'Last; - end loop; - - return Result (1 .. Result_Index - 1); - - exception - when others => - raise Picture_Error; - end Expand; - - ------------------- - -- Format_Number -- - ------------------- - - function Format_Number - (Pic : Format_Record; - Number : String; - Currency_Symbol : Wide_Wide_String; - Fill_Character : Wide_Wide_Character; - Separator_Character : Wide_Wide_Character; - Radix_Point : Wide_Wide_Character) return Wide_Wide_String - is - Attrs : Number_Attributes := Parse_Number_String (Number); - Position : Integer; - Rounded : String := Number; - - Sign_Position : Integer := Pic.Sign_Position; -- may float. - - Answer : Wide_Wide_String (1 .. Pic.Picture.Length); - Last : Integer; - Currency_Pos : Integer := Pic.Start_Currency; - - Dollar : Boolean := False; - -- Overridden immediately if necessary - - Zero : Boolean := True; - -- Set to False when a non-zero digit is output - - begin - - -- If the picture has fewer decimal places than the number, the image - -- must be rounded according to the usual rules. - - if Attrs.Has_Fraction then - declare - R : constant Integer := - (Attrs.End_Of_Fraction - Attrs.Start_Of_Fraction + 1) - - Pic.Max_Trailing_Digits; - R_Pos : Integer; - - begin - if R > 0 then - R_Pos := Rounded'Length - R; - - if Rounded (R_Pos + 1) > '4' then - - if Rounded (R_Pos) = '.' then - R_Pos := R_Pos - 1; - end if; - - if Rounded (R_Pos) /= '9' then - Rounded (R_Pos) := Character'Succ (Rounded (R_Pos)); - else - Rounded (R_Pos) := '0'; - R_Pos := R_Pos - 1; - - while R_Pos > 1 loop - if Rounded (R_Pos) = '.' then - R_Pos := R_Pos - 1; - end if; - - if Rounded (R_Pos) /= '9' then - Rounded (R_Pos) := Character'Succ (Rounded (R_Pos)); - exit; - else - Rounded (R_Pos) := '0'; - R_Pos := R_Pos - 1; - end if; - end loop; - - -- The rounding may add a digit in front. Either the - -- leading blank or the sign (already captured) can be - -- overwritten. - - if R_Pos = 1 then - Rounded (R_Pos) := '1'; - Attrs.Start_Of_Int := Attrs.Start_Of_Int - 1; - end if; - end if; - end if; - end if; - end; - end if; - - for J in Answer'Range loop - Answer (J) := To_Wide (Pic.Picture.Expanded (J)); - end loop; - - if Pic.Start_Currency /= Invalid_Position then - Dollar := Answer (Pic.Start_Currency) = '$'; - end if; - - -- Fix up "direct inserts" outside the playing field. Set up as one - -- loop to do the beginning, one (reverse) loop to do the end. - - Last := 1; - loop - exit when Last = Pic.Start_Float; - exit when Last = Pic.Radix_Position; - exit when Answer (Last) = '9'; - - case Answer (Last) is - when '_' => - Answer (Last) := Separator_Character; - - when 'b' => - Answer (Last) := ' '; - - when others => - null; - end case; - - exit when Last = Answer'Last; - - Last := Last + 1; - end loop; - - -- Now for the end... - - for J in reverse Last .. Answer'Last loop - exit when J = Pic.Radix_Position; - - -- Do this test First, Separator_Character can equal Pic.Floater - - if Answer (J) = Pic.Floater then - exit; - end if; - - case Answer (J) is - when '_' => - Answer (J) := Separator_Character; - - when 'b' => - Answer (J) := ' '; - - when '9' => - exit; - - when others => - null; - end case; - end loop; - - -- Non-floating sign - - if Pic.Start_Currency /= -1 - and then Answer (Pic.Start_Currency) = '#' - and then Pic.Floater /= '#' - then - if Currency_Symbol'Length > - Pic.End_Currency - Pic.Start_Currency + 1 - then - raise Picture_Error; - - elsif Currency_Symbol'Length = - Pic.End_Currency - Pic.Start_Currency + 1 - then - Answer (Pic.Start_Currency .. Pic.End_Currency) := - Currency_Symbol; - - elsif Pic.Radix_Position = Invalid_Position - or else Pic.Start_Currency < Pic.Radix_Position - then - Answer (Pic.Start_Currency .. Pic.End_Currency) := - (others => ' '); - Answer (Pic.End_Currency - Currency_Symbol'Length + 1 .. - Pic.End_Currency) := Currency_Symbol; - - else - Answer (Pic.Start_Currency .. Pic.End_Currency) := - (others => ' '); - Answer (Pic.Start_Currency .. - Pic.Start_Currency + Currency_Symbol'Length - 1) := - Currency_Symbol; - end if; - end if; - - -- Fill in leading digits - - if Attrs.End_Of_Int - Attrs.Start_Of_Int + 1 > - Pic.Max_Leading_Digits - then - raise Layout_Error; - end if; - - Position := - (if Pic.Radix_Position = Invalid_Position then Answer'Last - else Pic.Radix_Position - 1); - - for J in reverse Attrs.Start_Of_Int .. Attrs.End_Of_Int loop - while Answer (Position) /= '9' - and then - Answer (Position) /= Pic.Floater - loop - if Answer (Position) = '_' then - Answer (Position) := Separator_Character; - elsif Answer (Position) = 'b' then - Answer (Position) := ' '; - end if; - - Position := Position - 1; - end loop; - - Answer (Position) := To_Wide (Rounded (J)); - - if Rounded (J) /= '0' then - Zero := False; - end if; - - Position := Position - 1; - end loop; - - -- Do lead float - - if Pic.Start_Float = Invalid_Position then - - -- No leading floats, but need to change '9' to '0', '_' to - -- Separator_Character and 'b' to ' '. - - for J in Last .. Position loop - - -- Last set when fixing the "uninteresting" leaders above. - -- Don't duplicate the work. - - if Answer (J) = '9' then - Answer (J) := '0'; - - elsif Answer (J) = '_' then - Answer (J) := Separator_Character; - - elsif Answer (J) = 'b' then - Answer (J) := ' '; - - end if; - - end loop; - - elsif Pic.Floater = '<' - or else - Pic.Floater = '+' - or else - Pic.Floater = '-' - then - for J in Pic.End_Float .. Position loop -- May be null range - if Answer (J) = '9' then - Answer (J) := '0'; - - elsif Answer (J) = '_' then - Answer (J) := Separator_Character; - - elsif Answer (J) = 'b' then - Answer (J) := ' '; - - end if; - end loop; - - if Position > Pic.End_Float then - Position := Pic.End_Float; - end if; - - for J in Pic.Start_Float .. Position - 1 loop - Answer (J) := ' '; - end loop; - - Answer (Position) := Pic.Floater; - Sign_Position := Position; - - elsif Pic.Floater = '$' then - - for J in Pic.End_Float .. Position loop -- May be null range - if Answer (J) = '9' then - Answer (J) := '0'; - - elsif Answer (J) = '_' then - Answer (J) := ' '; -- no separator before leftmost digit - - elsif Answer (J) = 'b' then - Answer (J) := ' '; - end if; - end loop; - - if Position > Pic.End_Float then - Position := Pic.End_Float; - end if; - - for J in Pic.Start_Float .. Position - 1 loop - Answer (J) := ' '; - end loop; - - Answer (Position) := Pic.Floater; - Currency_Pos := Position; - - elsif Pic.Floater = '*' then - - for J in Pic.End_Float .. Position loop -- May be null range - if Answer (J) = '9' then - Answer (J) := '0'; - - elsif Answer (J) = '_' then - Answer (J) := Separator_Character; - - elsif Answer (J) = 'b' then - Answer (J) := '*'; - end if; - end loop; - - if Position > Pic.End_Float then - Position := Pic.End_Float; - end if; - - for J in Pic.Start_Float .. Position loop - Answer (J) := '*'; - end loop; - - else - if Pic.Floater = '#' then - Currency_Pos := Currency_Symbol'Length; - end if; - - for J in reverse Pic.Start_Float .. Position loop - case Answer (J) is - when '*' => - Answer (J) := Fill_Character; - - when 'Z' | 'b' | '/' | '0' => - Answer (J) := ' '; - - when '9' => - Answer (J) := '0'; - - when '.' | 'V' | 'v' | '<' | '$' | '+' | '-' => - null; - - when '#' => - if Currency_Pos = 0 then - Answer (J) := ' '; - else - Answer (J) := Currency_Symbol (Currency_Pos); - Currency_Pos := Currency_Pos - 1; - end if; - - when '_' => - case Pic.Floater is - when '*' => - Answer (J) := Fill_Character; - - when 'Z' | 'b' => - Answer (J) := ' '; - - when '#' => - if Currency_Pos = 0 then - Answer (J) := ' '; - - else - Answer (J) := Currency_Symbol (Currency_Pos); - Currency_Pos := Currency_Pos - 1; - end if; - - when others => - null; - end case; - - when others => - null; - end case; - end loop; - - if Pic.Floater = '#' and then Currency_Pos /= 0 then - raise Layout_Error; - end if; - end if; - - -- Do sign - - if Sign_Position = Invalid_Position then - if Attrs.Negative then - raise Layout_Error; - end if; - - else - if Attrs.Negative then - case Answer (Sign_Position) is - when 'C' | 'D' | '-' => - null; - - when '+' => - Answer (Sign_Position) := '-'; - - when '<' => - Answer (Sign_Position) := '('; - Answer (Pic.Second_Sign) := ')'; - - when others => - raise Picture_Error; - end case; - - else -- positive - - case Answer (Sign_Position) is - when '-' => - Answer (Sign_Position) := ' '; - - when '<' | 'C' | 'D' => - Answer (Sign_Position) := ' '; - Answer (Pic.Second_Sign) := ' '; - - when '+' => - null; - - when others => - raise Picture_Error; - end case; - end if; - end if; - - -- Fill in trailing digits - - if Pic.Max_Trailing_Digits > 0 then - if Attrs.Has_Fraction then - Position := Attrs.Start_Of_Fraction; - Last := Pic.Radix_Position + 1; - - for J in Last .. Answer'Last loop - if Answer (J) = '9' or else Answer (J) = Pic.Floater then - Answer (J) := To_Wide (Rounded (Position)); - - if Rounded (Position) /= '0' then - Zero := False; - end if; - - Position := Position + 1; - Last := J + 1; - - -- Used up fraction but remember place in Answer - - exit when Position > Attrs.End_Of_Fraction; - - elsif Answer (J) = 'b' then - Answer (J) := ' '; - - elsif Answer (J) = '_' then - Answer (J) := Separator_Character; - end if; - - Last := J + 1; - end loop; - - Position := Last; - - else - Position := Pic.Radix_Position + 1; - end if; - - -- Now fill remaining 9's with zeros and _ with separators - - Last := Answer'Last; - - for J in Position .. Last loop - if Answer (J) = '9' then - Answer (J) := '0'; - - elsif Answer (J) = Pic.Floater then - Answer (J) := '0'; - - elsif Answer (J) = '_' then - Answer (J) := Separator_Character; - - elsif Answer (J) = 'b' then - Answer (J) := ' '; - end if; - end loop; - - Position := Last + 1; - - else - if Pic.Floater = '#' and then Currency_Pos /= 0 then - raise Layout_Error; - end if; - - -- No trailing digits, but now J may need to stick in a currency - -- symbol or sign. - - Position := - (if Pic.Start_Currency = Invalid_Position then Answer'Last + 1 - else Pic.Start_Currency); - end if; - - for J in Position .. Answer'Last loop - if Pic.Start_Currency /= Invalid_Position - and then Answer (Pic.Start_Currency) = '#' - then - Currency_Pos := 1; - end if; - - -- Note: There are some weird cases J can imagine with 'b' or '#' - -- in currency strings where the following code will cause - -- glitches. The trick is to tell when the character in the - -- answer should be checked, and when to look at the original - -- string. Some other time. RIE 11/26/96 ??? - - case Answer (J) is - when '*' => - Answer (J) := Fill_Character; - - when 'b' => - Answer (J) := ' '; - - when '#' => - if Currency_Pos > Currency_Symbol'Length then - Answer (J) := ' '; - - else - Answer (J) := Currency_Symbol (Currency_Pos); - Currency_Pos := Currency_Pos + 1; - end if; - - when '_' => - case Pic.Floater is - when '*' => - Answer (J) := Fill_Character; - - when 'Z' | 'z' => - Answer (J) := ' '; - - when '#' => - if Currency_Pos > Currency_Symbol'Length then - Answer (J) := ' '; - else - Answer (J) := Currency_Symbol (Currency_Pos); - Currency_Pos := Currency_Pos + 1; - end if; - - when others => - null; - end case; - - when others => - exit; - end case; - end loop; - - -- Now get rid of Blank_when_Zero and complete Star fill - - if Zero and then Pic.Blank_When_Zero then - - -- Value is zero, and blank it - - Last := Answer'Last; - - if Dollar then - Last := Last - 1 + Currency_Symbol'Length; - end if; - - if Pic.Radix_Position /= Invalid_Position - and then Answer (Pic.Radix_Position) = 'V' - then - Last := Last - 1; - end if; - - return Wide_Wide_String'(1 .. Last => ' '); - - elsif Zero and then Pic.Star_Fill then - Last := Answer'Last; - - if Dollar then - Last := Last - 1 + Currency_Symbol'Length; - end if; - - if Pic.Radix_Position /= Invalid_Position then - - if Answer (Pic.Radix_Position) = 'V' then - Last := Last - 1; - - elsif Dollar then - if Pic.Radix_Position > Pic.Start_Currency then - return - Wide_Wide_String'(1 .. Pic.Radix_Position - 1 => '*') & - Radix_Point & - Wide_Wide_String'(Pic.Radix_Position + 1 .. Last => '*'); - - else - return - Wide_Wide_String' - (1 .. - Pic.Radix_Position + Currency_Symbol'Length - 2 - => '*') & - Radix_Point & - Wide_Wide_String' - (Pic.Radix_Position + Currency_Symbol'Length .. Last - => '*'); - end if; - - else - return - Wide_Wide_String'(1 .. Pic.Radix_Position - 1 => '*') & - Radix_Point & - Wide_Wide_String'(Pic.Radix_Position + 1 .. Last => '*'); - end if; - end if; - - return Wide_Wide_String'(1 .. Last => '*'); - end if; - - -- This was once a simple return statement, now there are nine different - -- return cases. Not to mention the five above to deal with zeros. Why - -- not split things out? - - -- Processing the radix and sign expansion separately would require - -- lots of copying--the string and some of its indexes--without - -- really simplifying the logic. The cases are: - - -- 1) Expand $, replace '.' with Radix_Point - -- 2) No currency expansion, replace '.' with Radix_Point - -- 3) Expand $, radix blanked - -- 4) No currency expansion, radix blanked - -- 5) Elide V - -- 6) Expand $, Elide V - -- 7) Elide V, Expand $ (Two cases depending on order.) - -- 8) No radix, expand $ - -- 9) No radix, no currency expansion - - if Pic.Radix_Position /= Invalid_Position then - if Answer (Pic.Radix_Position) = '.' then - Answer (Pic.Radix_Position) := Radix_Point; - - if Dollar then - - -- 1) Expand $, replace '.' with Radix_Point - - return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & - Answer (Currency_Pos + 1 .. Answer'Last); - - else - -- 2) No currency expansion, replace '.' with Radix_Point - - return Answer; - end if; - - elsif Answer (Pic.Radix_Position) = ' ' then -- blanked radix. - if Dollar then - - -- 3) Expand $, radix blanked - - return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & - Answer (Currency_Pos + 1 .. Answer'Last); - - else - -- 4) No expansion, radix blanked - - return Answer; - end if; - - -- V cases - - else - if not Dollar then - - -- 5) Elide V - - return Answer (1 .. Pic.Radix_Position - 1) & - Answer (Pic.Radix_Position + 1 .. Answer'Last); - - elsif Currency_Pos < Pic.Radix_Position then - - -- 6) Expand $, Elide V - - return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & - Answer (Currency_Pos + 1 .. Pic.Radix_Position - 1) & - Answer (Pic.Radix_Position + 1 .. Answer'Last); - - else - -- 7) Elide V, Expand $ - - return Answer (1 .. Pic.Radix_Position - 1) & - Answer (Pic.Radix_Position + 1 .. Currency_Pos - 1) & - Currency_Symbol & - Answer (Currency_Pos + 1 .. Answer'Last); - end if; - end if; - - elsif Dollar then - - -- 8) No radix, expand $ - - return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & - Answer (Currency_Pos + 1 .. Answer'Last); - - else - -- 9) No radix, no currency expansion - - return Answer; - end if; - end Format_Number; - - ------------------------- - -- Parse_Number_String -- - ------------------------- - - function Parse_Number_String (Str : String) return Number_Attributes is - Answer : Number_Attributes; - - begin - for J in Str'Range loop - case Str (J) is - when ' ' => - null; -- ignore - - when '1' .. '9' => - - -- Decide if this is the start of a number. - -- If so, figure out which one... - - if Answer.Has_Fraction then - Answer.End_Of_Fraction := J; - else - if Answer.Start_Of_Int = Invalid_Position then - -- start integer - Answer.Start_Of_Int := J; - end if; - Answer.End_Of_Int := J; - end if; - - when '0' => - - -- Only count a zero before the decimal point if it follows a - -- non-zero digit. After the decimal point, zeros will be - -- counted if followed by a non-zero digit. - - if not Answer.Has_Fraction then - if Answer.Start_Of_Int /= Invalid_Position then - Answer.End_Of_Int := J; - end if; - end if; - - when '-' => - - -- Set negative - - Answer.Negative := True; - - when '.' => - - -- Close integer, start fraction - - if Answer.Has_Fraction then - raise Picture_Error; - end if; - - -- Two decimal points is a no-no - - Answer.Has_Fraction := True; - Answer.End_Of_Fraction := J; - - -- Could leave this at Invalid_Position, but this seems the - -- right way to indicate a null range... - - Answer.Start_Of_Fraction := J + 1; - Answer.End_Of_Int := J - 1; - - when others => - raise Picture_Error; -- can this happen? probably not - end case; - end loop; - - if Answer.Start_Of_Int = Invalid_Position then - Answer.Start_Of_Int := Answer.End_Of_Int + 1; - end if; - - -- No significant (intger) digits needs a null range - - return Answer; - end Parse_Number_String; - - ---------------- - -- Pic_String -- - ---------------- - - -- The following ensures that we return B and not b being careful not - -- to break things which expect lower case b for blank. See CXF3A02. - - function Pic_String (Pic : Picture) return String is - Temp : String (1 .. Pic.Contents.Picture.Length) := - Pic.Contents.Picture.Expanded; - begin - for J in Temp'Range loop - if Temp (J) = 'b' then - Temp (J) := 'B'; - end if; - end loop; - - return Temp; - end Pic_String; - - ------------------ - -- Precalculate -- - ------------------ - - procedure Precalculate (Pic : in out Format_Record) is - - Computed_BWZ : Boolean := True; - - type Legality is (Okay, Reject); - State : Legality := Reject; - -- Start in reject, which will reject null strings - - Index : Pic_Index := Pic.Picture.Expanded'First; - - function At_End return Boolean; - pragma Inline (At_End); - - procedure Set_State (L : Legality); - pragma Inline (Set_State); - - function Look return Character; - pragma Inline (Look); - - function Is_Insert return Boolean; - pragma Inline (Is_Insert); - - procedure Skip; - pragma Inline (Skip); - - procedure Trailing_Currency; - procedure Trailing_Bracket; - procedure Number_Fraction; - procedure Number_Completion; - procedure Number_Fraction_Or_Bracket; - procedure Number_Fraction_Or_Z_Fill; - procedure Zero_Suppression; - procedure Floating_Bracket; - procedure Number_Fraction_Or_Star_Fill; - procedure Star_Suppression; - procedure Number_Fraction_Or_Dollar; - procedure Leading_Dollar; - procedure Number_Fraction_Or_Pound; - procedure Leading_Pound; - procedure Picture; - procedure Floating_Plus; - procedure Floating_Minus; - procedure Picture_Plus; - procedure Picture_Minus; - procedure Picture_Bracket; - procedure Number; - procedure Optional_RHS_Sign; - procedure Picture_String; - - ------------ - -- At_End -- - ------------ - - function At_End return Boolean is - begin - return Index > Pic.Picture.Length; - end At_End; - - ---------------------- - -- Floating_Bracket -- - ---------------------- - - -- Note that Floating_Bracket is only called with an acceptable - -- prefix. But we don't set Okay, because we must end with a '>'. - - procedure Floating_Bracket is - begin - Pic.Floater := '<'; - Pic.End_Float := Index; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - - -- First bracket wasn't counted... - - Skip; -- known '<' - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '<' => - Pic.End_Float := Index; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Skip; - - when '9' => - Number_Completion; - - when '$' => - Leading_Dollar; - - when '#' => - Leading_Pound; - - when 'V' | 'v' | '.' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction_Or_Bracket; - return; - - when others => - return; - end case; - end loop; - end Floating_Bracket; - - -------------------- - -- Floating_Minus -- - -------------------- - - procedure Floating_Minus is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '-' => - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Skip; - - when '9' => - Number_Completion; - return; - - when '.' | 'V' | 'v' => - Pic.Radix_Position := Index; - Skip; -- Radix - - while Is_Insert loop - Skip; - end loop; - - if At_End then - return; - end if; - - if Look = '-' then - loop - if At_End then - return; - end if; - - case Look is - when '-' => - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when others => - return; - end case; - end loop; - - else - Number_Completion; - end if; - - return; - - when others => - return; - end case; - end loop; - end Floating_Minus; - - ------------------- - -- Floating_Plus -- - ------------------- - - procedure Floating_Plus is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '+' => - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Skip; - - when '9' => - Number_Completion; - return; - - when '.' | 'V' | 'v' => - Pic.Radix_Position := Index; - Skip; -- Radix - - while Is_Insert loop - Skip; - end loop; - - if At_End then - return; - end if; - - if Look = '+' then - loop - if At_End then - return; - end if; - - case Look is - when '+' => - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when others => - return; - end case; - end loop; - - else - Number_Completion; - end if; - - return; - - when others => - return; - end case; - end loop; - end Floating_Plus; - - --------------- - -- Is_Insert -- - --------------- - - function Is_Insert return Boolean is - begin - if At_End then - return False; - end if; - - case Pic.Picture.Expanded (Index) is - when '_' | '0' | '/' => - return True; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; -- canonical - return True; - - when others => - return False; - end case; - end Is_Insert; - - -------------------- - -- Leading_Dollar -- - -------------------- - - -- Note that Leading_Dollar can be called in either State. It will set - -- state to Okay only if a 9 or (second) is encountered. - - -- Also notice the tricky bit with State and Zero_Suppression. - -- Zero_Suppression is Picture_Error if a '$' or a '9' has been - -- encountered, exactly the cases where State has been set. - - procedure Leading_Dollar is - begin - -- Treat as a floating dollar, and unwind otherwise - - Pic.Floater := '$'; - Pic.Start_Currency := Index; - Pic.End_Currency := Index; - Pic.Start_Float := Index; - Pic.End_Float := Index; - - -- Don't increment Pic.Max_Leading_Digits, we need one "real" - -- currency place. - - Skip; -- known '$' - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - -- A trailing insertion character is not part of the - -- floating currency, so need to look ahead. - - if Look /= '$' then - Pic.End_Float := Pic.End_Float - 1; - end if; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when 'Z' | 'z' => - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - if State = Okay then - raise Picture_Error; - else - -- Will overwrite Floater and Start_Float - - Zero_Suppression; - end if; - - when '*' => - if State = Okay then - raise Picture_Error; - else - -- Will overwrite Floater and Start_Float - - Star_Suppression; - end if; - - when '$' => - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Pic.End_Currency := Index; - Set_State (Okay); Skip; - - when '9' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- A single dollar does not a floating make - - Number_Completion; - return; - - when 'V' | 'v' | '.' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- Only one dollar before the sign is okay, but doesn't - -- float. - - Pic.Radix_Position := Index; - Skip; - Number_Fraction_Or_Dollar; - return; - - when others => - return; - end case; - end loop; - end Leading_Dollar; - - ------------------- - -- Leading_Pound -- - ------------------- - - -- This one is complex. A Leading_Pound can be fixed or floating, but - -- in some cases the decision has to be deferred until we leave this - -- procedure. Also note that Leading_Pound can be called in either - -- State. - - -- It will set state to Okay only if a 9 or (second) # is encountered - - -- One Last note: In ambiguous cases, the currency is treated as - -- floating unless there is only one '#'. - - procedure Leading_Pound is - Inserts : Boolean := False; - -- Set to True if a '_', '0', '/', 'B', or 'b' is encountered - - Must_Float : Boolean := False; - -- Set to true if a '#' occurs after an insert - - begin - -- Treat as a floating currency. If it isn't, this will be - -- overwritten later. - - Pic.Floater := '#'; - - Pic.Start_Currency := Index; - Pic.End_Currency := Index; - Pic.Start_Float := Index; - Pic.End_Float := Index; - - -- Don't increment Pic.Max_Leading_Digits, we need one "real" - -- currency place. - - Pic.Max_Currency_Digits := 1; -- we've seen one. - - Skip; -- known '#' - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Inserts := True; - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Pic.End_Float := Index; - Inserts := True; - Skip; - - when 'Z' | 'z' => - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - if Must_Float then - raise Picture_Error; - else - Pic.Max_Leading_Digits := 0; - - -- Will overwrite Floater and Start_Float - - Zero_Suppression; - end if; - - when '*' => - if Must_Float then - raise Picture_Error; - else - Pic.Max_Leading_Digits := 0; - - -- Will overwrite Floater and Start_Float - - Star_Suppression; - end if; - - when '#' => - if Inserts then - Must_Float := True; - end if; - - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Pic.End_Currency := Index; - Set_State (Okay); - Skip; - - when '9' => - if State /= Okay then - - -- A single '#' doesn't float - - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - Number_Completion; - return; - - when 'V' | 'v' | '.' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- Only one pound before the sign is okay, but doesn't - -- float. - - Pic.Radix_Position := Index; - Skip; - Number_Fraction_Or_Pound; - return; - - when others => - return; - end case; - end loop; - end Leading_Pound; - - ---------- - -- Look -- - ---------- - - function Look return Character is - begin - if At_End then - raise Picture_Error; - end if; - - return Pic.Picture.Expanded (Index); - end Look; - - ------------ - -- Number -- - ------------ - - procedure Number is - begin - loop - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '9' => - Computed_BWZ := False; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Set_State (Okay); - Skip; - - when '.' | 'V' | 'v' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction; - return; - - when others => - return; - - end case; - - if At_End then - return; - end if; - - -- Will return in Okay state if a '9' was seen - - end loop; - end Number; - - ----------------------- - -- Number_Completion -- - ----------------------- - - procedure Number_Completion is - begin - while not At_End loop - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '9' => - Computed_BWZ := False; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Set_State (Okay); - Skip; - - when 'V' | 'v' | '.' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction; - return; - - when others => - return; - end case; - end loop; - end Number_Completion; - - --------------------- - -- Number_Fraction -- - --------------------- - - procedure Number_Fraction is - begin - -- Note that number fraction can be called in either State. - -- It will set state to Valid only if a 9 is encountered. - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '9' => - Computed_BWZ := False; - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Set_State (Okay); Skip; - - when others => - return; - end case; - end loop; - end Number_Fraction; - - -------------------------------- - -- Number_Fraction_Or_Bracket -- - -------------------------------- - - procedure Number_Fraction_Or_Bracket is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '<' => - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '<' => - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when others => - return; - end case; - end loop; - - when others => - Number_Fraction; - return; - end case; - end loop; - end Number_Fraction_Or_Bracket; - - ------------------------------- - -- Number_Fraction_Or_Dollar -- - ------------------------------- - - procedure Number_Fraction_Or_Dollar is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '$' => - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '$' => - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when others => - return; - end case; - end loop; - - when others => - Number_Fraction; - return; - end case; - end loop; - end Number_Fraction_Or_Dollar; - - ------------------------------ - -- Number_Fraction_Or_Pound -- - ------------------------------ - - procedure Number_Fraction_Or_Pound is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '#' => - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '#' => - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when others => - return; - end case; - end loop; - - when others => - Number_Fraction; - return; - end case; - end loop; - end Number_Fraction_Or_Pound; - - ---------------------------------- - -- Number_Fraction_Or_Star_Fill -- - ---------------------------------- - - procedure Number_Fraction_Or_Star_Fill is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '*' => - Pic.Star_Fill := True; - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '*' => - Pic.Star_Fill := True; - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when others => - return; - end case; - end loop; - - when others => - Number_Fraction; - return; - end case; - end loop; - end Number_Fraction_Or_Star_Fill; - - ------------------------------- - -- Number_Fraction_Or_Z_Fill -- - ------------------------------- - - procedure Number_Fraction_Or_Z_Fill is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when 'Z' | 'z' => - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - Skip; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when 'Z' | 'z' => - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when others => - return; - end case; - end loop; - - when others => - Number_Fraction; - return; - end case; - end loop; - end Number_Fraction_Or_Z_Fill; - - ----------------------- - -- Optional_RHS_Sign -- - ----------------------- - - procedure Optional_RHS_Sign is - begin - if At_End then - return; - end if; - - case Look is - when '+' | '-' => - Pic.Sign_Position := Index; - Skip; - return; - - when 'C' | 'c' => - Pic.Sign_Position := Index; - Pic.Picture.Expanded (Index) := 'C'; - Skip; - - if Look = 'R' or else Look = 'r' then - Pic.Second_Sign := Index; - Pic.Picture.Expanded (Index) := 'R'; - Skip; - - else - raise Picture_Error; - end if; - - return; - - when 'D' | 'd' => - Pic.Sign_Position := Index; - Pic.Picture.Expanded (Index) := 'D'; - Skip; - - if Look = 'B' or else Look = 'b' then - Pic.Second_Sign := Index; - Pic.Picture.Expanded (Index) := 'B'; - Skip; - - else - raise Picture_Error; - end if; - - return; - - when '>' => - if Pic.Picture.Expanded (Pic.Sign_Position) = '<' then - Pic.Second_Sign := Index; - Skip; - - else - raise Picture_Error; - end if; - - when others => - return; - end case; - end Optional_RHS_Sign; - - ------------- - -- Picture -- - ------------- - - -- Note that Picture can be called in either State - - -- It will set state to Valid only if a 9 is encountered or floating - -- currency is called. - - procedure Picture is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '$' => - Leading_Dollar; - return; - - when '#' => - Leading_Pound; - return; - - when '9' => - Computed_BWZ := False; - Set_State (Okay); - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Skip; - - when 'V' | 'v' | '.' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction; - Trailing_Currency; - return; - - when others => - return; - end case; - end loop; - end Picture; - - --------------------- - -- Picture_Bracket -- - --------------------- - - procedure Picture_Bracket is - begin - Pic.Sign_Position := Index; - Pic.Sign_Position := Index; - - -- Treat as a floating sign, and unwind otherwise - - Pic.Floater := '<'; - Pic.Start_Float := Index; - Pic.End_Float := Index; - - -- Don't increment Pic.Max_Leading_Digits, we need one "real" - -- sign place. - - Skip; -- Known Bracket - - loop - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '<' => - Set_State (Okay); -- "<<>" is enough. - Floating_Bracket; - Trailing_Currency; - Trailing_Bracket; - return; - - when '$' | '#' | '9' | '*' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - Picture; - Trailing_Bracket; - Set_State (Okay); - return; - - when '.' | 'V' | 'v' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- Don't assume that state is okay, haven't seen a digit - - Picture; - Trailing_Bracket; - return; - - when others => - raise Picture_Error; - end case; - end loop; - end Picture_Bracket; - - ------------------- - -- Picture_Minus -- - ------------------- - - procedure Picture_Minus is - begin - Pic.Sign_Position := Index; - - -- Treat as a floating sign, and unwind otherwise - - Pic.Floater := '-'; - Pic.Start_Float := Index; - Pic.End_Float := Index; - - -- Don't increment Pic.Max_Leading_Digits, we need one "real" - -- sign place. - - Skip; -- Known Minus - - loop - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '-' => - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Skip; - Set_State (Okay); -- "-- " is enough. - Floating_Minus; - Trailing_Currency; - return; - - when '$' | '#' | '9' | '*' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - Picture; - Set_State (Okay); - return; - - when 'Z' | 'z' => - - -- Can't have Z and a floating sign - - if State = Okay then - Set_State (Reject); - end if; - - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - Zero_Suppression; - Trailing_Currency; - Optional_RHS_Sign; - return; - - when '.' | 'V' | 'v' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- Don't assume that state is okay, haven't seen a digit - - Picture; - return; - - when others => - return; - end case; - end loop; - end Picture_Minus; - - ------------------ - -- Picture_Plus -- - ------------------ - - procedure Picture_Plus is - begin - Pic.Sign_Position := Index; - - -- Treat as a floating sign, and unwind otherwise - - Pic.Floater := '+'; - Pic.Start_Float := Index; - Pic.End_Float := Index; - - -- Don't increment Pic.Max_Leading_Digits, we need one "real" - -- sign place. - - Skip; -- Known Plus - - loop - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '+' => - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Skip; - Set_State (Okay); -- "++" is enough - Floating_Plus; - Trailing_Currency; - return; - - when '$' | '#' | '9' | '*' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - Picture; - Set_State (Okay); - return; - - when 'Z' | 'z' => - if State = Okay then - Set_State (Reject); - end if; - - -- Can't have Z and a floating sign - - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - -- '+Z' is acceptable - - Set_State (Okay); - - Zero_Suppression; - Trailing_Currency; - Optional_RHS_Sign; - return; - - when '.' | 'V' | 'v' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- Don't assume that state is okay, haven't seen a digit - - Picture; - return; - - when others => - return; - end case; - end loop; - end Picture_Plus; - - -------------------- - -- Picture_String -- - -------------------- - - procedure Picture_String is - begin - while Is_Insert loop - Skip; - end loop; - - case Look is - when '$' | '#' => - Picture; - Optional_RHS_Sign; - - when '+' => - Picture_Plus; - - when '-' => - Picture_Minus; - - when '<' => - Picture_Bracket; - - when 'Z' | 'z' => - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - Zero_Suppression; - Trailing_Currency; - Optional_RHS_Sign; - - when '*' => - Star_Suppression; - Trailing_Currency; - Optional_RHS_Sign; - - when '9' | '.' | 'V' | 'v' => - Number; - Trailing_Currency; - Optional_RHS_Sign; - - when others => - raise Picture_Error; - end case; - - -- Blank when zero either if the PIC does not contain a '9' or if - -- requested by the user and no '*'. - - Pic.Blank_When_Zero := - (Computed_BWZ or else Pic.Blank_When_Zero) - and then not Pic.Star_Fill; - - -- Star fill if '*' and no '9' - - Pic.Star_Fill := Pic.Star_Fill and then Computed_BWZ; - - if not At_End then - Set_State (Reject); - end if; - end Picture_String; - - --------------- - -- Set_State -- - --------------- - - procedure Set_State (L : Legality) is - begin - State := L; - end Set_State; - - ---------- - -- Skip -- - ---------- - - procedure Skip is - begin - Index := Index + 1; - end Skip; - - ---------------------- - -- Star_Suppression -- - ---------------------- - - procedure Star_Suppression is - begin - Pic.Floater := '*'; - Pic.Start_Float := Index; - Pic.End_Float := Index; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Set_State (Okay); - - -- Even a single * is a valid picture - - Pic.Star_Fill := True; - Skip; -- Known * - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '*' => - Pic.End_Float := Index; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Set_State (Okay); Skip; - - when '9' => - Set_State (Okay); - Number_Completion; - return; - - when '.' | 'V' | 'v' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction_Or_Star_Fill; - return; - - when '#' | '$' => - Trailing_Currency; - Set_State (Okay); - return; - - when others => - raise Picture_Error; - end case; - end loop; - end Star_Suppression; - - ---------------------- - -- Trailing_Bracket -- - ---------------------- - - procedure Trailing_Bracket is - begin - if Look = '>' then - Pic.Second_Sign := Index; - Skip; - else - raise Picture_Error; - end if; - end Trailing_Bracket; - - ----------------------- - -- Trailing_Currency -- - ----------------------- - - procedure Trailing_Currency is - begin - if At_End then - return; - end if; - - if Look = '$' then - Pic.Start_Currency := Index; - Pic.End_Currency := Index; - Skip; - - else - while not At_End and then Look = '#' loop - if Pic.Start_Currency = Invalid_Position then - Pic.Start_Currency := Index; - end if; - - Pic.End_Currency := Index; - Skip; - end loop; - end if; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when others => - return; - end case; - end loop; - end Trailing_Currency; - - ---------------------- - -- Zero_Suppression -- - ---------------------- - - procedure Zero_Suppression is - begin - Pic.Floater := 'Z'; - Pic.Start_Float := Index; - Pic.End_Float := Index; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - Skip; -- Known Z - - loop - -- Even a single Z is a valid picture - - if At_End then - Set_State (Okay); - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when 'Z' | 'z' => - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Set_State (Okay); - Skip; - - when '9' => - Set_State (Okay); - Number_Completion; - return; - - when '.' | 'V' | 'v' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction_Or_Z_Fill; - return; - - when '#' | '$' => - Trailing_Currency; - Set_State (Okay); - return; - - when others => - return; - end case; - end loop; - end Zero_Suppression; - - -- Start of processing for Precalculate - - begin - Picture_String; - - if State = Reject then - raise Picture_Error; - end if; - - exception - - when Constraint_Error => - - -- To deal with special cases like null strings - - raise Picture_Error; - - end Precalculate; - - ---------------- - -- To_Picture -- - ---------------- - - function To_Picture - (Pic_String : String; - Blank_When_Zero : Boolean := False) return Picture - is - Result : Picture; - - begin - declare - Item : constant String := Expand (Pic_String); - - begin - Result.Contents.Picture := (Item'Length, Item); - Result.Contents.Original_BWZ := Blank_When_Zero; - Result.Contents.Blank_When_Zero := Blank_When_Zero; - Precalculate (Result.Contents); - return Result; - end; - - exception - when others => - raise Picture_Error; - - end To_Picture; - - ------------- - -- To_Wide -- - ------------- - - function To_Wide (C : Character) return Wide_Wide_Character is - begin - return Wide_Wide_Character'Val (Character'Pos (C)); - end To_Wide; - - ----------- - -- Valid -- - ----------- - - function Valid - (Pic_String : String; - Blank_When_Zero : Boolean := False) return Boolean - is - begin - declare - Expanded_Pic : constant String := Expand (Pic_String); - -- Raises Picture_Error if Item not well-formed - - Format_Rec : Format_Record; - - begin - Format_Rec.Picture := (Expanded_Pic'Length, Expanded_Pic); - Format_Rec.Blank_When_Zero := Blank_When_Zero; - Format_Rec.Original_BWZ := Blank_When_Zero; - Precalculate (Format_Rec); - - -- False only if Blank_When_0 is True but the pic string has a '*' - - return not Blank_When_Zero - or else Strings_Fixed.Index (Expanded_Pic, "*") = 0; - end; - - exception - when others => return False; - end Valid; - -end Ada.Wide_Wide_Text_IO.Editing; |