1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- I N T E R F A C E S . C O B O L -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 2, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- As a special exception, if other files instantiate generics from this -- 23-- unit, or you link this unit with other files to produce an executable, -- 24-- this unit does not by itself cause the resulting executable to be -- 25-- covered by the GNU General Public License. This exception does not -- 26-- however invalidate any other reasons why the executable file might be -- 27-- covered by the GNU Public License. -- 28-- -- 29-- GNAT was originally developed by the GNAT team at New York University. -- 30-- Extensive contributions were provided by Ada Core Technologies Inc. -- 31-- -- 32------------------------------------------------------------------------------ 33 34-- The body of Interfaces.COBOL is implementation independent (i.e. the 35-- same version is used with all versions of GNAT). The specialization 36-- to a particular COBOL format is completely contained in the private 37-- part ot the spec. 38 39with Interfaces; use Interfaces; 40with System; use System; 41with Unchecked_Conversion; 42 43package body Interfaces.COBOL is 44 45 ----------------------------------------------- 46 -- Declarations for External Binary Handling -- 47 ----------------------------------------------- 48 49 subtype B1 is Byte_Array (1 .. 1); 50 subtype B2 is Byte_Array (1 .. 2); 51 subtype B4 is Byte_Array (1 .. 4); 52 subtype B8 is Byte_Array (1 .. 8); 53 -- Representations for 1,2,4,8 byte binary values 54 55 function To_B1 is new Unchecked_Conversion (Integer_8, B1); 56 function To_B2 is new Unchecked_Conversion (Integer_16, B2); 57 function To_B4 is new Unchecked_Conversion (Integer_32, B4); 58 function To_B8 is new Unchecked_Conversion (Integer_64, B8); 59 -- Conversions from native binary to external binary 60 61 function From_B1 is new Unchecked_Conversion (B1, Integer_8); 62 function From_B2 is new Unchecked_Conversion (B2, Integer_16); 63 function From_B4 is new Unchecked_Conversion (B4, Integer_32); 64 function From_B8 is new Unchecked_Conversion (B8, Integer_64); 65 -- Conversions from external binary to signed native binary 66 67 function From_B1U is new Unchecked_Conversion (B1, Unsigned_8); 68 function From_B2U is new Unchecked_Conversion (B2, Unsigned_16); 69 function From_B4U is new Unchecked_Conversion (B4, Unsigned_32); 70 function From_B8U is new Unchecked_Conversion (B8, Unsigned_64); 71 -- Conversions from external binary to unsigned native binary 72 73 ----------------------- 74 -- Local Subprograms -- 75 ----------------------- 76 77 function Binary_To_Decimal 78 (Item : Byte_Array; 79 Format : Binary_Format) 80 return Integer_64; 81 -- This function converts a numeric value in the given format to its 82 -- corresponding integer value. This is the non-generic implementation 83 -- of Decimal_Conversions.To_Decimal. The generic routine does the 84 -- final conversion to the fixed-point format. 85 86 function Numeric_To_Decimal 87 (Item : Numeric; 88 Format : Display_Format) 89 return Integer_64; 90 -- This function converts a numeric value in the given format to its 91 -- corresponding integer value. This is the non-generic implementation 92 -- of Decimal_Conversions.To_Decimal. The generic routine does the 93 -- final conversion to the fixed-point format. 94 95 function Packed_To_Decimal 96 (Item : Packed_Decimal; 97 Format : Packed_Format) 98 return Integer_64; 99 -- This function converts a packed value in the given format to its 100 -- corresponding integer value. This is the non-generic implementation 101 -- of Decimal_Conversions.To_Decimal. The generic routine does the 102 -- final conversion to the fixed-point format. 103 104 procedure Swap (B : in out Byte_Array; F : Binary_Format); 105 -- Swaps the bytes if required by the binary format F 106 107 function To_Display 108 (Item : Integer_64; 109 Format : Display_Format; 110 Length : Natural) 111 return Numeric; 112 -- This function converts the given integer value into display format, 113 -- using the given format, with the length in bytes of the result given 114 -- by the last parameter. This is the non-generic implementation of 115 -- Decimal_Conversions.To_Display. The conversion of the item from its 116 -- original decimal format to Integer_64 is done by the generic routine. 117 118 function To_Packed 119 (Item : Integer_64; 120 Format : Packed_Format; 121 Length : Natural) 122 return Packed_Decimal; 123 -- This function converts the given integer value into packed format, 124 -- using the given format, with the length in digits of the result given 125 -- by the last parameter. This is the non-generic implementation of 126 -- Decimal_Conversions.To_Display. The conversion of the item from its 127 -- original decimal format to Integer_64 is done by the generic routine. 128 129 function Valid_Numeric 130 (Item : Numeric; 131 Format : Display_Format) 132 return Boolean; 133 -- This is the non-generic implementation of Decimal_Conversions.Valid 134 -- for the display case. 135 136 function Valid_Packed 137 (Item : Packed_Decimal; 138 Format : Packed_Format) 139 return Boolean; 140 -- This is the non-generic implementation of Decimal_Conversions.Valid 141 -- for the packed case. 142 143 ----------------------- 144 -- Binary_To_Decimal -- 145 ----------------------- 146 147 function Binary_To_Decimal 148 (Item : Byte_Array; 149 Format : Binary_Format) 150 return Integer_64 151 is 152 Len : constant Natural := Item'Length; 153 154 begin 155 if Len = 1 then 156 if Format in Binary_Unsigned_Format then 157 return Integer_64 (From_B1U (Item)); 158 else 159 return Integer_64 (From_B1 (Item)); 160 end if; 161 162 elsif Len = 2 then 163 declare 164 R : B2 := Item; 165 166 begin 167 Swap (R, Format); 168 169 if Format in Binary_Unsigned_Format then 170 return Integer_64 (From_B2U (R)); 171 else 172 return Integer_64 (From_B2 (R)); 173 end if; 174 end; 175 176 elsif Len = 4 then 177 declare 178 R : B4 := Item; 179 180 begin 181 Swap (R, Format); 182 183 if Format in Binary_Unsigned_Format then 184 return Integer_64 (From_B4U (R)); 185 else 186 return Integer_64 (From_B4 (R)); 187 end if; 188 end; 189 190 elsif Len = 8 then 191 declare 192 R : B8 := Item; 193 194 begin 195 Swap (R, Format); 196 197 if Format in Binary_Unsigned_Format then 198 return Integer_64 (From_B8U (R)); 199 else 200 return Integer_64 (From_B8 (R)); 201 end if; 202 end; 203 204 -- Length is not 1, 2, 4 or 8 205 206 else 207 raise Conversion_Error; 208 end if; 209 end Binary_To_Decimal; 210 211 ------------------------ 212 -- Numeric_To_Decimal -- 213 ------------------------ 214 215 -- The following assumptions are made in the coding of this routine 216 217 -- The range of COBOL_Digits is compact and the ten values 218 -- represent the digits 0-9 in sequence 219 220 -- The range of COBOL_Plus_Digits is compact and the ten values 221 -- represent the digits 0-9 in sequence with a plus sign. 222 223 -- The range of COBOL_Minus_Digits is compact and the ten values 224 -- represent the digits 0-9 in sequence with a minus sign. 225 226 -- The COBOL_Minus_Digits set is disjoint from COBOL_Digits 227 228 -- These assumptions are true for all COBOL representations we know of. 229 230 function Numeric_To_Decimal 231 (Item : Numeric; 232 Format : Display_Format) 233 return Integer_64 234 is 235 pragma Unsuppress (Range_Check); 236 Sign : COBOL_Character := COBOL_Plus; 237 Result : Integer_64 := 0; 238 239 begin 240 if not Valid_Numeric (Item, Format) then 241 raise Conversion_Error; 242 end if; 243 244 for J in Item'Range loop 245 declare 246 K : constant COBOL_Character := Item (J); 247 248 begin 249 if K in COBOL_Digits then 250 Result := Result * 10 + 251 (COBOL_Character'Pos (K) - 252 COBOL_Character'Pos (COBOL_Digits'First)); 253 254 elsif K in COBOL_Plus_Digits then 255 Result := Result * 10 + 256 (COBOL_Character'Pos (K) - 257 COBOL_Character'Pos (COBOL_Plus_Digits'First)); 258 259 elsif K in COBOL_Minus_Digits then 260 Result := Result * 10 + 261 (COBOL_Character'Pos (K) - 262 COBOL_Character'Pos (COBOL_Minus_Digits'First)); 263 Sign := COBOL_Minus; 264 265 -- Only remaining possibility is COBOL_Plus or COBOL_Minus 266 267 else 268 Sign := K; 269 end if; 270 end; 271 end loop; 272 273 if Sign = COBOL_Plus then 274 return Result; 275 else 276 return -Result; 277 end if; 278 279 exception 280 when Constraint_Error => 281 raise Conversion_Error; 282 283 end Numeric_To_Decimal; 284 285 ----------------------- 286 -- Packed_To_Decimal -- 287 ----------------------- 288 289 function Packed_To_Decimal 290 (Item : Packed_Decimal; 291 Format : Packed_Format) 292 return Integer_64 293 is 294 pragma Unsuppress (Range_Check); 295 Result : Integer_64 := 0; 296 Sign : constant Decimal_Element := Item (Item'Last); 297 298 begin 299 if not Valid_Packed (Item, Format) then 300 raise Conversion_Error; 301 end if; 302 303 case Packed_Representation is 304 when IBM => 305 for J in Item'First .. Item'Last - 1 loop 306 Result := Result * 10 + Integer_64 (Item (J)); 307 end loop; 308 309 if Sign = 16#0B# or else Sign = 16#0D# then 310 return -Result; 311 else 312 return +Result; 313 end if; 314 end case; 315 316 exception 317 when Constraint_Error => 318 raise Conversion_Error; 319 end Packed_To_Decimal; 320 321 ---------- 322 -- Swap -- 323 ---------- 324 325 procedure Swap (B : in out Byte_Array; F : Binary_Format) is 326 Little_Endian : constant Boolean := 327 System.Default_Bit_Order = System.Low_Order_First; 328 329 begin 330 -- Return if no swap needed 331 332 case F is 333 when H | HU => 334 if not Little_Endian then 335 return; 336 end if; 337 338 when L | LU => 339 if Little_Endian then 340 return; 341 end if; 342 343 when N | NU => 344 return; 345 end case; 346 347 -- Here a swap is needed 348 349 declare 350 Len : constant Natural := B'Length; 351 352 begin 353 for J in 1 .. Len / 2 loop 354 declare 355 Temp : constant Byte := B (J); 356 357 begin 358 B (J) := B (Len + 1 - J); 359 B (Len + 1 - J) := Temp; 360 end; 361 end loop; 362 end; 363 end Swap; 364 365 ----------------------- 366 -- To_Ada (function) -- 367 ----------------------- 368 369 function To_Ada (Item : Alphanumeric) return String is 370 Result : String (Item'Range); 371 372 begin 373 for J in Item'Range loop 374 Result (J) := COBOL_To_Ada (Item (J)); 375 end loop; 376 377 return Result; 378 end To_Ada; 379 380 ------------------------ 381 -- To_Ada (procedure) -- 382 ------------------------ 383 384 procedure To_Ada 385 (Item : Alphanumeric; 386 Target : out String; 387 Last : out Natural) 388 is 389 Last_Val : Integer; 390 391 begin 392 if Item'Length > Target'Length then 393 raise Constraint_Error; 394 end if; 395 396 Last_Val := Target'First - 1; 397 for J in Item'Range loop 398 Last_Val := Last_Val + 1; 399 Target (Last_Val) := COBOL_To_Ada (Item (J)); 400 end loop; 401 402 Last := Last_Val; 403 end To_Ada; 404 405 ------------------------- 406 -- To_COBOL (function) -- 407 ------------------------- 408 409 function To_COBOL (Item : String) return Alphanumeric is 410 Result : Alphanumeric (Item'Range); 411 412 begin 413 for J in Item'Range loop 414 Result (J) := Ada_To_COBOL (Item (J)); 415 end loop; 416 417 return Result; 418 end To_COBOL; 419 420 -------------------------- 421 -- To_COBOL (procedure) -- 422 -------------------------- 423 424 procedure To_COBOL 425 (Item : String; 426 Target : out Alphanumeric; 427 Last : out Natural) 428 is 429 Last_Val : Integer; 430 431 begin 432 if Item'Length > Target'Length then 433 raise Constraint_Error; 434 end if; 435 436 Last_Val := Target'First - 1; 437 for J in Item'Range loop 438 Last_Val := Last_Val + 1; 439 Target (Last_Val) := Ada_To_COBOL (Item (J)); 440 end loop; 441 442 Last := Last_Val; 443 end To_COBOL; 444 445 ---------------- 446 -- To_Display -- 447 ---------------- 448 449 function To_Display 450 (Item : Integer_64; 451 Format : Display_Format; 452 Length : Natural) 453 return Numeric 454 is 455 Result : Numeric (1 .. Length); 456 Val : Integer_64 := Item; 457 458 procedure Convert (First, Last : Natural); 459 -- Convert the number in Val into COBOL_Digits, storing the result 460 -- in Result (First .. Last). Raise Conversion_Error if too large. 461 462 procedure Embed_Sign (Loc : Natural); 463 -- Used for the nonseparate formats to embed the appropriate sign 464 -- at the specified location (i.e. at Result (Loc)) 465 466 procedure Convert (First, Last : Natural) is 467 J : Natural := Last; 468 469 begin 470 while J >= First loop 471 Result (J) := 472 COBOL_Character'Val 473 (COBOL_Character'Pos (COBOL_Digits'First) + 474 Integer (Val mod 10)); 475 Val := Val / 10; 476 477 if Val = 0 then 478 for K in First .. J - 1 loop 479 Result (J) := COBOL_Digits'First; 480 end loop; 481 482 return; 483 484 else 485 J := J - 1; 486 end if; 487 end loop; 488 489 raise Conversion_Error; 490 end Convert; 491 492 procedure Embed_Sign (Loc : Natural) is 493 Digit : Natural range 0 .. 9; 494 495 begin 496 Digit := COBOL_Character'Pos (Result (Loc)) - 497 COBOL_Character'Pos (COBOL_Digits'First); 498 499 if Item >= 0 then 500 Result (Loc) := 501 COBOL_Character'Val 502 (COBOL_Character'Pos (COBOL_Plus_Digits'First) + Digit); 503 else 504 Result (Loc) := 505 COBOL_Character'Val 506 (COBOL_Character'Pos (COBOL_Minus_Digits'First) + Digit); 507 end if; 508 end Embed_Sign; 509 510 -- Start of processing for To_Display 511 512 begin 513 case Format is 514 when Unsigned => 515 if Val < 0 then 516 raise Conversion_Error; 517 else 518 Convert (1, Length); 519 end if; 520 521 when Leading_Separate => 522 if Val < 0 then 523 Result (1) := COBOL_Minus; 524 Val := -Val; 525 else 526 Result (1) := COBOL_Plus; 527 end if; 528 529 Convert (2, Length); 530 531 when Trailing_Separate => 532 if Val < 0 then 533 Result (Length) := COBOL_Minus; 534 Val := -Val; 535 else 536 Result (Length) := COBOL_Plus; 537 end if; 538 539 Convert (1, Length - 1); 540 541 when Leading_Nonseparate => 542 Val := abs Val; 543 Convert (1, Length); 544 Embed_Sign (1); 545 546 when Trailing_Nonseparate => 547 Val := abs Val; 548 Convert (1, Length); 549 Embed_Sign (Length); 550 551 end case; 552 553 return Result; 554 end To_Display; 555 556 --------------- 557 -- To_Packed -- 558 --------------- 559 560 function To_Packed 561 (Item : Integer_64; 562 Format : Packed_Format; 563 Length : Natural) 564 return Packed_Decimal 565 is 566 Result : Packed_Decimal (1 .. Length); 567 Val : Integer_64; 568 569 procedure Convert (First, Last : Natural); 570 -- Convert the number in Val into a sequence of Decimal_Element values, 571 -- storing the result in Result (First .. Last). Raise Conversion_Error 572 -- if the value is too large to fit. 573 574 procedure Convert (First, Last : Natural) is 575 J : Natural := Last; 576 577 begin 578 while J >= First loop 579 Result (J) := Decimal_Element (Val mod 10); 580 581 Val := Val / 10; 582 583 if Val = 0 then 584 for K in First .. J - 1 loop 585 Result (K) := 0; 586 end loop; 587 588 return; 589 590 else 591 J := J - 1; 592 end if; 593 end loop; 594 595 raise Conversion_Error; 596 end Convert; 597 598 -- Start of processing for To_Packed 599 600 begin 601 case Packed_Representation is 602 when IBM => 603 if Format = Packed_Unsigned then 604 if Item < 0 then 605 raise Conversion_Error; 606 else 607 Result (Length) := 16#F#; 608 Val := Item; 609 end if; 610 611 elsif Item >= 0 then 612 Result (Length) := 16#C#; 613 Val := Item; 614 615 else -- Item < 0 616 Result (Length) := 16#D#; 617 Val := -Item; 618 end if; 619 620 Convert (1, Length - 1); 621 return Result; 622 end case; 623 end To_Packed; 624 625 ------------------- 626 -- Valid_Numeric -- 627 ------------------- 628 629 function Valid_Numeric 630 (Item : Numeric; 631 Format : Display_Format) 632 return Boolean 633 is 634 begin 635 -- All character positions except first and last must be Digits. 636 -- This is true for all the formats. 637 638 for J in Item'First + 1 .. Item'Last - 1 loop 639 if Item (J) not in COBOL_Digits then 640 return False; 641 end if; 642 end loop; 643 644 case Format is 645 when Unsigned => 646 return Item (Item'First) in COBOL_Digits 647 and then Item (Item'Last) in COBOL_Digits; 648 649 when Leading_Separate => 650 return (Item (Item'First) = COBOL_Plus or else 651 Item (Item'First) = COBOL_Minus) 652 and then Item (Item'Last) in COBOL_Digits; 653 654 when Trailing_Separate => 655 return Item (Item'First) in COBOL_Digits 656 and then 657 (Item (Item'Last) = COBOL_Plus or else 658 Item (Item'Last) = COBOL_Minus); 659 660 when Leading_Nonseparate => 661 return (Item (Item'First) in COBOL_Plus_Digits or else 662 Item (Item'First) in COBOL_Minus_Digits) 663 and then Item (Item'Last) in COBOL_Digits; 664 665 when Trailing_Nonseparate => 666 return Item (Item'First) in COBOL_Digits 667 and then 668 (Item (Item'Last) in COBOL_Plus_Digits or else 669 Item (Item'Last) in COBOL_Minus_Digits); 670 671 end case; 672 end Valid_Numeric; 673 674 ------------------ 675 -- Valid_Packed -- 676 ------------------ 677 678 function Valid_Packed 679 (Item : Packed_Decimal; 680 Format : Packed_Format) 681 return Boolean 682 is 683 begin 684 case Packed_Representation is 685 when IBM => 686 for J in Item'First .. Item'Last - 1 loop 687 if Item (J) > 9 then 688 return False; 689 end if; 690 end loop; 691 692 -- For unsigned, sign digit must be F 693 694 if Format = Packed_Unsigned then 695 return Item (Item'Last) = 16#F#; 696 697 -- For signed, accept all standard and non-standard signs 698 699 else 700 return Item (Item'Last) in 16#A# .. 16#F#; 701 end if; 702 end case; 703 end Valid_Packed; 704 705 ------------------------- 706 -- Decimal_Conversions -- 707 ------------------------- 708 709 package body Decimal_Conversions is 710 711 --------------------- 712 -- Length (binary) -- 713 --------------------- 714 715 -- Note that the tests here are all compile time tests 716 717 function Length (Format : Binary_Format) return Natural is 718 pragma Warnings (Off, Format); 719 720 begin 721 if Num'Digits <= 2 then 722 return 1; 723 724 elsif Num'Digits <= 4 then 725 return 2; 726 727 elsif Num'Digits <= 9 then 728 return 4; 729 730 else -- Num'Digits in 10 .. 18 731 return 8; 732 end if; 733 end Length; 734 735 ---------------------- 736 -- Length (display) -- 737 ---------------------- 738 739 function Length (Format : Display_Format) return Natural is 740 begin 741 if Format = Leading_Separate or else Format = Trailing_Separate then 742 return Num'Digits + 1; 743 else 744 return Num'Digits; 745 end if; 746 end Length; 747 748 --------------------- 749 -- Length (packed) -- 750 --------------------- 751 752 -- Note that the tests here are all compile time checks 753 754 function Length 755 (Format : Packed_Format) 756 return Natural 757 is 758 pragma Warnings (Off, Format); 759 760 begin 761 case Packed_Representation is 762 when IBM => 763 return (Num'Digits + 2) / 2 * 2; 764 end case; 765 end Length; 766 767 --------------- 768 -- To_Binary -- 769 --------------- 770 771 function To_Binary 772 (Item : Num; 773 Format : Binary_Format) 774 return Byte_Array 775 is 776 begin 777 -- Note: all these tests are compile time tests 778 779 if Num'Digits <= 2 then 780 return To_B1 (Integer_8'Integer_Value (Item)); 781 782 elsif Num'Digits <= 4 then 783 declare 784 R : B2 := To_B2 (Integer_16'Integer_Value (Item)); 785 786 begin 787 Swap (R, Format); 788 return R; 789 end; 790 791 elsif Num'Digits <= 9 then 792 declare 793 R : B4 := To_B4 (Integer_32'Integer_Value (Item)); 794 795 begin 796 Swap (R, Format); 797 return R; 798 end; 799 800 else -- Num'Digits in 10 .. 18 801 declare 802 R : B8 := To_B8 (Integer_64'Integer_Value (Item)); 803 804 begin 805 Swap (R, Format); 806 return R; 807 end; 808 end if; 809 810 exception 811 when Constraint_Error => 812 raise Conversion_Error; 813 end To_Binary; 814 815 --------------------------------- 816 -- To_Binary (internal binary) -- 817 --------------------------------- 818 819 function To_Binary (Item : Num) return Binary is 820 pragma Unsuppress (Range_Check); 821 begin 822 return Binary'Integer_Value (Item); 823 824 exception 825 when Constraint_Error => 826 raise Conversion_Error; 827 end To_Binary; 828 829 ------------------------- 830 -- To_Decimal (binary) -- 831 ------------------------- 832 833 function To_Decimal 834 (Item : Byte_Array; 835 Format : Binary_Format) 836 return Num 837 is 838 pragma Unsuppress (Range_Check); 839 840 begin 841 return Num'Fixed_Value (Binary_To_Decimal (Item, Format)); 842 843 exception 844 when Constraint_Error => 845 raise Conversion_Error; 846 end To_Decimal; 847 848 ---------------------------------- 849 -- To_Decimal (internal binary) -- 850 ---------------------------------- 851 852 function To_Decimal (Item : Binary) return Num is 853 pragma Unsuppress (Range_Check); 854 855 begin 856 return Num'Fixed_Value (Item); 857 858 exception 859 when Constraint_Error => 860 raise Conversion_Error; 861 end To_Decimal; 862 863 -------------------------- 864 -- To_Decimal (display) -- 865 -------------------------- 866 867 function To_Decimal 868 (Item : Numeric; 869 Format : Display_Format) 870 return Num 871 is 872 pragma Unsuppress (Range_Check); 873 874 begin 875 return Num'Fixed_Value (Numeric_To_Decimal (Item, Format)); 876 877 exception 878 when Constraint_Error => 879 raise Conversion_Error; 880 end To_Decimal; 881 882 --------------------------------------- 883 -- To_Decimal (internal long binary) -- 884 --------------------------------------- 885 886 function To_Decimal (Item : Long_Binary) return Num is 887 pragma Unsuppress (Range_Check); 888 889 begin 890 return Num'Fixed_Value (Item); 891 892 exception 893 when Constraint_Error => 894 raise Conversion_Error; 895 end To_Decimal; 896 897 ------------------------- 898 -- To_Decimal (packed) -- 899 ------------------------- 900 901 function To_Decimal 902 (Item : Packed_Decimal; 903 Format : Packed_Format) 904 return Num 905 is 906 pragma Unsuppress (Range_Check); 907 908 begin 909 return Num'Fixed_Value (Packed_To_Decimal (Item, Format)); 910 911 exception 912 when Constraint_Error => 913 raise Conversion_Error; 914 end To_Decimal; 915 916 ---------------- 917 -- To_Display -- 918 ---------------- 919 920 function To_Display 921 (Item : Num; 922 Format : Display_Format) 923 return Numeric 924 is 925 pragma Unsuppress (Range_Check); 926 927 begin 928 return 929 To_Display 930 (Integer_64'Integer_Value (Item), 931 Format, 932 Length (Format)); 933 934 exception 935 when Constraint_Error => 936 raise Conversion_Error; 937 end To_Display; 938 939 -------------------- 940 -- To_Long_Binary -- 941 -------------------- 942 943 function To_Long_Binary (Item : Num) return Long_Binary is 944 pragma Unsuppress (Range_Check); 945 946 begin 947 return Long_Binary'Integer_Value (Item); 948 949 exception 950 when Constraint_Error => 951 raise Conversion_Error; 952 end To_Long_Binary; 953 954 --------------- 955 -- To_Packed -- 956 --------------- 957 958 function To_Packed 959 (Item : Num; 960 Format : Packed_Format) 961 return Packed_Decimal 962 is 963 pragma Unsuppress (Range_Check); 964 965 begin 966 return 967 To_Packed 968 (Integer_64'Integer_Value (Item), 969 Format, 970 Length (Format)); 971 972 exception 973 when Constraint_Error => 974 raise Conversion_Error; 975 end To_Packed; 976 977 -------------------- 978 -- Valid (binary) -- 979 -------------------- 980 981 function Valid 982 (Item : Byte_Array; 983 Format : Binary_Format) 984 return Boolean 985 is 986 Val : Num; 987 pragma Unreferenced (Val); 988 989 begin 990 Val := To_Decimal (Item, Format); 991 return True; 992 993 exception 994 when Conversion_Error => 995 return False; 996 end Valid; 997 998 --------------------- 999 -- Valid (display) -- 1000 --------------------- 1001 1002 function Valid 1003 (Item : Numeric; 1004 Format : Display_Format) 1005 return Boolean 1006 is 1007 begin 1008 return Valid_Numeric (Item, Format); 1009 end Valid; 1010 1011 -------------------- 1012 -- Valid (packed) -- 1013 -------------------- 1014 1015 function Valid 1016 (Item : Packed_Decimal; 1017 Format : Packed_Format) 1018 return Boolean 1019 is 1020 begin 1021 return Valid_Packed (Item, Format); 1022 end Valid; 1023 1024 end Decimal_Conversions; 1025 1026end Interfaces.COBOL; 1027