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-2012, 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 and then 633 Answer (Pic.Start_Currency) = '#' then 634 Currency_Pos := 1; 635 end if; 636 637 case Answer (J) is 638 when '*' => 639 Answer (J) := Fill_Character; 640 641 when 'b' => 642 if In_Currency then 643 Answer (J) := Currency_Symbol (Currency_Pos); 644 Currency_Pos := Currency_Pos + 1; 645 646 if Currency_Pos > Currency_Symbol'Length then 647 In_Currency := False; 648 end if; 649 end if; 650 651 when '#' => 652 if Currency_Pos > Currency_Symbol'Length then 653 Answer (J) := ' '; 654 655 else 656 In_Currency := True; 657 Answer (J) := Currency_Symbol (Currency_Pos); 658 Currency_Pos := Currency_Pos + 1; 659 660 if Currency_Pos > Currency_Symbol'Length then 661 In_Currency := False; 662 end if; 663 end if; 664 665 when '_' => 666 Answer (J) := Currency_Symbol (Currency_Pos); 667 Currency_Pos := Currency_Pos + 1; 668 669 case Pic.Floater is 670 671 when '*' => 672 Answer (J) := Fill_Character; 673 674 when 'Z' | 'z' => 675 Answer (J) := ' '; 676 677 when '#' => 678 if Currency_Pos > Currency_Symbol'Length then 679 Answer (J) := ' '; 680 else 681 Answer (J) := Currency_Symbol (Currency_Pos); 682 Currency_Pos := Currency_Pos + 1; 683 end if; 684 685 when others => 686 null; 687 688 end case; 689 690 when others => 691 exit; 692 693 end case; 694 end loop; 695 696 -- Now get rid of Blank_when_Zero and complete Star fill 697 698 if Zero and then Pic.Blank_When_Zero then 699 700 -- Value is zero, and blank it 701 702 Last := Answer'Last; 703 704 if Dollar then 705 Last := Last - 1 + Currency_Symbol'Length; 706 end if; 707 708 if Pic.Radix_Position /= Invalid_Position and then 709 Answer (Pic.Radix_Position) = 'V' then 710 Last := Last - 1; 711 end if; 712 713 return String'(1 .. Last => ' '); 714 715 elsif Zero and then Pic.Star_Fill then 716 Last := Answer'Last; 717 718 if Dollar then 719 Last := Last - 1 + Currency_Symbol'Length; 720 end if; 721 722 if Pic.Radix_Position /= Invalid_Position then 723 724 if Answer (Pic.Radix_Position) = 'V' then 725 Last := Last - 1; 726 727 elsif Dollar then 728 if Pic.Radix_Position > Pic.Start_Currency then 729 return String'(1 .. Pic.Radix_Position - 1 => '*') & 730 Radix_Point & 731 String'(Pic.Radix_Position + 1 .. Last => '*'); 732 733 else 734 return 735 String' 736 (1 .. 737 Pic.Radix_Position + Currency_Symbol'Length - 2 => 738 '*') & Radix_Point & 739 String' 740 (Pic.Radix_Position + Currency_Symbol'Length .. Last 741 => '*'); 742 end if; 743 744 else 745 return String'(1 .. Pic.Radix_Position - 1 => '*') & 746 Radix_Point & 747 String'(Pic.Radix_Position + 1 .. Last => '*'); 748 end if; 749 end if; 750 751 return String'(1 .. Last => '*'); 752 end if; 753 754 -- This was once a simple return statement, now there are nine 755 -- different return cases. Not to mention the five above to deal 756 -- with zeros. Why not split things out? 757 758 -- Processing the radix and sign expansion separately 759 -- would require lots of copying--the string and some of its 760 -- indicies--without really simplifying the logic. The cases are: 761 762 -- 1) Expand $, replace '.' with Radix_Point 763 -- 2) No currency expansion, replace '.' with Radix_Point 764 -- 3) Expand $, radix blanked 765 -- 4) No currency expansion, radix blanked 766 -- 5) Elide V 767 -- 6) Expand $, Elide V 768 -- 7) Elide V, Expand $ (Two cases depending on order.) 769 -- 8) No radix, expand $ 770 -- 9) No radix, no currency expansion 771 772 if Pic.Radix_Position /= Invalid_Position then 773 774 if Answer (Pic.Radix_Position) = '.' then 775 Answer (Pic.Radix_Position) := Radix_Point; 776 777 if Dollar then 778 779 -- 1) Expand $, replace '.' with Radix_Point 780 781 return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & 782 Answer (Currency_Pos + 1 .. Answer'Last); 783 784 else 785 -- 2) No currency expansion, replace '.' with Radix_Point 786 787 return Answer; 788 end if; 789 790 elsif Answer (Pic.Radix_Position) = ' ' then -- blanked radix. 791 if Dollar then 792 793 -- 3) Expand $, radix blanked 794 795 return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & 796 Answer (Currency_Pos + 1 .. Answer'Last); 797 798 else 799 -- 4) No expansion, radix blanked 800 801 return Answer; 802 end if; 803 804 -- V cases 805 806 else 807 if not Dollar then 808 809 -- 5) Elide V 810 811 return Answer (1 .. Pic.Radix_Position - 1) & 812 Answer (Pic.Radix_Position + 1 .. Answer'Last); 813 814 elsif Currency_Pos < Pic.Radix_Position then 815 816 -- 6) Expand $, Elide V 817 818 return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & 819 Answer (Currency_Pos + 1 .. Pic.Radix_Position - 1) & 820 Answer (Pic.Radix_Position + 1 .. Answer'Last); 821 822 else 823 -- 7) Elide V, Expand $ 824 825 return Answer (1 .. Pic.Radix_Position - 1) & 826 Answer (Pic.Radix_Position + 1 .. Currency_Pos - 1) & 827 Currency_Symbol & 828 Answer (Currency_Pos + 1 .. Answer'Last); 829 end if; 830 end if; 831 832 elsif Dollar then 833 834 -- 8) No radix, expand $ 835 836 return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & 837 Answer (Currency_Pos + 1 .. Answer'Last); 838 839 else 840 -- 9) No radix, no currency expansion 841 842 return Answer; 843 end if; 844 end Format_Number; 845 846 ------------------------- 847 -- Parse_Number_String -- 848 ------------------------- 849 850 function Parse_Number_String (Str : String) return Number_Attributes is 851 Answer : Number_Attributes; 852 853 begin 854 for J in Str'Range loop 855 case Str (J) is 856 857 when ' ' => 858 null; -- ignore 859 860 when '1' .. '9' => 861 862 -- Decide if this is the start of a number. 863 -- If so, figure out which one... 864 865 if Answer.Has_Fraction then 866 Answer.End_Of_Fraction := J; 867 else 868 if Answer.Start_Of_Int = Invalid_Position then 869 -- start integer 870 Answer.Start_Of_Int := J; 871 end if; 872 Answer.End_Of_Int := J; 873 end if; 874 875 when '0' => 876 877 -- Only count a zero before the decimal point if it follows a 878 -- non-zero digit. After the decimal point, zeros will be 879 -- counted if followed by a non-zero digit. 880 881 if not Answer.Has_Fraction then 882 if Answer.Start_Of_Int /= Invalid_Position then 883 Answer.End_Of_Int := J; 884 end if; 885 end if; 886 887 when '-' => 888 889 -- Set negative 890 891 Answer.Negative := True; 892 893 when '.' => 894 895 -- Close integer, start fraction 896 897 if Answer.Has_Fraction then 898 raise Picture_Error; 899 end if; 900 901 -- Two decimal points is a no-no 902 903 Answer.Has_Fraction := True; 904 Answer.End_Of_Fraction := J; 905 906 -- Could leave this at Invalid_Position, but this seems the 907 -- right way to indicate a null range... 908 909 Answer.Start_Of_Fraction := J + 1; 910 Answer.End_Of_Int := J - 1; 911 912 when others => 913 raise Picture_Error; -- can this happen? probably not! 914 end case; 915 end loop; 916 917 if Answer.Start_Of_Int = Invalid_Position then 918 Answer.Start_Of_Int := Answer.End_Of_Int + 1; 919 end if; 920 921 -- No significant (integer) digits needs a null range 922 923 return Answer; 924 end Parse_Number_String; 925 926 ---------------- 927 -- Pic_String -- 928 ---------------- 929 930 -- The following ensures that we return B and not b being careful not 931 -- to break things which expect lower case b for blank. See CXF3A02. 932 933 function Pic_String (Pic : Picture) return String is 934 Temp : String (1 .. Pic.Contents.Picture.Length) := 935 Pic.Contents.Picture.Expanded; 936 begin 937 for J in Temp'Range loop 938 if Temp (J) = 'b' then 939 Temp (J) := 'B'; 940 end if; 941 end loop; 942 943 return Temp; 944 end Pic_String; 945 946 ------------------ 947 -- Precalculate -- 948 ------------------ 949 950 procedure Precalculate (Pic : in out Format_Record) is 951 Debug : constant Boolean := False; 952 -- Set True to generate debug output 953 954 Computed_BWZ : Boolean := True; 955 956 type Legality is (Okay, Reject); 957 958 State : Legality := Reject; 959 -- Start in reject, which will reject null strings 960 961 Index : Pic_Index := Pic.Picture.Expanded'First; 962 963 function At_End return Boolean; 964 pragma Inline (At_End); 965 966 procedure Set_State (L : Legality); 967 pragma Inline (Set_State); 968 969 function Look return Character; 970 pragma Inline (Look); 971 972 function Is_Insert return Boolean; 973 pragma Inline (Is_Insert); 974 975 procedure Skip; 976 pragma Inline (Skip); 977 978 procedure Debug_Start (Name : String); 979 pragma Inline (Debug_Start); 980 981 procedure Debug_Integer (Value : Integer; S : String); 982 pragma Inline (Debug_Integer); 983 984 procedure Trailing_Currency; 985 procedure Trailing_Bracket; 986 procedure Number_Fraction; 987 procedure Number_Completion; 988 procedure Number_Fraction_Or_Bracket; 989 procedure Number_Fraction_Or_Z_Fill; 990 procedure Zero_Suppression; 991 procedure Floating_Bracket; 992 procedure Number_Fraction_Or_Star_Fill; 993 procedure Star_Suppression; 994 procedure Number_Fraction_Or_Dollar; 995 procedure Leading_Dollar; 996 procedure Number_Fraction_Or_Pound; 997 procedure Leading_Pound; 998 procedure Picture; 999 procedure Floating_Plus; 1000 procedure Floating_Minus; 1001 procedure Picture_Plus; 1002 procedure Picture_Minus; 1003 procedure Picture_Bracket; 1004 procedure Number; 1005 procedure Optional_RHS_Sign; 1006 procedure Picture_String; 1007 procedure Set_Debug; 1008 1009 ------------ 1010 -- At_End -- 1011 ------------ 1012 1013 function At_End return Boolean is 1014 begin 1015 Debug_Start ("At_End"); 1016 return Index > Pic.Picture.Length; 1017 end At_End; 1018 1019 -------------- 1020 -- Set_Debug-- 1021 -------------- 1022 1023 -- Needed to have a procedure to pass to pragma Debug 1024 1025 procedure Set_Debug is 1026 begin 1027 -- Uncomment this line and make Debug a variable to enable debug 1028 1029 -- Debug := True; 1030 1031 null; 1032 end Set_Debug; 1033 1034 ------------------- 1035 -- Debug_Integer -- 1036 ------------------- 1037 1038 procedure Debug_Integer (Value : Integer; S : String) is 1039 use Ada.Text_IO; -- needed for > 1040 1041 begin 1042 if Debug and then Value > 0 then 1043 if Ada.Text_IO.Col > 70 - S'Length then 1044 Ada.Text_IO.New_Line; 1045 end if; 1046 1047 Ada.Text_IO.Put (' ' & S & Integer'Image (Value) & ','); 1048 end if; 1049 end Debug_Integer; 1050 1051 ----------------- 1052 -- Debug_Start -- 1053 ----------------- 1054 1055 procedure Debug_Start (Name : String) is 1056 begin 1057 if Debug then 1058 Ada.Text_IO.Put_Line (" In " & Name & '.'); 1059 end if; 1060 end Debug_Start; 1061 1062 ---------------------- 1063 -- Floating_Bracket -- 1064 ---------------------- 1065 1066 -- Note that Floating_Bracket is only called with an acceptable 1067 -- prefix. But we don't set Okay, because we must end with a '>'. 1068 1069 procedure Floating_Bracket is 1070 begin 1071 Debug_Start ("Floating_Bracket"); 1072 1073 -- Two different floats not allowed 1074 1075 if Pic.Floater /= '!' and then Pic.Floater /= '<' then 1076 raise Picture_Error; 1077 1078 else 1079 Pic.Floater := '<'; 1080 end if; 1081 1082 Pic.End_Float := Index; 1083 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; 1084 1085 -- First bracket wasn't counted... 1086 1087 Skip; -- known '<' 1088 1089 loop 1090 if At_End then 1091 return; 1092 end if; 1093 1094 case Look is 1095 1096 when '_' | '0' | '/' => 1097 Pic.End_Float := Index; 1098 Skip; 1099 1100 when 'B' | 'b' => 1101 Pic.End_Float := Index; 1102 Pic.Picture.Expanded (Index) := 'b'; 1103 Skip; 1104 1105 when '<' => 1106 Pic.End_Float := Index; 1107 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; 1108 Skip; 1109 1110 when '9' => 1111 Number_Completion; 1112 1113 when '$' => 1114 Leading_Dollar; 1115 1116 when '#' => 1117 Leading_Pound; 1118 1119 when 'V' | 'v' | '.' => 1120 Pic.Radix_Position := Index; 1121 Skip; 1122 Number_Fraction_Or_Bracket; 1123 return; 1124 1125 when others => 1126 return; 1127 end case; 1128 end loop; 1129 end Floating_Bracket; 1130 1131 -------------------- 1132 -- Floating_Minus -- 1133 -------------------- 1134 1135 procedure Floating_Minus is 1136 begin 1137 Debug_Start ("Floating_Minus"); 1138 1139 loop 1140 if At_End then 1141 return; 1142 end if; 1143 1144 case Look is 1145 when '_' | '0' | '/' => 1146 Pic.End_Float := Index; 1147 Skip; 1148 1149 when 'B' | 'b' => 1150 Pic.End_Float := Index; 1151 Pic.Picture.Expanded (Index) := 'b'; 1152 Skip; 1153 1154 when '-' => 1155 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; 1156 Pic.End_Float := Index; 1157 Skip; 1158 1159 when '9' => 1160 Number_Completion; 1161 return; 1162 1163 when '.' | 'V' | 'v' => 1164 Pic.Radix_Position := Index; 1165 Skip; -- Radix 1166 1167 while Is_Insert loop 1168 Skip; 1169 end loop; 1170 1171 if At_End then 1172 return; 1173 end if; 1174 1175 if Look = '-' then 1176 loop 1177 if At_End then 1178 return; 1179 end if; 1180 1181 case Look is 1182 1183 when '-' => 1184 Pic.Max_Trailing_Digits := 1185 Pic.Max_Trailing_Digits + 1; 1186 Pic.End_Float := Index; 1187 Skip; 1188 1189 when '_' | '0' | '/' => 1190 Skip; 1191 1192 when 'B' | 'b' => 1193 Pic.Picture.Expanded (Index) := 'b'; 1194 Skip; 1195 1196 when others => 1197 return; 1198 1199 end case; 1200 end loop; 1201 1202 else 1203 Number_Completion; 1204 end if; 1205 1206 return; 1207 1208 when others => 1209 return; 1210 end case; 1211 end loop; 1212 end Floating_Minus; 1213 1214 ------------------- 1215 -- Floating_Plus -- 1216 ------------------- 1217 1218 procedure Floating_Plus is 1219 begin 1220 Debug_Start ("Floating_Plus"); 1221 1222 loop 1223 if At_End then 1224 return; 1225 end if; 1226 1227 case Look is 1228 when '_' | '0' | '/' => 1229 Pic.End_Float := Index; 1230 Skip; 1231 1232 when 'B' | 'b' => 1233 Pic.End_Float := Index; 1234 Pic.Picture.Expanded (Index) := 'b'; 1235 Skip; 1236 1237 when '+' => 1238 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; 1239 Pic.End_Float := Index; 1240 Skip; 1241 1242 when '9' => 1243 Number_Completion; 1244 return; 1245 1246 when '.' | 'V' | 'v' => 1247 Pic.Radix_Position := Index; 1248 Skip; -- Radix 1249 1250 while Is_Insert loop 1251 Skip; 1252 end loop; 1253 1254 if At_End then 1255 return; 1256 end if; 1257 1258 if Look = '+' then 1259 loop 1260 if At_End then 1261 return; 1262 end if; 1263 1264 case Look is 1265 1266 when '+' => 1267 Pic.Max_Trailing_Digits := 1268 Pic.Max_Trailing_Digits + 1; 1269 Pic.End_Float := Index; 1270 Skip; 1271 1272 when '_' | '0' | '/' => 1273 Skip; 1274 1275 when 'B' | 'b' => 1276 Pic.Picture.Expanded (Index) := 'b'; 1277 Skip; 1278 1279 when others => 1280 return; 1281 1282 end case; 1283 end loop; 1284 1285 else 1286 Number_Completion; 1287 end if; 1288 1289 return; 1290 1291 when others => 1292 return; 1293 1294 end case; 1295 end loop; 1296 end Floating_Plus; 1297 1298 --------------- 1299 -- Is_Insert -- 1300 --------------- 1301 1302 function Is_Insert return Boolean is 1303 begin 1304 if At_End then 1305 return False; 1306 end if; 1307 1308 case Pic.Picture.Expanded (Index) is 1309 1310 when '_' | '0' | '/' => return True; 1311 1312 when 'B' | 'b' => 1313 Pic.Picture.Expanded (Index) := 'b'; -- canonical 1314 return True; 1315 1316 when others => return False; 1317 end case; 1318 end Is_Insert; 1319 1320 -------------------- 1321 -- Leading_Dollar -- 1322 -------------------- 1323 1324 -- Note that Leading_Dollar can be called in either State. 1325 -- It will set state to Okay only if a 9 or (second) $ 1326 -- is encountered. 1327 1328 -- Also notice the tricky bit with State and Zero_Suppression. 1329 -- Zero_Suppression is Picture_Error if a '$' or a '9' has been 1330 -- encountered, exactly the cases where State has been set. 1331 1332 procedure Leading_Dollar is 1333 begin 1334 Debug_Start ("Leading_Dollar"); 1335 1336 -- Treat as a floating dollar, and unwind otherwise 1337 1338 if Pic.Floater /= '!' and then Pic.Floater /= '$' then 1339 1340 -- Two floats not allowed 1341 1342 raise Picture_Error; 1343 1344 else 1345 Pic.Floater := '$'; 1346 end if; 1347 1348 Pic.Start_Currency := Index; 1349 Pic.End_Currency := Index; 1350 Pic.Start_Float := Index; 1351 Pic.End_Float := Index; 1352 1353 -- Don't increment Pic.Max_Leading_Digits, we need one "real" 1354 -- currency place. 1355 1356 Skip; -- known '$' 1357 1358 loop 1359 if At_End then 1360 return; 1361 end if; 1362 1363 case Look is 1364 1365 when '_' | '0' | '/' => 1366 Pic.End_Float := Index; 1367 Skip; 1368 1369 -- A trailing insertion character is not part of the 1370 -- floating currency, so need to look ahead. 1371 1372 if Look /= '$' then 1373 Pic.End_Float := Pic.End_Float - 1; 1374 end if; 1375 1376 when 'B' | 'b' => 1377 Pic.End_Float := Index; 1378 Pic.Picture.Expanded (Index) := 'b'; 1379 Skip; 1380 1381 when 'Z' | 'z' => 1382 Pic.Picture.Expanded (Index) := 'Z'; -- consistency 1383 1384 if State = Okay then 1385 raise Picture_Error; 1386 else 1387 -- Overwrite Floater and Start_Float 1388 1389 Pic.Floater := 'Z'; 1390 Pic.Start_Float := Index; 1391 Zero_Suppression; 1392 end if; 1393 1394 when '*' => 1395 if State = Okay then 1396 raise Picture_Error; 1397 else 1398 -- Overwrite Floater and Start_Float 1399 1400 Pic.Floater := '*'; 1401 Pic.Start_Float := Index; 1402 Star_Suppression; 1403 end if; 1404 1405 when '$' => 1406 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; 1407 Pic.End_Float := Index; 1408 Pic.End_Currency := Index; 1409 Set_State (Okay); Skip; 1410 1411 when '9' => 1412 if State /= Okay then 1413 Pic.Floater := '!'; 1414 Pic.Start_Float := Invalid_Position; 1415 Pic.End_Float := Invalid_Position; 1416 end if; 1417 1418 -- A single dollar does not a floating make 1419 1420 Number_Completion; 1421 return; 1422 1423 when 'V' | 'v' | '.' => 1424 if State /= Okay then 1425 Pic.Floater := '!'; 1426 Pic.Start_Float := Invalid_Position; 1427 Pic.End_Float := Invalid_Position; 1428 end if; 1429 1430 -- Only one dollar before the sign is okay, but doesn't 1431 -- float. 1432 1433 Pic.Radix_Position := Index; 1434 Skip; 1435 Number_Fraction_Or_Dollar; 1436 return; 1437 1438 when others => 1439 return; 1440 1441 end case; 1442 end loop; 1443 end Leading_Dollar; 1444 1445 ------------------- 1446 -- Leading_Pound -- 1447 ------------------- 1448 1449 -- This one is complex! A Leading_Pound can be fixed or floating, 1450 -- but in some cases the decision has to be deferred until we leave 1451 -- this procedure. Also note that Leading_Pound can be called in 1452 -- either State. 1453 1454 -- It will set state to Okay only if a 9 or (second) # is 1455 -- 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