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-2020, 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_Minus_Digits then 244 Result := Result * 10 + 245 (COBOL_Character'Pos (K) - 246 COBOL_Character'Pos (COBOL_Minus_Digits'First)); 247 Sign := COBOL_Minus; 248 249 -- Only remaining possibility is COBOL_Plus or COBOL_Minus 250 251 else 252 Sign := K; 253 end if; 254 end; 255 end loop; 256 257 if Sign = COBOL_Plus then 258 return Result; 259 else 260 return -Result; 261 end if; 262 263 exception 264 when Constraint_Error => 265 raise Conversion_Error; 266 267 end Numeric_To_Decimal; 268 269 ----------------------- 270 -- Packed_To_Decimal -- 271 ----------------------- 272 273 function Packed_To_Decimal 274 (Item : Packed_Decimal; 275 Format : Packed_Format) return Integer_64 276 is 277 pragma Unsuppress (Range_Check); 278 Result : Integer_64 := 0; 279 Sign : constant Decimal_Element := Item (Item'Last); 280 281 begin 282 if not Valid_Packed (Item, Format) then 283 raise Conversion_Error; 284 end if; 285 286 case Packed_Representation is 287 when IBM => 288 for J in Item'First .. Item'Last - 1 loop 289 Result := Result * 10 + Integer_64 (Item (J)); 290 end loop; 291 292 if Sign = 16#0B# or else Sign = 16#0D# then 293 return -Result; 294 else 295 return +Result; 296 end if; 297 end case; 298 299 exception 300 when Constraint_Error => 301 raise Conversion_Error; 302 end Packed_To_Decimal; 303 304 ---------- 305 -- Swap -- 306 ---------- 307 308 procedure Swap (B : in out Byte_Array; F : Binary_Format) is 309 Little_Endian : constant Boolean := 310 System.Default_Bit_Order = System.Low_Order_First; 311 312 begin 313 -- Return if no swap needed 314 315 case F is 316 when H | HU => 317 if not Little_Endian then 318 return; 319 end if; 320 321 when L | LU => 322 if Little_Endian then 323 return; 324 end if; 325 326 when N | NU => 327 return; 328 end case; 329 330 -- Here a swap is needed 331 332 declare 333 Len : constant Natural := B'Length; 334 335 begin 336 for J in 1 .. Len / 2 loop 337 declare 338 Temp : constant Byte := B (J); 339 340 begin 341 B (J) := B (Len + 1 - J); 342 B (Len + 1 - J) := Temp; 343 end; 344 end loop; 345 end; 346 end Swap; 347 348 ----------------------- 349 -- To_Ada (function) -- 350 ----------------------- 351 352 function To_Ada (Item : Alphanumeric) return String is 353 Result : String (Item'Range); 354 355 begin 356 for J in Item'Range loop 357 Result (J) := COBOL_To_Ada (Item (J)); 358 end loop; 359 360 return Result; 361 end To_Ada; 362 363 ------------------------ 364 -- To_Ada (procedure) -- 365 ------------------------ 366 367 procedure To_Ada 368 (Item : Alphanumeric; 369 Target : out String; 370 Last : out Natural) 371 is 372 Last_Val : Integer; 373 374 begin 375 if Item'Length > Target'Length then 376 raise Constraint_Error; 377 end if; 378 379 Last_Val := Target'First - 1; 380 for J in Item'Range loop 381 Last_Val := Last_Val + 1; 382 Target (Last_Val) := COBOL_To_Ada (Item (J)); 383 end loop; 384 385 Last := Last_Val; 386 end To_Ada; 387 388 ------------------------- 389 -- To_COBOL (function) -- 390 ------------------------- 391 392 function To_COBOL (Item : String) return Alphanumeric is 393 Result : Alphanumeric (Item'Range); 394 395 begin 396 for J in Item'Range loop 397 Result (J) := Ada_To_COBOL (Item (J)); 398 end loop; 399 400 return Result; 401 end To_COBOL; 402 403 -------------------------- 404 -- To_COBOL (procedure) -- 405 -------------------------- 406 407 procedure To_COBOL 408 (Item : String; 409 Target : out Alphanumeric; 410 Last : out Natural) 411 is 412 Last_Val : Integer; 413 414 begin 415 if Item'Length > Target'Length then 416 raise Constraint_Error; 417 end if; 418 419 Last_Val := Target'First - 1; 420 for J in Item'Range loop 421 Last_Val := Last_Val + 1; 422 Target (Last_Val) := Ada_To_COBOL (Item (J)); 423 end loop; 424 425 Last := Last_Val; 426 end To_COBOL; 427 428 ---------------- 429 -- To_Display -- 430 ---------------- 431 432 function To_Display 433 (Item : Integer_64; 434 Format : Display_Format; 435 Length : Natural) return Numeric 436 is 437 Result : Numeric (1 .. Length); 438 Val : Integer_64 := Item; 439 440 procedure Convert (First, Last : Natural); 441 -- Convert the number in Val into COBOL_Digits, storing the result 442 -- in Result (First .. Last). Raise Conversion_Error if too large. 443 444 procedure Embed_Sign (Loc : Natural); 445 -- Used for the nonseparate formats to embed the appropriate sign 446 -- at the specified location (i.e. at Result (Loc)) 447 448 ------------- 449 -- Convert -- 450 ------------- 451 452 procedure Convert (First, Last : Natural) is 453 J : Natural; 454 455 begin 456 J := Last; 457 while J >= First loop 458 Result (J) := 459 COBOL_Character'Val 460 (COBOL_Character'Pos (COBOL_Digits'First) + 461 Integer (Val mod 10)); 462 Val := Val / 10; 463 464 if Val = 0 then 465 for K in First .. J - 1 loop 466 Result (J) := COBOL_Digits'First; 467 end loop; 468 469 return; 470 471 else 472 J := J - 1; 473 end if; 474 end loop; 475 476 raise Conversion_Error; 477 end Convert; 478 479 ---------------- 480 -- Embed_Sign -- 481 ---------------- 482 483 procedure Embed_Sign (Loc : Natural) is 484 Digit : Natural range 0 .. 9; 485 486 begin 487 Digit := COBOL_Character'Pos (Result (Loc)) - 488 COBOL_Character'Pos (COBOL_Digits'First); 489 490 if Item >= 0 then 491 Result (Loc) := 492 COBOL_Character'Val 493 (COBOL_Character'Pos (COBOL_Plus_Digits'First) + Digit); 494 else 495 Result (Loc) := 496 COBOL_Character'Val 497 (COBOL_Character'Pos (COBOL_Minus_Digits'First) + Digit); 498 end if; 499 end Embed_Sign; 500 501 -- Start of processing for To_Display 502 503 begin 504 case Format is 505 when Unsigned => 506 if Val < 0 then 507 raise Conversion_Error; 508 else 509 Convert (1, Length); 510 end if; 511 512 when Leading_Separate => 513 if Val < 0 then 514 Result (1) := COBOL_Minus; 515 Val := -Val; 516 else 517 Result (1) := COBOL_Plus; 518 end if; 519 520 Convert (2, Length); 521 522 when Trailing_Separate => 523 if Val < 0 then 524 Result (Length) := COBOL_Minus; 525 Val := -Val; 526 else 527 Result (Length) := COBOL_Plus; 528 end if; 529 530 Convert (1, Length - 1); 531 532 when Leading_Nonseparate => 533 Val := abs Val; 534 Convert (1, Length); 535 Embed_Sign (1); 536 537 when Trailing_Nonseparate => 538 Val := abs Val; 539 Convert (1, Length); 540 Embed_Sign (Length); 541 end case; 542 543 return Result; 544 end To_Display; 545 546 --------------- 547 -- To_Packed -- 548 --------------- 549 550 function To_Packed 551 (Item : Integer_64; 552 Format : Packed_Format; 553 Length : Natural) return Packed_Decimal 554 is 555 Result : Packed_Decimal (1 .. Length); 556 Val : Integer_64; 557 558 procedure Convert (First, Last : Natural); 559 -- Convert the number in Val into a sequence of Decimal_Element values, 560 -- storing the result in Result (First .. Last). Raise Conversion_Error 561 -- if the value is too large to fit. 562 563 ------------- 564 -- Convert -- 565 ------------- 566 567 procedure Convert (First, Last : Natural) is 568 J : Natural := Last; 569 570 begin 571 while J >= First loop 572 Result (J) := Decimal_Element (Val mod 10); 573 574 Val := Val / 10; 575 576 if Val = 0 then 577 for K in First .. J - 1 loop 578 Result (K) := 0; 579 end loop; 580 581 return; 582 583 else 584 J := J - 1; 585 end if; 586 end loop; 587 588 raise Conversion_Error; 589 end Convert; 590 591 -- Start of processing for To_Packed 592 593 begin 594 case Packed_Representation is 595 when IBM => 596 if Format = Packed_Unsigned then 597 if Item < 0 then 598 raise Conversion_Error; 599 else 600 Result (Length) := 16#F#; 601 Val := Item; 602 end if; 603 604 elsif Item >= 0 then 605 Result (Length) := 16#C#; 606 Val := Item; 607 608 else -- Item < 0 609 Result (Length) := 16#D#; 610 Val := -Item; 611 end if; 612 613 Convert (1, Length - 1); 614 return Result; 615 end case; 616 end To_Packed; 617 618 ------------------- 619 -- Valid_Numeric -- 620 ------------------- 621 622 function Valid_Numeric 623 (Item : Numeric; 624 Format : Display_Format) return Boolean 625 is 626 begin 627 if Item'Length = 0 then 628 return False; 629 end if; 630 631 -- All character positions except first and last must be Digits. 632 -- This is true for all the formats. 633 634 for J in Item'First + 1 .. Item'Last - 1 loop 635 if Item (J) not in COBOL_Digits then 636 return False; 637 end if; 638 end loop; 639 640 case Format is 641 when Unsigned => 642 return Item (Item'First) in COBOL_Digits 643 and then Item (Item'Last) in COBOL_Digits; 644 645 when Leading_Separate => 646 return (Item (Item'First) = COBOL_Plus or else 647 Item (Item'First) = COBOL_Minus) 648 and then Item (Item'Last) in COBOL_Digits; 649 650 when Trailing_Separate => 651 return Item (Item'First) in COBOL_Digits 652 and then 653 (Item (Item'Last) = COBOL_Plus or else 654 Item (Item'Last) = COBOL_Minus); 655 656 when Leading_Nonseparate => 657 return (Item (Item'First) in COBOL_Plus_Digits or else 658 Item (Item'First) in COBOL_Minus_Digits) 659 and then Item (Item'Last) in COBOL_Digits; 660 661 when Trailing_Nonseparate => 662 return Item (Item'First) in COBOL_Digits 663 and then 664 (Item (Item'Last) in COBOL_Plus_Digits or else 665 Item (Item'Last) in COBOL_Minus_Digits); 666 667 end case; 668 end Valid_Numeric; 669 670 ------------------ 671 -- Valid_Packed -- 672 ------------------ 673 674 function Valid_Packed 675 (Item : Packed_Decimal; 676 Format : Packed_Format) return Boolean 677 is 678 begin 679 case Packed_Representation is 680 when IBM => 681 for J in Item'First .. Item'Last - 1 loop 682 if Item (J) > 9 then 683 return False; 684 end if; 685 end loop; 686 687 -- For unsigned, sign digit must be F 688 689 if Format = Packed_Unsigned then 690 return Item (Item'Last) = 16#F#; 691 692 -- For signed, accept all standard and non-standard signs 693 694 else 695 return Item (Item'Last) in 16#A# .. 16#F#; 696 end if; 697 end case; 698 end Valid_Packed; 699 700 ------------------------- 701 -- Decimal_Conversions -- 702 ------------------------- 703 704 package body Decimal_Conversions is 705 706 --------------------- 707 -- Length (binary) -- 708 --------------------- 709 710 -- Note that the tests here are all compile time tests 711 712 function Length (Format : Binary_Format) return Natural is 713 pragma Unreferenced (Format); 714 begin 715 if Num'Digits <= 2 then 716 return 1; 717 elsif Num'Digits <= 4 then 718 return 2; 719 elsif Num'Digits <= 9 then 720 return 4; 721 else -- Num'Digits in 10 .. 18 722 return 8; 723 end if; 724 end Length; 725 726 ---------------------- 727 -- Length (display) -- 728 ---------------------- 729 730 function Length (Format : Display_Format) return Natural is 731 begin 732 if Format = Leading_Separate or else Format = Trailing_Separate then 733 return Num'Digits + 1; 734 else 735 return Num'Digits; 736 end if; 737 end Length; 738 739 --------------------- 740 -- Length (packed) -- 741 --------------------- 742 743 -- Note that the tests here are all compile time checks 744 745 function Length 746 (Format : Packed_Format) return Natural 747 is 748 pragma Unreferenced (Format); 749 begin 750 case Packed_Representation is 751 when IBM => 752 return (Num'Digits + 2) / 2 * 2; 753 end case; 754 end Length; 755 756 --------------- 757 -- To_Binary -- 758 --------------- 759 760 function To_Binary 761 (Item : Num; 762 Format : Binary_Format) return Byte_Array 763 is 764 begin 765 -- Note: all these tests are compile time tests 766 767 if Num'Digits <= 2 then 768 return To_B1 (Integer_8'Integer_Value (Item)); 769 770 elsif Num'Digits <= 4 then 771 declare 772 R : B2 := To_B2 (Integer_16'Integer_Value (Item)); 773 774 begin 775 Swap (R, Format); 776 return R; 777 end; 778 779 elsif Num'Digits <= 9 then 780 declare 781 R : B4 := To_B4 (Integer_32'Integer_Value (Item)); 782 783 begin 784 Swap (R, Format); 785 return R; 786 end; 787 788 else -- Num'Digits in 10 .. 18 789 declare 790 R : B8 := To_B8 (Integer_64'Integer_Value (Item)); 791 792 begin 793 Swap (R, Format); 794 return R; 795 end; 796 end if; 797 798 exception 799 when Constraint_Error => 800 raise Conversion_Error; 801 end To_Binary; 802 803 --------------------------------- 804 -- To_Binary (internal binary) -- 805 --------------------------------- 806 807 function To_Binary (Item : Num) return Binary is 808 pragma Unsuppress (Range_Check); 809 begin 810 return Binary'Integer_Value (Item); 811 exception 812 when Constraint_Error => 813 raise Conversion_Error; 814 end To_Binary; 815 816 ------------------------- 817 -- To_Decimal (binary) -- 818 ------------------------- 819 820 function To_Decimal 821 (Item : Byte_Array; 822 Format : Binary_Format) return Num 823 is 824 pragma Unsuppress (Range_Check); 825 begin 826 return Num'Fixed_Value (Binary_To_Decimal (Item, Format)); 827 exception 828 when Constraint_Error => 829 raise Conversion_Error; 830 end To_Decimal; 831 832 ---------------------------------- 833 -- To_Decimal (internal binary) -- 834 ---------------------------------- 835 836 function To_Decimal (Item : Binary) return Num is 837 pragma Unsuppress (Range_Check); 838 begin 839 return Num'Fixed_Value (Item); 840 exception 841 when Constraint_Error => 842 raise Conversion_Error; 843 end To_Decimal; 844 845 -------------------------- 846 -- To_Decimal (display) -- 847 -------------------------- 848 849 function To_Decimal 850 (Item : Numeric; 851 Format : Display_Format) return Num 852 is 853 pragma Unsuppress (Range_Check); 854 855 begin 856 return Num'Fixed_Value (Numeric_To_Decimal (Item, Format)); 857 exception 858 when Constraint_Error => 859 raise Conversion_Error; 860 end To_Decimal; 861 862 --------------------------------------- 863 -- To_Decimal (internal long binary) -- 864 --------------------------------------- 865 866 function To_Decimal (Item : Long_Binary) return Num is 867 pragma Unsuppress (Range_Check); 868 begin 869 return Num'Fixed_Value (Item); 870 exception 871 when Constraint_Error => 872 raise Conversion_Error; 873 end To_Decimal; 874 875 ------------------------- 876 -- To_Decimal (packed) -- 877 ------------------------- 878 879 function To_Decimal 880 (Item : Packed_Decimal; 881 Format : Packed_Format) return Num 882 is 883 pragma Unsuppress (Range_Check); 884 begin 885 return Num'Fixed_Value (Packed_To_Decimal (Item, Format)); 886 exception 887 when Constraint_Error => 888 raise Conversion_Error; 889 end To_Decimal; 890 891 ---------------- 892 -- To_Display -- 893 ---------------- 894 895 function To_Display 896 (Item : Num; 897 Format : Display_Format) return Numeric 898 is 899 pragma Unsuppress (Range_Check); 900 begin 901 return 902 To_Display 903 (Integer_64'Integer_Value (Item), 904 Format, 905 Length (Format)); 906 exception 907 when Constraint_Error => 908 raise Conversion_Error; 909 end To_Display; 910 911 -------------------- 912 -- To_Long_Binary -- 913 -------------------- 914 915 function To_Long_Binary (Item : Num) return Long_Binary is 916 pragma Unsuppress (Range_Check); 917 begin 918 return Long_Binary'Integer_Value (Item); 919 exception 920 when Constraint_Error => 921 raise Conversion_Error; 922 end To_Long_Binary; 923 924 --------------- 925 -- To_Packed -- 926 --------------- 927 928 function To_Packed 929 (Item : Num; 930 Format : Packed_Format) return Packed_Decimal 931 is 932 pragma Unsuppress (Range_Check); 933 begin 934 return 935 To_Packed 936 (Integer_64'Integer_Value (Item), 937 Format, 938 Length (Format)); 939 exception 940 when Constraint_Error => 941 raise Conversion_Error; 942 end To_Packed; 943 944 -------------------- 945 -- Valid (binary) -- 946 -------------------- 947 948 function Valid 949 (Item : Byte_Array; 950 Format : Binary_Format) return Boolean 951 is 952 Val : Num; 953 pragma Unreferenced (Val); 954 begin 955 Val := To_Decimal (Item, Format); 956 return True; 957 exception 958 when Conversion_Error => 959 return False; 960 end Valid; 961 962 --------------------- 963 -- Valid (display) -- 964 --------------------- 965 966 function Valid 967 (Item : Numeric; 968 Format : Display_Format) return Boolean 969 is 970 begin 971 return Valid_Numeric (Item, Format); 972 end Valid; 973 974 -------------------- 975 -- Valid (packed) -- 976 -------------------- 977 978 function Valid 979 (Item : Packed_Decimal; 980 Format : Packed_Format) return Boolean 981 is 982 begin 983 return Valid_Packed (Item, Format); 984 end Valid; 985 986 end Decimal_Conversions; 987 988end Interfaces.COBOL; 989