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