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