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