gcc/ada/a-wtedit.adb

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