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