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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Strings.Fixed;
  35 package body Ada.Text_IO.Editing is
  36
  37    package Strings renames Ada.Strings;
  38    package Strings_Fixed renames Ada.Strings.Fixed;
  39    package Text_IO renames Ada.Text_IO;
  40
  41    ---------------------
  42    -- Blank_When_Zero --
  43    ---------------------
  44
  45    function Blank_When_Zero (Pic : 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 (integer) 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
1397                      Pic.Floater := '*';
1398                      Pic.Start_Float := Index;
1399                      Star_Suppression;
1400                   end if;
1401
1402                when '$' =>
1403                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1404                   Pic.End_Float := Index;
1405                   Pic.End_Currency := Index;
1406                   Set_State (Okay); Skip;
1407
1408                when '9' =>
1409                   if State /= Okay then
1410                      Pic.Floater := '!';
1411                      Pic.Start_Float := Invalid_Position;
1412                      Pic.End_Float := Invalid_Position;
1413                   end if;
1414
1415                   --  A single dollar does not a floating make
1416
1417                   Number_Completion;
1418                   return;
1419
1420                when 'V' | 'v' | '.' =>
1421                   if State /= Okay then
1422                      Pic.Floater := '!';
1423                      Pic.Start_Float := Invalid_Position;
1424                      Pic.End_Float := Invalid_Position;
1425                   end if;
1426
1427                   --  Only one dollar before the sign is okay, but doesn't
1428                   --  float.
1429
1430                   Pic.Radix_Position := Index;
1431                   Skip;
1432                   Number_Fraction_Or_Dollar;
1433                   return;
1434
1435                when others =>
1436                   return;
1437
1438             end case;
1439          end loop;
1440       end Leading_Dollar;
1441
1442       -------------------
1443       -- Leading_Pound --
1444       -------------------
1445
1446       --  This one is complex!  A Leading_Pound can be fixed or floating,
1447       --  but in some cases the decision has to be deferred until we leave
1448       --  this procedure.  Also note that Leading_Pound can be called in
1449       --  either State.
1450
1451       --  It will set state to Okay only if a 9 or  (second) # is
1452       --  encountered.
1453
1454       --  One Last note:  In ambiguous cases, the currency is treated as
1455       --  floating unless there is only one '#'.
1456
1457       procedure Leading_Pound is
1458
1459          Inserts : Boolean := False;
1460          --  Set to True if a '_', '0', '/', 'B', or 'b' is encountered
1461
1462          Must_Float : Boolean := False;
1463          --  Set to true if a '#' occurs after an insert
1464
1465       begin
1466          Debug_Start ("Leading_Pound");
1467
1468          --  Treat as a floating currency. If it isn't, this will be
1469          --  overwritten later.
1470
1471          if Pic.Floater /= '!' and then Pic.Floater /= '#' then
1472
1473             --  Two floats not allowed
1474
1475             raise Picture_Error;
1476
1477          else
1478             Pic.Floater := '#';
1479          end if;
1480
1481          Pic.Start_Currency := Index;
1482          Pic.End_Currency := Index;
1483          Pic.Start_Float := Index;
1484          Pic.End_Float := Index;
1485
1486          --  Don't increment Pic.Max_Leading_Digits, we need one "real"
1487          --  currency place.
1488
1489          Pic.Max_Currency_Digits := 1; --  we've seen one.
1490
1491          Skip; --  known '#'
1492
1493          loop
1494             if At_End then
1495                return;
1496             end if;
1497
1498             case Look is
1499
1500                when '_' | '0' | '/' =>
1501                   Pic.End_Float := Index;
1502                   Inserts := True;
1503                   Skip;
1504
1505                when 'B' | 'b'  =>
1506                   Pic.Picture.Expanded (Index) := 'b';
1507                   Pic.End_Float := Index;
1508                   Inserts := True;
1509                   Skip;
1510
1511                when 'Z' | 'z' =>
1512                   Pic.Picture.Expanded (Index) := 'Z'; -- consistency
1513
1514                   if Must_Float then
1515                      raise Picture_Error;
1516                   else
1517                      Pic.Max_Leading_Digits := 0;
1518
1519                      --  Overwrite Floater and Start_Float
1520
1521                      Pic.Floater := 'Z';
1522                      Pic.Start_Float := Index;
1523                      Zero_Suppression;
1524                   end if;
1525
1526                when '*' =>
1527                   if Must_Float then
1528                      raise Picture_Error;
1529                   else
1530                      Pic.Max_Leading_Digits := 0;
1531
1532                      --  Overwrite Floater and Start_Float
1533                      Pic.Floater := '*';
1534                      Pic.Start_Float := Index;
1535                      Star_Suppression;
1536                   end if;
1537
1538                when '#' =>
1539                   if Inserts then
1540                      Must_Float := True;
1541                   end if;
1542
1543                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1544                   Pic.End_Float := Index;
1545                   Pic.End_Currency := Index;
1546                   Set_State (Okay);
1547                   Skip;
1548
1549                when '9' =>
1550                   if State /= Okay then
1551
1552                      --  A single '#' doesn't float
1553
1554                      Pic.Floater := '!';
1555                      Pic.Start_Float := Invalid_Position;
1556                      Pic.End_Float := Invalid_Position;
1557                   end if;
1558
1559                   Number_Completion;
1560                   return;
1561
1562                when 'V' | 'v' | '.' =>
1563                   if State /= Okay then
1564                      Pic.Floater := '!';
1565                      Pic.Start_Float := Invalid_Position;
1566                      Pic.End_Float := Invalid_Position;
1567                   end if;
1568
1569                   --  Only one pound before the sign is okay, but doesn't
1570                   --  float.
1571
1572                   Pic.Radix_Position := Index;
1573                   Skip;
1574                   Number_Fraction_Or_Pound;
1575                   return;
1576
1577                when others =>
1578                   return;
1579             end case;
1580          end loop;
1581       end Leading_Pound;
1582
1583       ----------
1584       -- Look --
1585       ----------
1586
1587       function Look return Character is
1588       begin
1589          if At_End then
1590             raise Picture_Error;
1591          end if;
1592
1593          return Pic.Picture.Expanded (Index);
1594       end Look;
1595
1596       ------------
1597       -- Number --
1598       ------------
1599
1600       procedure Number is
1601       begin
1602          Debug_Start ("Number");
1603
1604          loop
1605
1606             case Look is
1607                when '_' | '0' | '/' =>
1608                   Skip;
1609
1610                when 'B' | 'b'  =>
1611                   Pic.Picture.Expanded (Index) := 'b';
1612                   Skip;
1613
1614                when '9' =>
1615                   Computed_BWZ := False;
1616                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1617                   Set_State (Okay);
1618                   Skip;
1619
1620                when '.' | 'V' | 'v' =>
1621                   Pic.Radix_Position := Index;
1622                   Skip;
1623                   Number_Fraction;
1624                   return;
1625
1626                when others =>
1627                   return;
1628
1629             end case;
1630
1631             if At_End then
1632                return;
1633             end if;
1634
1635             --  Will return in Okay state if a '9' was seen
1636
1637          end loop;
1638       end Number;
1639
1640       -----------------------
1641       -- Number_Completion --
1642       -----------------------
1643
1644       procedure Number_Completion is
1645       begin
1646          Debug_Start ("Number_Completion");
1647
1648          while not At_End loop
1649             case Look is
1650
1651                when '_' | '0' | '/' =>
1652                   Skip;
1653
1654                when 'B' | 'b'  =>
1655                   Pic.Picture.Expanded (Index) := 'b';
1656                   Skip;
1657
1658                when '9' =>
1659                   Computed_BWZ := False;
1660                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
1661                   Set_State (Okay);
1662                   Skip;
1663
1664                when 'V' | 'v' | '.' =>
1665                   Pic.Radix_Position := Index;
1666                   Skip;
1667                   Number_Fraction;
1668                   return;
1669
1670                when others =>
1671                   return;
1672             end case;
1673          end loop;
1674       end Number_Completion;
1675
1676       ---------------------
1677       -- Number_Fraction --
1678       ---------------------
1679
1680       procedure Number_Fraction is
1681       begin
1682          --  Note that number fraction can be called in either State.
1683          --  It will set state to Valid only if a 9 is encountered.
1684
1685          Debug_Start ("Number_Fraction");
1686
1687          loop
1688             if At_End then
1689                return;
1690             end if;
1691
1692             case Look is
1693                when '_' | '0' | '/' =>
1694                   Skip;
1695
1696                when 'B' | 'b'  =>
1697                   Pic.Picture.Expanded (Index) := 'b';
1698                   Skip;
1699
1700                when '9' =>
1701                   Computed_BWZ := False;
1702                   Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1703                   Set_State (Okay); Skip;
1704
1705                when others =>
1706                   return;
1707             end case;
1708          end loop;
1709       end Number_Fraction;
1710
1711       --------------------------------
1712       -- Number_Fraction_Or_Bracket --
1713       --------------------------------
1714
1715       procedure Number_Fraction_Or_Bracket is
1716       begin
1717          Debug_Start ("Number_Fraction_Or_Bracket");
1718
1719          loop
1720             if At_End then
1721                return;
1722             end if;
1723
1724             case Look is
1725
1726                when '_' | '0' | '/' => Skip;
1727
1728                when 'B' | 'b'  =>
1729                   Pic.Picture.Expanded (Index) := 'b';
1730                   Skip;
1731
1732                when '<' =>
1733                   Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1734                   Pic.End_Float := Index;
1735                   Skip;
1736
1737                   loop
1738                      if At_End then
1739                         return;
1740                      end if;
1741
1742                      case Look is
1743                         when '_' | '0' | '/' =>
1744                            Skip;
1745
1746                         when 'B' | 'b'  =>
1747                            Pic.Picture.Expanded (Index) := 'b';
1748                            Skip;
1749
1750                         when '<' =>
1751                            Pic.Max_Trailing_Digits :=
1752                              Pic.Max_Trailing_Digits + 1;
1753                            Pic.End_Float := Index;
1754                            Skip;
1755
1756                         when others =>
1757                            return;
1758                      end case;
1759                   end loop;
1760
1761                when others =>
1762                   Number_Fraction;
1763                   return;
1764             end case;
1765          end loop;
1766       end Number_Fraction_Or_Bracket;
1767
1768       -------------------------------
1769       -- Number_Fraction_Or_Dollar --
1770       -------------------------------
1771
1772       procedure Number_Fraction_Or_Dollar is
1773       begin
1774          Debug_Start ("Number_Fraction_Or_Dollar");
1775
1776          loop
1777             if At_End then
1778                return;
1779             end if;
1780
1781             case Look is
1782                when '_' | '0' | '/' =>
1783                   Skip;
1784
1785                when 'B' | 'b'  =>
1786                   Pic.Picture.Expanded (Index) := 'b';
1787                   Skip;
1788
1789                when '$' =>
1790                   Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1791                   Pic.End_Float := Index;
1792                   Skip;
1793
1794                   loop
1795                      if At_End then
1796                         return;
1797                      end if;
1798
1799                      case Look is
1800                         when '_' | '0' | '/' =>
1801                            Skip;
1802
1803                         when 'B' | 'b'  =>
1804                            Pic.Picture.Expanded (Index) := 'b';
1805                            Skip;
1806
1807                         when '$' =>
1808                            Pic.Max_Trailing_Digits :=
1809                              Pic.Max_Trailing_Digits + 1;
1810                            Pic.End_Float := Index;
1811                            Skip;
1812
1813                         when others =>
1814                            return;
1815                      end case;
1816                   end loop;
1817
1818                when others =>
1819                   Number_Fraction;
1820                   return;
1821             end case;
1822          end loop;
1823       end Number_Fraction_Or_Dollar;
1824
1825       ------------------------------
1826       -- Number_Fraction_Or_Pound --
1827       ------------------------------
1828
1829       procedure Number_Fraction_Or_Pound is
1830       begin
1831          loop
1832             if At_End then
1833                return;
1834             end if;
1835
1836             case Look is
1837
1838                when '_' | '0' | '/' =>
1839                   Skip;
1840
1841                when 'B' | 'b'  =>
1842                   Pic.Picture.Expanded (Index) := 'b';
1843                   Skip;
1844
1845                when '#' =>
1846                   Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1847                   Pic.End_Float := Index;
1848                   Skip;
1849
1850                   loop
1851                      if At_End then
1852                         return;
1853                      end if;
1854
1855                      case Look is
1856
1857                         when '_' | '0' | '/' =>
1858                            Skip;
1859
1860                         when 'B' | 'b'  =>
1861                            Pic.Picture.Expanded (Index) := 'b';
1862                            Skip;
1863
1864                         when '#' =>
1865                            Pic.Max_Trailing_Digits :=
1866                              Pic.Max_Trailing_Digits + 1;
1867                            Pic.End_Float := Index;
1868                            Skip;
1869
1870                         when others =>
1871                            return;
1872
1873                      end case;
1874                   end loop;
1875
1876                when others =>
1877                   Number_Fraction;
1878                   return;
1879
1880             end case;
1881          end loop;
1882       end Number_Fraction_Or_Pound;
1883
1884       ----------------------------------
1885       -- Number_Fraction_Or_Star_Fill --
1886       ----------------------------------
1887
1888       procedure Number_Fraction_Or_Star_Fill is
1889       begin
1890          Debug_Start ("Number_Fraction_Or_Star_Fill");
1891
1892          loop
1893             if At_End then
1894                return;
1895             end if;
1896
1897             case Look is
1898
1899                when '_' | '0' | '/' =>
1900                   Skip;
1901
1902                when 'B' | 'b'  =>
1903                   Pic.Picture.Expanded (Index) := 'b';
1904                   Skip;
1905
1906                when '*' =>
1907                   Pic.Star_Fill := True;
1908                   Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1909                   Pic.End_Float := Index;
1910                   Skip;
1911
1912                   loop
1913                      if At_End then
1914                         return;
1915                      end if;
1916
1917                      case Look is
1918
1919                         when '_' | '0' | '/' =>
1920                            Skip;
1921
1922                         when 'B' | 'b'  =>
1923                            Pic.Picture.Expanded (Index) := 'b';
1924                            Skip;
1925
1926                         when '*' =>
1927                            Pic.Star_Fill := True;
1928                            Pic.Max_Trailing_Digits :=
1929                              Pic.Max_Trailing_Digits + 1;
1930                            Pic.End_Float := Index;
1931                            Skip;
1932
1933                         when others =>
1934                            return;
1935                      end case;
1936                   end loop;
1937
1938                when others =>
1939                   Number_Fraction;
1940                   return;
1941
1942             end case;
1943          end loop;
1944       end Number_Fraction_Or_Star_Fill;
1945
1946       -------------------------------
1947       -- Number_Fraction_Or_Z_Fill --
1948       -------------------------------
1949
1950       procedure Number_Fraction_Or_Z_Fill is
1951       begin
1952          Debug_Start ("Number_Fraction_Or_Z_Fill");
1953
1954          loop
1955             if At_End then
1956                return;
1957             end if;
1958
1959             case Look is
1960
1961                when '_' | '0' | '/' =>
1962                   Skip;
1963
1964                when 'B' | 'b'  =>
1965                   Pic.Picture.Expanded (Index) := 'b';
1966                   Skip;
1967
1968                when 'Z' | 'z' =>
1969                   Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
1970                   Pic.End_Float := Index;
1971                   Pic.Picture.Expanded (Index) := 'Z'; -- consistency
1972
1973                   Skip;
1974
1975                   loop
1976                      if At_End then
1977                         return;
1978                      end if;
1979
1980                      case Look is
1981
1982                         when '_' | '0' | '/' =>
1983                            Skip;
1984
1985                         when 'B' | 'b'  =>
1986                            Pic.Picture.Expanded (Index) := 'b';
1987                            Skip;
1988
1989                         when 'Z' | 'z' =>
1990                            Pic.Picture.Expanded (Index) := 'Z'; -- consistency
1991
1992                            Pic.Max_Trailing_Digits :=
1993                              Pic.Max_Trailing_Digits + 1;
1994                            Pic.End_Float := Index;
1995                            Skip;
1996
1997                         when others =>
1998                            return;
1999                      end case;
2000                   end loop;
2001
2002                when others =>
2003                   Number_Fraction;
2004                   return;
2005             end case;
2006          end loop;
2007       end Number_Fraction_Or_Z_Fill;
2008
2009       -----------------------
2010       -- Optional_RHS_Sign --
2011       -----------------------
2012
2013       procedure Optional_RHS_Sign is
2014       begin
2015          Debug_Start ("Optional_RHS_Sign");
2016
2017          if At_End then
2018             return;
2019          end if;
2020
2021          case Look is
2022
2023             when '+' | '-' =>
2024                Pic.Sign_Position := Index;
2025                Skip;
2026                return;
2027
2028             when 'C' | 'c' =>
2029                Pic.Sign_Position := Index;
2030                Pic.Picture.Expanded (Index) := 'C';
2031                Skip;
2032
2033                if Look = 'R' or Look = 'r' then
2034                   Pic.Second_Sign := Index;
2035                   Pic.Picture.Expanded (Index) := 'R';
2036                   Skip;
2037
2038                else
2039                   raise Picture_Error;
2040                end if;
2041
2042                return;
2043
2044             when 'D' | 'd' =>
2045                Pic.Sign_Position := Index;
2046                Pic.Picture.Expanded (Index) := 'D';
2047                Skip;
2048
2049                if Look = 'B' or Look = 'b' then
2050                   Pic.Second_Sign := Index;
2051                   Pic.Picture.Expanded (Index) := 'B';
2052                   Skip;
2053
2054                else
2055                   raise Picture_Error;
2056                end if;
2057
2058                return;
2059
2060             when '>' =>
2061                if Pic.Picture.Expanded (Pic.Sign_Position) = '<' then
2062                   Pic.Second_Sign := Index;
2063                   Skip;
2064
2065                else
2066                   raise Picture_Error;
2067                end if;
2068
2069             when others =>
2070                return;
2071
2072          end case;
2073       end Optional_RHS_Sign;
2074
2075       -------------
2076       -- Picture --
2077       -------------
2078
2079       --  Note that Picture can be called in either State
2080
2081       --  It will set state to Valid only if a 9 is encountered or floating
2082       --  currency is called.
2083
2084       procedure Picture is
2085       begin
2086          Debug_Start ("Picture");
2087
2088          loop
2089             if At_End then
2090                return;
2091             end if;
2092
2093             case Look is
2094
2095                when '_' | '0' | '/' =>
2096                   Skip;
2097
2098                when 'B' | 'b'  =>
2099                   Pic.Picture.Expanded (Index) := 'b';
2100                   Skip;
2101
2102                when '$' =>
2103                   Leading_Dollar;
2104                   return;
2105
2106                when '#' =>
2107                   Leading_Pound;
2108                   return;
2109
2110                when '9' =>
2111                   Computed_BWZ := False;
2112                   Set_State (Okay);
2113                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2114                   Skip;
2115
2116                when 'V' | 'v' | '.' =>
2117                   Pic.Radix_Position := Index;
2118                   Skip;
2119                   Number_Fraction;
2120                   Trailing_Currency;
2121                   return;
2122
2123                when others =>
2124                   return;
2125
2126             end case;
2127          end loop;
2128       end Picture;
2129
2130       ---------------------
2131       -- Picture_Bracket --
2132       ---------------------
2133
2134       procedure Picture_Bracket is
2135       begin
2136          Pic.Sign_Position := Index;
2137          Debug_Start ("Picture_Bracket");
2138          Pic.Sign_Position := Index;
2139
2140          --  Treat as a floating sign, and unwind otherwise
2141
2142          Pic.Floater := '<';
2143          Pic.Start_Float := Index;
2144          Pic.End_Float := Index;
2145
2146          --  Don't increment Pic.Max_Leading_Digits, we need one "real"
2147          --  sign place.
2148
2149          Skip; --  Known Bracket
2150
2151          loop
2152             case Look is
2153
2154                when '_' | '0' | '/' =>
2155                   Pic.End_Float := Index;
2156                   Skip;
2157
2158                when 'B' | 'b'  =>
2159                   Pic.End_Float := Index;
2160                   Pic.Picture.Expanded (Index) := 'b';
2161                   Skip;
2162
2163                when '<' =>
2164                   Set_State (Okay);  --  "<<>" is enough.
2165                   Floating_Bracket;
2166                   Trailing_Currency;
2167                   Trailing_Bracket;
2168                   return;
2169
2170                when '$' | '#' | '9' | '*' =>
2171                   if State /= Okay then
2172                      Pic.Floater := '!';
2173                      Pic.Start_Float := Invalid_Position;
2174                      Pic.End_Float := Invalid_Position;
2175                   end if;
2176
2177                   Picture;
2178                   Trailing_Bracket;
2179                   Set_State (Okay);
2180                   return;
2181
2182                when '.' | 'V' | 'v' =>
2183                   if State /= Okay then
2184                      Pic.Floater := '!';
2185                      Pic.Start_Float := Invalid_Position;
2186                      Pic.End_Float := Invalid_Position;
2187                   end if;
2188
2189                   --  Don't assume that state is okay, haven't seen a digit
2190
2191                   Picture;
2192                   Trailing_Bracket;
2193                   return;
2194
2195                when others =>
2196                   raise Picture_Error;
2197
2198             end case;
2199          end loop;
2200       end Picture_Bracket;
2201
2202       -------------------
2203       -- Picture_Minus --
2204       -------------------
2205
2206       procedure Picture_Minus is
2207       begin
2208          Debug_Start ("Picture_Minus");
2209
2210          Pic.Sign_Position := Index;
2211
2212          --  Treat as a floating sign, and unwind otherwise
2213
2214          Pic.Floater := '-';
2215          Pic.Start_Float := Index;
2216          Pic.End_Float := Index;
2217
2218          --  Don't increment Pic.Max_Leading_Digits, we need one "real"
2219          --  sign place.
2220
2221          Skip; --  Known Minus
2222
2223          loop
2224             case Look is
2225
2226                when '_' | '0' | '/' =>
2227                   Pic.End_Float := Index;
2228                   Skip;
2229
2230                when 'B' | 'b'  =>
2231                   Pic.End_Float := Index;
2232                   Pic.Picture.Expanded (Index) := 'b';
2233                   Skip;
2234
2235                when '-' =>
2236                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2237                   Pic.End_Float := Index;
2238                   Skip;
2239                   Set_State (Okay);  --  "-- " is enough.
2240                   Floating_Minus;
2241                   Trailing_Currency;
2242                   return;
2243
2244                when '$' | '#' | '9' | '*' =>
2245                   if State /= Okay then
2246                      Pic.Floater := '!';
2247                      Pic.Start_Float := Invalid_Position;
2248                      Pic.End_Float := Invalid_Position;
2249                   end if;
2250
2251                   Picture;
2252                   Set_State (Okay);
2253                   return;
2254
2255                when 'Z' | 'z' =>
2256
2257                   --  Can't have Z and a floating sign
2258
2259                   if State = Okay then
2260                      Set_State (Reject);
2261                   end if;
2262
2263                   Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2264                   Zero_Suppression;
2265                   Trailing_Currency;
2266                   Optional_RHS_Sign;
2267                   return;
2268
2269                when '.' | 'V' | 'v' =>
2270                   if State /= Okay then
2271                      Pic.Floater := '!';
2272                      Pic.Start_Float := Invalid_Position;
2273                      Pic.End_Float := Invalid_Position;
2274                   end if;
2275
2276                   --  Don't assume that state is okay, haven't seen a digit
2277
2278                   Picture;
2279                   return;
2280
2281                when others =>
2282                   return;
2283
2284             end case;
2285          end loop;
2286       end Picture_Minus;
2287
2288       ------------------
2289       -- Picture_Plus --
2290       ------------------
2291
2292       procedure Picture_Plus is
2293       begin
2294          Debug_Start ("Picture_Plus");
2295          Pic.Sign_Position := Index;
2296
2297          --  Treat as a floating sign, and unwind otherwise
2298
2299          Pic.Floater := '+';
2300          Pic.Start_Float := Index;
2301          Pic.End_Float := Index;
2302
2303          --  Don't increment Pic.Max_Leading_Digits, we need one "real"
2304          --  sign place.
2305
2306          Skip; --  Known Plus
2307
2308          loop
2309             case Look is
2310
2311                when '_' | '0' | '/' =>
2312                   Pic.End_Float := Index;
2313                   Skip;
2314
2315                when 'B' | 'b'  =>
2316                   Pic.End_Float := Index;
2317                   Pic.Picture.Expanded (Index) := 'b';
2318                   Skip;
2319
2320                when '+' =>
2321                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2322                   Pic.End_Float := Index;
2323                   Skip;
2324                   Set_State (Okay);  --  "++" is enough
2325                   Floating_Plus;
2326                   Trailing_Currency;
2327                   return;
2328
2329                when '$' | '#' | '9' | '*' =>
2330                   if State /= Okay then
2331                      Pic.Floater := '!';
2332                      Pic.Start_Float := Invalid_Position;
2333                      Pic.End_Float := Invalid_Position;
2334                   end if;
2335
2336                   Picture;
2337                   Set_State (Okay);
2338                   return;
2339
2340                when 'Z' | 'z' =>
2341                   if State = Okay then
2342                      Set_State (Reject);
2343                   end if;
2344
2345                   --  Can't have Z and a floating sign
2346
2347                   Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2348
2349                   --  '+Z' is acceptable
2350
2351                   Set_State (Okay);
2352
2353                   --  Overwrite Floater and Start_Float
2354
2355                   Pic.Floater := 'Z';
2356                   Pic.Start_Float := Index;
2357
2358                   Zero_Suppression;
2359                   Trailing_Currency;
2360                   Optional_RHS_Sign;
2361                   return;
2362
2363                when '.' | 'V' | 'v' =>
2364                   if State /= Okay then
2365                      Pic.Floater := '!';
2366                      Pic.Start_Float := Invalid_Position;
2367                      Pic.End_Float := Invalid_Position;
2368                   end if;
2369
2370                   --  Don't assume that state is okay, haven't seen a digit
2371
2372                   Picture;
2373                   return;
2374
2375                when others =>
2376                   return;
2377
2378             end case;
2379          end loop;
2380       end Picture_Plus;
2381
2382       --------------------
2383       -- Picture_String --
2384       --------------------
2385
2386       procedure Picture_String is
2387       begin
2388          Debug_Start ("Picture_String");
2389
2390          while Is_Insert loop
2391             Skip;
2392          end loop;
2393
2394          case Look is
2395
2396             when '$' | '#' =>
2397                Picture;
2398                Optional_RHS_Sign;
2399
2400             when '+' =>
2401                Picture_Plus;
2402
2403             when '-' =>
2404                Picture_Minus;
2405
2406             when '<' =>
2407                Picture_Bracket;
2408
2409             when 'Z' | 'z' =>
2410                Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2411                Zero_Suppression;
2412                Trailing_Currency;
2413                Optional_RHS_Sign;
2414
2415             when '*' =>
2416                Star_Suppression;
2417                Trailing_Currency;
2418                Optional_RHS_Sign;
2419
2420             when '9' | '.' | 'V' | 'v' =>
2421                Number;
2422                Trailing_Currency;
2423                Optional_RHS_Sign;
2424
2425             when others =>
2426                raise Picture_Error;
2427
2428          end case;
2429
2430          --  Blank when zero either if the PIC does not contain a '9' or if
2431          --  requested by the user and no '*'.
2432
2433          Pic.Blank_When_Zero :=
2434            (Computed_BWZ or Pic.Blank_When_Zero) and not Pic.Star_Fill;
2435
2436          --  Star fill if '*' and no '9'
2437
2438          Pic.Star_Fill := Pic.Star_Fill and Computed_BWZ;
2439
2440          if not At_End then
2441             Set_State (Reject);
2442          end if;
2443
2444       end Picture_String;
2445
2446       ---------------
2447       -- Set_State --
2448       ---------------
2449
2450       procedure Set_State (L : Legality) is
2451       begin
2452          if Debug then Ada.Text_IO.Put_Line
2453             ("  Set state from " & Legality'Image (State) &
2454                              " to " & Legality'Image (L));
2455          end if;
2456
2457          State := L;
2458       end Set_State;
2459
2460       ----------
2461       -- Skip --
2462       ----------
2463
2464       procedure Skip is
2465       begin
2466          if Debug then Ada.Text_IO.Put_Line
2467             ("  Skip " & Pic.Picture.Expanded (Index));
2468          end if;
2469
2470          Index := Index + 1;
2471       end Skip;
2472
2473       ----------------------
2474       -- Star_Suppression --
2475       ----------------------
2476
2477       procedure Star_Suppression is
2478       begin
2479          Debug_Start ("Star_Suppression");
2480
2481          if Pic.Floater /= '!' and then Pic.Floater /= '*' then
2482
2483             --  Two floats not allowed
2484
2485             raise Picture_Error;
2486
2487          else
2488             Pic.Floater := '*';
2489          end if;
2490
2491          Pic.Start_Float := Index;
2492          Pic.End_Float := Index;
2493          Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2494          Set_State (Okay);
2495
2496          --  Even a single * is a valid picture
2497
2498          Pic.Star_Fill := True;
2499          Skip; --  Known *
2500
2501          loop
2502             if At_End then
2503                return;
2504             end if;
2505
2506             case Look is
2507
2508                when '_' | '0' | '/' =>
2509                   Pic.End_Float := Index;
2510                   Skip;
2511
2512                when 'B' | 'b'  =>
2513                   Pic.End_Float := Index;
2514                   Pic.Picture.Expanded (Index) := 'b';
2515                   Skip;
2516
2517                when '*' =>
2518                   Pic.End_Float := Index;
2519                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2520                   Set_State (Okay); Skip;
2521
2522                when '9' =>
2523                   Set_State (Okay);
2524                   Number_Completion;
2525                   return;
2526
2527                when '.' | 'V' | 'v' =>
2528                   Pic.Radix_Position := Index;
2529                   Skip;
2530                   Number_Fraction_Or_Star_Fill;
2531                   return;
2532
2533                when '#' | '$' =>
2534                   if Pic.Max_Currency_Digits > 0 then
2535                      raise Picture_Error;
2536                   end if;
2537
2538                   --  Cannot have leading and trailing currency
2539
2540                   Trailing_Currency;
2541                   Set_State (Okay);
2542                   return;
2543
2544                when others => raise Picture_Error;
2545             end case;
2546          end loop;
2547       end Star_Suppression;
2548
2549       ----------------------
2550       -- Trailing_Bracket --
2551       ----------------------
2552
2553       procedure Trailing_Bracket is
2554       begin
2555          Debug_Start ("Trailing_Bracket");
2556
2557          if Look = '>' then
2558             Pic.Second_Sign := Index;
2559             Skip;
2560          else
2561             raise Picture_Error;
2562          end if;
2563       end Trailing_Bracket;
2564
2565       -----------------------
2566       -- Trailing_Currency --
2567       -----------------------
2568
2569       procedure Trailing_Currency is
2570       begin
2571          Debug_Start ("Trailing_Currency");
2572
2573          if At_End then
2574             return;
2575          end if;
2576
2577          if Look = '$' then
2578             Pic.Start_Currency := Index;
2579             Pic.End_Currency := Index;
2580             Skip;
2581
2582          else
2583             while not At_End and then Look = '#' loop
2584                if Pic.Start_Currency = Invalid_Position then
2585                   Pic.Start_Currency := Index;
2586                end if;
2587
2588                Pic.End_Currency := Index;
2589                Skip;
2590             end loop;
2591          end if;
2592
2593          loop
2594             if At_End then
2595                return;
2596             end if;
2597
2598             case Look is
2599                when '_' | '0' | '/' => Skip;
2600
2601                when 'B' | 'b'  =>
2602                   Pic.Picture.Expanded (Index) := 'b';
2603                   Skip;
2604
2605                when others => return;
2606             end case;
2607          end loop;
2608       end Trailing_Currency;
2609
2610       ----------------------
2611       -- Zero_Suppression --
2612       ----------------------
2613
2614       procedure Zero_Suppression is
2615       begin
2616          Debug_Start ("Zero_Suppression");
2617
2618          Pic.Floater := 'Z';
2619          Pic.Start_Float := Index;
2620          Pic.End_Float := Index;
2621          Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2622          Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2623
2624          Skip; --  Known Z
2625
2626          loop
2627             --  Even a single Z is a valid picture
2628
2629             if At_End then
2630                Set_State (Okay);
2631                return;
2632             end if;
2633
2634             case Look is
2635                when '_' | '0' | '/' =>
2636                   Pic.End_Float := Index;
2637                   Skip;
2638
2639                when 'B' | 'b'  =>
2640                   Pic.End_Float := Index;
2641                   Pic.Picture.Expanded (Index) := 'b';
2642                   Skip;
2643
2644                when 'Z' | 'z' =>
2645                   Pic.Picture.Expanded (Index) := 'Z'; -- consistency
2646
2647                   Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
2648                   Pic.End_Float := Index;
2649                   Set_State (Okay);
2650                   Skip;
2651
2652                when '9' =>
2653                   Set_State (Okay);
2654                   Number_Completion;
2655                   return;
2656
2657                when '.' | 'V' | 'v' =>
2658                   Pic.Radix_Position := Index;
2659                   Skip;
2660                   Number_Fraction_Or_Z_Fill;
2661                   return;
2662
2663                when '#' | '$' =>
2664                   Trailing_Currency;
2665                   Set_State (Okay);
2666                   return;
2667
2668                when others =>
2669                   return;
2670             end case;
2671          end loop;
2672       end Zero_Suppression;
2673
2674    --  Start of processing for Precalculate
2675
2676    begin
2677       pragma Debug (Set_Debug);
2678
2679       Picture_String;
2680
2681       if Debug then
2682          Ada.Text_IO.New_Line;
2683          Ada.Text_IO.Put (" Picture : """ &
2684                      Pic.Picture.Expanded (1 .. Pic.Picture.Length) & """,");
2685          Ada.Text_IO.Put (" Floater : '" & Pic.Floater & "',");
2686       end if;
2687
2688       if State = Reject then
2689          raise Picture_Error;
2690       end if;
2691
2692       Debug_Integer (Pic.Radix_Position, "Radix Positon : ");
2693       Debug_Integer (Pic.Sign_Position, "Sign Positon : ");
2694       Debug_Integer (Pic.Second_Sign, "Second Sign : ");
2695       Debug_Integer (Pic.Start_Float, "Start Float : ");
2696       Debug_Integer (Pic.End_Float, "End Float : ");
2697       Debug_Integer (Pic.Start_Currency, "Start Currency : ");
2698       Debug_Integer (Pic.End_Currency, "End Currency : ");
2699       Debug_Integer (Pic.Max_Leading_Digits, "Max Leading Digits : ");
2700       Debug_Integer (Pic.Max_Trailing_Digits, "Max Trailing Digits : ");
2701
2702       if Debug then
2703          Ada.Text_IO.New_Line;
2704       end if;
2705
2706    exception
2707
2708       when Constraint_Error =>
2709
2710       --  To deal with special cases like null strings
2711
2712       raise Picture_Error;
2713    end Precalculate;
2714
2715    ----------------
2716    -- To_Picture --
2717    ----------------
2718
2719    function To_Picture
2720      (Pic_String      : in String;
2721       Blank_When_Zero : in Boolean := False)
2722       return            Picture
2723    is
2724       Result : Picture;
2725
2726    begin
2727       declare
2728          Item : constant String := Expand (Pic_String);
2729
2730       begin
2731          Result.Contents.Picture         := (Item'Length, Item);
2732          Result.Contents.Original_BWZ := Blank_When_Zero;
2733          Result.Contents.Blank_When_Zero := Blank_When_Zero;
2734          Precalculate (Result.Contents);
2735          return Result;
2736       end;
2737
2738    exception
2739       when others =>
2740          raise Picture_Error;
2741    end To_Picture;
2742
2743    -----------
2744    -- Valid --
2745    -----------
2746
2747    function Valid
2748      (Pic_String      : in String;
2749       Blank_When_Zero : in Boolean := False)
2750       return            Boolean
2751    is
2752    begin
2753       declare
2754          Expanded_Pic : constant String := Expand (Pic_String);
2755          --  Raises Picture_Error if Item not well-formed
2756
2757          Format_Rec : Format_Record;
2758
2759       begin
2760          Format_Rec.Picture := (Expanded_Pic'Length, Expanded_Pic);
2761          Format_Rec.Blank_When_Zero := Blank_When_Zero;
2762          Format_Rec.Original_BWZ := Blank_When_Zero;
2763          Precalculate (Format_Rec);
2764
2765          --  False only if Blank_When_Zero is True but the pic string has a '*'
2766
2767          return not Blank_When_Zero or
2768            Strings_Fixed.Index (Expanded_Pic, "*") = 0;
2769       end;
2770
2771    exception
2772       when others => return False;
2773    end Valid;
2774
2775    --------------------
2776    -- Decimal_Output --
2777    --------------------
2778
2779    package body Decimal_Output is
2780
2781       -----------
2782       -- Image --
2783       -----------
2784
2785       function Image
2786         (Item       : in Num;
2787          Pic        : in Picture;
2788          Currency   : in String    := Default_Currency;
2789          Fill       : in Character := Default_Fill;
2790          Separator  : in Character := Default_Separator;
2791          Radix_Mark : in Character := Default_Radix_Mark)
2792          return       String
2793       is
2794       begin
2795          return Format_Number
2796             (Pic.Contents, Num'Image (Item),
2797              Currency, Fill, Separator, Radix_Mark);
2798       end Image;
2799
2800       ------------
2801       -- Length --
2802       ------------
2803
2804       function Length
2805         (Pic      : in Picture;
2806          Currency : in String := Default_Currency)
2807          return     Natural
2808       is
2809          Picstr     : constant String := Pic_String (Pic);
2810          V_Adjust   : Integer := 0;
2811          Cur_Adjust : Integer := 0;
2812
2813       begin
2814          --  Check if Picstr has 'V' or '$'
2815
2816          --  If 'V', then length is 1 less than otherwise
2817
2818          --  If '$', then length is Currency'Length-1 more than otherwise
2819
2820          --  This should use the string handling package ???
2821
2822          for J in Picstr'Range loop
2823             if Picstr (J) = 'V' then
2824                V_Adjust := -1;
2825
2826             elsif Picstr (J) = '$' then
2827                Cur_Adjust := Currency'Length - 1;
2828             end if;
2829          end loop;
2830
2831          return Picstr'Length - V_Adjust + Cur_Adjust;
2832       end Length;
2833
2834       ---------
2835       -- Put --
2836       ---------
2837
2838       procedure Put
2839         (File       : in Text_IO.File_Type;
2840          Item       : in Num;
2841          Pic        : in Picture;
2842          Currency   : in String    := Default_Currency;
2843          Fill       : in Character := Default_Fill;
2844          Separator  : in Character := Default_Separator;
2845          Radix_Mark : in Character := Default_Radix_Mark)
2846       is
2847       begin
2848          Text_IO.Put (File, Image (Item, Pic,
2849                                    Currency, Fill, Separator, Radix_Mark));
2850       end Put;
2851
2852       procedure Put
2853         (Item       : in Num;
2854          Pic        : in Picture;
2855          Currency   : in String    := Default_Currency;
2856          Fill       : in Character := Default_Fill;
2857          Separator  : in Character := Default_Separator;
2858          Radix_Mark : in Character := Default_Radix_Mark)
2859       is
2860       begin
2861          Text_IO.Put (Image (Item, Pic,
2862                              Currency, Fill, Separator, Radix_Mark));
2863       end Put;
2864
2865       procedure Put
2866         (To         : out String;
2867          Item       : in Num;
2868          Pic        : in Picture;
2869          Currency   : in String    := Default_Currency;
2870          Fill       : in Character := Default_Fill;
2871          Separator  : in Character := Default_Separator;
2872          Radix_Mark : in Character := Default_Radix_Mark)
2873       is
2874          Result : constant String :=
2875            Image (Item, Pic, Currency, Fill, Separator, Radix_Mark);
2876
2877       begin
2878          if Result'Length > To'Length then
2879             raise Ada.Text_IO.Layout_Error;
2880          else
2881             Strings_Fixed.Move (Source => Result, Target => To,
2882                                 Justify => Strings.Right);
2883          end if;
2884       end Put;
2885
2886       -----------
2887       -- Valid --
2888       -----------
2889
2890       function Valid
2891         (Item     : Num;
2892          Pic      : in Picture;
2893          Currency : in String := Default_Currency)
2894          return     Boolean
2895       is
2896       begin
2897          declare
2898             Temp : constant String := Image (Item, Pic, Currency);
2899             pragma Warnings (Off, Temp);
2900          begin
2901             return True;
2902          end;
2903
2904       exception
2905          when Ada.Text_IO.Layout_Error => return False;
2906
2907       end Valid;
2908    end Decimal_Output;
2909
2910 end Ada.Text_IO.Editing;