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-2013, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Ada.Strings.Fixed;
  33 package body Ada.Text_IO.Editing is
  34
  35    package Strings renames Ada.Strings;
  36    package Strings_Fixed renames Ada.Strings.Fixed;
  37    package Text_IO renames Ada.Text_IO;
  38
  39    ---------------------
  40    -- Blank_When_Zero --
  41    ---------------------
  42
  43    function Blank_When_Zero (Pic : Picture) return Boolean is
  44    begin
  45       return Pic.Contents.Original_BWZ;
  46    end Blank_When_Zero;
  47
  48    ------------
  49    -- Expand --
  50    ------------
  51
  52    function Expand (Picture : String) return String is
  53       Result        : String (1 .. MAX_PICSIZE);
  54       Picture_Index : Integer := Picture'First;
  55       Result_Index  : Integer := Result'First;
  56       Count         : Natural;
  57       Last          : Integer;
  58
  59       package Int_IO is new Ada.Text_IO.Integer_IO (Integer);
  60
  61    begin
  62       if Picture'Length < 1 then
  63          raise Picture_Error;
  64       end if;
  65
  66       if Picture (Picture'First) = '(' then
  67          raise Picture_Error;
  68       end if;
  69
  70       loop
  71          case Picture (Picture_Index) is
  72
  73             when '(' =>
  74                Int_IO.Get
  75                  (Picture (Picture_Index + 1 .. Picture'Last), Count, Last);
  76
  77                if Picture (Last + 1) /= ')' then
  78                   raise Picture_Error;
  79                end if;
  80
  81                --  In what follows note that one copy of the repeated character
  82                --  has already been made, so a count of one is a no-op, and a
  83                --  count of zero erases a character.
  84
  85                if Result_Index + Count - 2 > Result'Last then
  86                   raise Picture_Error;
  87                end if;
  88
  89                for J in 2 .. Count loop
  90                   Result (Result_Index + J - 2) := Picture (Picture_Index - 1);
  91                end loop;
  92
  93                Result_Index := Result_Index + Count - 1;
  94
  95                --  Last + 1 was a ')' throw it away too
  96
  97                Picture_Index := Last + 2;
  98
  99             when ')' =>
 100                raise Picture_Error;
 101
 102             when others =>
 103                if Result_Index > Result'Last then
 104                   raise Picture_Error;
 105                end if;
 106
 107                Result (Result_Index) := Picture (Picture_Index);
 108                Picture_Index := Picture_Index + 1;
 109                Result_Index := Result_Index + 1;
 110
 111          end case;
 112
 113          exit when Picture_Index > Picture'Last;
 114       end loop;
 115
 116       return Result (1 .. Result_Index - 1);
 117
 118    exception
 119       when others =>
 120          raise Picture_Error;
 121    end Expand;
 122
 123    -------------------
 124    -- Format_Number --
 125    -------------------
 126
 127    function Format_Number
 128      (Pic                 : Format_Record;
 129       Number              : String;
 130       Currency_Symbol     : String;
 131       Fill_Character      : Character;
 132       Separator_Character : Character;
 133       Radix_Point         : Character) return String
 134    is
 135       Attrs    : Number_Attributes := Parse_Number_String (Number);
 136       Position : Integer;
 137       Rounded  : String := Number;
 138
 139       Sign_Position : Integer := Pic.Sign_Position; --  may float.
 140
 141       Answer : String (1 .. Pic.Picture.Length) := Pic.Picture.Expanded;
 142       Last          : Integer;
 143       Currency_Pos  : Integer := Pic.Start_Currency;
 144       In_Currency   : Boolean := False;
 145
 146       Dollar : Boolean := False;
 147       --  Overridden immediately if necessary
 148
 149       Zero : Boolean := True;
 150       --  Set to False when a non-zero digit is output
 151
 152    begin
 153
 154       --  If the picture has fewer decimal places than the number, the image
 155       --  must be rounded according to the usual rules.
 156
 157       if Attrs.Has_Fraction then
 158          declare
 159             R : constant Integer :=
 160               (Attrs.End_Of_Fraction - Attrs.Start_Of_Fraction + 1)
 161                 - Pic.Max_Trailing_Digits;
 162             R_Pos : Integer;
 163
 164          begin
 165             if R > 0 then
 166                R_Pos := Attrs.End_Of_Fraction - R;
 167
 168                if Rounded (R_Pos + 1) > '4' then
 169
 170                   if Rounded (R_Pos) = '.' then
 171                      R_Pos := R_Pos - 1;
 172                   end if;
 173
 174                   if Rounded (R_Pos) /= '9' then
 175                      Rounded (R_Pos) := Character'Succ (Rounded (R_Pos));
 176                   else
 177                      Rounded (R_Pos) := '0';
 178                      R_Pos := R_Pos - 1;
 179
 180                      while R_Pos > 1 loop
 181                         if Rounded (R_Pos) = '.' then
 182                            R_Pos := R_Pos - 1;
 183                         end if;
 184
 185                         if Rounded (R_Pos) /= '9' then
 186                            Rounded (R_Pos) := Character'Succ (Rounded (R_Pos));
 187                            exit;
 188                         else
 189                            Rounded (R_Pos) := '0';
 190                            R_Pos := R_Pos - 1;
 191                         end if;
 192                      end loop;
 193
 194                      --  The rounding may add a digit in front. Either the
 195                      --  leading blank or the sign (already captured) can
 196                      --  be overwritten.
 197
 198                      if R_Pos = 1 then
 199                         Rounded (R_Pos) := '1';
 200                         Attrs.Start_Of_Int := Attrs.Start_Of_Int - 1;
 201                      end if;
 202                   end if;
 203                end if;
 204             end if;
 205          end;
 206       end if;
 207
 208       if Pic.Start_Currency /= Invalid_Position then
 209          Dollar := Answer (Pic.Start_Currency) = '$';
 210       end if;
 211
 212       --  Fix up "direct inserts" outside the playing field. Set up as one
 213       --  loop to do the beginning, one (reverse) loop to do the end.
 214
 215       Last := 1;
 216       loop
 217          exit when Last = Pic.Start_Float;
 218          exit when Last = Pic.Radix_Position;
 219          exit when Answer (Last) = '9';
 220
 221          case Answer (Last) is
 222
 223             when '_' =>
 224                Answer (Last) := Separator_Character;
 225
 226             when 'b' =>
 227                Answer (Last) := ' ';
 228
 229             when others =>
 230                null;
 231
 232          end case;
 233
 234          exit when Last = Answer'Last;
 235
 236          Last := Last + 1;
 237       end loop;
 238
 239       --  Now for the end...
 240
 241       for J in reverse Last .. Answer'Last loop
 242          exit when J = Pic.Radix_Position;
 243
 244          --  Do this test First, Separator_Character can equal Pic.Floater
 245
 246          if Answer (J) = Pic.Floater then
 247             exit;
 248          end if;
 249
 250          case Answer (J) is
 251
 252             when '_' =>
 253                Answer (J) := Separator_Character;
 254
 255             when 'b' =>
 256                Answer (J) := ' ';
 257
 258             when '9' =>
 259                exit;
 260
 261             when others =>
 262                null;
 263
 264          end case;
 265       end loop;
 266
 267       --  Non-floating sign
 268
 269       if Pic.Start_Currency /= -1
 270         and then Answer (Pic.Start_Currency) = '#'
 271         and then Pic.Floater /= '#'
 272       then
 273          if Currency_Symbol'Length >
 274             Pic.End_Currency - Pic.Start_Currency + 1
 275          then
 276             raise Picture_Error;
 277
 278          elsif Currency_Symbol'Length =
 279             Pic.End_Currency - Pic.Start_Currency + 1
 280          then
 281             Answer (Pic.Start_Currency .. Pic.End_Currency) :=
 282               Currency_Symbol;
 283
 284          elsif Pic.Radix_Position = Invalid_Position
 285            or else Pic.Start_Currency < Pic.Radix_Position
 286          then
 287             Answer (Pic.Start_Currency .. Pic.End_Currency) :=
 288                                                         (others => ' ');
 289             Answer (Pic.End_Currency - Currency_Symbol'Length + 1 ..
 290                     Pic.End_Currency) := Currency_Symbol;
 291
 292          else
 293             Answer (Pic.Start_Currency .. Pic.End_Currency) :=
 294                                                         (others => ' ');
 295             Answer (Pic.Start_Currency ..
 296                     Pic.Start_Currency + Currency_Symbol'Length - 1) :=
 297                                                         Currency_Symbol;
 298          end if;
 299       end if;
 300
 301       --  Fill in leading digits
 302
 303       if Attrs.End_Of_Int - Attrs.Start_Of_Int + 1 >
 304                                                 Pic.Max_Leading_Digits
 305       then
 306          raise Ada.Text_IO.Layout_Error;
 307       end if;
 308
 309       Position :=
 310         (if Pic.Radix_Position = Invalid_Position
 311          then Answer'Last
 312          else Pic.Radix_Position - 1);
 313
 314       for J in reverse Attrs.Start_Of_Int .. Attrs.End_Of_Int loop
 315          while Answer (Position) /= '9'
 316                  and then
 317                Answer (Position) /= Pic.Floater
 318          loop
 319             if Answer (Position) = '_' then
 320                Answer (Position) := Separator_Character;
 321
 322             elsif Answer (Position) = 'b' then
 323                Answer (Position) := ' ';
 324             end if;
 325
 326             Position := Position - 1;
 327          end loop;
 328
 329          Answer (Position) := Rounded (J);
 330
 331          if Rounded (J) /= '0' then
 332             Zero := False;
 333          end if;
 334
 335          Position := Position - 1;
 336       end loop;
 337
 338       --  Do lead float
 339
 340       if Pic.Start_Float = Invalid_Position then
 341
 342          --  No leading floats, but need to change '9' to '0', '_' to
 343          --  Separator_Character and 'b' to ' '.
 344
 345          for J in Last .. Position loop
 346
 347             --  Last set when fixing the "uninteresting" leaders above.
 348             --  Don't duplicate the work.
 349
 350             if Answer (J) = '9' then
 351                Answer (J) := '0';
 352
 353             elsif Answer (J) = '_' then
 354                Answer (J) := Separator_Character;
 355
 356             elsif Answer (J) = 'b' then
 357                Answer (J) := ' ';
 358             end if;
 359          end loop;
 360
 361       elsif Pic.Floater = '<'
 362               or else
 363             Pic.Floater = '+'
 364               or else
 365             Pic.Floater = '-'
 366       then
 367          for J in Pic.End_Float .. Position loop --  May be null range.
 368             if Answer (J) = '9' then
 369                Answer (J) := '0';
 370
 371             elsif Answer (J) = '_' then
 372                Answer (J) := Separator_Character;
 373
 374             elsif Answer (J) = 'b' then
 375                Answer (J) := ' ';
 376             end if;
 377          end loop;
 378
 379          if Position > Pic.End_Float then
 380             Position := Pic.End_Float;
 381          end if;
 382
 383          for J in Pic.Start_Float .. Position - 1 loop
 384             Answer (J) := ' ';
 385          end loop;
 386
 387          Answer (Position) := Pic.Floater;
 388          Sign_Position     := Position;
 389
 390       elsif Pic.Floater = '$' then
 391
 392          for J in Pic.End_Float .. Position loop --  May be null range.
 393             if Answer (J) = '9' then
 394                Answer (J) := '0';
 395
 396             elsif Answer (J) = '_' then
 397                Answer (J) := ' ';    --  no separators before leftmost digit.
 398
 399             elsif Answer (J) = 'b' then
 400                Answer (J) := ' ';
 401             end if;
 402          end loop;
 403
 404          if Position > Pic.End_Float then
 405             Position := Pic.End_Float;
 406          end if;
 407
 408          for J in Pic.Start_Float .. Position - 1 loop
 409             Answer (J) := ' ';
 410          end loop;
 411
 412          Answer (Position) := Pic.Floater;
 413          Currency_Pos      := Position;
 414
 415       elsif Pic.Floater = '*' then
 416
 417          for J in Pic.End_Float .. Position loop --  May be null range.
 418             if Answer (J) = '9' then
 419                Answer (J) := '0';
 420
 421             elsif Answer (J) = '_' then
 422                Answer (J) := Separator_Character;
 423
 424             elsif Answer (J) = 'b' then
 425                Answer (J) := Fill_Character;
 426             end if;
 427          end loop;
 428
 429          if Position > Pic.End_Float then
 430             Position := Pic.End_Float;
 431          end if;
 432
 433          for J in Pic.Start_Float .. Position loop
 434             Answer (J) := Fill_Character;
 435          end loop;
 436
 437       else
 438          if Pic.Floater = '#' then
 439             Currency_Pos := Currency_Symbol'Length;
 440             In_Currency := True;
 441          end if;
 442
 443          for J in reverse Pic.Start_Float .. Position loop
 444             case Answer (J) is
 445
 446                when '*' =>
 447                   Answer (J) := Fill_Character;
 448
 449                when 'b' | '/' =>
 450                   if In_Currency and then Currency_Pos > 0 then
 451                      Answer (J)   := Currency_Symbol (Currency_Pos);
 452                      Currency_Pos := Currency_Pos - 1;
 453                   else
 454                      Answer (J) := ' ';
 455                   end if;
 456
 457                when 'Z' | '0' =>
 458                   Answer (J) := ' ';
 459
 460                when '9' =>
 461                   Answer (J) := '0';
 462
 463                when '.' | 'V' | 'v' | '<' | '$' | '+' | '-' =>
 464                   null;
 465
 466                when '#' =>
 467                   if Currency_Pos = 0 then
 468                      Answer (J) := ' ';
 469                   else
 470                      Answer (J)   := Currency_Symbol (Currency_Pos);
 471                      Currency_Pos := Currency_Pos - 1;
 472                   end if;
 473
 474                when '_' =>
 475
 476                   case Pic.Floater is
 477
 478                      when '*' =>
 479                         Answer (J) := Fill_Character;
 480
 481                      when 'Z' | 'b' =>
 482                         Answer (J) := ' ';
 483
 484                      when '#' =>
 485                         if Currency_Pos = 0 then
 486                            Answer (J) := ' ';
 487
 488                         else
 489                            Answer (J)   := Currency_Symbol (Currency_Pos);
 490                            Currency_Pos := Currency_Pos - 1;
 491                         end if;
 492
 493                      when others =>
 494                         null;
 495
 496                   end case;
 497
 498                when others =>
 499                   null;
 500
 501             end case;
 502          end loop;
 503
 504          if Pic.Floater = '#' and then Currency_Pos /= 0 then
 505             raise Ada.Text_IO.Layout_Error;
 506          end if;
 507       end if;
 508
 509       --  Do sign
 510
 511       if Sign_Position = Invalid_Position then
 512          if Attrs.Negative then
 513             raise Ada.Text_IO.Layout_Error;
 514          end if;
 515
 516       else
 517          if Attrs.Negative then
 518             case Answer (Sign_Position) is
 519                when 'C' | 'D' | '-' =>
 520                   null;
 521
 522                when '+' =>
 523                   Answer (Sign_Position) := '-';
 524
 525                when '<' =>
 526                   Answer (Sign_Position)   := '(';
 527                   Answer (Pic.Second_Sign) := ')';
 528
 529                when others =>
 530                   raise Picture_Error;
 531
 532             end case;
 533
 534          else --  positive
 535
 536             case Answer (Sign_Position) is
 537
 538                when '-' =>
 539                   Answer (Sign_Position) := ' ';
 540
 541                when '<' | 'C' | 'D' =>
 542                   Answer (Sign_Position)   := ' ';
 543                   Answer (Pic.Second_Sign) := ' ';
 544
 545                when '+' =>
 546                   null;
 547
 548                when others =>
 549                   raise Picture_Error;
 550
 551             end case;
 552          end if;
 553       end if;
 554
 555       --  Fill in trailing digits
 556
 557       if Pic.Max_Trailing_Digits > 0 then
 558
 559          if Attrs.Has_Fraction then
 560             Position := Attrs.Start_Of_Fraction;
 561             Last     := Pic.Radix_Position + 1;
 562
 563             for J in Last .. Answer'Last loop
 564                if Answer (J) = '9' or else Answer (J) = Pic.Floater then
 565                   Answer (J) := Rounded (Position);
 566
 567                   if Rounded (Position) /= '0' then
 568                      Zero := False;
 569                   end if;
 570
 571                   Position := Position + 1;
 572                   Last     := J + 1;
 573
 574                   --  Used up fraction but remember place in Answer
 575
 576                   exit when Position > Attrs.End_Of_Fraction;
 577
 578                elsif Answer (J) = 'b' then
 579                   Answer (J) := ' ';
 580
 581                elsif Answer (J) = '_' then
 582                   Answer (J) := Separator_Character;
 583
 584                end if;
 585
 586                Last := J + 1;
 587             end loop;
 588
 589             Position := Last;
 590
 591          else
 592             Position := Pic.Radix_Position + 1;
 593          end if;
 594
 595          --  Now fill remaining 9's with zeros and _ with separators
 596
 597          Last := Answer'Last;
 598
 599          for J in Position .. Last loop
 600             if Answer (J) = '9' then
 601                Answer (J) := '0';
 602
 603             elsif Answer (J) = Pic.Floater then
 604                Answer (J) := '0';
 605
 606             elsif Answer (J) = '_' then
 607                Answer (J) := Separator_Character;
 608
 609             elsif Answer (J) = 'b' then
 610                Answer (J) := ' ';
 611
 612             end if;
 613          end loop;
 614
 615          Position := Last + 1;
 616
 617       else
 618          if Pic.Floater = '#' and then Currency_Pos /= 0 then
 619             raise Ada.Text_IO.Layout_Error;
 620          end if;
 621
 622          --  No trailing digits, but now J may need to stick in a currency
 623          --  symbol or sign.
 624
 625          Position :=
 626            (if Pic.Start_Currency = Invalid_Position
 627             then Answer'Last + 1
 628             else Pic.Start_Currency);
 629       end if;
 630
 631       for J in Position .. Answer'Last loop
 632          if Pic.Start_Currency /= Invalid_Position and then
 633             Answer (Pic.Start_Currency) = '#' then
 634             Currency_Pos := 1;
 635          end if;
 636
 637          case Answer (J) is
 638             when '*' =>
 639                Answer (J) := Fill_Character;
 640
 641             when 'b' =>
 642                if In_Currency then
 643                   Answer (J) := Currency_Symbol (Currency_Pos);
 644                   Currency_Pos := Currency_Pos + 1;
 645
 646                   if Currency_Pos > Currency_Symbol'Length then
 647                      In_Currency := False;
 648                   end if;
 649                end if;
 650
 651             when '#' =>
 652                if Currency_Pos > Currency_Symbol'Length then
 653                   Answer (J) := ' ';
 654
 655                else
 656                   In_Currency := True;
 657                   Answer (J)   := Currency_Symbol (Currency_Pos);
 658                   Currency_Pos := Currency_Pos + 1;
 659
 660                   if Currency_Pos > Currency_Symbol'Length then
 661                      In_Currency := False;
 662                   end if;
 663                end if;
 664
 665             when '_' =>
 666                Answer (J) := Currency_Symbol (Currency_Pos);
 667                Currency_Pos := Currency_Pos + 1;
 668
 669                case Pic.Floater is
 670
 671                   when '*' =>
 672                      Answer (J) := Fill_Character;
 673
 674                   when 'Z' | 'z' =>
 675                      Answer (J) := ' ';
 676
 677                   when '#' =>
 678                      if Currency_Pos > Currency_Symbol'Length then
 679                         Answer (J) := ' ';
 680                      else
 681                         Answer (J)   := Currency_Symbol (Currency_Pos);
 682                         Currency_Pos := Currency_Pos + 1;
 683                      end if;
 684
 685                   when others =>
 686                      null;
 687
 688                end case;
 689
 690             when others =>
 691                exit;
 692
 693          end case;
 694       end loop;
 695
 696       --  Now get rid of Blank_when_Zero and complete Star fill
 697
 698       if Zero and then Pic.Blank_When_Zero then
 699
 700          --  Value is zero, and blank it
 701
 702          Last := Answer'Last;
 703
 704          if Dollar then
 705             Last := Last - 1 + Currency_Symbol'Length;
 706          end if;
 707
 708          if Pic.Radix_Position /= Invalid_Position and then
 709             Answer (Pic.Radix_Position) = 'V' then
 710             Last := Last - 1;
 711          end if;
 712
 713          return String'(1 .. Last => ' ');
 714
 715       elsif Zero and then Pic.Star_Fill then
 716          Last := Answer'Last;
 717
 718          if Dollar then
 719             Last := Last - 1 + Currency_Symbol'Length;
 720          end if;
 721
 722          if Pic.Radix_Position /= Invalid_Position then
 723
 724             if Answer (Pic.Radix_Position) = 'V' then
 725                Last := Last - 1;
 726
 727             elsif Dollar then
 728                if Pic.Radix_Position > Pic.Start_Currency then
 729                   return String'(1 .. Pic.Radix_Position - 1 => '*') &
 730                      Radix_Point &
 731                      String'(Pic.Radix_Position + 1 .. Last => '*');
 732
 733                else
 734                   return
 735                      String'
 736                      (1 ..
 737                       Pic.Radix_Position + Currency_Symbol'Length - 2 =>
 738                          '*') & Radix_Point &
 739                      String'
 740                      (Pic.Radix_Position + Currency_Symbol'Length .. Last
 741                       => '*');
 742                end if;
 743
 744             else
 745                return String'(1 .. Pic.Radix_Position - 1 => '*') &
 746                   Radix_Point &
 747                   String'(Pic.Radix_Position + 1 .. Last => '*');
 748             end if;
 749          end if;
 750
 751          return String'(1 .. Last => '*');
 752       end if;
 753
 754       --  This was once a simple return statement, now there are nine different
 755       --  return cases. Not to mention the five above to deal with zeros. Why
 756       --  not split things out?
 757
 758       --  Processing the radix and sign expansion separately would require
 759       --  lots of copying--the string and some of its indexes--without
 760       --  really simplifying the logic. The cases are:
 761
 762       --  1) Expand $, replace '.' with Radix_Point
 763       --  2) No currency expansion, replace '.' with Radix_Point
 764       --  3) Expand $, radix blanked
 765       --  4) No currency expansion, radix blanked
 766       --  5) Elide V
 767       --  6) Expand $, Elide V
 768       --  7) Elide V, Expand $ (Two cases depending on order.)
 769       --  8) No radix, expand $
 770       --  9) No radix, no currency expansion
 771
 772       if Pic.Radix_Position /= Invalid_Position then
 773
 774          if Answer (Pic.Radix_Position) = '.' then
 775             Answer (Pic.Radix_Position) := Radix_Point;
 776
 777             if Dollar then
 778
 779                --  1) Expand $, replace '.' with Radix_Point
 780
 781                return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
 782                   Answer (Currency_Pos + 1 .. Answer'Last);
 783
 784             else
 785                --  2) No currency expansion, replace '.' with Radix_Point
 786
 787                return Answer;
 788             end if;
 789
 790          elsif Answer (Pic.Radix_Position) = ' ' then --  blanked radix.
 791             if Dollar then
 792
 793                --  3) Expand $, radix blanked
 794
 795                return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
 796                  Answer (Currency_Pos + 1 .. Answer'Last);
 797
 798             else
 799                --  4) No expansion, radix blanked
 800
 801                return Answer;
 802             end if;
 803
 804          --  V cases
 805
 806          else
 807             if not Dollar then
 808
 809                --  5) Elide V
 810
 811                return Answer (1 .. Pic.Radix_Position - 1) &
 812                   Answer (Pic.Radix_Position + 1 .. Answer'Last);
 813
 814             elsif Currency_Pos < Pic.Radix_Position then
 815
 816                --  6) Expand $, Elide V
 817
 818                return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
 819                   Answer (Currency_Pos + 1 .. Pic.Radix_Position - 1) &
 820                   Answer (Pic.Radix_Position + 1 .. Answer'Last);
 821
 822             else
 823                --  7) Elide V, Expand $
 824
 825                return Answer (1 .. Pic.Radix_Position - 1) &
 826                   Answer (Pic.Radix_Position + 1 .. Currency_Pos - 1) &
 827                   Currency_Symbol &
 828                   Answer (Currency_Pos + 1 .. Answer'Last);
 829             end if;
 830          end if;
 831
 832       elsif Dollar then
 833
 834          --  8) No radix, expand $
 835
 836          return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
 837             Answer (Currency_Pos + 1 .. Answer'Last);
 838
 839       else
 840          --  9) No radix, no currency expansion
 841
 842          return Answer;
 843       end if;
 844    end Format_Number;
 845
 846    -------------------------
 847    -- Parse_Number_String --
 848    -------------------------
 849
 850    function Parse_Number_String (Str : String) return Number_Attributes is
 851       Answer : Number_Attributes;
 852
 853    begin
 854       for J in Str'Range loop
 855          case Str (J) is
 856
 857             when ' ' =>
 858                null; --  ignore
 859
 860             when '1' .. '9' =>
 861
 862                --  Decide if this is the start of a number.
 863                --  If so, figure out which one...
 864
 865                if Answer.Has_Fraction then
 866                   Answer.End_Of_Fraction := J;
 867                else
 868                   if Answer.Start_Of_Int = Invalid_Position then
 869                      --  start integer
 870                      Answer.Start_Of_Int := J;
 871                   end if;
 872                   Answer.End_Of_Int := J;
 873                end if;
 874
 875             when '0' =>
 876
 877                --  Only count a zero before the decimal point if it follows a
 878                --  non-zero digit. After the decimal point, zeros will be
 879                --  counted if followed by a non-zero digit.
 880
 881                if not Answer.Has_Fraction then
 882                   if Answer.Start_Of_Int /= Invalid_Position then
 883                      Answer.End_Of_Int := J;
 884                   end if;
 885                end if;
 886
 887             when '-' =>
 888
 889                --  Set negative
 890
 891                Answer.Negative := True;
 892
 893             when '.' =>
 894
 895                --  Close integer, start fraction
 896
 897                if Answer.Has_Fraction then
 898                   raise Picture_Error;
 899                end if;
 900
 901                --  Two decimal points is a no-no
 902
 903                Answer.Has_Fraction    := True;
 904                Answer.End_Of_Fraction := J;
 905
 906                --  Could leave this at Invalid_Position, but this seems the
 907                --  right way to indicate a null range...
 908
 909                Answer.Start_Of_Fraction := J + 1;
 910                Answer.End_Of_Int        := J - 1;
 911
 912             when others =>
 913                raise Picture_Error; -- can this happen? probably not
 914          end case;
 915       end loop;
 916
 917       if Answer.Start_Of_Int = Invalid_Position then
 918          Answer.Start_Of_Int := Answer.End_Of_Int + 1;
 919       end if;
 920
 921       --  No significant (integer) digits needs a null range
 922
 923       return Answer;
 924    end Parse_Number_String;
 925
 926    ----------------
 927    -- Pic_String --
 928    ----------------
 929
 930    --  The following ensures that we return B and not b being careful not
 931    --  to break things which expect lower case b for blank. See CXF3A02.
 932
 933    function Pic_String (Pic : Picture) return String is
 934       Temp : String (1 .. Pic.Contents.Picture.Length) :=
 935         Pic.Contents.Picture.Expanded;
 936    begin
 937       for J in Temp'Range loop
 938          if Temp (J) = 'b' then
 939             Temp (J) := 'B';
 940          end if;
 941       end loop;
 942
 943       return Temp;
 944    end Pic_String;
 945
 946    ------------------
 947    -- Precalculate --
 948    ------------------
 949
 950    procedure Precalculate  (Pic : in out Format_Record) is
 951       Debug : constant Boolean := False;
 952       --  Set True to generate debug output
 953
 954       Computed_BWZ : Boolean := True;
 955
 956       type Legality is  (Okay, Reject);
 957
 958       State : Legality := Reject;
 959       --  Start in reject, which will reject null strings
 960
 961       Index : Pic_Index := Pic.Picture.Expanded'First;
 962
 963       function At_End return Boolean;
 964       pragma Inline (At_End);
 965
 966       procedure Set_State (L : Legality);
 967       pragma Inline (Set_State);
 968
 969       function Look return Character;
 970       pragma Inline (Look);
 971
 972       function Is_Insert return Boolean;
 973       pragma Inline (Is_Insert);
 974
 975       procedure Skip;
 976       pragma Inline (Skip);
 977
 978       procedure Debug_Start (Name : String);
 979       pragma Inline (Debug_Start);
 980
 981       procedure Debug_Integer  (Value : Integer; S : String);
 982       pragma Inline (Debug_Integer);
 983
 984       procedure Trailing_Currency;
 985       procedure Trailing_Bracket;
 986       procedure Number_Fraction;
 987       procedure Number_Completion;
 988       procedure Number_Fraction_Or_Bracket;
 989       procedure Number_Fraction_Or_Z_Fill;
 990       procedure Zero_Suppression;
 991       procedure Floating_Bracket;
 992       procedure Number_Fraction_Or_Star_Fill;
 993       procedure Star_Suppression;
 994       procedure Number_Fraction_Or_Dollar;
 995       procedure Leading_Dollar;
 996       procedure Number_Fraction_Or_Pound;
 997       procedure Leading_Pound;
 998       procedure Picture;
 999       procedure Floating_Plus;
1000       procedure Floating_Minus;
1001       procedure Picture_Plus;
1002       procedure Picture_Minus;
1003       procedure Picture_Bracket;
1004       procedure Number;
1005       procedure Optional_RHS_Sign;
1006       procedure Picture_String;
1007       procedure Set_Debug;
1008
1009       ------------
1010       -- At_End --
1011       ------------
1012
1013       function At_End return Boolean is
1014       begin
1015          Debug_Start ("At_End");
1016          return Index > Pic.Picture.Length;
1017       end At_End;
1018
1019       --------------
1020       -- Set_Debug--
1021       --------------
1022
1023       --  Needed to have a procedure to pass to pragma Debug
1024
1025       procedure Set_Debug is
1026       begin
1027          --  Uncomment this line and make Debug a variable to enable debug
1028
1029          --  Debug := True;
1030
1031          null;
1032       end Set_Debug;
1033
1034       -------------------
1035       -- Debug_Integer --
1036       -------------------
1037
1038       procedure Debug_Integer (Value : Integer; S : String) is
1039          use Ada.Text_IO; --  needed for >
1040
1041       begin
1042          if Debug and then Value > 0 then
1043             if Ada.Text_IO.Col > 70 - S'Length then
1044                Ada.Text_IO.New_Line;
1045             end if;
1046
1047             Ada.Text_IO.Put (' ' & S & Integer'Image (Value) & ',');
1048          end if;
1049       end Debug_Integer;
1050
1051       -----------------
1052       -- Debug_Start --
1053       -----------------
1054
1055       procedure Debug_Start (Name : String) is
1056       begin
1057          if Debug then
1058             Ada.Text_IO.Put_Line ("  In " & Name & '.');
1059          end if;
1060       end Debug_Start;
1061
1062       ----------------------
1063       -- Floating_Bracket --
1064       ----------------------
1065
1066       --  Note that Floating_Bracket is only called with an acceptable
1067       --  prefix. But we don't set Okay, because we must end with a '>'.
1068
1069       procedure Floating_Bracket is
1070       begin
1071          Debug_Start ("Floating_Bracket");
1072
1073          --  Two different floats not allowed
1074
1075          if Pic.Floater /= '!' and then Pic.Floater /= '<' then
1076             raise Picture_Error;
1077
1078          else
1079             Pic.Floater := '<';
1080          end if;
1081
1082          Pic.End_Float := Index;
1083          Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1084
1085          --  First bracket wasn't counted...
1086
1087          Skip; --  known '<'
1088
1089          loop
1090             if At_End then
1091                return;
1092             end if;
1093
1094             case Look is
1095
1096                when '_' | '0' | '/' =>
1097                   Pic.End_Float := Index;
1098                   Skip;
1099
1100                when 'B' | 'b'  =>
1101                   Pic.End_Float := Index;
1102                   Pic.Picture.Expanded (Index) := 'b';
1103                   Skip;
1104
1105                when '<' =>
1106                   Pic.End_Float := Index;
1107                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1108                   Skip;
1109
1110                when '9' =>
1111                   Number_Completion;
1112
1113                when '$' =>
1114                   Leading_Dollar;
1115
1116                when '#' =>
1117                   Leading_Pound;
1118
1119                when 'V' | 'v' | '.' =>
1120                   Pic.Radix_Position := Index;
1121                   Skip;
1122                   Number_Fraction_Or_Bracket;
1123                   return;
1124
1125                when others =>
1126                return;
1127             end case;
1128          end loop;
1129       end Floating_Bracket;
1130
1131       --------------------
1132       -- Floating_Minus --
1133       --------------------
1134
1135       procedure Floating_Minus is
1136       begin
1137          Debug_Start ("Floating_Minus");
1138
1139          loop
1140             if At_End then
1141                return;
1142             end if;
1143
1144             case Look is
1145                when '_' | '0' | '/' =>
1146                   Pic.End_Float := Index;
1147                   Skip;
1148
1149                when 'B' | 'b'  =>
1150                   Pic.End_Float := Index;
1151                   Pic.Picture.Expanded (Index) := 'b';
1152                   Skip;
1153
1154                when '-' =>
1155                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1156                   Pic.End_Float := Index;
1157                   Skip;
1158
1159                when '9' =>
1160                   Number_Completion;
1161                   return;
1162
1163                when '.' | 'V' | 'v' =>
1164                   Pic.Radix_Position := Index;
1165                   Skip; --  Radix
1166
1167                   while Is_Insert loop
1168                      Skip;
1169                   end loop;
1170
1171                   if At_End then
1172                      return;
1173                   end if;
1174
1175                   if Look = '-' then
1176                      loop
1177                         if At_End then
1178                            return;
1179                         end if;
1180
1181                         case Look is
1182
1183                            when '-' =>
1184                               Pic.Max_Trailing_Digits :=
1185                                 Pic.Max_Trailing_Digits + 1;
1186                               Pic.End_Float := Index;
1187                               Skip;
1188
1189                            when '_' | '0' | '/' =>
1190                               Skip;
1191
1192                            when 'B' | 'b'  =>
1193                               Pic.Picture.Expanded (Index) := 'b';
1194                               Skip;
1195
1196                            when others =>
1197                               return;
1198
1199                         end case;
1200                      end loop;
1201
1202                   else
1203                      Number_Completion;
1204                   end if;
1205
1206                   return;
1207
1208                when others =>
1209                   return;
1210             end case;
1211          end loop;
1212       end Floating_Minus;
1213
1214       -------------------
1215       -- Floating_Plus --
1216       -------------------
1217
1218       procedure Floating_Plus is
1219       begin
1220          Debug_Start ("Floating_Plus");
1221
1222          loop
1223             if At_End then
1224                return;
1225             end if;
1226
1227             case Look is
1228                when '_' | '0' | '/' =>
1229                   Pic.End_Float := Index;
1230                   Skip;
1231
1232                when 'B' | 'b'  =>
1233                   Pic.End_Float := Index;
1234                   Pic.Picture.Expanded (Index) := 'b';
1235                   Skip;
1236
1237                when '+' =>
1238                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1239                   Pic.End_Float := Index;
1240                   Skip;
1241
1242                when '9' =>
1243                   Number_Completion;
1244                   return;
1245
1246                when '.' | 'V' | 'v' =>
1247                   Pic.Radix_Position := Index;
1248                   Skip; --  Radix
1249
1250                   while Is_Insert loop
1251                      Skip;
1252                   end loop;
1253
1254                   if At_End then
1255                      return;
1256                   end if;
1257
1258                   if Look = '+' then
1259                      loop
1260                         if At_End then
1261                            return;
1262                         end if;
1263
1264                         case Look is
1265
1266                            when '+' =>
1267                               Pic.Max_Trailing_Digits :=
1268                                 Pic.Max_Trailing_Digits + 1;
1269                               Pic.End_Float := Index;
1270                               Skip;
1271
1272                            when '_' | '0' | '/' =>
1273                               Skip;
1274
1275                            when 'B' | 'b'  =>
1276                               Pic.Picture.Expanded (Index) := 'b';
1277                               Skip;
1278
1279                            when others =>
1280                               return;
1281
1282                         end case;
1283                      end loop;
1284
1285                   else
1286                      Number_Completion;
1287                   end if;
1288
1289                   return;
1290
1291                when others =>
1292                   return;
1293
1294             end case;
1295          end loop;
1296       end Floating_Plus;
1297
1298       ---------------
1299       -- Is_Insert --
1300       ---------------
1301
1302       function Is_Insert return Boolean is
1303       begin
1304          if At_End then
1305             return False;
1306          end if;
1307
1308          case Pic.Picture.Expanded (Index) is
1309
1310             when '_' | '0' | '/' => return True;
1311
1312             when 'B' | 'b' =>
1313                Pic.Picture.Expanded (Index) := 'b'; --  canonical
1314                return True;
1315
1316             when others => return False;
1317          end case;
1318       end Is_Insert;
1319
1320       --------------------
1321       -- Leading_Dollar --
1322       --------------------
1323
1324       --  Note that Leading_Dollar can be called in either State. It will set
1325       --  state to Okay only if a 9 or (second) $ is encountered.
1326
1327       --  Also notice the tricky bit with State and Zero_Suppression.
1328       --  Zero_Suppression is Picture_Error if a '$' or a '9' has been
1329       --  encountered, exactly the cases where State has been set.
1330
1331       procedure Leading_Dollar is
1332       begin
1333          Debug_Start ("Leading_Dollar");
1334
1335          --  Treat as a floating dollar, and unwind otherwise
1336
1337          if Pic.Floater /= '!' and then Pic.Floater /= '$' then
1338
1339             --  Two floats not allowed
1340
1341             raise Picture_Error;
1342
1343          else
1344             Pic.Floater := '$';
1345          end if;
1346
1347          Pic.Start_Currency := Index;
1348          Pic.End_Currency := Index;
1349          Pic.Start_Float := Index;
1350          Pic.End_Float := Index;
1351
1352          --  Don't increment Pic.Max_Leading_Digits, we need one "real"
1353          --  currency place.
1354
1355          Skip; --  known '$'
1356
1357          loop
1358             if At_End then
1359                return;
1360             end if;
1361
1362             case Look is
1363
1364                when '_' | '0' | '/' =>
1365                   Pic.End_Float := Index;
1366                   Skip;
1367
1368                   --  A trailing insertion character is not part of the
1369                   --  floating currency, so need to look ahead.
1370
1371                   if Look /= '$' then
1372                      Pic.End_Float := Pic.End_Float - 1;
1373                   end if;
1374
1375                when 'B' | 'b'  =>
1376                   Pic.End_Float := Index;
1377                   Pic.Picture.Expanded (Index) := 'b';
1378                   Skip;
1379
1380                when 'Z' | 'z' =>
1381                   Pic.Picture.Expanded (Index) := 'Z'; -- consistency
1382
1383                   if State = Okay then
1384                      raise Picture_Error;
1385                   else
1386                      --  Overwrite Floater and Start_Float
1387
1388                      Pic.Floater := 'Z';
1389                      Pic.Start_Float := Index;
1390                      Zero_Suppression;
1391                   end if;
1392
1393                when '*' =>
1394                   if State = Okay then
1395                      raise Picture_Error;
1396                   else
1397                      --  Overwrite Floater and Start_Float
1398
1399                      Pic.Floater := '*';
1400                      Pic.Start_Float := Index;
1401                      Star_Suppression;
1402                   end if;
1403
1404                when '$' =>
1405                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1406                   Pic.End_Float := Index;
1407                   Pic.End_Currency := Index;
1408                   Set_State (Okay); Skip;
1409
1410                when '9' =>
1411                   if State /= Okay then
1412                      Pic.Floater := '!';
1413                      Pic.Start_Float := Invalid_Position;
1414                      Pic.End_Float := Invalid_Position;
1415                   end if;
1416
1417                   --  A single dollar does not a floating make
1418
1419                   Number_Completion;
1420                   return;
1421
1422                when 'V' | 'v' | '.' =>
1423                   if State /= Okay then
1424                      Pic.Floater := '!';
1425                      Pic.Start_Float := Invalid_Position;
1426                      Pic.End_Float := Invalid_Position;
1427                   end if;
1428
1429                   --  Only one dollar before the sign is okay, but doesn't
1430                   --  float.
1431
1432                   Pic.Radix_Position := Index;
1433                   Skip;
1434                   Number_Fraction_Or_Dollar;
1435                   return;
1436
1437                when others =>
1438                   return;
1439
1440             end case;
1441          end loop;
1442       end Leading_Dollar;
1443
1444       -------------------
1445       -- Leading_Pound --
1446       -------------------
1447
1448       --  This one is complex.  A Leading_Pound can be fixed or floating,
1449       --  but in some cases the decision has to be deferred until we leave
1450       --  this procedure. Also note that Leading_Pound can be called in
1451       --  either State.
1452
1453       --  It will set state to Okay only if a 9 or (second) # is 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 else 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 else 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 else Pic.Blank_When_Zero)
2436              and then not Pic.Star_Fill;
2437
2438          --  Star fill if '*' and no '9'
2439
2440          Pic.Star_Fill := Pic.Star_Fill and then Computed_BWZ;
2441
2442          if not At_End then
2443             Set_State (Reject);
2444          end if;
2445
2446       end Picture_String;
2447
2448       ---------------
2449       -- Set_State --
2450       ---------------
2451
2452       procedure Set_State (L : Legality) is
2453       begin
2454          if Debug then
2455             Ada.Text_IO.Put_Line
2456               ("  Set state from " & Legality'Image (State)
2457                & " to " & Legality'Image (L));
2458          end if;
2459
2460          State := L;
2461       end Set_State;
2462
2463       ----------
2464       -- Skip --
2465       ----------
2466
2467       procedure Skip is
2468       begin
2469          if Debug then
2470             Ada.Text_IO.Put_Line ("  Skip " & Pic.Picture.Expanded (Index));
2471          end if;
2472
2473          Index := Index + 1;
2474       end Skip;
2475
2476       ----------------------
2477       -- Star_Suppression --
2478       ----------------------
2479
2480       procedure Star_Suppression is
2481       begin
2482          Debug_Start ("Star_Suppression");
2483
2484          if Pic.Floater /= '!' and then Pic.Floater /= '*' then
2485
2486             --  Two floats not allowed
2487
2488             raise Picture_Error;
2489
2490          else
2491             Pic.Floater := '*';
2492          end if;
2493
2494          Pic.Start_Float := Index;
2495          Pic.End_Float := Index;
2496          Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2497          Set_State (Okay);
2498
2499          --  Even a single * is a valid picture
2500
2501          Pic.Star_Fill := True;
2502          Skip; --  Known *
2503
2504          loop
2505             if At_End then
2506                return;
2507             end if;
2508
2509             case Look is
2510
2511                when '_' | '0' | '/' =>
2512                   Pic.End_Float := Index;
2513                   Skip;
2514
2515                when 'B' | 'b'  =>
2516                   Pic.End_Float := Index;
2517                   Pic.Picture.Expanded (Index) := 'b';
2518                   Skip;
2519
2520                when '*' =>
2521                   Pic.End_Float := Index;
2522                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2523                   Set_State (Okay); Skip;
2524
2525                when '9' =>
2526                   Set_State (Okay);
2527                   Number_Completion;
2528                   return;
2529
2530                when '.' | 'V' | 'v' =>
2531                   Pic.Radix_Position := Index;
2532                   Skip;
2533                   Number_Fraction_Or_Star_Fill;
2534                   return;
2535
2536                when '#' | '$' =>
2537                   if Pic.Max_Currency_Digits > 0 then
2538                      raise Picture_Error;
2539                   end if;
2540
2541                   --  Cannot have leading and trailing currency
2542
2543                   Trailing_Currency;
2544                   Set_State (Okay);
2545                   return;
2546
2547                when others => raise Picture_Error;
2548             end case;
2549          end loop;
2550       end Star_Suppression;
2551
2552       ----------------------
2553       -- Trailing_Bracket --
2554       ----------------------
2555
2556       procedure Trailing_Bracket is
2557       begin
2558          Debug_Start ("Trailing_Bracket");
2559
2560          if Look = '>' then
2561             Pic.Second_Sign := Index;
2562             Skip;
2563          else
2564             raise Picture_Error;
2565          end if;
2566       end Trailing_Bracket;
2567
2568       -----------------------
2569       -- Trailing_Currency --
2570       -----------------------
2571
2572       procedure Trailing_Currency is
2573       begin
2574          Debug_Start ("Trailing_Currency");
2575
2576          if At_End then
2577             return;
2578          end if;
2579
2580          if Look = '$' then
2581             Pic.Start_Currency := Index;
2582             Pic.End_Currency := Index;
2583             Skip;
2584
2585          else
2586             while not At_End and then Look = '#' loop
2587                if Pic.Start_Currency = Invalid_Position then
2588                   Pic.Start_Currency := Index;
2589                end if;
2590
2591                Pic.End_Currency := Index;
2592                Skip;
2593             end loop;
2594          end if;
2595
2596          loop
2597             if At_End then
2598                return;
2599             end if;
2600
2601             case Look is
2602                when '_' | '0' | '/' => Skip;
2603
2604                when 'B' | 'b'  =>
2605                   Pic.Picture.Expanded (Index) := 'b';
2606                   Skip;
2607
2608                when others => return;
2609             end case;
2610          end loop;
2611       end Trailing_Currency;
2612
2613       ----------------------
2614       -- Zero_Suppression --
2615       ----------------------
2616
2617       procedure Zero_Suppression is
2618       begin
2619          Debug_Start ("Zero_Suppression");
2620
2621          Pic.Floater := 'Z';
2622          Pic.Start_Float := Index;
2623          Pic.End_Float := Index;
2624          Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2625          Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2626
2627          Skip; --  Known Z
2628
2629          loop
2630             --  Even a single Z is a valid picture
2631
2632             if At_End then
2633                Set_State (Okay);
2634                return;
2635             end if;
2636
2637             case Look is
2638                when '_' | '0' | '/' =>
2639                   Pic.End_Float := Index;
2640                   Skip;
2641
2642                when 'B' | 'b'  =>
2643                   Pic.End_Float := Index;
2644                   Pic.Picture.Expanded (Index) := 'b';
2645                   Skip;
2646
2647                when 'Z' | 'z' =>
2648                   Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2649
2650                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2651                   Pic.End_Float := Index;
2652                   Set_State (Okay);
2653                   Skip;
2654
2655                when '9' =>
2656                   Set_State (Okay);
2657                   Number_Completion;
2658                   return;
2659
2660                when '.' | 'V' | 'v' =>
2661                   Pic.Radix_Position := Index;
2662                   Skip;
2663                   Number_Fraction_Or_Z_Fill;
2664                   return;
2665
2666                when '#' | '$' =>
2667                   Trailing_Currency;
2668                   Set_State (Okay);
2669                   return;
2670
2671                when others =>
2672                   return;
2673             end case;
2674          end loop;
2675       end Zero_Suppression;
2676
2677    --  Start of processing for Precalculate
2678
2679    begin
2680       pragma Debug (Set_Debug);
2681
2682       Picture_String;
2683
2684       if Debug then
2685          Ada.Text_IO.New_Line;
2686          Ada.Text_IO.Put (" Picture : """ &
2687                      Pic.Picture.Expanded (1 .. Pic.Picture.Length) & """,");
2688          Ada.Text_IO.Put (" Floater : '" & Pic.Floater & "',");
2689       end if;
2690
2691       if State = Reject then
2692          raise Picture_Error;
2693       end if;
2694
2695       Debug_Integer (Pic.Radix_Position, "Radix Positon : ");
2696       Debug_Integer (Pic.Sign_Position, "Sign Positon : ");
2697       Debug_Integer (Pic.Second_Sign, "Second Sign : ");
2698       Debug_Integer (Pic.Start_Float, "Start Float : ");
2699       Debug_Integer (Pic.End_Float, "End Float : ");
2700       Debug_Integer (Pic.Start_Currency, "Start Currency : ");
2701       Debug_Integer (Pic.End_Currency, "End Currency : ");
2702       Debug_Integer (Pic.Max_Leading_Digits, "Max Leading Digits : ");
2703       Debug_Integer (Pic.Max_Trailing_Digits, "Max Trailing Digits : ");
2704
2705       if Debug then
2706          Ada.Text_IO.New_Line;
2707       end if;
2708
2709    exception
2710
2711       when Constraint_Error =>
2712
2713       --  To deal with special cases like null strings
2714
2715       raise Picture_Error;
2716    end Precalculate;
2717
2718    ----------------
2719    -- To_Picture --
2720    ----------------
2721
2722    function To_Picture
2723      (Pic_String      : String;
2724       Blank_When_Zero : Boolean := False) return Picture
2725    is
2726       Result : Picture;
2727
2728    begin
2729       declare
2730          Item : constant String := Expand (Pic_String);
2731
2732       begin
2733          Result.Contents.Picture         := (Item'Length, Item);
2734          Result.Contents.Original_BWZ := Blank_When_Zero;
2735          Result.Contents.Blank_When_Zero := Blank_When_Zero;
2736          Precalculate (Result.Contents);
2737          return Result;
2738       end;
2739
2740    exception
2741       when others =>
2742          raise Picture_Error;
2743    end To_Picture;
2744
2745    -----------
2746    -- Valid --
2747    -----------
2748
2749    function Valid
2750      (Pic_String      : String;
2751       Blank_When_Zero : Boolean := False) return Boolean
2752    is
2753    begin
2754       declare
2755          Expanded_Pic : constant String := Expand (Pic_String);
2756          --  Raises Picture_Error if Item not well-formed
2757
2758          Format_Rec : Format_Record;
2759
2760       begin
2761          Format_Rec.Picture := (Expanded_Pic'Length, Expanded_Pic);
2762          Format_Rec.Blank_When_Zero := Blank_When_Zero;
2763          Format_Rec.Original_BWZ := Blank_When_Zero;
2764          Precalculate (Format_Rec);
2765
2766          --  False only if Blank_When_Zero is True but the pic string has a '*'
2767
2768          return not Blank_When_Zero
2769            or else Strings_Fixed.Index (Expanded_Pic, "*") = 0;
2770       end;
2771
2772    exception
2773       when others => return False;
2774    end Valid;
2775
2776    --------------------
2777    -- Decimal_Output --
2778    --------------------
2779
2780    package body Decimal_Output is
2781
2782       -----------
2783       -- Image --
2784       -----------
2785
2786       function Image
2787         (Item       : Num;
2788          Pic        : Picture;
2789          Currency   : String    := Default_Currency;
2790          Fill       : Character := Default_Fill;
2791          Separator  : Character := Default_Separator;
2792          Radix_Mark : Character := Default_Radix_Mark) return String
2793       is
2794       begin
2795          return Format_Number
2796             (Pic.Contents, Num'Image (Item),
2797              Currency, Fill, Separator, Radix_Mark);
2798       end Image;
2799
2800       ------------
2801       -- Length --
2802       ------------
2803
2804       function Length
2805         (Pic      : Picture;
2806          Currency : String := Default_Currency) return Natural
2807       is
2808          Picstr     : constant String := Pic_String (Pic);
2809          V_Adjust   : Integer := 0;
2810          Cur_Adjust : Integer := 0;
2811
2812       begin
2813          --  Check if Picstr has 'V' or '$'
2814
2815          --  If 'V', then length is 1 less than otherwise
2816
2817          --  If '$', then length is Currency'Length-1 more than otherwise
2818
2819          --  This should use the string handling package ???
2820
2821          for J in Picstr'Range loop
2822             if Picstr (J) = 'V' then
2823                V_Adjust := -1;
2824
2825             elsif Picstr (J) = '$' then
2826                Cur_Adjust := Currency'Length - 1;
2827             end if;
2828          end loop;
2829
2830          return Picstr'Length - V_Adjust + Cur_Adjust;
2831       end Length;
2832
2833       ---------
2834       -- Put --
2835       ---------
2836
2837       procedure Put
2838         (File       : Text_IO.File_Type;
2839          Item       : Num;
2840          Pic        : Picture;
2841          Currency   : String    := Default_Currency;
2842          Fill       : Character := Default_Fill;
2843          Separator  : Character := Default_Separator;
2844          Radix_Mark : Character := Default_Radix_Mark)
2845       is
2846       begin
2847          Text_IO.Put (File, Image (Item, Pic,
2848                                    Currency, Fill, Separator, Radix_Mark));
2849       end Put;
2850
2851       procedure Put
2852         (Item       : Num;
2853          Pic        : Picture;
2854          Currency   : String    := Default_Currency;
2855          Fill       : Character := Default_Fill;
2856          Separator  : Character := Default_Separator;
2857          Radix_Mark : Character := Default_Radix_Mark)
2858       is
2859       begin
2860          Text_IO.Put (Image (Item, Pic,
2861                              Currency, Fill, Separator, Radix_Mark));
2862       end Put;
2863
2864       procedure Put
2865         (To         : out String;
2866          Item       : Num;
2867          Pic        : Picture;
2868          Currency   : String    := Default_Currency;
2869          Fill       : Character := Default_Fill;
2870          Separator  : Character := Default_Separator;
2871          Radix_Mark : Character := Default_Radix_Mark)
2872       is
2873          Result : constant String :=
2874            Image (Item, Pic, Currency, Fill, Separator, Radix_Mark);
2875
2876       begin
2877          if Result'Length > To'Length then
2878             raise Ada.Text_IO.Layout_Error;
2879          else
2880             Strings_Fixed.Move (Source => Result, Target => To,
2881                                 Justify => Strings.Right);
2882          end if;
2883       end Put;
2884
2885       -----------
2886       -- Valid --
2887       -----------
2888
2889       function Valid
2890         (Item     : Num;
2891          Pic      : Picture;
2892          Currency : String := Default_Currency) return Boolean
2893       is
2894       begin
2895          declare
2896             Temp : constant String := Image (Item, Pic, Currency);
2897             pragma Warnings (Off, Temp);
2898          begin
2899             return True;
2900          end;
2901
2902       exception
2903          when Ada.Text_IO.Layout_Error => return False;
2904
2905       end Valid;
2906    end Decimal_Output;
2907
2908 end Ada.Text_IO.Editing;