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-2013, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with Ada.Strings.Fixed; 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 796 and then Answer (Pic.Start_Currency) = '#' 797 then 798 Currency_Pos := 1; 799 end if; 800 801 -- Note: There are some weird cases J can imagine with 'b' or '#' in 802 -- currency strings where the following code will cause glitches. The 803 -- trick is to tell when the character in the answer should be 804 -- checked, and when to look at the original string. Some other time. 805 -- RIE 11/26/96 ??? 806 807 case Answer (J) is 808 when '*' => 809 Answer (J) := Fill_Character; 810 811 when 'b' => 812 Answer (J) := ' '; 813 814 when '#' => 815 if Currency_Pos > Currency_Symbol'Length then 816 Answer (J) := ' '; 817 818 else 819 Answer (J) := Currency_Symbol (Currency_Pos); 820 Currency_Pos := Currency_Pos + 1; 821 end if; 822 823 when '_' => 824 825 case Pic.Floater is 826 827 when '*' => 828 Answer (J) := Fill_Character; 829 830 when 'Z' | 'z' => 831 Answer (J) := ' '; 832 833 when '#' => 834 if Currency_Pos > Currency_Symbol'Length then 835 Answer (J) := ' '; 836 else 837 Answer (J) := Currency_Symbol (Currency_Pos); 838 Currency_Pos := Currency_Pos + 1; 839 end if; 840 841 when others => 842 null; 843 844 end case; 845 846 when others => 847 exit; 848 849 end case; 850 end loop; 851 852 -- Now get rid of Blank_when_Zero and complete Star fill 853 854 if Zero and then Pic.Blank_When_Zero then 855 856 -- Value is zero, and blank it 857 858 Last := Answer'Last; 859 860 if Dollar then 861 Last := Last - 1 + Currency_Symbol'Length; 862 end if; 863 864 if Pic.Radix_Position /= Invalid_Position 865 and then Answer (Pic.Radix_Position) = 'V' 866 then 867 Last := Last - 1; 868 end if; 869 870 return Wide_String'(1 .. Last => ' '); 871 872 elsif Zero and then Pic.Star_Fill then 873 Last := Answer'Last; 874 875 if Dollar then 876 Last := Last - 1 + Currency_Symbol'Length; 877 end if; 878 879 if Pic.Radix_Position /= Invalid_Position then 880 881 if Answer (Pic.Radix_Position) = 'V' then 882 Last := Last - 1; 883 884 elsif Dollar then 885 if Pic.Radix_Position > Pic.Start_Currency then 886 return Wide_String'(1 .. Pic.Radix_Position - 1 => '*') & 887 Radix_Point & 888 Wide_String'(Pic.Radix_Position + 1 .. Last => '*'); 889 890 else 891 return 892 Wide_String' 893 (1 .. 894 Pic.Radix_Position + Currency_Symbol'Length - 2 895 => '*') & 896 Radix_Point & 897 Wide_String' 898 (Pic.Radix_Position + Currency_Symbol'Length .. Last 899 => '*'); 900 end if; 901 902 else 903 return 904 Wide_String'(1 .. Pic.Radix_Position - 1 => '*') & 905 Radix_Point & 906 Wide_String'(Pic.Radix_Position + 1 .. Last => '*'); 907 end if; 908 end if; 909 910 return Wide_String'(1 .. Last => '*'); 911 end if; 912 913 -- This was once a simple return statement, now there are nine 914 -- different return cases. Not to mention the five above to deal 915 -- with zeros. Why not split things out? 916 917 -- Processing the radix and sign expansion separately would require 918 -- lots of copying--the string and some of its indexes--without 919 -- really simplifying the logic. The cases are: 920 921 -- 1) Expand $, replace '.' with Radix_Point 922 -- 2) No currency expansion, replace '.' with Radix_Point 923 -- 3) Expand $, radix blanked 924 -- 4) No currency expansion, radix blanked 925 -- 5) Elide V 926 -- 6) Expand $, Elide V 927 -- 7) Elide V, Expand $ (Two cases depending on order.) 928 -- 8) No radix, expand $ 929 -- 9) No radix, no currency expansion 930 931 if Pic.Radix_Position /= Invalid_Position then 932 933 if Answer (Pic.Radix_Position) = '.' then 934 Answer (Pic.Radix_Position) := Radix_Point; 935 936 if Dollar then 937 938 -- 1) Expand $, replace '.' with Radix_Point 939 940 return 941 Answer (1 .. Currency_Pos - 1) & Currency_Symbol & 942 Answer (Currency_Pos + 1 .. Answer'Last); 943 944 else 945 -- 2) No currency expansion, replace '.' with Radix_Point 946 947 return Answer; 948 end if; 949 950 elsif Answer (Pic.Radix_Position) = ' ' then -- blanked radix. 951 if Dollar then 952 953 -- 3) Expand $, radix blanked 954 955 return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & 956 Answer (Currency_Pos + 1 .. Answer'Last); 957 958 else 959 -- 4) No expansion, radix blanked 960 961 return Answer; 962 end if; 963 964 -- V cases 965 966 else 967 if not Dollar then 968 969 -- 5) Elide V 970 971 return Answer (1 .. Pic.Radix_Position - 1) & 972 Answer (Pic.Radix_Position + 1 .. Answer'Last); 973 974 elsif Currency_Pos < Pic.Radix_Position then 975 976 -- 6) Expand $, Elide V 977 978 return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & 979 Answer (Currency_Pos + 1 .. Pic.Radix_Position - 1) & 980 Answer (Pic.Radix_Position + 1 .. Answer'Last); 981 982 else 983 -- 7) Elide V, Expand $ 984 985 return Answer (1 .. Pic.Radix_Position - 1) & 986 Answer (Pic.Radix_Position + 1 .. Currency_Pos - 1) & 987 Currency_Symbol & 988 Answer (Currency_Pos + 1 .. Answer'Last); 989 end if; 990 end if; 991 992 elsif Dollar then 993 994 -- 8) No radix, expand $ 995 996 return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & 997 Answer (Currency_Pos + 1 .. Answer'Last); 998 999 else 1000 -- 9) No radix, no currency expansion 1001 1002 return Answer; 1003 end if; 1004 end Format_Number; 1005 1006 ------------------------- 1007 -- Parse_Number_String -- 1008 ------------------------- 1009 1010 function Parse_Number_String (Str : String) return Number_Attributes is 1011 Answer : Number_Attributes; 1012 1013 begin 1014 for J in Str'Range loop 1015 case Str (J) is 1016 1017 when ' ' => 1018 null; -- ignore 1019 1020 when '1' .. '9' => 1021 1022 -- Decide if this is the start of a number. 1023 -- If so, figure out which one... 1024 1025 if Answer.Has_Fraction then 1026 Answer.End_Of_Fraction := J; 1027 else 1028 if Answer.Start_Of_Int = Invalid_Position then 1029 -- start integer 1030 Answer.Start_Of_Int := J; 1031 end if; 1032 Answer.End_Of_Int := J; 1033 end if; 1034 1035 when '0' => 1036 1037 -- Only count a zero before the decimal point if it follows a 1038 -- non-zero digit. After the decimal point, zeros will be 1039 -- counted if followed by a non-zero digit. 1040 1041 if not Answer.Has_Fraction then 1042 if Answer.Start_Of_Int /= Invalid_Position then 1043 Answer.End_Of_Int := J; 1044 end if; 1045 end if; 1046 1047 when '-' => 1048 1049 -- Set negative 1050 1051 Answer.Negative := True; 1052 1053 when '.' => 1054 1055 -- Close integer, start fraction 1056 1057 if Answer.Has_Fraction then 1058 raise Picture_Error; 1059 end if; 1060 1061 -- Two decimal points is a no-no 1062 1063 Answer.Has_Fraction := True; 1064 Answer.End_Of_Fraction := J; 1065 1066 -- Could leave this at Invalid_Position, but this seems the 1067 -- right way to indicate a null range... 1068 1069 Answer.Start_Of_Fraction := J + 1; 1070 Answer.End_Of_Int := J - 1; 1071 1072 when others => 1073 raise Picture_Error; -- can this happen? probably not 1074 end case; 1075 end loop; 1076 1077 if Answer.Start_Of_Int = Invalid_Position then 1078 Answer.Start_Of_Int := Answer.End_Of_Int + 1; 1079 end if; 1080 1081 -- No significant (intger) digits needs a null range 1082 1083 return Answer; 1084 end Parse_Number_String; 1085 1086 ---------------- 1087 -- Pic_String -- 1088 ---------------- 1089 1090 -- The following ensures that we return B and not b being careful not 1091 -- to break things which expect lower case b for blank. See CXF3A02. 1092 1093 function Pic_String (Pic : Picture) return String is 1094 Temp : String (1 .. Pic.Contents.Picture.Length) := 1095 Pic.Contents.Picture.Expanded; 1096 begin 1097 for J in Temp'Range loop 1098 if Temp (J) = 'b' then 1099 Temp (J) := 'B'; 1100 end if; 1101 end loop; 1102 1103 return Temp; 1104 end Pic_String; 1105 1106 ------------------ 1107 -- Precalculate -- 1108 ------------------ 1109 1110 procedure Precalculate (Pic : in out Format_Record) is 1111 1112 Computed_BWZ : Boolean := True; 1113 1114 type Legality is (Okay, Reject); 1115 State : Legality := Reject; 1116 -- Start in reject, which will reject null strings 1117 1118 Index : Pic_Index := Pic.Picture.Expanded'First; 1119 1120 function At_End return Boolean; 1121 pragma Inline (At_End); 1122 1123 procedure Set_State (L : Legality); 1124 pragma Inline (Set_State); 1125 1126 function Look return Character; 1127 pragma Inline (Look); 1128 1129 function Is_Insert return Boolean; 1130 pragma Inline (Is_Insert); 1131 1132 procedure Skip; 1133 pragma Inline (Skip); 1134 1135 procedure Trailing_Currency; 1136 procedure Trailing_Bracket; 1137 procedure Number_Fraction; 1138 procedure Number_Completion; 1139 procedure Number_Fraction_Or_Bracket; 1140 procedure Number_Fraction_Or_Z_Fill; 1141 procedure Zero_Suppression; 1142 procedure Floating_Bracket; 1143 procedure Number_Fraction_Or_Star_Fill; 1144 procedure Star_Suppression; 1145 procedure Number_Fraction_Or_Dollar; 1146 procedure Leading_Dollar; 1147 procedure Number_Fraction_Or_Pound; 1148 procedure Leading_Pound; 1149 procedure Picture; 1150 procedure Floating_Plus; 1151 procedure Floating_Minus; 1152 procedure Picture_Plus; 1153 procedure Picture_Minus; 1154 procedure Picture_Bracket; 1155 procedure Number; 1156 procedure Optional_RHS_Sign; 1157 procedure Picture_String; 1158 1159 ------------ 1160 -- At_End -- 1161 ------------ 1162 1163 function At_End return Boolean is 1164 begin 1165 return Index > Pic.Picture.Length; 1166 end At_End; 1167 1168 ---------------------- 1169 -- Floating_Bracket -- 1170 ---------------------- 1171 1172 -- Note that Floating_Bracket is only called with an acceptable 1173 -- prefix. But we don't set Okay, because we must end with a '>'. 1174 1175 procedure Floating_Bracket is 1176 begin 1177 Pic.Floater := '<'; 1178 Pic.End_Float := Index; 1179 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; 1180 1181 -- First bracket wasn't counted... 1182 1183 Skip; -- known '<' 1184 1185 loop 1186 if At_End then 1187 return; 1188 end if; 1189 1190 case Look is 1191 1192 when '_' | '0' | '/' => 1193 Pic.End_Float := Index; 1194 Skip; 1195 1196 when 'B' | 'b' => 1197 Pic.End_Float := Index; 1198 Pic.Picture.Expanded (Index) := 'b'; 1199 Skip; 1200 1201 when '<' => 1202 Pic.End_Float := Index; 1203 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; 1204 Skip; 1205 1206 when '9' => 1207 Number_Completion; 1208 1209 when '$' => 1210 Leading_Dollar; 1211 1212 when '#' => 1213 Leading_Pound; 1214 1215 when 'V' | 'v' | '.' => 1216 Pic.Radix_Position := Index; 1217 Skip; 1218 Number_Fraction_Or_Bracket; 1219 return; 1220 1221 when others => 1222 return; 1223 end case; 1224 end loop; 1225 end Floating_Bracket; 1226 1227 -------------------- 1228 -- Floating_Minus -- 1229 -------------------- 1230 1231 procedure Floating_Minus is 1232 begin 1233 loop 1234 if At_End then 1235 return; 1236 end if; 1237 1238 case Look is 1239 when '_' | '0' | '/' => 1240 Pic.End_Float := Index; 1241 Skip; 1242 1243 when 'B' | 'b' => 1244 Pic.End_Float := Index; 1245 Pic.Picture.Expanded (Index) := 'b'; 1246 Skip; 1247 1248 when '-' => 1249 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; 1250 Pic.End_Float := Index; 1251 Skip; 1252 1253 when '9' => 1254 Number_Completion; 1255 return; 1256 1257 when '.' | 'V' | 'v' => 1258 Pic.Radix_Position := Index; 1259 Skip; -- Radix 1260 1261 while Is_Insert loop 1262 Skip; 1263 end loop; 1264 1265 if At_End then 1266 return; 1267 end if; 1268 1269 if Look = '-' then 1270 loop 1271 if At_End then 1272 return; 1273 end if; 1274 1275 case Look is 1276 1277 when '-' => 1278 Pic.Max_Trailing_Digits := 1279 Pic.Max_Trailing_Digits + 1; 1280 Pic.End_Float := Index; 1281 Skip; 1282 1283 when '_' | '0' | '/' => 1284 Skip; 1285 1286 when 'B' | 'b' => 1287 Pic.Picture.Expanded (Index) := 'b'; 1288 Skip; 1289 1290 when others => 1291 return; 1292 1293 end case; 1294 end loop; 1295 1296 else 1297 Number_Completion; 1298 end if; 1299 1300 return; 1301 1302 when others => 1303 return; 1304 end case; 1305 end loop; 1306 end Floating_Minus; 1307 1308 ------------------- 1309 -- Floating_Plus -- 1310 ------------------- 1311 1312 procedure Floating_Plus is 1313 begin 1314 loop 1315 if At_End then 1316 return; 1317 end if; 1318 1319 case Look is 1320 when '_' | '0' | '/' => 1321 Pic.End_Float := Index; 1322 Skip; 1323 1324 when 'B' | 'b' => 1325 Pic.End_Float := Index; 1326 Pic.Picture.Expanded (Index) := 'b'; 1327 Skip; 1328 1329 when '+' => 1330 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; 1331 Pic.End_Float := Index; 1332 Skip; 1333 1334 when '9' => 1335 Number_Completion; 1336 return; 1337 1338 when '.' | 'V' | 'v' => 1339 Pic.Radix_Position := Index; 1340 Skip; -- Radix 1341 1342 while Is_Insert loop 1343 Skip; 1344 end loop; 1345 1346 if At_End then 1347 return; 1348 end if; 1349 1350 if Look = '+' then 1351 loop 1352 if At_End then 1353 return; 1354 end if; 1355 1356 case Look is 1357 1358 when '+' => 1359 Pic.Max_Trailing_Digits := 1360 Pic.Max_Trailing_Digits + 1; 1361 Pic.End_Float := Index; 1362 Skip; 1363 1364 when '_' | '0' | '/' => 1365 Skip; 1366 1367 when 'B' | 'b' => 1368 Pic.Picture.Expanded (Index) := 'b'; 1369 Skip; 1370 1371 when others => 1372 return; 1373 1374 end case; 1375 end loop; 1376 1377 else 1378 Number_Completion; 1379 end if; 1380 1381 return; 1382 1383 when others => 1384 return; 1385 1386 end case; 1387 end loop; 1388 end Floating_Plus; 1389 1390 --------------- 1391 -- Is_Insert -- 1392 --------------- 1393 1394 function Is_Insert return Boolean is 1395 begin 1396 if At_End then 1397 return False; 1398 end if; 1399 1400 case Pic.Picture.Expanded (Index) is 1401 1402 when '_' | '0' | '/' => return True; 1403 1404 when 'B' | 'b' => 1405 Pic.Picture.Expanded (Index) := 'b'; -- canonical 1406 return True; 1407 1408 when others => return False; 1409 end case; 1410 end Is_Insert; 1411 1412 -------------------- 1413 -- Leading_Dollar -- 1414 -------------------- 1415 1416 -- Note that Leading_Dollar can be called in either State. 1417 -- It will set state to Okay only if a 9 or (second) $ is encountered. 1418 1419 -- Also notice the tricky bit with State and Zero_Suppression. 1420 -- Zero_Suppression is Picture_Error if a '$' or a '9' has been 1421 -- encountered, exactly the cases where State has been set. 1422 1423 procedure Leading_Dollar is 1424 begin 1425 -- Treat as a floating dollar, and unwind otherwise 1426 1427 Pic.Floater := '$'; 1428 Pic.Start_Currency := Index; 1429 Pic.End_Currency := Index; 1430 Pic.Start_Float := Index; 1431 Pic.End_Float := Index; 1432 1433 -- Don't increment Pic.Max_Leading_Digits, we need one "real" 1434 -- currency place. 1435 1436 Skip; -- known '$' 1437 1438 loop 1439 if At_End then 1440 return; 1441 end if; 1442 1443 case Look is 1444 1445 when '_' | '0' | '/' => 1446 Pic.End_Float := Index; 1447 Skip; 1448 1449 -- A trailing insertion character is not part of the 1450 -- floating currency, so need to look ahead. 1451 1452 if Look /= '$' then 1453 Pic.End_Float := Pic.End_Float - 1; 1454 end if; 1455 1456 when 'B' | 'b' => 1457 Pic.End_Float := Index; 1458 Pic.Picture.Expanded (Index) := 'b'; 1459 Skip; 1460 1461 when 'Z' | 'z' => 1462 Pic.Picture.Expanded (Index) := 'Z'; -- consistency 1463 1464 if State = Okay then 1465 raise Picture_Error; 1466 else 1467 -- Will overwrite Floater and Start_Float 1468 1469 Zero_Suppression; 1470 end if; 1471 1472 when '*' => 1473 if State = Okay then 1474 raise Picture_Error; 1475 else 1476 -- Will overwrite Floater and Start_Float 1477 1478 Star_Suppression; 1479 end if; 1480 1481 when '$' => 1482 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; 1483 Pic.End_Float := Index; 1484 Pic.End_Currency := Index; 1485 Set_State (Okay); Skip; 1486 1487 when '9' => 1488 if State /= Okay then 1489 Pic.Floater := '!'; 1490 Pic.Start_Float := Invalid_Position; 1491 Pic.End_Float := Invalid_Position; 1492 end if; 1493 1494 -- A single dollar does not a floating make 1495 1496 Number_Completion; 1497 return; 1498 1499 when 'V' | 'v' | '.' => 1500 if State /= Okay then 1501 Pic.Floater := '!'; 1502 Pic.Start_Float := Invalid_Position; 1503 Pic.End_Float := Invalid_Position; 1504 end if; 1505 1506 -- Only one dollar before the sign is okay, but doesn't 1507 -- float. 1508 1509 Pic.Radix_Position := Index; 1510 Skip; 1511 Number_Fraction_Or_Dollar; 1512 return; 1513 1514 when others => 1515 return; 1516 1517 end case; 1518 end loop; 1519 end Leading_Dollar; 1520 1521 ------------------- 1522 -- Leading_Pound -- 1523 ------------------- 1524 1525 -- This one is complex. A Leading_Pound can be fixed or floating, 1526 -- but in some cases the decision has to be deferred until we leave 1527 -- this procedure. Also note that Leading_Pound can be called in 1528 -- either State. 1529 1530 -- It will set state to Okay only if a 9 or (second) # is 1531 -- encountered. 1532 1533 -- One Last note: In ambiguous cases, the currency is treated as 1534 -- floating unless there is only one '#'. 1535 1536 procedure Leading_Pound is 1537 1538 Inserts : Boolean := False; 1539 -- Set to True if a '_', '0', '/', 'B', or 'b' is encountered 1540 1541 Must_Float : Boolean := False; 1542 -- Set to true if a '#' occurs after an insert 1543 1544 begin 1545 -- Treat as a floating currency. If it isn't, this will be 1546 -- overwritten later. 1547 1548 Pic.Floater := '#'; 1549 1550 Pic.Start_Currency := Index; 1551 Pic.End_Currency := Index; 1552 Pic.Start_Float := Index; 1553 Pic.End_Float := Index; 1554 1555 -- Don't increment Pic.Max_Leading_Digits, we need one "real" 1556 -- currency place. 1557 1558 Pic.Max_Currency_Digits := 1; -- we've seen one. 1559 1560 Skip; -- known '#' 1561 1562 loop 1563 if At_End then 1564 return; 1565 end if; 1566 1567 case Look is 1568 1569 when '_' | '0' | '/' => 1570 Pic.End_Float := Index; 1571 Inserts := True; 1572 Skip; 1573 1574 when 'B' | 'b' => 1575 Pic.Picture.Expanded (Index) := 'b'; 1576 Pic.End_Float := Index; 1577 Inserts := True; 1578 Skip; 1579 1580 when 'Z' | 'z' => 1581 Pic.Picture.Expanded (Index) := 'Z'; -- consistency 1582 1583 if Must_Float then 1584 raise Picture_Error; 1585 else 1586 Pic.Max_Leading_Digits := 0; 1587 1588 -- Will overwrite Floater and Start_Float 1589 1590 Zero_Suppression; 1591 end if; 1592 1593 when '*' => 1594 if Must_Float then 1595 raise Picture_Error; 1596 else 1597 Pic.Max_Leading_Digits := 0; 1598 1599 -- Will overwrite Floater and Start_Float 1600 1601 Star_Suppression; 1602 end if; 1603 1604 when '#' => 1605 if Inserts then 1606 Must_Float := True; 1607 end if; 1608 1609 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; 1610 Pic.End_Float := Index; 1611 Pic.End_Currency := Index; 1612 Set_State (Okay); 1613 Skip; 1614 1615 when '9' => 1616 if State /= Okay then 1617 1618 -- A single '#' doesn't float 1619 1620 Pic.Floater := '!'; 1621 Pic.Start_Float := Invalid_Position; 1622 Pic.End_Float := Invalid_Position; 1623 end if; 1624 1625 Number_Completion; 1626 return; 1627 1628 when 'V' | 'v' | '.' => 1629 if State /= Okay then 1630 Pic.Floater := '!'; 1631 Pic.Start_Float := Invalid_Position; 1632 Pic.End_Float := Invalid_Position; 1633 end if; 1634 1635 -- Only one pound before the sign is okay, but doesn't 1636 -- float. 1637 1638 Pic.Radix_Position := Index; 1639 Skip; 1640 Number_Fraction_Or_Pound; 1641 return; 1642 1643 when others => 1644 return; 1645 end case; 1646 end loop; 1647 end Leading_Pound; 1648 1649 ---------- 1650 -- Look -- 1651 ---------- 1652 1653 function Look return Character is 1654 begin 1655 if At_End then 1656 raise Picture_Error; 1657 end if; 1658 1659 return Pic.Picture.Expanded (Index); 1660 end Look; 1661 1662 ------------ 1663 -- Number -- 1664 ------------ 1665 1666 procedure Number is 1667 begin 1668 loop 1669 1670 case Look is 1671 when '_' | '0' | '/' => 1672 Skip; 1673 1674 when 'B' | 'b' => 1675 Pic.Picture.Expanded (Index) := 'b'; 1676 Skip; 1677 1678 when '9' => 1679 Computed_BWZ := False; 1680 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; 1681 Set_State (Okay); 1682 Skip; 1683 1684 when '.' | 'V' | 'v' => 1685 Pic.Radix_Position := Index; 1686 Skip; 1687 Number_Fraction; 1688 return; 1689 1690 when others => 1691 return; 1692 1693 end case; 1694 1695 if At_End then 1696 return; 1697 end if; 1698 1699 -- Will return in Okay state if a '9' was seen 1700 1701 end loop; 1702 end Number; 1703 1704 ----------------------- 1705 -- Number_Completion -- 1706 ----------------------- 1707 1708 procedure Number_Completion is 1709 begin 1710 while not At_End loop 1711 case Look is 1712 1713 when '_' | '0' | '/' => 1714 Skip; 1715 1716 when 'B' | 'b' => 1717 Pic.Picture.Expanded (Index) := 'b'; 1718 Skip; 1719 1720 when '9' => 1721 Computed_BWZ := False; 1722 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; 1723 Set_State (Okay); 1724 Skip; 1725 1726 when 'V' | 'v' | '.' => 1727 Pic.Radix_Position := Index; 1728 Skip; 1729 Number_Fraction; 1730 return; 1731 1732 when others => 1733 return; 1734 end case; 1735 end loop; 1736 end Number_Completion; 1737 1738 --------------------- 1739 -- Number_Fraction -- 1740 --------------------- 1741 1742 procedure Number_Fraction is 1743 begin 1744 -- Note that number fraction can be called in either State. 1745 -- It will set state to Valid only if a 9 is encountered. 1746 1747 loop 1748 if At_End then 1749 return; 1750 end if; 1751 1752 case Look is 1753 when '_' | '0' | '/' => 1754 Skip; 1755 1756 when 'B' | 'b' => 1757 Pic.Picture.Expanded (Index) := 'b'; 1758 Skip; 1759 1760 when '9' => 1761 Computed_BWZ := False; 1762 Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; 1763 Set_State (Okay); Skip; 1764 1765 when others => 1766 return; 1767 end case; 1768 end loop; 1769 end Number_Fraction; 1770 1771 -------------------------------- 1772 -- Number_Fraction_Or_Bracket -- 1773 -------------------------------- 1774 1775 procedure Number_Fraction_Or_Bracket is 1776 begin 1777 loop 1778 if At_End then 1779 return; 1780 end if; 1781 1782 case Look is 1783 1784 when '_' | '0' | '/' => Skip; 1785 1786 when 'B' | 'b' => 1787 Pic.Picture.Expanded (Index) := 'b'; 1788 Skip; 1789 1790 when '<' => 1791 Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; 1792 Pic.End_Float := Index; 1793 Skip; 1794 1795 loop 1796 if At_End then 1797 return; 1798 end if; 1799 1800 case Look is 1801 when '_' | '0' | '/' => 1802 Skip; 1803 1804 when 'B' | 'b' => 1805 Pic.Picture.Expanded (Index) := 'b'; 1806 Skip; 1807 1808 when '<' => 1809 Pic.Max_Trailing_Digits := 1810 Pic.Max_Trailing_Digits + 1; 1811 Pic.End_Float := Index; 1812 Skip; 1813 1814 when others => 1815 return; 1816 end case; 1817 end loop; 1818 1819 when others => 1820 Number_Fraction; 1821 return; 1822 end case; 1823 end loop; 1824 end Number_Fraction_Or_Bracket; 1825 1826 ------------------------------- 1827 -- Number_Fraction_Or_Dollar -- 1828 ------------------------------- 1829 1830 procedure Number_Fraction_Or_Dollar is 1831 begin 1832 loop 1833 if At_End then 1834 return; 1835 end if; 1836 1837 case Look is 1838 when '_' | '0' | '/' => 1839 Skip; 1840 1841 when 'B' | 'b' => 1842 Pic.Picture.Expanded (Index) := 'b'; 1843 Skip; 1844 1845 when '$' => 1846 Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; 1847 Pic.End_Float := Index; 1848 Skip; 1849 1850 loop 1851 if At_End then 1852 return; 1853 end if; 1854 1855 case Look is 1856 when '_' | '0' | '/' => 1857 Skip; 1858 1859 when 'B' | 'b' => 1860 Pic.Picture.Expanded (Index) := 'b'; 1861 Skip; 1862 1863 when '$' => 1864 Pic.Max_Trailing_Digits := 1865 Pic.Max_Trailing_Digits + 1; 1866 Pic.End_Float := Index; 1867 Skip; 1868 1869 when others => 1870 return; 1871 end case; 1872 end loop; 1873 1874 when others => 1875 Number_Fraction; 1876 return; 1877 end case; 1878 end loop; 1879 end Number_Fraction_Or_Dollar; 1880 1881 ------------------------------ 1882 -- Number_Fraction_Or_Pound -- 1883 ------------------------------ 1884 1885 procedure Number_Fraction_Or_Pound is 1886 begin 1887 loop 1888 if At_End then 1889 return; 1890 end if; 1891 1892 case Look is 1893 1894 when '_' | '0' | '/' => 1895 Skip; 1896 1897 when 'B' | 'b' => 1898 Pic.Picture.Expanded (Index) := 'b'; 1899 Skip; 1900 1901 when '#' => 1902 Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; 1903 Pic.End_Float := Index; 1904 Skip; 1905 1906 loop 1907 if At_End then 1908 return; 1909 end if; 1910 1911 case Look is 1912 1913 when '_' | '0' | '/' => 1914 Skip; 1915 1916 when 'B' | 'b' => 1917 Pic.Picture.Expanded (Index) := 'b'; 1918 Skip; 1919 1920 when '#' => 1921 Pic.Max_Trailing_Digits := 1922 Pic.Max_Trailing_Digits + 1; 1923 Pic.End_Float := Index; 1924 Skip; 1925 1926 when others => 1927 return; 1928 1929 end case; 1930 end loop; 1931 1932 when others => 1933 Number_Fraction; 1934 return; 1935 1936 end case; 1937 end loop; 1938 end Number_Fraction_Or_Pound; 1939 1940 ---------------------------------- 1941 -- Number_Fraction_Or_Star_Fill -- 1942 ---------------------------------- 1943 1944 procedure Number_Fraction_Or_Star_Fill is 1945 begin 1946 loop 1947 if At_End then 1948 return; 1949 end if; 1950 1951 case Look is 1952 1953 when '_' | '0' | '/' => 1954 Skip; 1955 1956 when 'B' | 'b' => 1957 Pic.Picture.Expanded (Index) := 'b'; 1958 Skip; 1959 1960 when '*' => 1961 Pic.Star_Fill := True; 1962 Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; 1963 Pic.End_Float := Index; 1964 Skip; 1965 1966 loop 1967 if At_End then 1968 return; 1969 end if; 1970 1971 case Look is 1972 1973 when '_' | '0' | '/' => 1974 Skip; 1975 1976 when 'B' | 'b' => 1977 Pic.Picture.Expanded (Index) := 'b'; 1978 Skip; 1979 1980 when '*' => 1981 Pic.Star_Fill := True; 1982 Pic.Max_Trailing_Digits := 1983 Pic.Max_Trailing_Digits + 1; 1984 Pic.End_Float := Index; 1985 Skip; 1986 1987 when others => 1988 return; 1989 end case; 1990 end loop; 1991 1992 when others => 1993 Number_Fraction; 1994 return; 1995 1996 end case; 1997 end loop; 1998 end Number_Fraction_Or_Star_Fill; 1999 2000 ------------------------------- 2001 -- Number_Fraction_Or_Z_Fill -- 2002 ------------------------------- 2003 2004 procedure Number_Fraction_Or_Z_Fill is 2005 begin 2006 loop 2007 if At_End then 2008 return; 2009 end if; 2010 2011 case Look is 2012 2013 when '_' | '0' | '/' => 2014 Skip; 2015 2016 when 'B' | 'b' => 2017 Pic.Picture.Expanded (Index) := 'b'; 2018 Skip; 2019 2020 when 'Z' | 'z' => 2021 Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; 2022 Pic.End_Float := Index; 2023 Pic.Picture.Expanded (Index) := 'Z'; -- consistency 2024 2025 Skip; 2026 2027 loop 2028 if At_End then 2029 return; 2030 end if; 2031 2032 case Look is 2033 2034 when '_' | '0' | '/' => 2035 Skip; 2036 2037 when 'B' | 'b' => 2038 Pic.Picture.Expanded (Index) := 'b'; 2039 Skip; 2040 2041 when 'Z' | 'z' => 2042 Pic.Picture.Expanded (Index) := 'Z'; -- consistency 2043 2044 Pic.Max_Trailing_Digits := 2045 Pic.Max_Trailing_Digits + 1; 2046 Pic.End_Float := Index; 2047 Skip; 2048 2049 when others => 2050 return; 2051 end case; 2052 end loop; 2053 2054 when others => 2055 Number_Fraction; 2056 return; 2057 end case; 2058 end loop; 2059 end Number_Fraction_Or_Z_Fill; 2060 2061 ----------------------- 2062 -- Optional_RHS_Sign -- 2063 ----------------------- 2064 2065 procedure Optional_RHS_Sign is 2066 begin 2067 if At_End then 2068 return; 2069 end if; 2070 2071 case Look is 2072 2073 when '+' | '-' => 2074 Pic.Sign_Position := Index; 2075 Skip; 2076 return; 2077 2078 when 'C' | 'c' => 2079 Pic.Sign_Position := Index; 2080 Pic.Picture.Expanded (Index) := 'C'; 2081 Skip; 2082 2083 if Look = 'R' or else Look = 'r' then 2084 Pic.Second_Sign := Index; 2085 Pic.Picture.Expanded (Index) := 'R'; 2086 Skip; 2087 2088 else 2089 raise Picture_Error; 2090 end if; 2091 2092 return; 2093 2094 when 'D' | 'd' => 2095 Pic.Sign_Position := Index; 2096 Pic.Picture.Expanded (Index) := 'D'; 2097 Skip; 2098 2099 if Look = 'B' or else Look = 'b' then 2100 Pic.Second_Sign := Index; 2101 Pic.Picture.Expanded (Index) := 'B'; 2102 Skip; 2103 2104 else 2105 raise Picture_Error; 2106 end if; 2107 2108 return; 2109 2110 when '>' => 2111 if Pic.Picture.Expanded (Pic.Sign_Position) = '<' then 2112 Pic.Second_Sign := Index; 2113 Skip; 2114 2115 else 2116 raise Picture_Error; 2117 end if; 2118 2119 when others => 2120 return; 2121 2122 end case; 2123 end Optional_RHS_Sign; 2124 2125 ------------- 2126 -- Picture -- 2127 ------------- 2128 2129 -- Note that Picture can be called in either State 2130 2131 -- It will set state to Valid only if a 9 is encountered or floating 2132 -- currency is called. 2133 2134 procedure Picture is 2135 begin 2136 loop 2137 if At_End then 2138 return; 2139 end if; 2140 2141 case Look is 2142 2143 when '_' | '0' | '/' => 2144 Skip; 2145 2146 when 'B' | 'b' => 2147 Pic.Picture.Expanded (Index) := 'b'; 2148 Skip; 2149 2150 when '$' => 2151 Leading_Dollar; 2152 return; 2153 2154 when '#' => 2155 Leading_Pound; 2156 return; 2157 2158 when '9' => 2159 Computed_BWZ := False; 2160 Set_State (Okay); 2161 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; 2162 Skip; 2163 2164 when 'V' | 'v' | '.' => 2165 Pic.Radix_Position := Index; 2166 Skip; 2167 Number_Fraction; 2168 Trailing_Currency; 2169 return; 2170 2171 when others => 2172 return; 2173 2174 end case; 2175 end loop; 2176 end Picture; 2177 2178 --------------------- 2179 -- Picture_Bracket -- 2180 --------------------- 2181 2182 procedure Picture_Bracket is 2183 begin 2184 Pic.Sign_Position := Index; 2185 Pic.Sign_Position := Index; 2186 2187 -- Treat as a floating sign, and unwind otherwise 2188 2189 Pic.Floater := '<'; 2190 Pic.Start_Float := Index; 2191 Pic.End_Float := Index; 2192 2193 -- Don't increment Pic.Max_Leading_Digits, we need one "real" 2194 -- sign place. 2195 2196 Skip; -- Known Bracket 2197 2198 loop 2199 case Look is 2200 2201 when '_' | '0' | '/' => 2202 Pic.End_Float := Index; 2203 Skip; 2204 2205 when 'B' | 'b' => 2206 Pic.End_Float := Index; 2207 Pic.Picture.Expanded (Index) := 'b'; 2208 Skip; 2209 2210 when '<' => 2211 Set_State (Okay); -- "<<>" is enough. 2212 Floating_Bracket; 2213 Trailing_Currency; 2214 Trailing_Bracket; 2215 return; 2216 2217 when '$' | '#' | '9' | '*' => 2218 if State /= Okay then 2219 Pic.Floater := '!'; 2220 Pic.Start_Float := Invalid_Position; 2221 Pic.End_Float := Invalid_Position; 2222 end if; 2223 2224 Picture; 2225 Trailing_Bracket; 2226 Set_State (Okay); 2227 return; 2228 2229 when '.' | 'V' | 'v' => 2230 if State /= Okay then 2231 Pic.Floater := '!'; 2232 Pic.Start_Float := Invalid_Position; 2233 Pic.End_Float := Invalid_Position; 2234 end if; 2235 2236 -- Don't assume that state is okay, haven't seen a digit 2237 2238 Picture; 2239 Trailing_Bracket; 2240 return; 2241 2242 when others => 2243 raise Picture_Error; 2244 2245 end case; 2246 end loop; 2247 end Picture_Bracket; 2248 2249 ------------------- 2250 -- Picture_Minus -- 2251 ------------------- 2252 2253 procedure Picture_Minus is 2254 begin 2255 Pic.Sign_Position := Index; 2256 2257 -- Treat as a floating sign, and unwind otherwise 2258 2259 Pic.Floater := '-'; 2260 Pic.Start_Float := Index; 2261 Pic.End_Float := Index; 2262 2263 -- Don't increment Pic.Max_Leading_Digits, we need one "real" 2264 -- sign place. 2265 2266 Skip; -- Known Minus 2267 2268 loop 2269 case Look is 2270 2271 when '_' | '0' | '/' => 2272 Pic.End_Float := Index; 2273 Skip; 2274 2275 when 'B' | 'b' => 2276 Pic.End_Float := Index; 2277 Pic.Picture.Expanded (Index) := 'b'; 2278 Skip; 2279 2280 when '-' => 2281 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; 2282 Pic.End_Float := Index; 2283 Skip; 2284 Set_State (Okay); -- "-- " is enough 2285 Floating_Minus; 2286 Trailing_Currency; 2287 return; 2288 2289 when '$' | '#' | '9' | '*' => 2290 if State /= Okay then 2291 Pic.Floater := '!'; 2292 Pic.Start_Float := Invalid_Position; 2293 Pic.End_Float := Invalid_Position; 2294 end if; 2295 2296 Picture; 2297 Set_State (Okay); 2298 return; 2299 2300 when 'Z' | 'z' => 2301 2302 -- Can't have Z and a floating sign 2303 2304 if State = Okay then 2305 Set_State (Reject); 2306 end if; 2307 2308 Pic.Picture.Expanded (Index) := 'Z'; -- consistency 2309 Zero_Suppression; 2310 Trailing_Currency; 2311 Optional_RHS_Sign; 2312 return; 2313 2314 when '.' | 'V' | 'v' => 2315 if State /= Okay then 2316 Pic.Floater := '!'; 2317 Pic.Start_Float := Invalid_Position; 2318 Pic.End_Float := Invalid_Position; 2319 end if; 2320 2321 -- Don't assume that state is okay, haven't seen a digit 2322 2323 Picture; 2324 return; 2325 2326 when others => 2327 return; 2328 2329 end case; 2330 end loop; 2331 end Picture_Minus; 2332 2333 ------------------ 2334 -- Picture_Plus -- 2335 ------------------ 2336 2337 procedure Picture_Plus is 2338 begin 2339 Pic.Sign_Position := Index; 2340 2341 -- Treat as a floating sign, and unwind otherwise 2342 2343 Pic.Floater := '+'; 2344 Pic.Start_Float := Index; 2345 Pic.End_Float := Index; 2346 2347 -- Don't increment Pic.Max_Leading_Digits, we need one "real" 2348 -- sign place. 2349 2350 Skip; -- Known Plus 2351 2352 loop 2353 case Look is 2354 2355 when '_' | '0' | '/' => 2356 Pic.End_Float := Index; 2357 Skip; 2358 2359 when 'B' | 'b' => 2360 Pic.End_Float := Index; 2361 Pic.Picture.Expanded (Index) := 'b'; 2362 Skip; 2363 2364 when '+' => 2365 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; 2366 Pic.End_Float := Index; 2367 Skip; 2368 Set_State (Okay); -- "++" is enough 2369 Floating_Plus; 2370 Trailing_Currency; 2371 return; 2372 2373 when '$' | '#' | '9' | '*' => 2374 if State /= Okay then 2375 Pic.Floater := '!'; 2376 Pic.Start_Float := Invalid_Position; 2377 Pic.End_Float := Invalid_Position; 2378 end if; 2379 2380 Picture; 2381 Set_State (Okay); 2382 return; 2383 2384 when 'Z' | 'z' => 2385 if State = Okay then 2386 Set_State (Reject); 2387 end if; 2388 2389 -- Can't have Z and a floating sign 2390 2391 Pic.Picture.Expanded (Index) := 'Z'; -- consistency 2392 2393 -- '+Z' is acceptable 2394 2395 Set_State (Okay); 2396 2397 Zero_Suppression; 2398 Trailing_Currency; 2399 Optional_RHS_Sign; 2400 return; 2401 2402 when '.' | 'V' | 'v' => 2403 if State /= Okay then 2404 Pic.Floater := '!'; 2405 Pic.Start_Float := Invalid_Position; 2406 Pic.End_Float := Invalid_Position; 2407 end if; 2408 2409 -- Don't assume that state is okay, haven't seen a digit 2410 2411 Picture; 2412 return; 2413 2414 when others => 2415 return; 2416 2417 end case; 2418 end loop; 2419 end Picture_Plus; 2420 2421 -------------------- 2422 -- Picture_String -- 2423 -------------------- 2424 2425 procedure Picture_String is 2426 begin 2427 while Is_Insert loop 2428 Skip; 2429 end loop; 2430 2431 case Look is 2432 2433 when '$' | '#' => 2434 Picture; 2435 Optional_RHS_Sign; 2436 2437 when '+' => 2438 Picture_Plus; 2439 2440 when '-' => 2441 Picture_Minus; 2442 2443 when '<' => 2444 Picture_Bracket; 2445 2446 when 'Z' | 'z' => 2447 Pic.Picture.Expanded (Index) := 'Z'; -- consistency 2448 Zero_Suppression; 2449 Trailing_Currency; 2450 Optional_RHS_Sign; 2451 2452 when '*' => 2453 Star_Suppression; 2454 Trailing_Currency; 2455 Optional_RHS_Sign; 2456 2457 when '9' | '.' | 'V' | 'v' => 2458 Number; 2459 Trailing_Currency; 2460 Optional_RHS_Sign; 2461 2462 when others => 2463 raise Picture_Error; 2464 2465 end case; 2466 2467 -- Blank when zero either if the PIC does not contain a '9' or if 2468 -- requested by the user and no '*'. 2469 2470 Pic.Blank_When_Zero := 2471 (Computed_BWZ or else Pic.Blank_When_Zero) 2472 and then not Pic.Star_Fill; 2473 2474 -- Star fill if '*' and no '9' 2475 2476 Pic.Star_Fill := Pic.Star_Fill and then Computed_BWZ; 2477 2478 if not At_End then 2479 Set_State (Reject); 2480 end if; 2481 2482 end Picture_String; 2483 2484 --------------- 2485 -- Set_State -- 2486 --------------- 2487 2488 procedure Set_State (L : Legality) is 2489 begin 2490 State := L; 2491 end Set_State; 2492 2493 ---------- 2494 -- Skip -- 2495 ---------- 2496 2497 procedure Skip is 2498 begin 2499 Index := Index + 1; 2500 end Skip; 2501 2502 ---------------------- 2503 -- Star_Suppression -- 2504 ---------------------- 2505 2506 procedure Star_Suppression is 2507 begin 2508 Pic.Floater := '*'; 2509 Pic.Start_Float := Index; 2510 Pic.End_Float := Index; 2511 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; 2512 Set_State (Okay); 2513 2514 -- Even a single * is a valid picture 2515 2516 Pic.Star_Fill := True; 2517 Skip; -- Known * 2518 2519 loop 2520 if At_End then 2521 return; 2522 end if; 2523 2524 case Look is 2525 2526 when '_' | '0' | '/' => 2527 Pic.End_Float := Index; 2528 Skip; 2529 2530 when 'B' | 'b' => 2531 Pic.End_Float := Index; 2532 Pic.Picture.Expanded (Index) := 'b'; 2533 Skip; 2534 2535 when '*' => 2536 Pic.End_Float := Index; 2537 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; 2538 Set_State (Okay); Skip; 2539 2540 when '9' => 2541 Set_State (Okay); 2542 Number_Completion; 2543 return; 2544 2545 when '.' | 'V' | 'v' => 2546 Pic.Radix_Position := Index; 2547 Skip; 2548 Number_Fraction_Or_Star_Fill; 2549 return; 2550 2551 when '#' | '$' => 2552 Trailing_Currency; 2553 Set_State (Okay); 2554 return; 2555 2556 when others => raise Picture_Error; 2557 end case; 2558 end loop; 2559 end Star_Suppression; 2560 2561 ---------------------- 2562 -- Trailing_Bracket -- 2563 ---------------------- 2564 2565 procedure Trailing_Bracket is 2566 begin 2567 if Look = '>' then 2568 Pic.Second_Sign := Index; 2569 Skip; 2570 else 2571 raise Picture_Error; 2572 end if; 2573 end Trailing_Bracket; 2574 2575 ----------------------- 2576 -- Trailing_Currency -- 2577 ----------------------- 2578 2579 procedure Trailing_Currency is 2580 begin 2581 if At_End then 2582 return; 2583 end if; 2584 2585 if Look = '$' then 2586 Pic.Start_Currency := Index; 2587 Pic.End_Currency := Index; 2588 Skip; 2589 2590 else 2591 while not At_End and then Look = '#' loop 2592 if Pic.Start_Currency = Invalid_Position then 2593 Pic.Start_Currency := Index; 2594 end if; 2595 2596 Pic.End_Currency := Index; 2597 Skip; 2598 end loop; 2599 end if; 2600 2601 loop 2602 if At_End then 2603 return; 2604 end if; 2605 2606 case Look is 2607 when '_' | '0' | '/' => Skip; 2608 2609 when 'B' | 'b' => 2610 Pic.Picture.Expanded (Index) := 'b'; 2611 Skip; 2612 2613 when others => return; 2614 end case; 2615 end loop; 2616 end Trailing_Currency; 2617 2618 ---------------------- 2619 -- Zero_Suppression -- 2620 ---------------------- 2621 2622 procedure Zero_Suppression is 2623 begin 2624 Pic.Floater := 'Z'; 2625 Pic.Start_Float := Index; 2626 Pic.End_Float := Index; 2627 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; 2628 Pic.Picture.Expanded (Index) := 'Z'; -- consistency 2629 2630 Skip; -- Known Z 2631 2632 loop 2633 -- Even a single Z is a valid picture 2634 2635 if At_End then 2636 Set_State (Okay); 2637 return; 2638 end if; 2639 2640 case Look is 2641 when '_' | '0' | '/' => 2642 Pic.End_Float := Index; 2643 Skip; 2644 2645 when 'B' | 'b' => 2646 Pic.End_Float := Index; 2647 Pic.Picture.Expanded (Index) := 'b'; 2648 Skip; 2649 2650 when 'Z' | 'z' => 2651 Pic.Picture.Expanded (Index) := 'Z'; -- consistency 2652 2653 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; 2654 Pic.End_Float := Index; 2655 Set_State (Okay); 2656 Skip; 2657 2658 when '9' => 2659 Set_State (Okay); 2660 Number_Completion; 2661 return; 2662 2663 when '.' | 'V' | 'v' => 2664 Pic.Radix_Position := Index; 2665 Skip; 2666 Number_Fraction_Or_Z_Fill; 2667 return; 2668 2669 when '#' | '$' => 2670 Trailing_Currency; 2671 Set_State (Okay); 2672 return; 2673 2674 when others => 2675 return; 2676 end case; 2677 end loop; 2678 end Zero_Suppression; 2679 2680 -- Start of processing for Precalculate 2681 2682 begin 2683 Picture_String; 2684 2685 if State = Reject then 2686 raise Picture_Error; 2687 end if; 2688 2689 exception 2690 2691 when Constraint_Error => 2692 2693 -- To deal with special cases like null strings 2694 2695 raise Picture_Error; 2696 2697 end Precalculate; 2698 2699 ---------------- 2700 -- To_Picture -- 2701 ---------------- 2702 2703 function To_Picture 2704 (Pic_String : String; 2705 Blank_When_Zero : Boolean := False) return Picture 2706 is 2707 Result : Picture; 2708 2709 begin 2710 declare 2711 Item : constant String := Expand (Pic_String); 2712 2713 begin 2714 Result.Contents.Picture := (Item'Length, Item); 2715 Result.Contents.Original_BWZ := Blank_When_Zero; 2716 Result.Contents.Blank_When_Zero := Blank_When_Zero; 2717 Precalculate (Result.Contents); 2718 return Result; 2719 end; 2720 2721 exception 2722 when others => 2723 raise Picture_Error; 2724 2725 end To_Picture; 2726 2727 ------------- 2728 -- To_Wide -- 2729 ------------- 2730 2731 function To_Wide (C : Character) return Wide_Character is 2732 begin 2733 return Wide_Character'Val (Character'Pos (C)); 2734 end To_Wide; 2735 2736 ----------- 2737 -- Valid -- 2738 ----------- 2739 2740 function Valid 2741 (Pic_String : String; 2742 Blank_When_Zero : Boolean := False) return Boolean 2743 is 2744 begin 2745 declare 2746 Expanded_Pic : constant String := Expand (Pic_String); 2747 -- Raises Picture_Error if Item not well-formed 2748 2749 Format_Rec : Format_Record; 2750 2751 begin 2752 Format_Rec.Picture := (Expanded_Pic'Length, Expanded_Pic); 2753 Format_Rec.Blank_When_Zero := Blank_When_Zero; 2754 Format_Rec.Original_BWZ := Blank_When_Zero; 2755 Precalculate (Format_Rec); 2756 2757 -- False only if Blank_When_0 is True but the pic string has a '*' 2758 2759 return not Blank_When_Zero 2760 or else Strings_Fixed.Index (Expanded_Pic, "*") = 0; 2761 end; 2762 2763 exception 2764 when others => return False; 2765 end Valid; 2766 2767end Ada.Wide_Text_IO.Editing; 2768