diff options
Diffstat (limited to 'gcc/ada/a-teioed.adb')
| -rw-r--r-- | gcc/ada/a-teioed.adb | 2827 |
1 files changed, 2827 insertions, 0 deletions
diff --git a/gcc/ada/a-teioed.adb b/gcc/ada/a-teioed.adb new file mode 100644 index 00000000000..8a448c87b5f --- /dev/null +++ b/gcc/ada/a-teioed.adb @@ -0,0 +1,2827 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . E D I T I N G -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.18 $ +-- -- +-- Copyright (C) 1992-2001 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Fixed; +package body Ada.Text_IO.Editing is + + package Strings renames Ada.Strings; + package Strings_Fixed renames Ada.Strings.Fixed; + package Text_IO renames Ada.Text_IO; + + --------------------- + -- Blank_When_Zero -- + --------------------- + + function Blank_When_Zero (Pic : in Picture) return Boolean is + begin + return Pic.Contents.Original_BWZ; + end Blank_When_Zero; + + ------------ + -- Expand -- + ------------ + + function Expand (Picture : in String) return String is + Result : String (1 .. MAX_PICSIZE); + Picture_Index : Integer := Picture'First; + Result_Index : Integer := Result'First; + Count : Natural; + Last : Integer; + + package Int_IO is new Ada.Text_IO.Integer_IO (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 '(' => + Int_IO.Get (Picture (Picture_Index + 1 .. Picture'Last), + Count, Last); + + if Picture (Last + 1) /= ')' then + raise Picture_Error; + end if; + + -- In what follows note that one copy of the repeated + -- character has already been made, so a count of one is a + -- 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 + 1 was a ')' throw it away too. + + Picture_Index := Last + 2; + + 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 : String; + Fill_Character : Character; + Separator_Character : Character; + Radix_Point : Character) + return String + is + Attrs : Number_Attributes := Parse_Number_String (Number); + Position : Integer; + Rounded : String := Number; + + Sign_Position : Integer := Pic.Sign_Position; -- may float. + + Answer : String (1 .. Pic.Picture.Length) := Pic.Picture.Expanded; + 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 := Attrs.End_Of_Fraction - 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; + + 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; + + if Pic.Radix_Position = Invalid_Position then + Position := Answer'Last; + else + Position := Pic.Radix_Position - 1; + end if; + + for J in reverse Attrs.Start_Of_Int .. Attrs.End_Of_Int loop + + while Answer (Position) /= '9' + and 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) := 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 separators 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 Answer (J) = Pic.Floater then + Answer (J) := 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. + + if Pic.Start_Currency = Invalid_Position then + Position := Answer'Last + 1; + else + Position := Pic.Start_Currency; + end if; + 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 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 String' (1 .. Last => ' '); + + elsif Zero and 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 String' (1 .. Pic.Radix_Position - 1 => '*') & + Radix_Point & + String' (Pic.Radix_Position + 1 .. Last => '*'); + + else + return + String' + (1 .. + Pic.Radix_Position + Currency_Symbol'Length - 2 => + '*') & Radix_Point & + String' + (Pic.Radix_Position + Currency_Symbol'Length .. Last + => '*'); + end if; + + else + return String' (1 .. Pic.Radix_Position - 1 => '*') & + Radix_Point & + String' (Pic.Radix_Position + 1 .. Last => '*'); + end if; + end if; + + return 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 + -- indicies--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 : in 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; + Debug : Boolean := False; + + 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 Debug_Start (Name : String); + pragma Inline (Debug_Start); + + procedure Debug_Integer (Value : in Integer; S : String); + pragma Inline (Debug_Integer); + + 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; + + ------------------- + -- Debug_Integer -- + ------------------- + + procedure Debug_Integer (Value : in Integer; S : String) is + use Ada.Text_IO; -- needed for > + + begin + if Debug and then Value > 0 then + if Ada.Text_IO.Col > 70 - S'Length then + Ada.Text_IO.New_Line; + end if; + + Ada.Text_IO.Put (' ' & S & Integer'Image (Value) & ','); + end if; + end Debug_Integer; + + ----------------- + -- Debug_Start -- + ----------------- + + procedure Debug_Start (Name : String) is + begin + if Debug then + Ada.Text_IO.Put_Line (" In " & Name & '.'); + end if; + end Debug_Start; + + ---------------------- + -- 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 + Debug_Start ("Floating_Bracket"); + 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 + Debug_Start ("Floating_Minus"); + + 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 + Debug_Start ("Floating_Plus"); + + 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 + Debug_Start ("Leading_Dollar"); + + -- 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 + Debug_Start ("Leading_Pound"); + + -- 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 + Debug_Start ("Number"); + + 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 + Debug_Start ("Number_Completion"); + + 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. + + Debug_Start ("Number_Fraction"); + + 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 + Debug_Start ("Number_Fraction_Or_Bracket"); + + 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 + Debug_Start ("Number_Fraction_Or_Dollar"); + + 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 + Debug_Start ("Number_Fraction_Or_Star_Fill"); + + 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 + Debug_Start ("Number_Fraction_Or_Z_Fill"); + + 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 + Debug_Start ("Optional_RHS_Sign"); + + 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 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 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 + Debug_Start ("Picture"); + + 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; + Debug_Start ("Picture_Bracket"); + 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 + Debug_Start ("Picture_Minus"); + + 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 + Debug_Start ("Picture_Plus"); + 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 + Debug_Start ("Picture_String"); + + 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 Pic.Blank_When_Zero) and not Pic.Star_Fill; + + -- Star fill if '*' and no '9'. + + Pic.Star_Fill := Pic.Star_Fill and Computed_BWZ; + + if not At_End then + Set_State (Reject); + end if; + + end Picture_String; + + --------------- + -- Set_State -- + --------------- + + procedure Set_State (L : Legality) is + begin + if Debug then Ada.Text_IO.Put_Line + (" Set state from " & Legality'Image (State) & + " to " & Legality'Image (L)); + end if; + + State := L; + end Set_State; + + ---------- + -- Skip -- + ---------- + + procedure Skip is + begin + if Debug then Ada.Text_IO.Put_Line + (" Skip " & Pic.Picture.Expanded (Index)); + end if; + + Index := Index + 1; + end Skip; + + ---------------------- + -- Star_Suppression -- + ---------------------- + + procedure Star_Suppression is + begin + Debug_Start ("Star_Suppression"); + 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 + Debug_Start ("Trailing_Bracket"); + + if Look = '>' then + Pic.Second_Sign := Index; + Skip; + else + raise Picture_Error; + end if; + end Trailing_Bracket; + + ----------------------- + -- Trailing_Currency -- + ----------------------- + + procedure Trailing_Currency is + begin + Debug_Start ("Trailing_Currency"); + + 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 + Debug_Start ("Zero_Suppression"); + + 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 Debug then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put (" Picture : """ & + Pic.Picture.Expanded (1 .. Pic.Picture.Length) & ""","); + Ada.Text_IO.Put (" Floater : '" & Pic.Floater & "',"); + end if; + + if State = Reject then + raise Picture_Error; + end if; + + Debug_Integer (Pic.Radix_Position, "Radix Positon : "); + Debug_Integer (Pic.Sign_Position, "Sign Positon : "); + Debug_Integer (Pic.Second_Sign, "Second Sign : "); + Debug_Integer (Pic.Start_Float, "Start Float : "); + Debug_Integer (Pic.End_Float, "End Float : "); + Debug_Integer (Pic.Start_Currency, "Start Currency : "); + Debug_Integer (Pic.End_Currency, "End Currency : "); + Debug_Integer (Pic.Max_Leading_Digits, "Max Leading Digits : "); + Debug_Integer (Pic.Max_Trailing_Digits, "Max Trailing Digits : "); + + if Debug then + Ada.Text_IO.New_Line; + 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 : in String; + Blank_When_Zero : in 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; + + ----------- + -- Valid -- + ----------- + + function Valid + (Pic_String : in String; + Blank_When_Zero : in 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 + Strings_Fixed.Index (Expanded_Pic, "*") = 0; + end; + + exception + when others => return False; + + end Valid; + + -------------------- + -- Decimal_Output -- + -------------------- + + package body Decimal_Output is + + ----------- + -- Image -- + ----------- + + function Image + (Item : in Num; + Pic : in Picture; + Currency : in String := Default_Currency; + Fill : in Character := Default_Fill; + Separator : in Character := Default_Separator; + Radix_Mark : in Character := Default_Radix_Mark) + return String + is + begin + return Format_Number + (Pic.Contents, Num'Image (Item), + Currency, Fill, Separator, Radix_Mark); + end Image; + + ------------ + -- Length -- + ------------ + + function Length + (Pic : in Picture; + Currency : in 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 : in Text_IO.File_Type; + Item : in Num; + Pic : in Picture; + Currency : in String := Default_Currency; + Fill : in Character := Default_Fill; + Separator : in Character := Default_Separator; + Radix_Mark : in Character := Default_Radix_Mark) + is + begin + Text_IO.Put (File, Image (Item, Pic, + Currency, Fill, Separator, Radix_Mark)); + end Put; + + procedure Put + (Item : in Num; + Pic : in Picture; + Currency : in String := Default_Currency; + Fill : in Character := Default_Fill; + Separator : in Character := Default_Separator; + Radix_Mark : in Character := Default_Radix_Mark) + is + begin + Text_IO.Put (Image (Item, Pic, + Currency, Fill, Separator, Radix_Mark)); + end Put; + + procedure Put + (To : out String; + Item : in Num; + Pic : in Picture; + Currency : in String := Default_Currency; + Fill : in Character := Default_Fill; + Separator : in Character := Default_Separator; + Radix_Mark : in Character := Default_Radix_Mark) + is + Result : constant String := + Image (Item, Pic, Currency, Fill, Separator, Radix_Mark); + + begin + if Result'Length > To'Length then + raise Text_IO.Layout_Error; + else + Strings_Fixed.Move (Source => Result, Target => To, + Justify => Strings.Right); + end if; + end Put; + + ----------- + -- Valid -- + ----------- + + function Valid + (Item : Num; + Pic : in Picture; + Currency : in String := Default_Currency) + return Boolean + is + begin + declare + Temp : constant String := Image (Item, Pic, Currency); + pragma Warnings (Off, Temp); + begin + return True; + end; + + exception + when Layout_Error => return False; + + end Valid; + + end Decimal_Output; + +end Ada.Text_IO.Editing; |