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