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