-- --
-- B o d y --
-- --
--- $Revision: 1.1 $
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 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- --
-- 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). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
exception
when others =>
raise Picture_Error;
-
end Expand;
-------------------
Answer : String (1 .. Pic.Picture.Length) := Pic.Picture.Expanded;
Last : Integer;
Currency_Pos : Integer := Pic.Start_Currency;
+ In_Currency : Boolean := False;
Dollar : Boolean := False;
-- Overridden immediately if necessary.
if Attrs.End_Of_Int - Attrs.Start_Of_Int + 1 >
Pic.Max_Leading_Digits
then
- raise Layout_Error;
+ raise Ada.Text_IO.Layout_Error;
end if;
if Pic.Radix_Position = Invalid_Position then
else
if Pic.Floater = '#' then
Currency_Pos := Currency_Symbol'Length;
+ In_Currency := True;
end if;
for J in reverse Pic.Start_Float .. Position loop
when '*' =>
Answer (J) := Fill_Character;
- when 'Z' | 'b' | '/' | '0' =>
+ when 'b' | '/' =>
+ if In_Currency and then Currency_Pos > 0 then
+ Answer (J) := Currency_Symbol (Currency_Pos);
+ Currency_Pos := Currency_Pos - 1;
+ else
+ Answer (J) := ' ';
+ end if;
+
+ when 'Z' | '0' =>
Answer (J) := ' ';
when '9' =>
end loop;
if Pic.Floater = '#' and then Currency_Pos /= 0 then
- raise Layout_Error;
+ raise Ada.Text_IO.Layout_Error;
end if;
end if;
if Sign_Position = Invalid_Position then
if Attrs.Negative then
- raise Layout_Error;
+ raise Ada.Text_IO.Layout_Error;
end if;
else
else
if Pic.Floater = '#' and then Currency_Pos /= 0 then
- raise Layout_Error;
+ raise Ada.Text_IO.Layout_Error;
end if;
-- No trailing digits, but now J may need to stick in a currency
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) := ' ';
+ if In_Currency then
+ Answer (J) := Currency_Symbol (Currency_Pos);
+ Currency_Pos := Currency_Pos + 1;
+
+ if Currency_Pos > Currency_Symbol'Length then
+ In_Currency := False;
+ end if;
+ end if;
when '#' =>
if Currency_Pos > Currency_Symbol'Length then
Answer (J) := ' ';
else
+ In_Currency := True;
Answer (J) := Currency_Symbol (Currency_Pos);
Currency_Pos := Currency_Pos + 1;
+
+ if Currency_Pos > Currency_Symbol'Length then
+ In_Currency := False;
+ end if;
end if;
when '_' =>
+ Answer (J) := Currency_Symbol (Currency_Pos);
+ Currency_Pos := Currency_Pos + 1;
case Pic.Floater is
Last := Last - 1;
end if;
- return String' (1 .. Last => ' ');
+ return String'(1 .. Last => ' ');
elsif Zero and Pic.Star_Fill then
Last := Answer'Last;
elsif Dollar then
if Pic.Radix_Position > Pic.Start_Currency then
- return String' (1 .. Pic.Radix_Position - 1 => '*') &
+ return String'(1 .. Pic.Radix_Position - 1 => '*') &
Radix_Point &
- String' (Pic.Radix_Position + 1 .. Last => '*');
+ String'(Pic.Radix_Position + 1 .. Last => '*');
else
return
end if;
else
- return String' (1 .. Pic.Radix_Position - 1 => '*') &
+ return String'(1 .. Pic.Radix_Position - 1 => '*') &
Radix_Point &
- String' (Pic.Radix_Position + 1 .. Last => '*');
+ String'(Pic.Radix_Position + 1 .. Last => '*');
end if;
end if;
- return String' (1 .. Last => '*');
+ return String'(1 .. Last => '*');
end if;
-- This was once a simple return statement, now there are nine
-- Processing the radix and sign expansion separately
-- would require lots of copying--the string and some of its
- -- indices--without really simplifying the logic. The cases are:
+ -- indicies--without really simplifying the logic. The cases are:
-- 1) Expand $, replace '.' with Radix_Point
-- 2) No currency expansion, replace '.' with Radix_Point
return Answer;
end if;
-
end Format_Number;
-------------------------
-- No significant (intger) digits needs a null range.
return Answer;
-
end Parse_Number_String;
----------------
------------------
procedure Precalculate (Pic : in out Format_Record) is
+ Debug : constant Boolean := False;
+ -- Set True to generate debug output
Computed_BWZ : Boolean := True;
- Debug : Boolean := False;
type Legality is (Okay, Reject);
+
State : Legality := Reject;
-- Start in reject, which will reject null strings.
procedure Number;
procedure Optional_RHS_Sign;
procedure Picture_String;
+ procedure Set_Debug;
------------
-- At_End --
function At_End return Boolean is
begin
+ Debug_Start ("At_End");
return Index > Pic.Picture.Length;
end At_End;
+ --------------
+ -- Set_Debug--
+ --------------
+
+ -- Needed to have a procedure to pass to pragma Debug
+
+ procedure Set_Debug is
+ begin
+ -- Uncomment this line and make Debug a variable to enable debug
+
+ -- Debug := True;
+
+ null;
+ end Set_Debug;
+
-------------------
-- Debug_Integer --
-------------------
procedure Floating_Bracket is
begin
Debug_Start ("Floating_Bracket");
- Pic.Floater := '<';
+
+ -- Two different floats not allowed.
+
+ if Pic.Floater /= '!' and then Pic.Floater /= '<' then
+ raise Picture_Error;
+
+ else
+ Pic.Floater := '<';
+ end if;
+
Pic.End_Float := Index;
Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
end loop;
end Floating_Bracket;
-
--------------------
-- Floating_Minus --
--------------------
begin
Debug_Start ("Leading_Dollar");
- -- Treat as a floating dollar, and unwind otherwise.
+ -- Treat as a floating dollar, and unwind otherwise
+
+ if Pic.Floater /= '!' and then Pic.Floater /= '$' then
+
+ -- Two floats not allowed
+
+ raise Picture_Error;
+
+ else
+ Pic.Floater := '$';
+ end if;
- Pic.Floater := '$';
Pic.Start_Currency := Index;
Pic.End_Currency := Index;
Pic.Start_Float := Index;
if State = Okay then
raise Picture_Error;
else
- -- Will overwrite Floater and Start_Float
+ -- Overwrite Floater and Start_Float
+ Pic.Floater := 'Z';
+ Pic.Start_Float := Index;
Zero_Suppression;
end if;
if State = Okay then
raise Picture_Error;
else
- -- Will overwrite Floater and Start_Float
-
+ -- Overwrite Floater and Start_Float
+ Pic.Floater := '*';
+ Pic.Start_Float := Index;
Star_Suppression;
end if;
-- Treat as a floating currency. If it isn't, this will be
-- overwritten later.
- Pic.Floater := '#';
+ if Pic.Floater /= '!' and then Pic.Floater /= '#' then
+
+ -- Two floats not allowed
+
+ raise Picture_Error;
+
+ else
+ Pic.Floater := '#';
+ end if;
Pic.Start_Currency := Index;
Pic.End_Currency := Index;
else
Pic.Max_Leading_Digits := 0;
- -- Will overwrite Floater and Start_Float
+ -- Overwrite Floater and Start_Float
+ Pic.Floater := 'Z';
+ Pic.Start_Float := Index;
Zero_Suppression;
end if;
else
Pic.Max_Leading_Digits := 0;
- -- Will overwrite Floater and Start_Float
-
+ -- Overwrite Floater and Start_Float
+ Pic.Floater := '*';
+ Pic.Start_Float := Index;
Star_Suppression;
end if;
Set_State (Okay);
+ -- Overwrite Floater and Start_Float
+
+ Pic.Floater := 'Z';
+ Pic.Start_Float := Index;
+
Zero_Suppression;
Trailing_Currency;
Optional_RHS_Sign;
procedure Star_Suppression is
begin
Debug_Start ("Star_Suppression");
- Pic.Floater := '*';
+
+ if Pic.Floater /= '!' and then Pic.Floater /= '*' then
+
+ -- Two floats not allowed
+
+ raise Picture_Error;
+
+ else
+ Pic.Floater := '*';
+ end if;
+
Pic.Start_Float := Index;
Pic.End_Float := Index;
Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
return;
when '#' | '$' =>
+ if Pic.Max_Currency_Digits > 0 then
+ raise Picture_Error;
+ end if;
+
+ -- Cannot have leading and trailing currency
+
Trailing_Currency;
Set_State (Okay);
return;
-- Start of processing for Precalculate
begin
+ pragma Debug (Set_Debug);
+
Picture_String;
if Debug then
-- To deal with special cases like null strings.
raise Picture_Error;
-
end Precalculate;
----------------
exception
when others =>
raise Picture_Error;
-
end To_Picture;
-----------
Format_Rec.Original_BWZ := Blank_When_Zero;
Precalculate (Format_Rec);
- -- False only if Blank_When_0 is True but the pic string has a '*'
+ -- False only if Blank_When_Zero is True but the pic string has a '*'
return not Blank_When_Zero or
Strings_Fixed.Index (Expanded_Pic, "*") = 0;
exception
when others => return False;
-
end Valid;
--------------------
begin
if Result'Length > To'Length then
- raise Text_IO.Layout_Error;
+ raise Ada.Text_IO.Layout_Error;
else
Strings_Fixed.Move (Source => Result, Target => To,
Justify => Strings.Right);
end;
exception
- when Layout_Error => return False;
+ when Ada.Text_IO.Layout_Error => return False;
end Valid;
-
end Decimal_Output;
end Ada.Text_IO.Editing;
OSDN Git Service
