gcc/ada/a-teioed.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                  A D A . T E X T _ I O . E D I T I N G                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Ada.Strings.Fixed;
  33 package body Ada.Text_IO.Editing is
  34
  35    package Strings renames Ada.Strings;
  36    package Strings_Fixed renames Ada.Strings.Fixed;
  37    package Text_IO renames Ada.Text_IO;
  38
  39    ---------------------
  40    -- Blank_When_Zero --
  41    ---------------------
  42
  43    function Blank_When_Zero (Pic : Picture) return Boolean is
  44    begin
  45       return Pic.Contents.Original_BWZ;
  46    end Blank_When_Zero;
  47
  48    ------------
  49    -- Expand --
  50    ------------
  51
  52    function Expand (Picture : String) return String is
  53       Result        : String (1 .. MAX_PICSIZE);
  54       Picture_Index : Integer := Picture'First;
  55       Result_Index  : Integer := Result'First;
  56       Count         : Natural;
  57       Last          : Integer;
  58
  59       package Int_IO is new Ada.Text_IO.Integer_IO (Integer);
  60
  61    begin
  62       if Picture'Length < 1 then
  63          raise Picture_Error;
  64       end if;
  65
  66       if Picture (Picture'First) = '(' then
  67          raise Picture_Error;
  68       end if;
  69
  70       loop
  71          case Picture (Picture_Index) is
  72
  73             when '(' =>
  74                Int_IO.Get
  75                  (Picture (Picture_Index + 1 .. Picture'Last), Count, Last);
  76
  77                if Picture (Last + 1) /= ')' then
  78                   raise Picture_Error;
  79                end if;
  80
  81                --  In what follows note that one copy of the repeated character
  82                --  has already been made, so a count of one is a no-op, and a
  83                --  count of zero erases a character.
  84
  85                if Result_Index + Count - 2 > Result'Last then
  86                   raise Picture_Error;
  87                end if;
  88
  89                for J in 2 .. Count loop
  90                   Result (Result_Index + J - 2) := Picture (Picture_Index - 1);
  91                end loop;
  92
  93                Result_Index := Result_Index + Count - 1;
  94
  95                --  Last + 1 was a ')' throw it away too
  96
  97                Picture_Index := Last + 2;
  98
  99             when ')' =>
 100                raise Picture_Error;
 101
 102             when others =>
 103                if Result_Index > Result'Last then
 104                   raise Picture_Error;
 105                end if;
 106
 107                Result (Result_Index) := Picture (Picture_Index);
 108                Picture_Index := Picture_Index + 1;
 109                Result_Index := Result_Index + 1;
 110
 111          end case;
 112
 113          exit when Picture_Index > Picture'Last;
 114       end loop;
 115
 116       return Result (1 .. Result_Index - 1);
 117
 118    exception
 119       when others =>
 120          raise Picture_Error;
 121    end Expand;
 122
 123    -------------------
 124    -- Format_Number --
 125    -------------------
 126
 127    function Format_Number
 128      (Pic                 : Format_Record;
 129       Number              : String;
 130       Currency_Symbol     : String;
 131       Fill_Character      : Character;
 132       Separator_Character : Character;
 133       Radix_Point         : Character) return String
 134    is
 135       Attrs    : Number_Attributes := Parse_Number_String (Number);
 136       Position : Integer;
 137       Rounded  : String := Number;
 138
 139       Sign_Position : Integer := Pic.Sign_Position; --  may float.
 140
 141       Answer : String (1 .. Pic.Picture.Length) := Pic.Picture.Expanded;
 142       Last          : Integer;
 143       Currency_Pos  : Integer := Pic.Start_Currency;
 144       In_Currency   : Boolean := False;
 145
 146       Dollar : Boolean := False;
 147       --  Overridden immediately if necessary
 148
 149       Zero : Boolean := True;
 150       --  Set to False when a non-zero digit is output
 151
 152    begin
 153
 154       --  If the picture has fewer decimal places than the number, the image
 155       --  must be rounded according to the usual rules.
 156
 157       if Attrs.Has_Fraction then
 158          declare
 159             R : constant Integer :=
 160               (Attrs.End_Of_Fraction - Attrs.Start_Of_Fraction + 1)
 161                 - Pic.Max_Trailing_Digits;
 162             R_Pos : Integer;
 163
 164          begin
 165             if R > 0 then
 166                R_Pos := Attrs.End_Of_Fraction - R;
 167
 168                if Rounded (R_Pos + 1) > '4' then
 169
 170                   if Rounded (R_Pos) = '.' then
 171                      R_Pos := R_Pos - 1;
 172                   end if;
 173
 174                   if Rounded (R_Pos) /= '9' then
 175                      Rounded (R_Pos) := Character'Succ (Rounded (R_Pos));
 176                   else
 177                      Rounded (R_Pos) := '0';
 178                      R_Pos := R_Pos - 1;
 179
 180                      while R_Pos > 1 loop
 181                         if Rounded (R_Pos) = '.' then
 182                            R_Pos := R_Pos - 1;
 183                         end if;
 184
 185                         if Rounded (R_Pos) /= '9' then
 186                            Rounded (R_Pos) := Character'Succ (Rounded (R_Pos));
 187                            exit;
 188                         else
 189                            Rounded (R_Pos) := '0';
 190                            R_Pos := R_Pos - 1;
 191                         end if;
 192                      end loop;
 193
 194                      --  The rounding may add a digit in front. Either the
 195                      --  leading blank or the sign (already captured) can
 196                      --  be overwritten.
 197
 198                      if R_Pos = 1 then
 199                         Rounded (R_Pos) := '1';
 200                         Attrs.Start_Of_Int := Attrs.Start_Of_Int - 1;
 201                      end if;
 202                   end if;
 203                end if;
 204             end if;
 205          end;
 206       end if;
 207
 208       if Pic.Start_Currency /= Invalid_Position then
 209          Dollar := Answer (Pic.Start_Currency) = '$';
 210       end if;
 211
 212       --  Fix up "direct inserts" outside the playing field. Set up as one
 213       --  loop to do the beginning, one (reverse) loop to do the end.
 214
 215       Last := 1;
 216       loop
 217          exit when Last = Pic.Start_Float;
 218          exit when Last = Pic.Radix_Position;
 219          exit when Answer (Last) = '9';
 220
 221          case Answer (Last) is
 222
 223             when '_' =>
 224                Answer (Last) := Separator_Character;
 225
 226             when 'b' =>
 227                Answer (Last) := ' ';
 228
 229             when others =>
 230                null;
 231
 232          end case;
 233
 234          exit when Last = Answer'Last;
 235
 236          Last := Last + 1;
 237       end loop;
 238
 239       --  Now for the end...
 240
 241       for J in reverse Last .. Answer'Last loop
 242          exit when J = Pic.Radix_Position;
 243
 244          --  Do this test First, Separator_Character can equal Pic.Floater
 245
 246          if Answer (J) = Pic.Floater then
 247             exit;
 248          end if;
 249
 250          case Answer (J) is
 251
 252             when '_' =>
 253                Answer (J) := Separator_Character;
 254
 255             when 'b' =>
 256                Answer (J) := ' ';
 257
 258             when '9' =>
 259                exit;
 260
 261             when others =>
 262                null;
 263
 264          end case;
 265       end loop;
 266
 267       --  Non-floating sign
 268
 269       if Pic.Start_Currency /= -1
 270         and then Answer (Pic.Start_Currency) = '#'
 271         and then Pic.Floater /= '#'
 272       then
 273          if Currency_Symbol'Length >
 274             Pic.End_Currency - Pic.Start_Currency + 1
 275          then
 276             raise Picture_Error;
 277
 278          elsif Currency_Symbol'Length =
 279             Pic.End_Currency - Pic.Start_Currency + 1
 280          then
 281             Answer (Pic.Start_Currency .. Pic.End_Currency) :=
 282               Currency_Symbol;
 283
 284          elsif Pic.Radix_Position = Invalid_Position
 285            or else Pic.Start_Currency < Pic.Radix_Position
 286          then
 287             Answer (Pic.Start_Currency .. Pic.End_Currency) :=
 288                                                         (others => ' ');
 289             Answer (Pic.End_Currency - Currency_Symbol'Length + 1 ..
 290                     Pic.End_Currency) := Currency_Symbol;
 291
 292          else
 293             Answer (Pic.Start_Currency .. Pic.End_Currency) :=
 294                                                         (others => ' ');
 295             Answer (Pic.Start_Currency ..
 296                     Pic.Start_Currency + Currency_Symbol'Length - 1) :=
 297                                                         Currency_Symbol;
 298          end if;
 299       end if;
 300
 301       --  Fill in leading digits
 302
 303       if Attrs.End_Of_Int - Attrs.Start_Of_Int + 1 >
 304                                                 Pic.Max_Leading_Digits
 305       then
 306          raise Ada.Text_IO.Layout_Error;
 307       end if;
 308
 309       Position :=
 310         (if Pic.Radix_Position = Invalid_Position
 311          then Answer'Last
 312          else Pic.Radix_Position - 1);
 313
 314       for J in reverse Attrs.Start_Of_Int .. Attrs.End_Of_Int loop
 315          while Answer (Position) /= '9'
 316                  and then
 317                Answer (Position) /= Pic.Floater
 318          loop
 319             if Answer (Position) = '_' then
 320                Answer (Position) := Separator_Character;
 321
 322             elsif Answer (Position) = 'b' then
 323                Answer (Position) := ' ';
 324             end if;
 325
 326             Position := Position - 1;
 327          end loop;
 328
 329          Answer (Position) := Rounded (J);
 330
 331          if Rounded (J) /= '0' then
 332             Zero := False;
 333          end if;
 334
 335          Position := Position - 1;
 336       end loop;
 337
 338       --  Do lead float
 339
 340       if Pic.Start_Float = Invalid_Position then
 341
 342          --  No leading floats, but need to change '9' to '0', '_' to
 343          --  Separator_Character and 'b' to ' '.
 344
 345          for J in Last .. Position loop
 346
 347             --  Last set when fixing the "uninteresting" leaders above.
 348             --  Don't duplicate the work.
 349
 350             if Answer (J) = '9' then
 351                Answer (J) := '0';
 352
 353             elsif Answer (J) = '_' then
 354                Answer (J) := Separator_Character;
 355
 356             elsif Answer (J) = 'b' then
 357                Answer (J) := ' ';
 358             end if;
 359          end loop;
 360
 361       elsif Pic.Floater = '<'
 362               or else
 363             Pic.Floater = '+'
 364               or else
 365             Pic.Floater = '-'
 366       then
 367          for J in Pic.End_Float .. Position loop --  May be null range.
 368             if Answer (J) = '9' then
 369                Answer (J) := '0';
 370
 371             elsif Answer (J) = '_' then
 372                Answer (J) := Separator_Character;
 373
 374             elsif Answer (J) = 'b' then
 375                Answer (J) := ' ';
 376             end if;
 377          end loop;
 378
 379          if Position > Pic.End_Float then
 380             Position := Pic.End_Float;
 381          end if;
 382
 383          for J in Pic.Start_Float .. Position - 1 loop
 384             Answer (J) := ' ';
 385          end loop;
 386
 387          Answer (Position) := Pic.Floater;
 388          Sign_Position     := Position;
 389
 390       elsif Pic.Floater = '$' then
 391
 392          for J in Pic.End_Float .. Position loop --  May be null range.
 393             if Answer (J) = '9' then
 394                Answer (J) := '0';
 395
 396             elsif Answer (J) = '_' then
 397                Answer (J) := ' ';    --  no separators before leftmost digit.
 398
 399             elsif Answer (J) = 'b' then
 400                Answer (J) := ' ';
 401             end if;
 402          end loop;
 403
 404          if Position > Pic.End_Float then
 405             Position := Pic.End_Float;
 406          end if;
 407
 408          for J in Pic.Start_Float .. Position - 1 loop
 409             Answer (J) := ' ';
 410          end loop;
 411
 412          Answer (Position) := Pic.Floater;
 413          Currency_Pos      := Position;
 414
 415       elsif Pic.Floater = '*' then
 416
 417          for J in Pic.End_Float .. Position loop --  May be null range.
 418             if Answer (J) = '9' then
 419                Answer (J) := '0';
 420
 421             elsif Answer (J) = '_' then
 422                Answer (J) := Separator_Character;
 423
 424             elsif Answer (J) = 'b' then
 425                Answer (J) := Fill_Character;
 426             end if;
 427          end loop;
 428
 429          if Position > Pic.End_Float then
 430             Position := Pic.End_Float;
 431          end if;
 432
 433          for J in Pic.Start_Float .. Position loop
 434             Answer (J) := Fill_Character;
 435          end loop;
 436
 437       else
 438          if Pic.Floater = '#' then
 439             Currency_Pos := Currency_Symbol'Length;
 440             In_Currency := True;
 441          end if;
 442
 443          for J in reverse Pic.Start_Float .. Position loop
 444             case Answer (J) is
 445
 446                when '*' =>
 447                   Answer (J) := Fill_Character;
 448
 449                when 'b' | '/' =>
 450                   if In_Currency and then Currency_Pos > 0 then
 451                      Answer (J)   := Currency_Symbol (Currency_Pos);
 452                      Currency_Pos := Currency_Pos - 1;
 453                   else
 454                      Answer (J) := ' ';
 455                   end if;
 456
 457                when 'Z' | '0' =>
 458                   Answer (J) := ' ';
 459
 460                when '9' =>
 461                   Answer (J) := '0';
 462
 463                when '.' | 'V' | 'v' | '<' | '$' | '+' | '-' =>
 464                   null;
 465
 466                when '#' =>
 467                   if Currency_Pos = 0 then
 468                      Answer (J) := ' ';
 469                   else
 470                      Answer (J)   := Currency_Symbol (Currency_Pos);
 471                      Currency_Pos := Currency_Pos - 1;
 472                   end if;
 473
 474                when '_' =>
 475
 476                   case Pic.Floater is
 477
 478                      when '*' =>
 479                         Answer (J) := Fill_Character;
 480
 481                      when 'Z' | 'b' =>
 482                         Answer (J) := ' ';
 483
 484                      when '#' =>
 485                         if Currency_Pos = 0 then
 486                            Answer (J) := ' ';
 487
 488                         else
 489                            Answer (J)   := Currency_Symbol (Currency_Pos);
 490                            Currency_Pos := Currency_Pos - 1;
 491                         end if;
 492
 493                      when others =>
 494                         null;
 495
 496                   end case;
 497
 498                when others =>
 499                   null;
 500
 501             end case;
 502          end loop;
 503
 504          if Pic.Floater = '#' and then Currency_Pos /= 0 then
 505             raise Ada.Text_IO.Layout_Error;
 506          end if;
 507       end if;
 508
 509       --  Do sign
 510
 511       if Sign_Position = Invalid_Position then
 512          if Attrs.Negative then
 513             raise Ada.Text_IO.Layout_Error;
 514          end if;
 515
 516       else
 517          if Attrs.Negative then
 518             case Answer (Sign_Position) is
 519                when 'C' | 'D' | '-' =>
 520                   null;
 521
 522                when '+' =>
 523                   Answer (Sign_Position) := '-';
 524
 525                when '<' =>
 526                   Answer (Sign_Position)   := '(';
 527                   Answer (Pic.Second_Sign) := ')';
 528
 529                when others =>
 530                   raise Picture_Error;
 531
 532             end case;
 533
 534          else --  positive
 535
 536             case Answer (Sign_Position) is
 537
 538                when '-' =>
 539                   Answer (Sign_Position) := ' ';
 540
 541                when '<' | 'C' | 'D' =>
 542                   Answer (Sign_Position)   := ' ';
 543                   Answer (Pic.Second_Sign) := ' ';
 544
 545                when '+' =>
 546                   null;
 547
 548                when others =>
 549                   raise Picture_Error;
 550
 551             end case;
 552          end if;
 553       end if;
 554
 555       --  Fill in trailing digits
 556
 557       if Pic.Max_Trailing_Digits > 0 then
 558
 559          if Attrs.Has_Fraction then
 560             Position := Attrs.Start_Of_Fraction;
 561             Last     := Pic.Radix_Position + 1;
 562
 563             for J in Last .. Answer'Last loop
 564                if Answer (J) = '9' or else Answer (J) = Pic.Floater then
 565                   Answer (J) := Rounded (Position);
 566
 567                   if Rounded (Position) /= '0' then
 568                      Zero := False;
 569                   end if;
 570
 571                   Position := Position + 1;
 572                   Last     := J + 1;
 573
 574                   --  Used up fraction but remember place in Answer
 575
 576                   exit when Position > Attrs.End_Of_Fraction;
 577
 578                elsif Answer (J) = 'b' then
 579                   Answer (J) := ' ';
 580
 581                elsif Answer (J) = '_' then
 582                   Answer (J) := Separator_Character;
 583
 584                end if;
 585
 586                Last := J + 1;
 587             end loop;
 588
 589             Position := Last;
 590
 591          else
 592             Position := Pic.Radix_Position + 1;
 593          end if;
 594
 595          --  Now fill remaining 9's with zeros and _ with separators
 596
 597          Last := Answer'Last;
 598
 599          for J in Position .. Last loop
 600             if Answer (J) = '9' then
 601                Answer (J) := '0';
 602
 603             elsif Answer (J) = Pic.Floater then
 604                Answer (J) := '0';
 605
 606             elsif Answer (J) = '_' then
 607                Answer (J) := Separator_Character;
 608
 609             elsif Answer (J) = 'b' then
 610                Answer (J) := ' ';
 611
 612             end if;
 613          end loop;
 614
 615          Position := Last + 1;
 616
 617       else
 618          if Pic.Floater = '#' and then Currency_Pos /= 0 then
 619             raise Ada.Text_IO.Layout_Error;
 620          end if;
 621
 622          --  No trailing digits, but now J may need to stick in a currency
 623          --  symbol or sign.
 624
 625          Position :=
 626            (if Pic.Start_Currency = Invalid_Position
 627             then Answer'Last + 1
 628             else Pic.Start_Currency);
 629       end if;
 630
 631       for J in Position .. Answer'Last loop
 632          if Pic.Start_Currency /= Invalid_Position and then
 633             Answer (Pic.Start_Currency) = '#' then
 634             Currency_Pos := 1;
 635          end if;
 636
 637          case Answer (J) is
 638             when '*' =>
 639                Answer (J) := Fill_Character;
 640
 641             when 'b' =>
 642                if In_Currency then
 643                   Answer (J) := Currency_Symbol (Currency_Pos);
 644                   Currency_Pos := Currency_Pos + 1;
 645
 646                   if Currency_Pos > Currency_Symbol'Length then
 647                      In_Currency := False;
 648                   end if;
 649                end if;
 650
 651             when '#' =>
 652                if Currency_Pos > Currency_Symbol'Length then
 653                   Answer (J) := ' ';
 654
 655                else
 656                   In_Currency := True;
 657                   Answer (J)   := Currency_Symbol (Currency_Pos);
 658                   Currency_Pos := Currency_Pos + 1;
 659
 660                   if Currency_Pos > Currency_Symbol'Length then
 661                      In_Currency := False;
 662                   end if;
 663                end if;
 664
 665             when '_' =>
 666                Answer (J) := Currency_Symbol (Currency_Pos);
 667                Currency_Pos := Currency_Pos + 1;
 668
 669                case Pic.Floater is
 670
 671                   when '*' =>
 672                      Answer (J) := Fill_Character;
 673
 674                   when 'Z' | 'z' =>
 675                      Answer (J) := ' ';
 676
 677                   when '#' =>
 678                      if Currency_Pos > Currency_Symbol'Length then
 679                         Answer (J) := ' ';
 680                      else
 681                         Answer (J)   := Currency_Symbol (Currency_Pos);
 682                         Currency_Pos := Currency_Pos + 1;
 683                      end if;
 684
 685                   when others =>
 686                      null;
 687
 688                end case;
 689
 690             when others =>
 691                exit;
 692
 693          end case;
 694       end loop;
 695
 696       --  Now get rid of Blank_when_Zero and complete Star fill
 697
 698       if Zero and then Pic.Blank_When_Zero then
 699
 700          --  Value is zero, and blank it
 701
 702          Last := Answer'Last;
 703
 704          if Dollar then
 705             Last := Last - 1 + Currency_Symbol'Length;
 706          end if;
 707
 708          if Pic.Radix_Position /= Invalid_Position and then
 709             Answer (Pic.Radix_Position) = 'V' then
 710             Last := Last - 1;
 711          end if;
 712
 713          return String'(1 .. Last => ' ');
 714
 715       elsif Zero and then Pic.Star_Fill then
 716          Last := Answer'Last;
 717
 718          if Dollar then
 719             Last := Last - 1 + Currency_Symbol'Length;
 720          end if;
 721
 722          if Pic.Radix_Position /= Invalid_Position then
 723
 724             if Answer (Pic.Radix_Position) = 'V' then
 725                Last := Last - 1;
 726
 727             elsif Dollar then
 728                if Pic.Radix_Position > Pic.Start_Currency then
 729                   return String'(1 .. Pic.Radix_Position - 1 => '*') &
 730                      Radix_Point &
 731                      String'(Pic.Radix_Position + 1 .. Last => '*');
 732
 733                else
 734                   return
 735                      String'
 736                      (1 ..
 737                       Pic.Radix_Position + Currency_Symbol'Length - 2 =>
 738                          '*') & Radix_Point &
 739                      String'
 740                      (Pic.Radix_Position + Currency_Symbol'Length .. Last
 741                       => '*');
 742                end if;
 743
 744             else
 745                return String'(1 .. Pic.Radix_Position - 1 => '*') &
 746                   Radix_Point &
 747                   String'(Pic.Radix_Position + 1 .. Last => '*');
 748             end if;
 749          end if;
 750
 751          return String'(1 .. Last => '*');
 752       end if;
 753
 754       --  This was once a simple return statement, now there are nine
 755       --  different return cases.  Not to mention the five above to deal
 756       --  with zeros.  Why not split things out?
 757
 758       --  Processing the radix and sign expansion separately
 759       --  would require lots of copying--the string and some of its
 760       --  indicies--without really simplifying the logic.  The cases are:
 761
 762       --  1) Expand $, replace '.' with Radix_Point
 763       --  2) No currency expansion, replace '.' with Radix_Point
 764       --  3) Expand $, radix blanked
 765       --  4) No currency expansion, radix blanked
 766       --  5) Elide V
 767       --  6) Expand $, Elide V
 768       --  7) Elide V, Expand $ (Two cases depending on order.)
 769       --  8) No radix, expand $
 770       --  9) No radix, no currency expansion
 771
 772       if Pic.Radix_Position /= Invalid_Position then
 773
 774          if Answer (Pic.Radix_Position) = '.' then
 775             Answer (Pic.Radix_Position) := Radix_Point;
 776
 777             if Dollar then
 778
 779                --  1) Expand $, replace '.' with Radix_Point
 780
 781                return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
 782                   Answer (Currency_Pos + 1 .. Answer'Last);
 783
 784             else
 785                --  2) No currency expansion, replace '.' with Radix_Point
 786
 787                return Answer;
 788             end if;
 789
 790          elsif Answer (Pic.Radix_Position) = ' ' then --  blanked radix.
 791             if Dollar then
 792
 793                --  3) Expand $, radix blanked
 794
 795                return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
 796                  Answer (Currency_Pos + 1 .. Answer'Last);
 797
 798             else
 799                --  4) No expansion, radix blanked
 800
 801                return Answer;
 802             end if;
 803
 804          --  V cases
 805
 806          else
 807             if not Dollar then
 808
 809                --  5) Elide V
 810
 811                return Answer (1 .. Pic.Radix_Position - 1) &
 812                   Answer (Pic.Radix_Position + 1 .. Answer'Last);
 813
 814             elsif Currency_Pos < Pic.Radix_Position then
 815
 816                --  6) Expand $, Elide V
 817
 818                return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
 819                   Answer (Currency_Pos + 1 .. Pic.Radix_Position - 1) &
 820                   Answer (Pic.Radix_Position + 1 .. Answer'Last);
 821
 822             else
 823                --  7) Elide V, Expand $
 824
 825                return Answer (1 .. Pic.Radix_Position - 1) &
 826                   Answer (Pic.Radix_Position + 1 .. Currency_Pos - 1) &
 827                   Currency_Symbol &
 828                   Answer (Currency_Pos + 1 .. Answer'Last);
 829             end if;
 830          end if;
 831
 832       elsif Dollar then
 833
 834          --  8) No radix, expand $
 835
 836          return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
 837             Answer (Currency_Pos + 1 .. Answer'Last);
 838
 839       else
 840          --  9) No radix, no currency expansion
 841
 842          return Answer;
 843       end if;
 844    end Format_Number;
 845
 846    -------------------------
 847    -- Parse_Number_String --
 848    -------------------------
 849
 850    function Parse_Number_String (Str : String) return Number_Attributes is
 851       Answer : Number_Attributes;
 852
 853    begin
 854       for J in Str'Range loop
 855          case Str (J) is
 856
 857             when ' ' =>
 858                null; --  ignore
 859
 860             when '1' .. '9' =>
 861
 862                --  Decide if this is the start of a number.
 863                --  If so, figure out which one...
 864
 865                if Answer.Has_Fraction then
 866                   Answer.End_Of_Fraction := J;
 867                else
 868                   if Answer.Start_Of_Int = Invalid_Position then
 869                      --  start integer
 870                      Answer.Start_Of_Int := J;
 871                   end if;
 872                   Answer.End_Of_Int := J;
 873                end if;
 874
 875             when '0' =>
 876
 877                --  Only count a zero before the decimal point if it follows a
 878                --  non-zero digit.  After the decimal point, zeros will be
 879                --  counted if followed by a non-zero digit.
 880
 881                if not Answer.Has_Fraction then
 882                   if Answer.Start_Of_Int /= Invalid_Position then
 883                      Answer.End_Of_Int := J;
 884                   end if;
 885                end if;
 886
 887             when '-' =>
 888
 889                --  Set negative
 890
 891                Answer.Negative := True;
 892
 893             when '.' =>
 894
 895                --  Close integer, start fraction
 896
 897                if Answer.Has_Fraction then
 898                   raise Picture_Error;
 899                end if;
 900
 901                --  Two decimal points is a no-no
 902
 903                Answer.Has_Fraction    := True;
 904                Answer.End_Of_Fraction := J;
 905
 906                --  Could leave this at Invalid_Position, but this seems the
 907                --  right way to indicate a null range...
 908
 909                Answer.Start_Of_Fraction := J + 1;
 910                Answer.End_Of_Int        := J - 1;
 911
 912             when others =>
 913                raise Picture_Error; -- can this happen? probably not!
 914          end case;
 915       end loop;
 916
 917       if Answer.Start_Of_Int = Invalid_Position then
 918          Answer.Start_Of_Int := Answer.End_Of_Int + 1;
 919       end if;
 920
 921       --  No significant (integer) digits needs a null range
 922
 923       return Answer;
 924    end Parse_Number_String;
 925
 926    ----------------
 927    -- Pic_String --
 928    ----------------
 929
 930    --  The following ensures that we return B and not b being careful not
 931    --  to break things which expect lower case b for blank. See CXF3A02.
 932
 933    function Pic_String (Pic : Picture) return String is
 934       Temp : String (1 .. Pic.Contents.Picture.Length) :=
 935                               Pic.Contents.Picture.Expanded;
 936    begin
 937       for J in Temp'Range loop
 938          if Temp (J) = 'b' then
 939             Temp (J) := 'B';
 940          end if;
 941       end loop;
 942
 943       return Temp;
 944    end Pic_String;
 945
 946    ------------------
 947    -- Precalculate --
 948    ------------------
 949
 950    procedure Precalculate  (Pic : in out Format_Record) is
 951       Debug : constant Boolean := False;
 952       --  Set True to generate debug output
 953
 954       Computed_BWZ : Boolean := True;
 955
 956       type Legality is  (Okay, Reject);
 957
 958       State : Legality := Reject;
 959       --  Start in reject, which will reject null strings
 960
 961       Index : Pic_Index := Pic.Picture.Expanded'First;
 962
 963       function At_End return Boolean;
 964       pragma Inline (At_End);
 965
 966       procedure Set_State (L : Legality);
 967       pragma Inline (Set_State);
 968
 969       function Look return Character;
 970       pragma Inline (Look);
 971
 972       function Is_Insert return Boolean;
 973       pragma Inline (Is_Insert);
 974
 975       procedure Skip;
 976       pragma Inline (Skip);
 977
 978       procedure Debug_Start (Name : String);
 979       pragma Inline (Debug_Start);
 980
 981       procedure Debug_Integer  (Value : Integer; S : String);
 982       pragma Inline (Debug_Integer);
 983
 984       procedure Trailing_Currency;
 985       procedure Trailing_Bracket;
 986       procedure Number_Fraction;
 987       procedure Number_Completion;
 988       procedure Number_Fraction_Or_Bracket;
 989       procedure Number_Fraction_Or_Z_Fill;
 990       procedure Zero_Suppression;
 991       procedure Floating_Bracket;
 992       procedure Number_Fraction_Or_Star_Fill;
 993       procedure Star_Suppression;
 994       procedure Number_Fraction_Or_Dollar;
 995       procedure Leading_Dollar;
 996       procedure Number_Fraction_Or_Pound;
 997       procedure Leading_Pound;
 998       procedure Picture;
 999       procedure Floating_Plus;
1000       procedure Floating_Minus;
1001       procedure Picture_Plus;
1002       procedure Picture_Minus;
1003       procedure Picture_Bracket;
1004       procedure Number;
1005       procedure Optional_RHS_Sign;
1006       procedure Picture_String;
1007       procedure Set_Debug;
1008
1009       ------------
1010       -- At_End --
1011       ------------
1012
1013       function At_End return Boolean is
1014       begin
1015          Debug_Start ("At_End");
1016          return Index > Pic.Picture.Length;
1017       end At_End;
1018
1019       --------------
1020       -- Set_Debug--
1021       --------------
1022
1023       --  Needed to have a procedure to pass to pragma Debug
1024
1025       procedure Set_Debug is
1026       begin
1027          --  Uncomment this line and make Debug a variable to enable debug
1028
1029          --  Debug := True;
1030
1031          null;
1032       end Set_Debug;
1033
1034       -------------------
1035       -- Debug_Integer --
1036       -------------------
1037
1038       procedure Debug_Integer (Value : Integer; S : String) is
1039          use Ada.Text_IO; --  needed for >
1040
1041       begin
1042          if Debug and then Value > 0 then
1043             if Ada.Text_IO.Col > 70 - S'Length then
1044                Ada.Text_IO.New_Line;
1045             end if;
1046
1047             Ada.Text_IO.Put (' ' & S & Integer'Image (Value) & ',');
1048          end if;
1049       end Debug_Integer;
1050
1051       -----------------
1052       -- Debug_Start --
1053       -----------------
1054
1055       procedure Debug_Start (Name : String) is
1056       begin
1057          if Debug then
1058             Ada.Text_IO.Put_Line ("  In " & Name & '.');
1059          end if;
1060       end Debug_Start;
1061
1062       ----------------------
1063       -- Floating_Bracket --
1064       ----------------------
1065
1066       --  Note that Floating_Bracket is only called with an acceptable
1067       --  prefix. But we don't set Okay, because we must end with a '>'.
1068
1069       procedure Floating_Bracket is
1070       begin
1071          Debug_Start ("Floating_Bracket");
1072
1073          --  Two different floats not allowed
1074
1075          if Pic.Floater /= '!' and then Pic.Floater /= '<' then
1076             raise Picture_Error;
1077
1078          else
1079             Pic.Floater := '<';
1080          end if;
1081
1082          Pic.End_Float := Index;
1083          Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1084
1085          --  First bracket wasn't counted...
1086
1087          Skip; --  known '<'
1088
1089          loop
1090             if At_End then
1091                return;
1092             end if;
1093
1094             case Look is
1095
1096                when '_' | '0' | '/' =>
1097                   Pic.End_Float := Index;
1098                   Skip;
1099
1100                when 'B' | 'b'  =>
1101                   Pic.End_Float := Index;
1102                   Pic.Picture.Expanded (Index) := 'b';
1103                   Skip;
1104
1105                when '<' =>
1106                   Pic.End_Float := Index;
1107                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1108                   Skip;
1109
1110                when '9' =>
1111                   Number_Completion;
1112
1113                when '$' =>
1114                   Leading_Dollar;
1115
1116                when '#' =>
1117                   Leading_Pound;
1118
1119                when 'V' | 'v' | '.' =>
1120                   Pic.Radix_Position := Index;
1121                   Skip;
1122                   Number_Fraction_Or_Bracket;
1123                   return;
1124
1125                when others =>
1126                return;
1127             end case;
1128          end loop;
1129       end Floating_Bracket;
1130
1131       --------------------
1132       -- Floating_Minus --
1133       --------------------
1134
1135       procedure Floating_Minus is
1136       begin
1137          Debug_Start ("Floating_Minus");
1138
1139          loop
1140             if At_End then
1141                return;
1142             end if;
1143
1144             case Look is
1145                when '_' | '0' | '/' =>
1146                   Pic.End_Float := Index;
1147                   Skip;
1148
1149                when 'B' | 'b'  =>
1150                   Pic.End_Float := Index;
1151                   Pic.Picture.Expanded (Index) := 'b';
1152                   Skip;
1153
1154                when '-' =>
1155                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1156                   Pic.End_Float := Index;
1157                   Skip;
1158
1159                when '9' =>
1160                   Number_Completion;
1161                   return;
1162
1163                when '.' | 'V' | 'v' =>
1164                   Pic.Radix_Position := Index;
1165                   Skip; --  Radix
1166
1167                   while Is_Insert loop
1168                      Skip;
1169                   end loop;
1170
1171                   if At_End then
1172                      return;
1173                   end if;
1174
1175                   if Look = '-' then
1176                      loop
1177                         if At_End then
1178                            return;
1179                         end if;
1180
1181                         case Look is
1182
1183                            when '-' =>
1184                               Pic.Max_Trailing_Digits :=
1185                                 Pic.Max_Trailing_Digits + 1;
1186                               Pic.End_Float := Index;
1187                               Skip;
1188
1189                            when '_' | '0' | '/' =>
1190                               Skip;
1191
1192                            when 'B' | 'b'  =>
1193                               Pic.Picture.Expanded (Index) := 'b';
1194                               Skip;
1195
1196                            when others =>
1197                               return;
1198
1199                         end case;
1200                      end loop;
1201
1202                   else
1203                      Number_Completion;
1204                   end if;
1205
1206                   return;
1207
1208                when others =>
1209                   return;
1210             end case;
1211          end loop;
1212       end Floating_Minus;
1213
1214       -------------------
1215       -- Floating_Plus --
1216       -------------------
1217
1218       procedure Floating_Plus is
1219       begin
1220          Debug_Start ("Floating_Plus");
1221
1222          loop
1223             if At_End then
1224                return;
1225             end if;
1226
1227             case Look is
1228                when '_' | '0' | '/' =>
1229                   Pic.End_Float := Index;
1230                   Skip;
1231
1232                when 'B' | 'b'  =>
1233                   Pic.End_Float := Index;
1234                   Pic.Picture.Expanded (Index) := 'b';
1235                   Skip;
1236
1237                when '+' =>
1238                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1239                   Pic.End_Float := Index;
1240                   Skip;
1241
1242                when '9' =>
1243                   Number_Completion;
1244                   return;
1245
1246                when '.' | 'V' | 'v' =>
1247                   Pic.Radix_Position := Index;
1248                   Skip; --  Radix
1249
1250                   while Is_Insert loop
1251                      Skip;
1252                   end loop;
1253
1254                   if At_End then
1255                      return;
1256                   end if;
1257
1258                   if Look = '+' then
1259                      loop
1260                         if At_End then
1261                            return;
1262                         end if;
1263
1264                         case Look is
1265
1266                            when '+' =>
1267                               Pic.Max_Trailing_Digits :=
1268                                 Pic.Max_Trailing_Digits + 1;
1269                               Pic.End_Float := Index;
1270                               Skip;
1271
1272                            when '_' | '0' | '/' =>
1273                               Skip;
1274
1275                            when 'B' | 'b'  =>
1276                               Pic.Picture.Expanded (Index) := 'b';
1277                               Skip;
1278
1279                            when others =>
1280                               return;
1281
1282                         end case;
1283                      end loop;
1284
1285                   else
1286                      Number_Completion;
1287                   end if;
1288
1289                   return;
1290
1291                when others =>
1292                   return;
1293
1294             end case;
1295          end loop;
1296       end Floating_Plus;
1297
1298       ---------------
1299       -- Is_Insert --
1300       ---------------
1301
1302       function Is_Insert return Boolean is
1303       begin
1304          if At_End then
1305             return False;
1306          end if;
1307
1308          case Pic.Picture.Expanded (Index) is
1309
1310             when '_' | '0' | '/' => return True;
1311
1312             when 'B' | 'b' =>
1313                Pic.Picture.Expanded (Index) := 'b'; --  canonical
1314                return True;
1315
1316             when others => return False;
1317          end case;
1318       end Is_Insert;
1319
1320       --------------------
1321       -- Leading_Dollar --
1322       --------------------
1323
1324       --  Note that Leading_Dollar can be called in either State.
1325       --  It will set state to Okay only if a 9 or (second) $
1326       --  is encountered.
1327
1328       --  Also notice the tricky bit with State and Zero_Suppression.
1329       --  Zero_Suppression is Picture_Error if a '$' or a '9' has been
1330       --  encountered, exactly the cases where State has been set.
1331
1332       procedure Leading_Dollar is
1333       begin
1334          Debug_Start ("Leading_Dollar");
1335
1336          --  Treat as a floating dollar, and unwind otherwise
1337
1338          if Pic.Floater /= '!' and then Pic.Floater /= '$' then
1339
1340             --  Two floats not allowed
1341
1342             raise Picture_Error;
1343
1344          else
1345             Pic.Floater := '$';
1346          end if;
1347
1348          Pic.Start_Currency := Index;
1349          Pic.End_Currency := Index;
1350          Pic.Start_Float := Index;
1351          Pic.End_Float := Index;
1352
1353          --  Don't increment Pic.Max_Leading_Digits, we need one "real"
1354          --  currency place.
1355
1356          Skip; --  known '$'
1357
1358          loop
1359             if At_End then
1360                return;
1361             end if;
1362
1363             case Look is
1364
1365                when '_' | '0' | '/' =>
1366                   Pic.End_Float := Index;
1367                   Skip;
1368
1369                   --  A trailing insertion character is not part of the
1370                   --  floating currency, so need to look ahead.
1371
1372                   if Look /= '$' then
1373                      Pic.End_Float := Pic.End_Float - 1;
1374                   end if;
1375
1376                when 'B' | 'b'  =>
1377                   Pic.End_Float := Index;
1378                   Pic.Picture.Expanded (Index) := 'b';
1379                   Skip;
1380
1381                when 'Z' | 'z' =>
1382                   Pic.Picture.Expanded (Index) := 'Z'; -- consistency
1383
1384                   if State = Okay then
1385                      raise Picture_Error;
1386                   else
1387                      --  Overwrite Floater and Start_Float
1388
1389                      Pic.Floater := 'Z';
1390                      Pic.Start_Float := Index;
1391                      Zero_Suppression;
1392                   end if;
1393
1394                when '*' =>
1395                   if State = Okay then
1396                      raise Picture_Error;
1397                   else
1398                      --  Overwrite Floater and Start_Float
1399
1400                      Pic.Floater := '*';
1401                      Pic.Start_Float := Index;
1402                      Star_Suppression;
1403                   end if;
1404
1405                when '$' =>
1406                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1407                   Pic.End_Float := Index;
1408                   Pic.End_Currency := Index;
1409                   Set_State (Okay); Skip;
1410
1411                when '9' =>
1412                   if State /= Okay then
1413                      Pic.Floater := '!';
1414                      Pic.Start_Float := Invalid_Position;
1415                      Pic.End_Float := Invalid_Position;
1416                   end if;
1417
1418                   --  A single dollar does not a floating make
1419
1420                   Number_Completion;
1421                   return;
1422
1423                when 'V' | 'v' | '.' =>
1424                   if State /= Okay then
1425                      Pic.Floater := '!';
1426                      Pic.Start_Float := Invalid_Position;
1427                      Pic.End_Float := Invalid_Position;
1428                   end if;
1429
1430                   --  Only one dollar before the sign is okay, but doesn't
1431                   --  float.
1432
1433                   Pic.Radix_Position := Index;
1434                   Skip;
1435                   Number_Fraction_Or_Dollar;
1436                   return;
1437
1438                when others =>
1439                   return;
1440
1441             end case;
1442          end loop;
1443       end Leading_Dollar;
1444
1445       -------------------
1446       -- Leading_Pound --
1447       -------------------
1448
1449       --  This one is complex!  A Leading_Pound can be fixed or floating,
1450       --  but in some cases the decision has to be deferred until we leave
1451       --  this procedure.  Also note that Leading_Pound can be called in
1452       --  either State.
1453
1454       --  It will set state to Okay only if a 9 or  (second) # is
1455       --  encountered.
1456
1457       --  One Last note:  In ambiguous cases, the currency is treated as
1458       --  floating unless there is only one '#'.
1459
1460       procedure Leading_Pound is
1461
1462          Inserts : Boolean := False;
1463          --  Set to True if a '_', '0', '/', 'B', or 'b' is encountered
1464
1465          Must_Float : Boolean := False;
1466          --  Set to true if a '#' occurs after an insert
1467
1468       begin
1469          Debug_Start ("Leading_Pound");
1470
1471          --  Treat as a floating currency. If it isn't, this will be
1472          --  overwritten later.
1473
1474          if Pic.Floater /= '!' and then Pic.Floater /= '#' then
1475
1476             --  Two floats not allowed
1477
1478             raise Picture_Error;
1479
1480          else
1481             Pic.Floater := '#';
1482          end if;
1483
1484          Pic.Start_Currency := Index;
1485          Pic.End_Currency := Index;
1486          Pic.Start_Float := Index;
1487          Pic.End_Float := Index;
1488
1489          --  Don't increment Pic.Max_Leading_Digits, we need one "real"
1490          --  currency place.
1491
1492          Pic.Max_Currency_Digits := 1; --  we've seen one.
1493
1494          Skip; --  known '#'
1495
1496          loop
1497             if At_End then
1498                return;
1499             end if;
1500
1501             case Look is
1502
1503                when '_' | '0' | '/' =>
1504                   Pic.End_Float := Index;
1505                   Inserts := True;
1506                   Skip;
1507
1508                when 'B' | 'b'  =>
1509                   Pic.Picture.Expanded (Index) := 'b';
1510                   Pic.End_Float := Index;
1511                   Inserts := True;
1512                   Skip;
1513
1514                when 'Z' | 'z' =>
1515                   Pic.Picture.Expanded (Index) := 'Z'; -- consistency
1516
1517                   if Must_Float then
1518                      raise Picture_Error;
1519                   else
1520                      Pic.Max_Leading_Digits := 0;
1521
1522                      --  Overwrite Floater and Start_Float
1523
1524                      Pic.Floater := 'Z';
1525                      Pic.Start_Float := Index;
1526                      Zero_Suppression;
1527                   end if;
1528
1529                when '*' =>
1530                   if Must_Float then
1531                      raise Picture_Error;
1532                   else
1533                      Pic.Max_Leading_Digits := 0;
1534
1535                      --  Overwrite Floater and Start_Float
1536                      Pic.Floater := '*';
1537                      Pic.Start_Float := Index;
1538                      Star_Suppression;
1539                   end if;
1540
1541                when '#' =>
1542                   if Inserts then
1543                      Must_Float := True;
1544                   end if;
1545
1546                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1547                   Pic.End_Float := Index;
1548                   Pic.End_Currency := Index;
1549                   Set_State (Okay);
1550                   Skip;
1551
1552                when '9' =>
1553                   if State /= Okay then
1554
1555                      --  A single '#' doesn't float
1556
1557                      Pic.Floater := '!';
1558                      Pic.Start_Float := Invalid_Position;
1559                      Pic.End_Float := Invalid_Position;
1560                   end if;
1561
1562                   Number_Completion;
1563                   return;
1564
1565                when 'V' | 'v' | '.' =>
1566                   if State /= Okay then
1567                      Pic.Floater := '!';
1568                      Pic.Start_Float := Invalid_Position;
1569                      Pic.End_Float := Invalid_Position;
1570                   end if;
1571
1572                   --  Only one pound before the sign is okay, but doesn't
1573                   --  float.
1574
1575                   Pic.Radix_Position := Index;
1576                   Skip;
1577                   Number_Fraction_Or_Pound;
1578                   return;
1579
1580                when others =>
1581                   return;
1582             end case;
1583          end loop;
1584       end Leading_Pound;
1585
1586       ----------
1587       -- Look --
1588       ----------
1589
1590       function Look return Character is
1591       begin
1592          if At_End then
1593             raise Picture_Error;
1594          end if;
1595
1596          return Pic.Picture.Expanded (Index);
1597       end Look;
1598
1599       ------------
1600       -- Number --
1601       ------------
1602
1603       procedure Number is
1604       begin
1605          Debug_Start ("Number");
1606
1607          loop
1608
1609             case Look is
1610                when '_' | '0' | '/' =>
1611                   Skip;
1612
1613                when 'B' | 'b'  =>
1614                   Pic.Picture.Expanded (Index) := 'b';
1615                   Skip;
1616
1617                when '9' =>
1618                   Computed_BWZ := False;
1619                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1620                   Set_State (Okay);
1621                   Skip;
1622
1623                when '.' | 'V' | 'v' =>
1624                   Pic.Radix_Position := Index;
1625                   Skip;
1626                   Number_Fraction;
1627                   return;
1628
1629                when others =>
1630                   return;
1631
1632             end case;
1633
1634             if At_End then
1635                return;
1636             end if;
1637
1638             --  Will return in Okay state if a '9' was seen
1639
1640          end loop;
1641       end Number;
1642
1643       -----------------------
1644       -- Number_Completion --
1645       -----------------------
1646
1647       procedure Number_Completion is
1648       begin
1649          Debug_Start ("Number_Completion");
1650
1651          while not At_End loop
1652             case Look is
1653
1654                when '_' | '0' | '/' =>
1655                   Skip;
1656
1657                when 'B' | 'b'  =>
1658                   Pic.Picture.Expanded (Index) := 'b';
1659                   Skip;
1660
1661                when '9' =>
1662                   Computed_BWZ := False;
1663                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1664                   Set_State (Okay);
1665                   Skip;
1666
1667                when 'V' | 'v' | '.' =>
1668                   Pic.Radix_Position := Index;
1669                   Skip;
1670                   Number_Fraction;
1671                   return;
1672
1673                when others =>
1674                   return;
1675             end case;
1676          end loop;
1677       end Number_Completion;
1678
1679       ---------------------
1680       -- Number_Fraction --
1681       ---------------------
1682
1683       procedure Number_Fraction is
1684       begin
1685          --  Note that number fraction can be called in either State.
1686          --  It will set state to Valid only if a 9 is encountered.
1687
1688          Debug_Start ("Number_Fraction");
1689
1690          loop
1691             if At_End then
1692                return;
1693             end if;
1694
1695             case Look is
1696                when '_' | '0' | '/' =>
1697                   Skip;
1698
1699                when 'B' | 'b'  =>
1700                   Pic.Picture.Expanded (Index) := 'b';
1701                   Skip;
1702
1703                when '9' =>
1704                   Computed_BWZ := False;
1705                   Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1706                   Set_State (Okay); Skip;
1707
1708                when others =>
1709                   return;
1710             end case;
1711          end loop;
1712       end Number_Fraction;
1713
1714       --------------------------------
1715       -- Number_Fraction_Or_Bracket --
1716       --------------------------------
1717
1718       procedure Number_Fraction_Or_Bracket is
1719       begin
1720          Debug_Start ("Number_Fraction_Or_Bracket");
1721
1722          loop
1723             if At_End then
1724                return;
1725             end if;
1726
1727             case Look is
1728
1729                when '_' | '0' | '/' => Skip;
1730
1731                when 'B' | 'b'  =>
1732                   Pic.Picture.Expanded (Index) := 'b';
1733                   Skip;
1734
1735                when '<' =>
1736                   Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1737                   Pic.End_Float := Index;
1738                   Skip;
1739
1740                   loop
1741                      if At_End then
1742                         return;
1743                      end if;
1744
1745                      case Look is
1746                         when '_' | '0' | '/' =>
1747                            Skip;
1748
1749                         when 'B' | 'b'  =>
1750                            Pic.Picture.Expanded (Index) := 'b';
1751                            Skip;
1752
1753                         when '<' =>
1754                            Pic.Max_Trailing_Digits :=
1755                              Pic.Max_Trailing_Digits + 1;
1756                            Pic.End_Float := Index;
1757                            Skip;
1758
1759                         when others =>
1760                            return;
1761                      end case;
1762                   end loop;
1763
1764                when others =>
1765                   Number_Fraction;
1766                   return;
1767             end case;
1768          end loop;
1769       end Number_Fraction_Or_Bracket;
1770
1771       -------------------------------
1772       -- Number_Fraction_Or_Dollar --
1773       -------------------------------
1774
1775       procedure Number_Fraction_Or_Dollar is
1776       begin
1777          Debug_Start ("Number_Fraction_Or_Dollar");
1778
1779          loop
1780             if At_End then
1781                return;
1782             end if;
1783
1784             case Look is
1785                when '_' | '0' | '/' =>
1786                   Skip;
1787
1788                when 'B' | 'b'  =>
1789                   Pic.Picture.Expanded (Index) := 'b';
1790                   Skip;
1791
1792                when '$' =>
1793                   Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1794                   Pic.End_Float := Index;
1795                   Skip;
1796
1797                   loop
1798                      if At_End then
1799                         return;
1800                      end if;
1801
1802                      case Look is
1803                         when '_' | '0' | '/' =>
1804                            Skip;
1805
1806                         when 'B' | 'b'  =>
1807                            Pic.Picture.Expanded (Index) := 'b';
1808                            Skip;
1809
1810                         when '$' =>
1811                            Pic.Max_Trailing_Digits :=
1812                              Pic.Max_Trailing_Digits + 1;
1813                            Pic.End_Float := Index;
1814                            Skip;
1815
1816                         when others =>
1817                            return;
1818                      end case;
1819                   end loop;
1820
1821                when others =>
1822                   Number_Fraction;
1823                   return;
1824             end case;
1825          end loop;
1826       end Number_Fraction_Or_Dollar;
1827
1828       ------------------------------
1829       -- Number_Fraction_Or_Pound --
1830       ------------------------------
1831
1832       procedure Number_Fraction_Or_Pound is
1833       begin
1834          loop
1835             if At_End then
1836                return;
1837             end if;
1838
1839             case Look is
1840
1841                when '_' | '0' | '/' =>
1842                   Skip;
1843
1844                when 'B' | 'b'  =>
1845                   Pic.Picture.Expanded (Index) := 'b';
1846                   Skip;
1847
1848                when '#' =>
1849                   Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1850                   Pic.End_Float := Index;
1851                   Skip;
1852
1853                   loop
1854                      if At_End then
1855                         return;
1856                      end if;
1857
1858                      case Look is
1859
1860                         when '_' | '0' | '/' =>
1861                            Skip;
1862
1863                         when 'B' | 'b'  =>
1864                            Pic.Picture.Expanded (Index) := 'b';
1865                            Skip;
1866
1867                         when '#' =>
1868                            Pic.Max_Trailing_Digits :=
1869                              Pic.Max_Trailing_Digits + 1;
1870                            Pic.End_Float := Index;
1871                            Skip;
1872
1873                         when others =>
1874                            return;
1875
1876                      end case;
1877                   end loop;
1878
1879                when others =>
1880                   Number_Fraction;
1881                   return;
1882
1883             end case;
1884          end loop;
1885       end Number_Fraction_Or_Pound;
1886
1887       ----------------------------------
1888       -- Number_Fraction_Or_Star_Fill --
1889       ----------------------------------
1890
1891       procedure Number_Fraction_Or_Star_Fill is
1892       begin
1893          Debug_Start ("Number_Fraction_Or_Star_Fill");
1894
1895          loop
1896             if At_End then
1897                return;
1898             end if;
1899
1900             case Look is
1901
1902                when '_' | '0' | '/' =>
1903                   Skip;
1904
1905                when 'B' | 'b'  =>
1906                   Pic.Picture.Expanded (Index) := 'b';
1907                   Skip;
1908
1909                when '*' =>
1910                   Pic.Star_Fill := True;
1911                   Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1912                   Pic.End_Float := Index;
1913                   Skip;
1914
1915                   loop
1916                      if At_End then
1917                         return;
1918                      end if;
1919
1920                      case Look is
1921
1922                         when '_' | '0' | '/' =>
1923                            Skip;
1924
1925                         when 'B' | 'b'  =>
1926                            Pic.Picture.Expanded (Index) := 'b';
1927                            Skip;
1928
1929                         when '*' =>
1930                            Pic.Star_Fill := True;
1931                            Pic.Max_Trailing_Digits :=
1932                              Pic.Max_Trailing_Digits + 1;
1933                            Pic.End_Float := Index;
1934                            Skip;
1935
1936                         when others =>
1937                            return;
1938                      end case;
1939                   end loop;
1940
1941                when others =>
1942                   Number_Fraction;
1943                   return;
1944
1945             end case;
1946          end loop;
1947       end Number_Fraction_Or_Star_Fill;
1948
1949       -------------------------------
1950       -- Number_Fraction_Or_Z_Fill --
1951       -------------------------------
1952
1953       procedure Number_Fraction_Or_Z_Fill is
1954       begin
1955          Debug_Start ("Number_Fraction_Or_Z_Fill");
1956
1957          loop
1958             if At_End then
1959                return;
1960             end if;
1961
1962             case Look is
1963
1964                when '_' | '0' | '/' =>
1965                   Skip;
1966
1967                when 'B' | 'b'  =>
1968                   Pic.Picture.Expanded (Index) := 'b';
1969                   Skip;
1970
1971                when 'Z' | 'z' =>
1972                   Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1973                   Pic.End_Float := Index;
1974                   Pic.Picture.Expanded (Index) := 'Z'; -- consistency
1975
1976                   Skip;
1977
1978                   loop
1979                      if At_End then
1980                         return;
1981                      end if;
1982
1983                      case Look is
1984
1985                         when '_' | '0' | '/' =>
1986                            Skip;
1987
1988                         when 'B' | 'b'  =>
1989                            Pic.Picture.Expanded (Index) := 'b';
1990                            Skip;
1991
1992                         when 'Z' | 'z' =>
1993                            Pic.Picture.Expanded (Index) := 'Z'; -- consistency
1994
1995                            Pic.Max_Trailing_Digits :=
1996                              Pic.Max_Trailing_Digits + 1;
1997                            Pic.End_Float := Index;
1998                            Skip;
1999
2000                         when others =>
2001                            return;
2002                      end case;
2003                   end loop;
2004
2005                when others =>
2006                   Number_Fraction;
2007                   return;
2008             end case;
2009          end loop;
2010       end Number_Fraction_Or_Z_Fill;
2011
2012       -----------------------
2013       -- Optional_RHS_Sign --
2014       -----------------------
2015
2016       procedure Optional_RHS_Sign is
2017       begin
2018          Debug_Start ("Optional_RHS_Sign");
2019
2020          if At_End then
2021             return;
2022          end if;
2023
2024          case Look is
2025
2026             when '+' | '-' =>
2027                Pic.Sign_Position := Index;
2028                Skip;
2029                return;
2030
2031             when 'C' | 'c' =>
2032                Pic.Sign_Position := Index;
2033                Pic.Picture.Expanded (Index) := 'C';
2034                Skip;
2035
2036                if Look = 'R' or else Look = 'r' then
2037                   Pic.Second_Sign := Index;
2038                   Pic.Picture.Expanded (Index) := 'R';
2039                   Skip;
2040
2041                else
2042                   raise Picture_Error;
2043                end if;
2044
2045                return;
2046
2047             when 'D' | 'd' =>
2048                Pic.Sign_Position := Index;
2049                Pic.Picture.Expanded (Index) := 'D';
2050                Skip;
2051
2052                if Look = 'B' or else Look = 'b' then
2053                   Pic.Second_Sign := Index;
2054                   Pic.Picture.Expanded (Index) := 'B';
2055                   Skip;
2056
2057                else
2058                   raise Picture_Error;
2059                end if;
2060
2061                return;
2062
2063             when '>' =>
2064                if Pic.Picture.Expanded (Pic.Sign_Position) = '<' then
2065                   Pic.Second_Sign := Index;
2066                   Skip;
2067
2068                else
2069                   raise Picture_Error;
2070                end if;
2071
2072             when others =>
2073                return;
2074
2075          end case;
2076       end Optional_RHS_Sign;
2077
2078       -------------
2079       -- Picture --
2080       -------------
2081
2082       --  Note that Picture can be called in either State
2083
2084       --  It will set state to Valid only if a 9 is encountered or floating
2085       --  currency is called.
2086
2087       procedure Picture is
2088       begin
2089          Debug_Start ("Picture");
2090
2091          loop
2092             if At_End then
2093                return;
2094             end if;
2095
2096             case Look is
2097
2098                when '_' | '0' | '/' =>
2099                   Skip;
2100
2101                when 'B' | 'b'  =>
2102                   Pic.Picture.Expanded (Index) := 'b';
2103                   Skip;
2104
2105                when '$' =>
2106                   Leading_Dollar;
2107                   return;
2108
2109                when '#' =>
2110                   Leading_Pound;
2111                   return;
2112
2113                when '9' =>
2114                   Computed_BWZ := False;
2115                   Set_State (Okay);
2116                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2117                   Skip;
2118
2119                when 'V' | 'v' | '.' =>
2120                   Pic.Radix_Position := Index;
2121                   Skip;
2122                   Number_Fraction;
2123                   Trailing_Currency;
2124                   return;
2125
2126                when others =>
2127                   return;
2128
2129             end case;
2130          end loop;
2131       end Picture;
2132
2133       ---------------------
2134       -- Picture_Bracket --
2135       ---------------------
2136
2137       procedure Picture_Bracket is
2138       begin
2139          Pic.Sign_Position := Index;
2140          Debug_Start ("Picture_Bracket");
2141          Pic.Sign_Position := Index;
2142
2143          --  Treat as a floating sign, and unwind otherwise
2144
2145          Pic.Floater := '<';
2146          Pic.Start_Float := Index;
2147          Pic.End_Float := Index;
2148
2149          --  Don't increment Pic.Max_Leading_Digits, we need one "real"
2150          --  sign place.
2151
2152          Skip; --  Known Bracket
2153
2154          loop
2155             case Look is
2156
2157                when '_' | '0' | '/' =>
2158                   Pic.End_Float := Index;
2159                   Skip;
2160
2161                when 'B' | 'b'  =>
2162                   Pic.End_Float := Index;
2163                   Pic.Picture.Expanded (Index) := 'b';
2164                   Skip;
2165
2166                when '<' =>
2167                   Set_State (Okay);  --  "<<>" is enough.
2168                   Floating_Bracket;
2169                   Trailing_Currency;
2170                   Trailing_Bracket;
2171                   return;
2172
2173                when '$' | '#' | '9' | '*' =>
2174                   if State /= Okay then
2175                      Pic.Floater := '!';
2176                      Pic.Start_Float := Invalid_Position;
2177                      Pic.End_Float := Invalid_Position;
2178                   end if;
2179
2180                   Picture;
2181                   Trailing_Bracket;
2182                   Set_State (Okay);
2183                   return;
2184
2185                when '.' | 'V' | 'v' =>
2186                   if State /= Okay then
2187                      Pic.Floater := '!';
2188                      Pic.Start_Float := Invalid_Position;
2189                      Pic.End_Float := Invalid_Position;
2190                   end if;
2191
2192                   --  Don't assume that state is okay, haven't seen a digit
2193
2194                   Picture;
2195                   Trailing_Bracket;
2196                   return;
2197
2198                when others =>
2199                   raise Picture_Error;
2200
2201             end case;
2202          end loop;
2203       end Picture_Bracket;
2204
2205       -------------------
2206       -- Picture_Minus --
2207       -------------------
2208
2209       procedure Picture_Minus is
2210       begin
2211          Debug_Start ("Picture_Minus");
2212
2213          Pic.Sign_Position := Index;
2214
2215          --  Treat as a floating sign, and unwind otherwise
2216
2217          Pic.Floater := '-';
2218          Pic.Start_Float := Index;
2219          Pic.End_Float := Index;
2220
2221          --  Don't increment Pic.Max_Leading_Digits, we need one "real"
2222          --  sign place.
2223
2224          Skip; --  Known Minus
2225
2226          loop
2227             case Look is
2228
2229                when '_' | '0' | '/' =>
2230                   Pic.End_Float := Index;
2231                   Skip;
2232
2233                when 'B' | 'b'  =>
2234                   Pic.End_Float := Index;
2235                   Pic.Picture.Expanded (Index) := 'b';
2236                   Skip;
2237
2238                when '-' =>
2239                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2240                   Pic.End_Float := Index;
2241                   Skip;
2242                   Set_State (Okay);  --  "-- " is enough.
2243                   Floating_Minus;
2244                   Trailing_Currency;
2245                   return;
2246
2247                when '$' | '#' | '9' | '*' =>
2248                   if State /= Okay then
2249                      Pic.Floater := '!';
2250                      Pic.Start_Float := Invalid_Position;
2251                      Pic.End_Float := Invalid_Position;
2252                   end if;
2253
2254                   Picture;
2255                   Set_State (Okay);
2256                   return;
2257
2258                when 'Z' | 'z' =>
2259
2260                   --  Can't have Z and a floating sign
2261
2262                   if State = Okay then
2263                      Set_State (Reject);
2264                   end if;
2265
2266                   Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2267                   Zero_Suppression;
2268                   Trailing_Currency;
2269                   Optional_RHS_Sign;
2270                   return;
2271
2272                when '.' | 'V' | 'v' =>
2273                   if State /= Okay then
2274                      Pic.Floater := '!';
2275                      Pic.Start_Float := Invalid_Position;
2276                      Pic.End_Float := Invalid_Position;
2277                   end if;
2278
2279                   --  Don't assume that state is okay, haven't seen a digit
2280
2281                   Picture;
2282                   return;
2283
2284                when others =>
2285                   return;
2286
2287             end case;
2288          end loop;
2289       end Picture_Minus;
2290
2291       ------------------
2292       -- Picture_Plus --
2293       ------------------
2294
2295       procedure Picture_Plus is
2296       begin
2297          Debug_Start ("Picture_Plus");
2298          Pic.Sign_Position := Index;
2299
2300          --  Treat as a floating sign, and unwind otherwise
2301
2302          Pic.Floater := '+';
2303          Pic.Start_Float := Index;
2304          Pic.End_Float := Index;
2305
2306          --  Don't increment Pic.Max_Leading_Digits, we need one "real"
2307          --  sign place.
2308
2309          Skip; --  Known Plus
2310
2311          loop
2312             case Look is
2313
2314                when '_' | '0' | '/' =>
2315                   Pic.End_Float := Index;
2316                   Skip;
2317
2318                when 'B' | 'b'  =>
2319                   Pic.End_Float := Index;
2320                   Pic.Picture.Expanded (Index) := 'b';
2321                   Skip;
2322
2323                when '+' =>
2324                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2325                   Pic.End_Float := Index;
2326                   Skip;
2327                   Set_State (Okay);  --  "++" is enough
2328                   Floating_Plus;
2329                   Trailing_Currency;
2330                   return;
2331
2332                when '$' | '#' | '9' | '*' =>
2333                   if State /= Okay then
2334                      Pic.Floater := '!';
2335                      Pic.Start_Float := Invalid_Position;
2336                      Pic.End_Float := Invalid_Position;
2337                   end if;
2338
2339                   Picture;
2340                   Set_State (Okay);
2341                   return;
2342
2343                when 'Z' | 'z' =>
2344                   if State = Okay then
2345                      Set_State (Reject);
2346                   end if;
2347
2348                   --  Can't have Z and a floating sign
2349
2350                   Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2351
2352                   --  '+Z' is acceptable
2353
2354                   Set_State (Okay);
2355
2356                   --  Overwrite Floater and Start_Float
2357
2358                   Pic.Floater := 'Z';
2359                   Pic.Start_Float := Index;
2360
2361                   Zero_Suppression;
2362                   Trailing_Currency;
2363                   Optional_RHS_Sign;
2364                   return;
2365
2366                when '.' | 'V' | 'v' =>
2367                   if State /= Okay then
2368                      Pic.Floater := '!';
2369                      Pic.Start_Float := Invalid_Position;
2370                      Pic.End_Float := Invalid_Position;
2371                   end if;
2372
2373                   --  Don't assume that state is okay, haven't seen a digit
2374
2375                   Picture;
2376                   return;
2377
2378                when others =>
2379                   return;
2380
2381             end case;
2382          end loop;
2383       end Picture_Plus;
2384
2385       --------------------
2386       -- Picture_String --
2387       --------------------
2388
2389       procedure Picture_String is
2390       begin
2391          Debug_Start ("Picture_String");
2392
2393          while Is_Insert loop
2394             Skip;
2395          end loop;
2396
2397          case Look is
2398
2399             when '$' | '#' =>
2400                Picture;
2401                Optional_RHS_Sign;
2402
2403             when '+' =>
2404                Picture_Plus;
2405
2406             when '-' =>
2407                Picture_Minus;
2408
2409             when '<' =>
2410                Picture_Bracket;
2411
2412             when 'Z' | 'z' =>
2413                Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2414                Zero_Suppression;
2415                Trailing_Currency;
2416                Optional_RHS_Sign;
2417
2418             when '*' =>
2419                Star_Suppression;
2420                Trailing_Currency;
2421                Optional_RHS_Sign;
2422
2423             when '9' | '.' | 'V' | 'v' =>
2424                Number;
2425                Trailing_Currency;
2426                Optional_RHS_Sign;
2427
2428             when others =>
2429                raise Picture_Error;
2430
2431          end case;
2432
2433          --  Blank when zero either if the PIC does not contain a '9' or if
2434          --  requested by the user and no '*'.
2435
2436          Pic.Blank_When_Zero :=
2437            (Computed_BWZ or else Pic.Blank_When_Zero)
2438              and then not Pic.Star_Fill;
2439
2440          --  Star fill if '*' and no '9'
2441
2442          Pic.Star_Fill := Pic.Star_Fill and then Computed_BWZ;
2443
2444          if not At_End then
2445             Set_State (Reject);
2446          end if;
2447
2448       end Picture_String;
2449
2450       ---------------
2451       -- Set_State --
2452       ---------------
2453
2454       procedure Set_State (L : Legality) is
2455       begin
2456          if Debug then
2457             Ada.Text_IO.Put_Line
2458               ("  Set state from " & Legality'Image (State)
2459                & " to " & Legality'Image (L));
2460          end if;
2461
2462          State := L;
2463       end Set_State;
2464
2465       ----------
2466       -- Skip --
2467       ----------
2468
2469       procedure Skip is
2470       begin
2471          if Debug then
2472             Ada.Text_IO.Put_Line ("  Skip " & Pic.Picture.Expanded (Index));
2473          end if;
2474
2475          Index := Index + 1;
2476       end Skip;
2477
2478       ----------------------
2479       -- Star_Suppression --
2480       ----------------------
2481
2482       procedure Star_Suppression is
2483       begin
2484          Debug_Start ("Star_Suppression");
2485
2486          if Pic.Floater /= '!' and then Pic.Floater /= '*' then
2487
2488             --  Two floats not allowed
2489
2490             raise Picture_Error;
2491
2492          else
2493             Pic.Floater := '*';
2494          end if;
2495
2496          Pic.Start_Float := Index;
2497          Pic.End_Float := Index;
2498          Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2499          Set_State (Okay);
2500
2501          --  Even a single * is a valid picture
2502
2503          Pic.Star_Fill := True;
2504          Skip; --  Known *
2505
2506          loop
2507             if At_End then
2508                return;
2509             end if;
2510
2511             case Look is
2512
2513                when '_' | '0' | '/' =>
2514                   Pic.End_Float := Index;
2515                   Skip;
2516
2517                when 'B' | 'b'  =>
2518                   Pic.End_Float := Index;
2519                   Pic.Picture.Expanded (Index) := 'b';
2520                   Skip;
2521
2522                when '*' =>
2523                   Pic.End_Float := Index;
2524                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2525                   Set_State (Okay); Skip;
2526
2527                when '9' =>
2528                   Set_State (Okay);
2529                   Number_Completion;
2530                   return;
2531
2532                when '.' | 'V' | 'v' =>
2533                   Pic.Radix_Position := Index;
2534                   Skip;
2535                   Number_Fraction_Or_Star_Fill;
2536                   return;
2537
2538                when '#' | '$' =>
2539                   if Pic.Max_Currency_Digits > 0 then
2540                      raise Picture_Error;
2541                   end if;
2542
2543                   --  Cannot have leading and trailing currency
2544
2545                   Trailing_Currency;
2546                   Set_State (Okay);
2547                   return;
2548
2549                when others => raise Picture_Error;
2550             end case;
2551          end loop;
2552       end Star_Suppression;
2553
2554       ----------------------
2555       -- Trailing_Bracket --
2556       ----------------------
2557
2558       procedure Trailing_Bracket is
2559       begin
2560          Debug_Start ("Trailing_Bracket");
2561
2562          if Look = '>' then
2563             Pic.Second_Sign := Index;
2564             Skip;
2565          else
2566             raise Picture_Error;
2567          end if;
2568       end Trailing_Bracket;
2569
2570       -----------------------
2571       -- Trailing_Currency --
2572       -----------------------
2573
2574       procedure Trailing_Currency is
2575       begin
2576          Debug_Start ("Trailing_Currency");
2577
2578          if At_End then
2579             return;
2580          end if;
2581
2582          if Look = '$' then
2583             Pic.Start_Currency := Index;
2584             Pic.End_Currency := Index;
2585             Skip;
2586
2587          else
2588             while not At_End and then Look = '#' loop
2589                if Pic.Start_Currency = Invalid_Position then
2590                   Pic.Start_Currency := Index;
2591                end if;
2592
2593                Pic.End_Currency := Index;
2594                Skip;
2595             end loop;
2596          end if;
2597
2598          loop
2599             if At_End then
2600                return;
2601             end if;
2602
2603             case Look is
2604                when '_' | '0' | '/' => Skip;
2605
2606                when 'B' | 'b'  =>
2607                   Pic.Picture.Expanded (Index) := 'b';
2608                   Skip;
2609
2610                when others => return;
2611             end case;
2612          end loop;
2613       end Trailing_Currency;
2614
2615       ----------------------
2616       -- Zero_Suppression --
2617       ----------------------
2618
2619       procedure Zero_Suppression is
2620       begin
2621          Debug_Start ("Zero_Suppression");
2622
2623          Pic.Floater := 'Z';
2624          Pic.Start_Float := Index;
2625          Pic.End_Float := Index;
2626          Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2627          Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2628
2629          Skip; --  Known Z
2630
2631          loop
2632             --  Even a single Z is a valid picture
2633
2634             if At_End then
2635                Set_State (Okay);
2636                return;
2637             end if;
2638
2639             case Look is
2640                when '_' | '0' | '/' =>
2641                   Pic.End_Float := Index;
2642                   Skip;
2643
2644                when 'B' | 'b'  =>
2645                   Pic.End_Float := Index;
2646                   Pic.Picture.Expanded (Index) := 'b';
2647                   Skip;
2648
2649                when 'Z' | 'z' =>
2650                   Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2651
2652                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2653                   Pic.End_Float := Index;
2654                   Set_State (Okay);
2655                   Skip;
2656
2657                when '9' =>
2658                   Set_State (Okay);
2659                   Number_Completion;
2660                   return;
2661
2662                when '.' | 'V' | 'v' =>
2663                   Pic.Radix_Position := Index;
2664                   Skip;
2665                   Number_Fraction_Or_Z_Fill;
2666                   return;
2667
2668                when '#' | '$' =>
2669                   Trailing_Currency;
2670                   Set_State (Okay);
2671                   return;
2672
2673                when others =>
2674                   return;
2675             end case;
2676          end loop;
2677       end Zero_Suppression;
2678
2679    --  Start of processing for Precalculate
2680
2681    begin
2682       pragma Debug (Set_Debug);
2683
2684       Picture_String;
2685
2686       if Debug then
2687          Ada.Text_IO.New_Line;
2688          Ada.Text_IO.Put (" Picture : """ &
2689                      Pic.Picture.Expanded (1 .. Pic.Picture.Length) & """,");
2690          Ada.Text_IO.Put (" Floater : '" & Pic.Floater & "',");
2691       end if;
2692
2693       if State = Reject then
2694          raise Picture_Error;
2695       end if;
2696
2697       Debug_Integer (Pic.Radix_Position, "Radix Positon : ");
2698       Debug_Integer (Pic.Sign_Position, "Sign Positon : ");
2699       Debug_Integer (Pic.Second_Sign, "Second Sign : ");
2700       Debug_Integer (Pic.Start_Float, "Start Float : ");
2701       Debug_Integer (Pic.End_Float, "End Float : ");
2702       Debug_Integer (Pic.Start_Currency, "Start Currency : ");
2703       Debug_Integer (Pic.End_Currency, "End Currency : ");
2704       Debug_Integer (Pic.Max_Leading_Digits, "Max Leading Digits : ");
2705       Debug_Integer (Pic.Max_Trailing_Digits, "Max Trailing Digits : ");
2706
2707       if Debug then
2708          Ada.Text_IO.New_Line;
2709       end if;
2710
2711    exception
2712
2713       when Constraint_Error =>
2714
2715       --  To deal with special cases like null strings
2716
2717       raise Picture_Error;
2718    end Precalculate;
2719
2720    ----------------
2721    -- To_Picture --
2722    ----------------
2723
2724    function To_Picture
2725      (Pic_String      : String;
2726       Blank_When_Zero : Boolean := False) return Picture
2727    is
2728       Result : Picture;
2729
2730    begin
2731       declare
2732          Item : constant String := Expand (Pic_String);
2733
2734       begin
2735          Result.Contents.Picture         := (Item'Length, Item);
2736          Result.Contents.Original_BWZ := Blank_When_Zero;
2737          Result.Contents.Blank_When_Zero := Blank_When_Zero;
2738          Precalculate (Result.Contents);
2739          return Result;
2740       end;
2741
2742    exception
2743       when others =>
2744          raise Picture_Error;
2745    end To_Picture;
2746
2747    -----------
2748    -- Valid --
2749    -----------
2750
2751    function Valid
2752      (Pic_String      : String;
2753       Blank_When_Zero : Boolean := False) return Boolean
2754    is
2755    begin
2756       declare
2757          Expanded_Pic : constant String := Expand (Pic_String);
2758          --  Raises Picture_Error if Item not well-formed
2759
2760          Format_Rec : Format_Record;
2761
2762       begin
2763          Format_Rec.Picture := (Expanded_Pic'Length, Expanded_Pic);
2764          Format_Rec.Blank_When_Zero := Blank_When_Zero;
2765          Format_Rec.Original_BWZ := Blank_When_Zero;
2766          Precalculate (Format_Rec);
2767
2768          --  False only if Blank_When_Zero is True but the pic string has a '*'
2769
2770          return not Blank_When_Zero
2771            or else Strings_Fixed.Index (Expanded_Pic, "*") = 0;
2772       end;
2773
2774    exception
2775       when others => return False;
2776    end Valid;
2777
2778    --------------------
2779    -- Decimal_Output --
2780    --------------------
2781
2782    package body Decimal_Output is
2783
2784       -----------
2785       -- Image --
2786       -----------
2787
2788       function Image
2789         (Item       : Num;
2790          Pic        : Picture;
2791          Currency   : String    := Default_Currency;
2792          Fill       : Character := Default_Fill;
2793          Separator  : Character := Default_Separator;
2794          Radix_Mark : Character := Default_Radix_Mark) return String
2795       is
2796       begin
2797          return Format_Number
2798             (Pic.Contents, Num'Image (Item),
2799              Currency, Fill, Separator, Radix_Mark);
2800       end Image;
2801
2802       ------------
2803       -- Length --
2804       ------------
2805
2806       function Length
2807         (Pic      : Picture;
2808          Currency : String := Default_Currency) return Natural
2809       is
2810          Picstr     : constant String := Pic_String (Pic);
2811          V_Adjust   : Integer := 0;
2812          Cur_Adjust : Integer := 0;
2813
2814       begin
2815          --  Check if Picstr has 'V' or '$'
2816
2817          --  If 'V', then length is 1 less than otherwise
2818
2819          --  If '$', then length is Currency'Length-1 more than otherwise
2820
2821          --  This should use the string handling package ???
2822
2823          for J in Picstr'Range loop
2824             if Picstr (J) = 'V' then
2825                V_Adjust := -1;
2826
2827             elsif Picstr (J) = '$' then
2828                Cur_Adjust := Currency'Length - 1;
2829             end if;
2830          end loop;
2831
2832          return Picstr'Length - V_Adjust + Cur_Adjust;
2833       end Length;
2834
2835       ---------
2836       -- Put --
2837       ---------
2838
2839       procedure Put
2840         (File       : Text_IO.File_Type;
2841          Item       : Num;
2842          Pic        : Picture;
2843          Currency   : String    := Default_Currency;
2844          Fill       : Character := Default_Fill;
2845          Separator  : Character := Default_Separator;
2846          Radix_Mark : Character := Default_Radix_Mark)
2847       is
2848       begin
2849          Text_IO.Put (File, Image (Item, Pic,
2850                                    Currency, Fill, Separator, Radix_Mark));
2851       end Put;
2852
2853       procedure Put
2854         (Item       : Num;
2855          Pic        : Picture;
2856          Currency   : String    := Default_Currency;
2857          Fill       : Character := Default_Fill;
2858          Separator  : Character := Default_Separator;
2859          Radix_Mark : Character := Default_Radix_Mark)
2860       is
2861       begin
2862          Text_IO.Put (Image (Item, Pic,
2863                              Currency, Fill, Separator, Radix_Mark));
2864       end Put;
2865
2866       procedure Put
2867         (To         : out String;
2868          Item       : Num;
2869          Pic        : Picture;
2870          Currency   : String    := Default_Currency;
2871          Fill       : Character := Default_Fill;
2872          Separator  : Character := Default_Separator;
2873          Radix_Mark : Character := Default_Radix_Mark)
2874       is
2875          Result : constant String :=
2876            Image (Item, Pic, Currency, Fill, Separator, Radix_Mark);
2877
2878       begin
2879          if Result'Length > To'Length then
2880             raise Ada.Text_IO.Layout_Error;
2881          else
2882             Strings_Fixed.Move (Source => Result, Target => To,
2883                                 Justify => Strings.Right);
2884          end if;
2885       end Put;
2886
2887       -----------
2888       -- Valid --
2889       -----------
2890
2891       function Valid
2892         (Item     : Num;
2893          Pic      : Picture;
2894          Currency : String := Default_Currency) return Boolean
2895       is
2896       begin
2897          declare
2898             Temp : constant String := Image (Item, Pic, Currency);
2899             pragma Warnings (Off, Temp);
2900          begin
2901             return True;
2902          end;
2903
2904       exception
2905          when Ada.Text_IO.Layout_Error => return False;
2906
2907       end Valid;
2908    end Decimal_Output;
2909
2910 end Ada.Text_IO.Editing;