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-2007, 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) := Fill_Character;
 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) := Fill_Character;
 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
 937             Temp (J) := 'B';
 938          end if;
 939       end loop;
 940
 941       return Temp;
 942    end Pic_String;
 943
 944    ------------------
 945    -- Precalculate --
 946    ------------------
 947
 948    procedure Precalculate  (Pic : in out Format_Record) is
 949       Debug : constant Boolean := False;
 950       --  Set True to generate debug output
 951
 952       Computed_BWZ : Boolean := True;
 953
 954       type Legality is  (Okay, Reject);
 955
 956       State : Legality := Reject;
 957       --  Start in reject, which will reject null strings
 958
 959       Index : Pic_Index := Pic.Picture.Expanded'First;
 960
 961       function At_End return Boolean;
 962       pragma Inline (At_End);
 963
 964       procedure Set_State (L : Legality);
 965       pragma Inline (Set_State);
 966
 967       function Look return Character;
 968       pragma Inline (Look);
 969
 970       function Is_Insert return Boolean;
 971       pragma Inline (Is_Insert);
 972
 973       procedure Skip;
 974       pragma Inline (Skip);
 975
 976       procedure Debug_Start (Name : String);
 977       pragma Inline (Debug_Start);
 978
 979       procedure Debug_Integer  (Value : Integer; S : String);
 980       pragma Inline (Debug_Integer);
 981
 982       procedure Trailing_Currency;
 983       procedure Trailing_Bracket;
 984       procedure Number_Fraction;
 985       procedure Number_Completion;
 986       procedure Number_Fraction_Or_Bracket;
 987       procedure Number_Fraction_Or_Z_Fill;
 988       procedure Zero_Suppression;
 989       procedure Floating_Bracket;
 990       procedure Number_Fraction_Or_Star_Fill;
 991       procedure Star_Suppression;
 992       procedure Number_Fraction_Or_Dollar;
 993       procedure Leading_Dollar;
 994       procedure Number_Fraction_Or_Pound;
 995       procedure Leading_Pound;
 996       procedure Picture;
 997       procedure Floating_Plus;
 998       procedure Floating_Minus;
 999       procedure Picture_Plus;
1000       procedure Picture_Minus;
1001       procedure Picture_Bracket;
1002       procedure Number;
1003       procedure Optional_RHS_Sign;
1004       procedure Picture_String;
1005       procedure Set_Debug;
1006
1007       ------------
1008       -- At_End --
1009       ------------
1010
1011       function At_End return Boolean is
1012       begin
1013          Debug_Start ("At_End");
1014          return Index > Pic.Picture.Length;
1015       end At_End;
1016
1017       --------------
1018       -- Set_Debug--
1019       --------------
1020
1021       --  Needed to have a procedure to pass to pragma Debug
1022
1023       procedure Set_Debug is
1024       begin
1025          --  Uncomment this line and make Debug a variable to enable debug
1026
1027          --  Debug := True;
1028
1029          null;
1030       end Set_Debug;
1031
1032       -------------------
1033       -- Debug_Integer --
1034       -------------------
1035
1036       procedure Debug_Integer (Value : Integer; S : String) is
1037          use Ada.Text_IO; --  needed for >
1038
1039       begin
1040          if Debug and then Value > 0 then
1041             if Ada.Text_IO.Col > 70 - S'Length then
1042                Ada.Text_IO.New_Line;
1043             end if;
1044
1045             Ada.Text_IO.Put (' ' & S & Integer'Image (Value) & ',');
1046          end if;
1047       end Debug_Integer;
1048
1049       -----------------
1050       -- Debug_Start --
1051       -----------------
1052
1053       procedure Debug_Start (Name : String) is
1054       begin
1055          if Debug then
1056             Ada.Text_IO.Put_Line ("  In " & Name & '.');
1057          end if;
1058       end Debug_Start;
1059
1060       ----------------------
1061       -- Floating_Bracket --
1062       ----------------------
1063
1064       --  Note that Floating_Bracket is only called with an acceptable
1065       --  prefix. But we don't set Okay, because we must end with a '>'.
1066
1067       procedure Floating_Bracket is
1068       begin
1069          Debug_Start ("Floating_Bracket");
1070
1071          --  Two different floats not allowed
1072
1073          if Pic.Floater /= '!' and then Pic.Floater /= '<' then
1074             raise Picture_Error;
1075
1076          else
1077             Pic.Floater := '<';
1078          end if;
1079
1080          Pic.End_Float := Index;
1081          Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1082
1083          --  First bracket wasn't counted...
1084
1085          Skip; --  known '<'
1086
1087          loop
1088             if At_End then
1089                return;
1090             end if;
1091
1092             case Look is
1093
1094                when '_' | '0' | '/' =>
1095                   Pic.End_Float := Index;
1096                   Skip;
1097
1098                when 'B' | 'b'  =>
1099                   Pic.End_Float := Index;
1100                   Pic.Picture.Expanded (Index) := 'b';
1101                   Skip;
1102
1103                when '<' =>
1104                   Pic.End_Float := Index;
1105                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1106                   Skip;
1107
1108                when '9' =>
1109                   Number_Completion;
1110
1111                when '$' =>
1112                   Leading_Dollar;
1113
1114                when '#' =>
1115                   Leading_Pound;
1116
1117                when 'V' | 'v' | '.' =>
1118                   Pic.Radix_Position := Index;
1119                   Skip;
1120                   Number_Fraction_Or_Bracket;
1121                   return;
1122
1123                when others =>
1124                return;
1125             end case;
1126          end loop;
1127       end Floating_Bracket;
1128
1129       --------------------
1130       -- Floating_Minus --
1131       --------------------
1132
1133       procedure Floating_Minus is
1134       begin
1135          Debug_Start ("Floating_Minus");
1136
1137          loop
1138             if At_End then
1139                return;
1140             end if;
1141
1142             case Look is
1143                when '_' | '0' | '/' =>
1144                   Pic.End_Float := Index;
1145                   Skip;
1146
1147                when 'B' | 'b'  =>
1148                   Pic.End_Float := Index;
1149                   Pic.Picture.Expanded (Index) := 'b';
1150                   Skip;
1151
1152                when '-' =>
1153                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1154                   Pic.End_Float := Index;
1155                   Skip;
1156
1157                when '9' =>
1158                   Number_Completion;
1159                   return;
1160
1161                when '.' | 'V' | 'v' =>
1162                   Pic.Radix_Position := Index;
1163                   Skip; --  Radix
1164
1165                   while Is_Insert loop
1166                      Skip;
1167                   end loop;
1168
1169                   if At_End then
1170                      return;
1171                   end if;
1172
1173                   if Look = '-' then
1174                      loop
1175                         if At_End then
1176                            return;
1177                         end if;
1178
1179                         case Look is
1180
1181                            when '-' =>
1182                               Pic.Max_Trailing_Digits :=
1183                                 Pic.Max_Trailing_Digits + 1;
1184                               Pic.End_Float := Index;
1185                               Skip;
1186
1187                            when '_' | '0' | '/' =>
1188                               Skip;
1189
1190                            when 'B' | 'b'  =>
1191                               Pic.Picture.Expanded (Index) := 'b';
1192                               Skip;
1193
1194                            when others =>
1195                               return;
1196
1197                         end case;
1198                      end loop;
1199
1200                   else
1201                      Number_Completion;
1202                   end if;
1203
1204                   return;
1205
1206                when others =>
1207                   return;
1208             end case;
1209          end loop;
1210       end Floating_Minus;
1211
1212       -------------------
1213       -- Floating_Plus --
1214       -------------------
1215
1216       procedure Floating_Plus is
1217       begin
1218          Debug_Start ("Floating_Plus");
1219
1220          loop
1221             if At_End then
1222                return;
1223             end if;
1224
1225             case Look is
1226                when '_' | '0' | '/' =>
1227                   Pic.End_Float := Index;
1228                   Skip;
1229
1230                when 'B' | 'b'  =>
1231                   Pic.End_Float := Index;
1232                   Pic.Picture.Expanded (Index) := 'b';
1233                   Skip;
1234
1235                when '+' =>
1236                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1237                   Pic.End_Float := Index;
1238                   Skip;
1239
1240                when '9' =>
1241                   Number_Completion;
1242                   return;
1243
1244                when '.' | 'V' | 'v' =>
1245                   Pic.Radix_Position := Index;
1246                   Skip; --  Radix
1247
1248                   while Is_Insert loop
1249                      Skip;
1250                   end loop;
1251
1252                   if At_End then
1253                      return;
1254                   end if;
1255
1256                   if Look = '+' then
1257                      loop
1258                         if At_End then
1259                            return;
1260                         end if;
1261
1262                         case Look is
1263
1264                            when '+' =>
1265                               Pic.Max_Trailing_Digits :=
1266                                 Pic.Max_Trailing_Digits + 1;
1267                               Pic.End_Float := Index;
1268                               Skip;
1269
1270                            when '_' | '0' | '/' =>
1271                               Skip;
1272
1273                            when 'B' | 'b'  =>
1274                               Pic.Picture.Expanded (Index) := 'b';
1275                               Skip;
1276
1277                            when others =>
1278                               return;
1279
1280                         end case;
1281                      end loop;
1282
1283                   else
1284                      Number_Completion;
1285                   end if;
1286
1287                   return;
1288
1289                when others =>
1290                   return;
1291
1292             end case;
1293          end loop;
1294       end Floating_Plus;
1295
1296       ---------------
1297       -- Is_Insert --
1298       ---------------
1299
1300       function Is_Insert return Boolean is
1301       begin
1302          if At_End then
1303             return False;
1304          end if;
1305
1306          case Pic.Picture.Expanded (Index) is
1307
1308             when '_' | '0' | '/' => return True;
1309
1310             when 'B' | 'b' =>
1311                Pic.Picture.Expanded (Index) := 'b'; --  canonical
1312                return True;
1313
1314             when others => return False;
1315          end case;
1316       end Is_Insert;
1317
1318       --------------------
1319       -- Leading_Dollar --
1320       --------------------
1321
1322       --  Note that Leading_Dollar can be called in either State.
1323       --  It will set state to Okay only if a 9 or (second) $
1324       --  is encountered.
1325
1326       --  Also notice the tricky bit with State and Zero_Suppression.
1327       --  Zero_Suppression is Picture_Error if a '$' or a '9' has been
1328       --  encountered, exactly the cases where State has been set.
1329
1330       procedure Leading_Dollar is
1331       begin
1332          Debug_Start ("Leading_Dollar");
1333
1334          --  Treat as a floating dollar, and unwind otherwise
1335
1336          if Pic.Floater /= '!' and then Pic.Floater /= '$' then
1337
1338             --  Two floats not allowed
1339
1340             raise Picture_Error;
1341
1342          else
1343             Pic.Floater := '$';
1344          end if;
1345
1346          Pic.Start_Currency := Index;
1347          Pic.End_Currency := Index;
1348          Pic.Start_Float := Index;
1349          Pic.End_Float := Index;
1350
1351          --  Don't increment Pic.Max_Leading_Digits, we need one "real"
1352          --  currency place.
1353
1354          Skip; --  known '$'
1355
1356          loop
1357             if At_End then
1358                return;
1359             end if;
1360
1361             case Look is
1362
1363                when '_' | '0' | '/' =>
1364                   Pic.End_Float := Index;
1365                   Skip;
1366
1367                   --  A trailing insertion character is not part of the
1368                   --  floating currency, so need to look ahead.
1369
1370                   if Look /= '$' then
1371                      Pic.End_Float := Pic.End_Float - 1;
1372                   end if;
1373
1374                when 'B' | 'b'  =>
1375                   Pic.End_Float := Index;
1376                   Pic.Picture.Expanded (Index) := 'b';
1377                   Skip;
1378
1379                when 'Z' | 'z' =>
1380                   Pic.Picture.Expanded (Index) := 'Z'; -- consistency
1381
1382                   if State = Okay then
1383                      raise Picture_Error;
1384                   else
1385                      --  Overwrite Floater and Start_Float
1386
1387                      Pic.Floater := 'Z';
1388                      Pic.Start_Float := Index;
1389                      Zero_Suppression;
1390                   end if;
1391
1392                when '*' =>
1393                   if State = Okay then
1394                      raise Picture_Error;
1395                   else
1396                      --  Overwrite Floater and Start_Float
1397
1398                      Pic.Floater := '*';
1399                      Pic.Start_Float := Index;
1400                      Star_Suppression;
1401                   end if;
1402
1403                when '$' =>
1404                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1405                   Pic.End_Float := Index;
1406                   Pic.End_Currency := Index;
1407                   Set_State (Okay); Skip;
1408
1409                when '9' =>
1410                   if State /= Okay then
1411                      Pic.Floater := '!';
1412                      Pic.Start_Float := Invalid_Position;
1413                      Pic.End_Float := Invalid_Position;
1414                   end if;
1415
1416                   --  A single dollar does not a floating make
1417
1418                   Number_Completion;
1419                   return;
1420
1421                when 'V' | 'v' | '.' =>
1422                   if State /= Okay then
1423                      Pic.Floater := '!';
1424                      Pic.Start_Float := Invalid_Position;
1425                      Pic.End_Float := Invalid_Position;
1426                   end if;
1427
1428                   --  Only one dollar before the sign is okay, but doesn't
1429                   --  float.
1430
1431                   Pic.Radix_Position := Index;
1432                   Skip;
1433                   Number_Fraction_Or_Dollar;
1434                   return;
1435
1436                when others =>
1437                   return;
1438
1439             end case;
1440          end loop;
1441       end Leading_Dollar;
1442
1443       -------------------
1444       -- Leading_Pound --
1445       -------------------
1446
1447       --  This one is complex!  A Leading_Pound can be fixed or floating,
1448       --  but in some cases the decision has to be deferred until we leave
1449       --  this procedure.  Also note that Leading_Pound can be called in
1450       --  either State.
1451
1452       --  It will set state to Okay only if a 9 or  (second) # is
1453       --  encountered.
1454
1455       --  One Last note:  In ambiguous cases, the currency is treated as
1456       --  floating unless there is only one '#'.
1457
1458       procedure Leading_Pound is
1459
1460          Inserts : Boolean := False;
1461          --  Set to True if a '_', '0', '/', 'B', or 'b' is encountered
1462
1463          Must_Float : Boolean := False;
1464          --  Set to true if a '#' occurs after an insert
1465
1466       begin
1467          Debug_Start ("Leading_Pound");
1468
1469          --  Treat as a floating currency. If it isn't, this will be
1470          --  overwritten later.
1471
1472          if Pic.Floater /= '!' and then Pic.Floater /= '#' then
1473
1474             --  Two floats not allowed
1475
1476             raise Picture_Error;
1477
1478          else
1479             Pic.Floater := '#';
1480          end if;
1481
1482          Pic.Start_Currency := Index;
1483          Pic.End_Currency := Index;
1484          Pic.Start_Float := Index;
1485          Pic.End_Float := Index;
1486
1487          --  Don't increment Pic.Max_Leading_Digits, we need one "real"
1488          --  currency place.
1489
1490          Pic.Max_Currency_Digits := 1; --  we've seen one.
1491
1492          Skip; --  known '#'
1493
1494          loop
1495             if At_End then
1496                return;
1497             end if;
1498
1499             case Look is
1500
1501                when '_' | '0' | '/' =>
1502                   Pic.End_Float := Index;
1503                   Inserts := True;
1504                   Skip;
1505
1506                when 'B' | 'b'  =>
1507                   Pic.Picture.Expanded (Index) := 'b';
1508                   Pic.End_Float := Index;
1509                   Inserts := True;
1510                   Skip;
1511
1512                when 'Z' | 'z' =>
1513                   Pic.Picture.Expanded (Index) := 'Z'; -- consistency
1514
1515                   if Must_Float then
1516                      raise Picture_Error;
1517                   else
1518                      Pic.Max_Leading_Digits := 0;
1519
1520                      --  Overwrite Floater and Start_Float
1521
1522                      Pic.Floater := 'Z';
1523                      Pic.Start_Float := Index;
1524                      Zero_Suppression;
1525                   end if;
1526
1527                when '*' =>
1528                   if Must_Float then
1529                      raise Picture_Error;
1530                   else
1531                      Pic.Max_Leading_Digits := 0;
1532
1533                      --  Overwrite Floater and Start_Float
1534                      Pic.Floater := '*';
1535                      Pic.Start_Float := Index;
1536                      Star_Suppression;
1537                   end if;
1538
1539                when '#' =>
1540                   if Inserts then
1541                      Must_Float := True;
1542                   end if;
1543
1544                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1545                   Pic.End_Float := Index;
1546                   Pic.End_Currency := Index;
1547                   Set_State (Okay);
1548                   Skip;
1549
1550                when '9' =>
1551                   if State /= Okay then
1552
1553                      --  A single '#' doesn't float
1554
1555                      Pic.Floater := '!';
1556                      Pic.Start_Float := Invalid_Position;
1557                      Pic.End_Float := Invalid_Position;
1558                   end if;
1559
1560                   Number_Completion;
1561                   return;
1562
1563                when 'V' | 'v' | '.' =>
1564                   if State /= Okay then
1565                      Pic.Floater := '!';
1566                      Pic.Start_Float := Invalid_Position;
1567                      Pic.End_Float := Invalid_Position;
1568                   end if;
1569
1570                   --  Only one pound before the sign is okay, but doesn't
1571                   --  float.
1572
1573                   Pic.Radix_Position := Index;
1574                   Skip;
1575                   Number_Fraction_Or_Pound;
1576                   return;
1577
1578                when others =>
1579                   return;
1580             end case;
1581          end loop;
1582       end Leading_Pound;
1583
1584       ----------
1585       -- Look --
1586       ----------
1587
1588       function Look return Character is
1589       begin
1590          if At_End then
1591             raise Picture_Error;
1592          end if;
1593
1594          return Pic.Picture.Expanded (Index);
1595       end Look;
1596
1597       ------------
1598       -- Number --
1599       ------------
1600
1601       procedure Number is
1602       begin
1603          Debug_Start ("Number");
1604
1605          loop
1606
1607             case Look is
1608                when '_' | '0' | '/' =>
1609                   Skip;
1610
1611                when 'B' | 'b'  =>
1612                   Pic.Picture.Expanded (Index) := 'b';
1613                   Skip;
1614
1615                when '9' =>
1616                   Computed_BWZ := False;
1617                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1618                   Set_State (Okay);
1619                   Skip;
1620
1621                when '.' | 'V' | 'v' =>
1622                   Pic.Radix_Position := Index;
1623                   Skip;
1624                   Number_Fraction;
1625                   return;
1626
1627                when others =>
1628                   return;
1629
1630             end case;
1631
1632             if At_End then
1633                return;
1634             end if;
1635
1636             --  Will return in Okay state if a '9' was seen
1637
1638          end loop;
1639       end Number;
1640
1641       -----------------------
1642       -- Number_Completion --
1643       -----------------------
1644
1645       procedure Number_Completion is
1646       begin
1647          Debug_Start ("Number_Completion");
1648
1649          while not At_End loop
1650             case Look is
1651
1652                when '_' | '0' | '/' =>
1653                   Skip;
1654
1655                when 'B' | 'b'  =>
1656                   Pic.Picture.Expanded (Index) := 'b';
1657                   Skip;
1658
1659                when '9' =>
1660                   Computed_BWZ := False;
1661                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1662                   Set_State (Okay);
1663                   Skip;
1664
1665                when 'V' | 'v' | '.' =>
1666                   Pic.Radix_Position := Index;
1667                   Skip;
1668                   Number_Fraction;
1669                   return;
1670
1671                when others =>
1672                   return;
1673             end case;
1674          end loop;
1675       end Number_Completion;
1676
1677       ---------------------
1678       -- Number_Fraction --
1679       ---------------------
1680
1681       procedure Number_Fraction is
1682       begin
1683          --  Note that number fraction can be called in either State.
1684          --  It will set state to Valid only if a 9 is encountered.
1685
1686          Debug_Start ("Number_Fraction");
1687
1688          loop
1689             if At_End then
1690                return;
1691             end if;
1692
1693             case Look is
1694                when '_' | '0' | '/' =>
1695                   Skip;
1696
1697                when 'B' | 'b'  =>
1698                   Pic.Picture.Expanded (Index) := 'b';
1699                   Skip;
1700
1701                when '9' =>
1702                   Computed_BWZ := False;
1703                   Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1704                   Set_State (Okay); Skip;
1705
1706                when others =>
1707                   return;
1708             end case;
1709          end loop;
1710       end Number_Fraction;
1711
1712       --------------------------------
1713       -- Number_Fraction_Or_Bracket --
1714       --------------------------------
1715
1716       procedure Number_Fraction_Or_Bracket is
1717       begin
1718          Debug_Start ("Number_Fraction_Or_Bracket");
1719
1720          loop
1721             if At_End then
1722                return;
1723             end if;
1724
1725             case Look is
1726
1727                when '_' | '0' | '/' => Skip;
1728
1729                when 'B' | 'b'  =>
1730                   Pic.Picture.Expanded (Index) := 'b';
1731                   Skip;
1732
1733                when '<' =>
1734                   Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1735                   Pic.End_Float := Index;
1736                   Skip;
1737
1738                   loop
1739                      if At_End then
1740                         return;
1741                      end if;
1742
1743                      case Look is
1744                         when '_' | '0' | '/' =>
1745                            Skip;
1746
1747                         when 'B' | 'b'  =>
1748                            Pic.Picture.Expanded (Index) := 'b';
1749                            Skip;
1750
1751                         when '<' =>
1752                            Pic.Max_Trailing_Digits :=
1753                              Pic.Max_Trailing_Digits + 1;
1754                            Pic.End_Float := Index;
1755                            Skip;
1756
1757                         when others =>
1758                            return;
1759                      end case;
1760                   end loop;
1761
1762                when others =>
1763                   Number_Fraction;
1764                   return;
1765             end case;
1766          end loop;
1767       end Number_Fraction_Or_Bracket;
1768
1769       -------------------------------
1770       -- Number_Fraction_Or_Dollar --
1771       -------------------------------
1772
1773       procedure Number_Fraction_Or_Dollar is
1774       begin
1775          Debug_Start ("Number_Fraction_Or_Dollar");
1776
1777          loop
1778             if At_End then
1779                return;
1780             end if;
1781
1782             case Look is
1783                when '_' | '0' | '/' =>
1784                   Skip;
1785
1786                when 'B' | 'b'  =>
1787                   Pic.Picture.Expanded (Index) := 'b';
1788                   Skip;
1789
1790                when '$' =>
1791                   Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1792                   Pic.End_Float := Index;
1793                   Skip;
1794
1795                   loop
1796                      if At_End then
1797                         return;
1798                      end if;
1799
1800                      case Look is
1801                         when '_' | '0' | '/' =>
1802                            Skip;
1803
1804                         when 'B' | 'b'  =>
1805                            Pic.Picture.Expanded (Index) := 'b';
1806                            Skip;
1807
1808                         when '$' =>
1809                            Pic.Max_Trailing_Digits :=
1810                              Pic.Max_Trailing_Digits + 1;
1811                            Pic.End_Float := Index;
1812                            Skip;
1813
1814                         when others =>
1815                            return;
1816                      end case;
1817                   end loop;
1818
1819                when others =>
1820                   Number_Fraction;
1821                   return;
1822             end case;
1823          end loop;
1824       end Number_Fraction_Or_Dollar;
1825
1826       ------------------------------
1827       -- Number_Fraction_Or_Pound --
1828       ------------------------------
1829
1830       procedure Number_Fraction_Or_Pound is
1831       begin
1832          loop
1833             if At_End then
1834                return;
1835             end if;
1836
1837             case Look is
1838
1839                when '_' | '0' | '/' =>
1840                   Skip;
1841
1842                when 'B' | 'b'  =>
1843                   Pic.Picture.Expanded (Index) := 'b';
1844                   Skip;
1845
1846                when '#' =>
1847                   Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1848                   Pic.End_Float := Index;
1849                   Skip;
1850
1851                   loop
1852                      if At_End then
1853                         return;
1854                      end if;
1855
1856                      case Look is
1857
1858                         when '_' | '0' | '/' =>
1859                            Skip;
1860
1861                         when 'B' | 'b'  =>
1862                            Pic.Picture.Expanded (Index) := 'b';
1863                            Skip;
1864
1865                         when '#' =>
1866                            Pic.Max_Trailing_Digits :=
1867                              Pic.Max_Trailing_Digits + 1;
1868                            Pic.End_Float := Index;
1869                            Skip;
1870
1871                         when others =>
1872                            return;
1873
1874                      end case;
1875                   end loop;
1876
1877                when others =>
1878                   Number_Fraction;
1879                   return;
1880
1881             end case;
1882          end loop;
1883       end Number_Fraction_Or_Pound;
1884
1885       ----------------------------------
1886       -- Number_Fraction_Or_Star_Fill --
1887       ----------------------------------
1888
1889       procedure Number_Fraction_Or_Star_Fill is
1890       begin
1891          Debug_Start ("Number_Fraction_Or_Star_Fill");
1892
1893          loop
1894             if At_End then
1895                return;
1896             end if;
1897
1898             case Look is
1899
1900                when '_' | '0' | '/' =>
1901                   Skip;
1902
1903                when 'B' | 'b'  =>
1904                   Pic.Picture.Expanded (Index) := 'b';
1905                   Skip;
1906
1907                when '*' =>
1908                   Pic.Star_Fill := True;
1909                   Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1910                   Pic.End_Float := Index;
1911                   Skip;
1912
1913                   loop
1914                      if At_End then
1915                         return;
1916                      end if;
1917
1918                      case Look is
1919
1920                         when '_' | '0' | '/' =>
1921                            Skip;
1922
1923                         when 'B' | 'b'  =>
1924                            Pic.Picture.Expanded (Index) := 'b';
1925                            Skip;
1926
1927                         when '*' =>
1928                            Pic.Star_Fill := True;
1929                            Pic.Max_Trailing_Digits :=
1930                              Pic.Max_Trailing_Digits + 1;
1931                            Pic.End_Float := Index;
1932                            Skip;
1933
1934                         when others =>
1935                            return;
1936                      end case;
1937                   end loop;
1938
1939                when others =>
1940                   Number_Fraction;
1941                   return;
1942
1943             end case;
1944          end loop;
1945       end Number_Fraction_Or_Star_Fill;
1946
1947       -------------------------------
1948       -- Number_Fraction_Or_Z_Fill --
1949       -------------------------------
1950
1951       procedure Number_Fraction_Or_Z_Fill is
1952       begin
1953          Debug_Start ("Number_Fraction_Or_Z_Fill");
1954
1955          loop
1956             if At_End then
1957                return;
1958             end if;
1959
1960             case Look is
1961
1962                when '_' | '0' | '/' =>
1963                   Skip;
1964
1965                when 'B' | 'b'  =>
1966                   Pic.Picture.Expanded (Index) := 'b';
1967                   Skip;
1968
1969                when 'Z' | 'z' =>
1970                   Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1971                   Pic.End_Float := Index;
1972                   Pic.Picture.Expanded (Index) := 'Z'; -- consistency
1973
1974                   Skip;
1975
1976                   loop
1977                      if At_End then
1978                         return;
1979                      end if;
1980
1981                      case Look is
1982
1983                         when '_' | '0' | '/' =>
1984                            Skip;
1985
1986                         when 'B' | 'b'  =>
1987                            Pic.Picture.Expanded (Index) := 'b';
1988                            Skip;
1989
1990                         when 'Z' | 'z' =>
1991                            Pic.Picture.Expanded (Index) := 'Z'; -- consistency
1992
1993                            Pic.Max_Trailing_Digits :=
1994                              Pic.Max_Trailing_Digits + 1;
1995                            Pic.End_Float := Index;
1996                            Skip;
1997
1998                         when others =>
1999                            return;
2000                      end case;
2001                   end loop;
2002
2003                when others =>
2004                   Number_Fraction;
2005                   return;
2006             end case;
2007          end loop;
2008       end Number_Fraction_Or_Z_Fill;
2009
2010       -----------------------
2011       -- Optional_RHS_Sign --
2012       -----------------------
2013
2014       procedure Optional_RHS_Sign is
2015       begin
2016          Debug_Start ("Optional_RHS_Sign");
2017
2018          if At_End then
2019             return;
2020          end if;
2021
2022          case Look is
2023
2024             when '+' | '-' =>
2025                Pic.Sign_Position := Index;
2026                Skip;
2027                return;
2028
2029             when 'C' | 'c' =>
2030                Pic.Sign_Position := Index;
2031                Pic.Picture.Expanded (Index) := 'C';
2032                Skip;
2033
2034                if Look = 'R' or Look = 'r' then
2035                   Pic.Second_Sign := Index;
2036                   Pic.Picture.Expanded (Index) := 'R';
2037                   Skip;
2038
2039                else
2040                   raise Picture_Error;
2041                end if;
2042
2043                return;
2044
2045             when 'D' | 'd' =>
2046                Pic.Sign_Position := Index;
2047                Pic.Picture.Expanded (Index) := 'D';
2048                Skip;
2049
2050                if Look = 'B' or Look = 'b' then
2051                   Pic.Second_Sign := Index;
2052                   Pic.Picture.Expanded (Index) := 'B';
2053                   Skip;
2054
2055                else
2056                   raise Picture_Error;
2057                end if;
2058
2059                return;
2060
2061             when '>' =>
2062                if Pic.Picture.Expanded (Pic.Sign_Position) = '<' then
2063                   Pic.Second_Sign := Index;
2064                   Skip;
2065
2066                else
2067                   raise Picture_Error;
2068                end if;
2069
2070             when others =>
2071                return;
2072
2073          end case;
2074       end Optional_RHS_Sign;
2075
2076       -------------
2077       -- Picture --
2078       -------------
2079
2080       --  Note that Picture can be called in either State
2081
2082       --  It will set state to Valid only if a 9 is encountered or floating
2083       --  currency is called.
2084
2085       procedure Picture is
2086       begin
2087          Debug_Start ("Picture");
2088
2089          loop
2090             if At_End then
2091                return;
2092             end if;
2093
2094             case Look is
2095
2096                when '_' | '0' | '/' =>
2097                   Skip;
2098
2099                when 'B' | 'b'  =>
2100                   Pic.Picture.Expanded (Index) := 'b';
2101                   Skip;
2102
2103                when '$' =>
2104                   Leading_Dollar;
2105                   return;
2106
2107                when '#' =>
2108                   Leading_Pound;
2109                   return;
2110
2111                when '9' =>
2112                   Computed_BWZ := False;
2113                   Set_State (Okay);
2114                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2115                   Skip;
2116
2117                when 'V' | 'v' | '.' =>
2118                   Pic.Radix_Position := Index;
2119                   Skip;
2120                   Number_Fraction;
2121                   Trailing_Currency;
2122                   return;
2123
2124                when others =>
2125                   return;
2126
2127             end case;
2128          end loop;
2129       end Picture;
2130
2131       ---------------------
2132       -- Picture_Bracket --
2133       ---------------------
2134
2135       procedure Picture_Bracket is
2136       begin
2137          Pic.Sign_Position := Index;
2138          Debug_Start ("Picture_Bracket");
2139          Pic.Sign_Position := Index;
2140
2141          --  Treat as a floating sign, and unwind otherwise
2142
2143          Pic.Floater := '<';
2144          Pic.Start_Float := Index;
2145          Pic.End_Float := Index;
2146
2147          --  Don't increment Pic.Max_Leading_Digits, we need one "real"
2148          --  sign place.
2149
2150          Skip; --  Known Bracket
2151
2152          loop
2153             case Look is
2154
2155                when '_' | '0' | '/' =>
2156                   Pic.End_Float := Index;
2157                   Skip;
2158
2159                when 'B' | 'b'  =>
2160                   Pic.End_Float := Index;
2161                   Pic.Picture.Expanded (Index) := 'b';
2162                   Skip;
2163
2164                when '<' =>
2165                   Set_State (Okay);  --  "<<>" is enough.
2166                   Floating_Bracket;
2167                   Trailing_Currency;
2168                   Trailing_Bracket;
2169                   return;
2170
2171                when '$' | '#' | '9' | '*' =>
2172                   if State /= Okay then
2173                      Pic.Floater := '!';
2174                      Pic.Start_Float := Invalid_Position;
2175                      Pic.End_Float := Invalid_Position;
2176                   end if;
2177
2178                   Picture;
2179                   Trailing_Bracket;
2180                   Set_State (Okay);
2181                   return;
2182
2183                when '.' | 'V' | 'v' =>
2184                   if State /= Okay then
2185                      Pic.Floater := '!';
2186                      Pic.Start_Float := Invalid_Position;
2187                      Pic.End_Float := Invalid_Position;
2188                   end if;
2189
2190                   --  Don't assume that state is okay, haven't seen a digit
2191
2192                   Picture;
2193                   Trailing_Bracket;
2194                   return;
2195
2196                when others =>
2197                   raise Picture_Error;
2198
2199             end case;
2200          end loop;
2201       end Picture_Bracket;
2202
2203       -------------------
2204       -- Picture_Minus --
2205       -------------------
2206
2207       procedure Picture_Minus is
2208       begin
2209          Debug_Start ("Picture_Minus");
2210
2211          Pic.Sign_Position := Index;
2212
2213          --  Treat as a floating sign, and unwind otherwise
2214
2215          Pic.Floater := '-';
2216          Pic.Start_Float := Index;
2217          Pic.End_Float := Index;
2218
2219          --  Don't increment Pic.Max_Leading_Digits, we need one "real"
2220          --  sign place.
2221
2222          Skip; --  Known Minus
2223
2224          loop
2225             case Look is
2226
2227                when '_' | '0' | '/' =>
2228                   Pic.End_Float := Index;
2229                   Skip;
2230
2231                when 'B' | 'b'  =>
2232                   Pic.End_Float := Index;
2233                   Pic.Picture.Expanded (Index) := 'b';
2234                   Skip;
2235
2236                when '-' =>
2237                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2238                   Pic.End_Float := Index;
2239                   Skip;
2240                   Set_State (Okay);  --  "-- " is enough.
2241                   Floating_Minus;
2242                   Trailing_Currency;
2243                   return;
2244
2245                when '$' | '#' | '9' | '*' =>
2246                   if State /= Okay then
2247                      Pic.Floater := '!';
2248                      Pic.Start_Float := Invalid_Position;
2249                      Pic.End_Float := Invalid_Position;
2250                   end if;
2251
2252                   Picture;
2253                   Set_State (Okay);
2254                   return;
2255
2256                when 'Z' | 'z' =>
2257
2258                   --  Can't have Z and a floating sign
2259
2260                   if State = Okay then
2261                      Set_State (Reject);
2262                   end if;
2263
2264                   Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2265                   Zero_Suppression;
2266                   Trailing_Currency;
2267                   Optional_RHS_Sign;
2268                   return;
2269
2270                when '.' | 'V' | 'v' =>
2271                   if State /= Okay then
2272                      Pic.Floater := '!';
2273                      Pic.Start_Float := Invalid_Position;
2274                      Pic.End_Float := Invalid_Position;
2275                   end if;
2276
2277                   --  Don't assume that state is okay, haven't seen a digit
2278
2279                   Picture;
2280                   return;
2281
2282                when others =>
2283                   return;
2284
2285             end case;
2286          end loop;
2287       end Picture_Minus;
2288
2289       ------------------
2290       -- Picture_Plus --
2291       ------------------
2292
2293       procedure Picture_Plus is
2294       begin
2295          Debug_Start ("Picture_Plus");
2296          Pic.Sign_Position := Index;
2297
2298          --  Treat as a floating sign, and unwind otherwise
2299
2300          Pic.Floater := '+';
2301          Pic.Start_Float := Index;
2302          Pic.End_Float := Index;
2303
2304          --  Don't increment Pic.Max_Leading_Digits, we need one "real"
2305          --  sign place.
2306
2307          Skip; --  Known Plus
2308
2309          loop
2310             case Look is
2311
2312                when '_' | '0' | '/' =>
2313                   Pic.End_Float := Index;
2314                   Skip;
2315
2316                when 'B' | 'b'  =>
2317                   Pic.End_Float := Index;
2318                   Pic.Picture.Expanded (Index) := 'b';
2319                   Skip;
2320
2321                when '+' =>
2322                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2323                   Pic.End_Float := Index;
2324                   Skip;
2325                   Set_State (Okay);  --  "++" is enough
2326                   Floating_Plus;
2327                   Trailing_Currency;
2328                   return;
2329
2330                when '$' | '#' | '9' | '*' =>
2331                   if State /= Okay then
2332                      Pic.Floater := '!';
2333                      Pic.Start_Float := Invalid_Position;
2334                      Pic.End_Float := Invalid_Position;
2335                   end if;
2336
2337                   Picture;
2338                   Set_State (Okay);
2339                   return;
2340
2341                when 'Z' | 'z' =>
2342                   if State = Okay then
2343                      Set_State (Reject);
2344                   end if;
2345
2346                   --  Can't have Z and a floating sign
2347
2348                   Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2349
2350                   --  '+Z' is acceptable
2351
2352                   Set_State (Okay);
2353
2354                   --  Overwrite Floater and Start_Float
2355
2356                   Pic.Floater := 'Z';
2357                   Pic.Start_Float := Index;
2358
2359                   Zero_Suppression;
2360                   Trailing_Currency;
2361                   Optional_RHS_Sign;
2362                   return;
2363
2364                when '.' | 'V' | 'v' =>
2365                   if State /= Okay then
2366                      Pic.Floater := '!';
2367                      Pic.Start_Float := Invalid_Position;
2368                      Pic.End_Float := Invalid_Position;
2369                   end if;
2370
2371                   --  Don't assume that state is okay, haven't seen a digit
2372
2373                   Picture;
2374                   return;
2375
2376                when others =>
2377                   return;
2378
2379             end case;
2380          end loop;
2381       end Picture_Plus;
2382
2383       --------------------
2384       -- Picture_String --
2385       --------------------
2386
2387       procedure Picture_String is
2388       begin
2389          Debug_Start ("Picture_String");
2390
2391          while Is_Insert loop
2392             Skip;
2393          end loop;
2394
2395          case Look is
2396
2397             when '$' | '#' =>
2398                Picture;
2399                Optional_RHS_Sign;
2400
2401             when '+' =>
2402                Picture_Plus;
2403
2404             when '-' =>
2405                Picture_Minus;
2406
2407             when '<' =>
2408                Picture_Bracket;
2409
2410             when 'Z' | 'z' =>
2411                Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2412                Zero_Suppression;
2413                Trailing_Currency;
2414                Optional_RHS_Sign;
2415
2416             when '*' =>
2417                Star_Suppression;
2418                Trailing_Currency;
2419                Optional_RHS_Sign;
2420
2421             when '9' | '.' | 'V' | 'v' =>
2422                Number;
2423                Trailing_Currency;
2424                Optional_RHS_Sign;
2425
2426             when others =>
2427                raise Picture_Error;
2428
2429          end case;
2430
2431          --  Blank when zero either if the PIC does not contain a '9' or if
2432          --  requested by the user and no '*'.
2433
2434          Pic.Blank_When_Zero :=
2435            (Computed_BWZ or Pic.Blank_When_Zero) and not Pic.Star_Fill;
2436
2437          --  Star fill if '*' and no '9'
2438
2439          Pic.Star_Fill := Pic.Star_Fill and Computed_BWZ;
2440
2441          if not At_End then
2442             Set_State (Reject);
2443          end if;
2444
2445       end Picture_String;
2446
2447       ---------------
2448       -- Set_State --
2449       ---------------
2450
2451       procedure Set_State (L : Legality) is
2452       begin
2453          if Debug then
2454             Ada.Text_IO.Put_Line
2455               ("  Set state from " & Legality'Image (State)
2456                & " to " & Legality'Image (L));
2457          end if;
2458
2459          State := L;
2460       end Set_State;
2461
2462       ----------
2463       -- Skip --
2464       ----------
2465
2466       procedure Skip is
2467       begin
2468          if Debug then
2469             Ada.Text_IO.Put_Line ("  Skip " & Pic.Picture.Expanded (Index));
2470          end if;
2471
2472          Index := Index + 1;
2473       end Skip;
2474
2475       ----------------------
2476       -- Star_Suppression --
2477       ----------------------
2478
2479       procedure Star_Suppression is
2480       begin
2481          Debug_Start ("Star_Suppression");
2482
2483          if Pic.Floater /= '!' and then Pic.Floater /= '*' then
2484
2485             --  Two floats not allowed
2486
2487             raise Picture_Error;
2488
2489          else
2490             Pic.Floater := '*';
2491          end if;
2492
2493          Pic.Start_Float := Index;
2494          Pic.End_Float := Index;
2495          Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2496          Set_State (Okay);
2497
2498          --  Even a single * is a valid picture
2499
2500          Pic.Star_Fill := True;
2501          Skip; --  Known *
2502
2503          loop
2504             if At_End then
2505                return;
2506             end if;
2507
2508             case Look is
2509
2510                when '_' | '0' | '/' =>
2511                   Pic.End_Float := Index;
2512                   Skip;
2513
2514                when 'B' | 'b'  =>
2515                   Pic.End_Float := Index;
2516                   Pic.Picture.Expanded (Index) := 'b';
2517                   Skip;
2518
2519                when '*' =>
2520                   Pic.End_Float := Index;
2521                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2522                   Set_State (Okay); Skip;
2523
2524                when '9' =>
2525                   Set_State (Okay);
2526                   Number_Completion;
2527                   return;
2528
2529                when '.' | 'V' | 'v' =>
2530                   Pic.Radix_Position := Index;
2531                   Skip;
2532                   Number_Fraction_Or_Star_Fill;
2533                   return;
2534
2535                when '#' | '$' =>
2536                   if Pic.Max_Currency_Digits > 0 then
2537                      raise Picture_Error;
2538                   end if;
2539
2540                   --  Cannot have leading and trailing currency
2541
2542                   Trailing_Currency;
2543                   Set_State (Okay);
2544                   return;
2545
2546                when others => raise Picture_Error;
2547             end case;
2548          end loop;
2549       end Star_Suppression;
2550
2551       ----------------------
2552       -- Trailing_Bracket --
2553       ----------------------
2554
2555       procedure Trailing_Bracket is
2556       begin
2557          Debug_Start ("Trailing_Bracket");
2558
2559          if Look = '>' then
2560             Pic.Second_Sign := Index;
2561             Skip;
2562          else
2563             raise Picture_Error;
2564          end if;
2565       end Trailing_Bracket;
2566
2567       -----------------------
2568       -- Trailing_Currency --
2569       -----------------------
2570
2571       procedure Trailing_Currency is
2572       begin
2573          Debug_Start ("Trailing_Currency");
2574
2575          if At_End then
2576             return;
2577          end if;
2578
2579          if Look = '$' then
2580             Pic.Start_Currency := Index;
2581             Pic.End_Currency := Index;
2582             Skip;
2583
2584          else
2585             while not At_End and then Look = '#' loop
2586                if Pic.Start_Currency = Invalid_Position then
2587                   Pic.Start_Currency := Index;
2588                end if;
2589
2590                Pic.End_Currency := Index;
2591                Skip;
2592             end loop;
2593          end if;
2594
2595          loop
2596             if At_End then
2597                return;
2598             end if;
2599
2600             case Look is
2601                when '_' | '0' | '/' => Skip;
2602
2603                when 'B' | 'b'  =>
2604                   Pic.Picture.Expanded (Index) := 'b';
2605                   Skip;
2606
2607                when others => return;
2608             end case;
2609          end loop;
2610       end Trailing_Currency;
2611
2612       ----------------------
2613       -- Zero_Suppression --
2614       ----------------------
2615
2616       procedure Zero_Suppression is
2617       begin
2618          Debug_Start ("Zero_Suppression");
2619
2620          Pic.Floater := 'Z';
2621          Pic.Start_Float := Index;
2622          Pic.End_Float := Index;
2623          Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2624          Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2625
2626          Skip; --  Known Z
2627
2628          loop
2629             --  Even a single Z is a valid picture
2630
2631             if At_End then
2632                Set_State (Okay);
2633                return;
2634             end if;
2635
2636             case Look is
2637                when '_' | '0' | '/' =>
2638                   Pic.End_Float := Index;
2639                   Skip;
2640
2641                when 'B' | 'b'  =>
2642                   Pic.End_Float := Index;
2643                   Pic.Picture.Expanded (Index) := 'b';
2644                   Skip;
2645
2646                when 'Z' | 'z' =>
2647                   Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2648
2649                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2650                   Pic.End_Float := Index;
2651                   Set_State (Okay);
2652                   Skip;
2653
2654                when '9' =>
2655                   Set_State (Okay);
2656                   Number_Completion;
2657                   return;
2658
2659                when '.' | 'V' | 'v' =>
2660                   Pic.Radix_Position := Index;
2661                   Skip;
2662                   Number_Fraction_Or_Z_Fill;
2663                   return;
2664
2665                when '#' | '$' =>
2666                   Trailing_Currency;
2667                   Set_State (Okay);
2668                   return;
2669
2670                when others =>
2671                   return;
2672             end case;
2673          end loop;
2674       end Zero_Suppression;
2675
2676    --  Start of processing for Precalculate
2677
2678    begin
2679       pragma Debug (Set_Debug);
2680
2681       Picture_String;
2682
2683       if Debug then
2684          Ada.Text_IO.New_Line;
2685          Ada.Text_IO.Put (" Picture : """ &
2686                      Pic.Picture.Expanded (1 .. Pic.Picture.Length) & """,");
2687          Ada.Text_IO.Put (" Floater : '" & Pic.Floater & "',");
2688       end if;
2689
2690       if State = Reject then
2691          raise Picture_Error;
2692       end if;
2693
2694       Debug_Integer (Pic.Radix_Position, "Radix Positon : ");
2695       Debug_Integer (Pic.Sign_Position, "Sign Positon : ");
2696       Debug_Integer (Pic.Second_Sign, "Second Sign : ");
2697       Debug_Integer (Pic.Start_Float, "Start Float : ");
2698       Debug_Integer (Pic.End_Float, "End Float : ");
2699       Debug_Integer (Pic.Start_Currency, "Start Currency : ");
2700       Debug_Integer (Pic.End_Currency, "End Currency : ");
2701       Debug_Integer (Pic.Max_Leading_Digits, "Max Leading Digits : ");
2702       Debug_Integer (Pic.Max_Trailing_Digits, "Max Trailing Digits : ");
2703
2704       if Debug then
2705          Ada.Text_IO.New_Line;
2706       end if;
2707
2708    exception
2709
2710       when Constraint_Error =>
2711
2712       --  To deal with special cases like null strings
2713
2714       raise Picture_Error;
2715    end Precalculate;
2716
2717    ----------------
2718    -- To_Picture --
2719    ----------------
2720
2721    function To_Picture
2722      (Pic_String      : String;
2723       Blank_When_Zero : Boolean := False) return Picture
2724    is
2725       Result : Picture;
2726
2727    begin
2728       declare
2729          Item : constant String := Expand (Pic_String);
2730
2731       begin
2732          Result.Contents.Picture         := (Item'Length, Item);
2733          Result.Contents.Original_BWZ := Blank_When_Zero;
2734          Result.Contents.Blank_When_Zero := Blank_When_Zero;
2735          Precalculate (Result.Contents);
2736          return Result;
2737       end;
2738
2739    exception
2740       when others =>
2741          raise Picture_Error;
2742    end To_Picture;
2743
2744    -----------
2745    -- Valid --
2746    -----------
2747
2748    function Valid
2749      (Pic_String      : String;
2750       Blank_When_Zero : Boolean := False) return Boolean
2751    is
2752    begin
2753       declare
2754          Expanded_Pic : constant String := Expand (Pic_String);
2755          --  Raises Picture_Error if Item not well-formed
2756
2757          Format_Rec : Format_Record;
2758
2759       begin
2760          Format_Rec.Picture := (Expanded_Pic'Length, Expanded_Pic);
2761          Format_Rec.Blank_When_Zero := Blank_When_Zero;
2762          Format_Rec.Original_BWZ := Blank_When_Zero;
2763          Precalculate (Format_Rec);
2764
2765          --  False only if Blank_When_Zero is True but the pic string has a '*'
2766
2767          return not Blank_When_Zero
2768            or else Strings_Fixed.Index (Expanded_Pic, "*") = 0;
2769       end;
2770
2771    exception
2772       when others => return False;
2773    end Valid;
2774
2775    --------------------
2776    -- Decimal_Output --
2777    --------------------
2778
2779    package body Decimal_Output is
2780
2781       -----------
2782       -- Image --
2783       -----------
2784
2785       function Image
2786         (Item       : Num;
2787          Pic        : Picture;
2788          Currency   : String    := Default_Currency;
2789          Fill       : Character := Default_Fill;
2790          Separator  : Character := Default_Separator;
2791          Radix_Mark : Character := Default_Radix_Mark) return String
2792       is
2793       begin
2794          return Format_Number
2795             (Pic.Contents, Num'Image (Item),
2796              Currency, Fill, Separator, Radix_Mark);
2797       end Image;
2798
2799       ------------
2800       -- Length --
2801       ------------
2802
2803       function Length
2804         (Pic      : Picture;
2805          Currency : String := Default_Currency) return Natural
2806       is
2807          Picstr     : constant String := Pic_String (Pic);
2808          V_Adjust   : Integer := 0;
2809          Cur_Adjust : Integer := 0;
2810
2811       begin
2812          --  Check if Picstr has 'V' or '$'
2813
2814          --  If 'V', then length is 1 less than otherwise
2815
2816          --  If '$', then length is Currency'Length-1 more than otherwise
2817
2818          --  This should use the string handling package ???
2819
2820          for J in Picstr'Range loop
2821             if Picstr (J) = 'V' then
2822                V_Adjust := -1;
2823
2824             elsif Picstr (J) = '$' then
2825                Cur_Adjust := Currency'Length - 1;
2826             end if;
2827          end loop;
2828
2829          return Picstr'Length - V_Adjust + Cur_Adjust;
2830       end Length;
2831
2832       ---------
2833       -- Put --
2834       ---------
2835
2836       procedure Put
2837         (File       : Text_IO.File_Type;
2838          Item       : Num;
2839          Pic        : Picture;
2840          Currency   : String    := Default_Currency;
2841          Fill       : Character := Default_Fill;
2842          Separator  : Character := Default_Separator;
2843          Radix_Mark : Character := Default_Radix_Mark)
2844       is
2845       begin
2846          Text_IO.Put (File, Image (Item, Pic,
2847                                    Currency, Fill, Separator, Radix_Mark));
2848       end Put;
2849
2850       procedure Put
2851         (Item       : Num;
2852          Pic        : Picture;
2853          Currency   : String    := Default_Currency;
2854          Fill       : Character := Default_Fill;
2855          Separator  : Character := Default_Separator;
2856          Radix_Mark : Character := Default_Radix_Mark)
2857       is
2858       begin
2859          Text_IO.Put (Image (Item, Pic,
2860                              Currency, Fill, Separator, Radix_Mark));
2861       end Put;
2862
2863       procedure Put
2864         (To         : out String;
2865          Item       : Num;
2866          Pic        : Picture;
2867          Currency   : String    := Default_Currency;
2868          Fill       : Character := Default_Fill;
2869          Separator  : Character := Default_Separator;
2870          Radix_Mark : Character := Default_Radix_Mark)
2871       is
2872          Result : constant String :=
2873            Image (Item, Pic, Currency, Fill, Separator, Radix_Mark);
2874
2875       begin
2876          if Result'Length > To'Length then
2877             raise Ada.Text_IO.Layout_Error;
2878          else
2879             Strings_Fixed.Move (Source => Result, Target => To,
2880                                 Justify => Strings.Right);
2881          end if;
2882       end Put;
2883
2884       -----------
2885       -- Valid --
2886       -----------
2887
2888       function Valid
2889         (Item     : Num;
2890          Pic      : Picture;
2891          Currency : String := Default_Currency) return Boolean
2892       is
2893       begin
2894          declare
2895             Temp : constant String := Image (Item, Pic, Currency);
2896             pragma Warnings (Off, Temp);
2897          begin
2898             return True;
2899          end;
2900
2901       exception
2902          when Ada.Text_IO.Layout_Error => return False;
2903
2904       end Valid;
2905    end Decimal_Output;
2906
2907 end Ada.Text_IO.Editing;