2768 lines
75 KiB
Ada
2768 lines
75 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT RUN-TIME COMPONENTS --
|
|
-- --
|
|
-- A D A . W I D E _ T E X T _ I O . E D I T I N G --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1992-2013, 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_Fixed;
|
|
|
|
package body Ada.Wide_Text_IO.Editing is
|
|
|
|
package Strings renames Ada.Strings;
|
|
package Strings_Fixed renames Ada.Strings.Fixed;
|
|
package Strings_Wide_Fixed renames Ada.Strings.Wide_Fixed;
|
|
package Wide_Text_IO renames Ada.Wide_Text_IO;
|
|
|
|
-----------------------
|
|
-- Local_Subprograms --
|
|
-----------------------
|
|
|
|
function To_Wide (C : Character) return Wide_Character;
|
|
pragma Inline (To_Wide);
|
|
-- Convert Character to corresponding 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_String := Default_Currency;
|
|
Fill : Wide_Character := Default_Fill;
|
|
Separator : Wide_Character := Default_Separator;
|
|
Radix_Mark : Wide_Character := Default_Radix_Mark) return 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_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_Text_IO.File_Type;
|
|
Item : Num;
|
|
Pic : Picture;
|
|
Currency : Wide_String := Default_Currency;
|
|
Fill : Wide_Character := Default_Fill;
|
|
Separator : Wide_Character := Default_Separator;
|
|
Radix_Mark : Wide_Character := Default_Radix_Mark)
|
|
is
|
|
begin
|
|
Wide_Text_IO.Put (File, Image (Item, Pic,
|
|
Currency, Fill, Separator, Radix_Mark));
|
|
end Put;
|
|
|
|
procedure Put
|
|
(Item : Num;
|
|
Pic : Picture;
|
|
Currency : Wide_String := Default_Currency;
|
|
Fill : Wide_Character := Default_Fill;
|
|
Separator : Wide_Character := Default_Separator;
|
|
Radix_Mark : Wide_Character := Default_Radix_Mark)
|
|
is
|
|
begin
|
|
Wide_Text_IO.Put (Image (Item, Pic,
|
|
Currency, Fill, Separator, Radix_Mark));
|
|
end Put;
|
|
|
|
procedure Put
|
|
(To : out Wide_String;
|
|
Item : Num;
|
|
Pic : Picture;
|
|
Currency : Wide_String := Default_Currency;
|
|
Fill : Wide_Character := Default_Fill;
|
|
Separator : Wide_Character := Default_Separator;
|
|
Radix_Mark : Wide_Character := Default_Radix_Mark)
|
|
is
|
|
Result : constant Wide_String :=
|
|
Image (Item, Pic, Currency, Fill, Separator, Radix_Mark);
|
|
|
|
begin
|
|
if Result'Length > To'Length then
|
|
raise Wide_Text_IO.Layout_Error;
|
|
else
|
|
Strings_Wide_Fixed.Move (Source => Result, Target => To,
|
|
Justify => Strings.Right);
|
|
end if;
|
|
end Put;
|
|
|
|
-----------
|
|
-- Valid --
|
|
-----------
|
|
|
|
function Valid
|
|
(Item : Num;
|
|
Pic : Picture;
|
|
Currency : Wide_String := Default_Currency) return Boolean
|
|
is
|
|
begin
|
|
declare
|
|
Temp : constant 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_String;
|
|
Fill_Character : Wide_Character;
|
|
Separator_Character : Wide_Character;
|
|
Radix_Point : Wide_Character) return 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_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_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_String'(1 .. Pic.Radix_Position - 1 => '*') &
|
|
Radix_Point &
|
|
Wide_String'(Pic.Radix_Position + 1 .. Last => '*');
|
|
|
|
else
|
|
return
|
|
Wide_String'
|
|
(1 ..
|
|
Pic.Radix_Position + Currency_Symbol'Length - 2
|
|
=> '*') &
|
|
Radix_Point &
|
|
Wide_String'
|
|
(Pic.Radix_Position + Currency_Symbol'Length .. Last
|
|
=> '*');
|
|
end if;
|
|
|
|
else
|
|
return
|
|
Wide_String'(1 .. Pic.Radix_Position - 1 => '*') &
|
|
Radix_Point &
|
|
Wide_String'(Pic.Radix_Position + 1 .. Last => '*');
|
|
end if;
|
|
end if;
|
|
|
|
return 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_Character is
|
|
begin
|
|
return 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_Text_IO.Editing;
|