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