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