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