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-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 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 end case; 547 548 return Result; 549 end To_Display; 550 551 --------------- 552 -- To_Packed -- 553 --------------- 554 555 function To_Packed 556 (Item : Integer_64; 557 Format : Packed_Format; 558 Length : Natural) return Packed_Decimal 559 is 560 Result : Packed_Decimal (1 .. Length); 561 Val : Integer_64; 562 563 procedure Convert (First, Last : Natural); 564 -- Convert the number in Val into a sequence of Decimal_Element values, 565 -- storing the result in Result (First .. Last). Raise Conversion_Error 566 -- if the value is too large to fit. 567 568 ------------- 569 -- Convert -- 570 ------------- 571 572 procedure Convert (First, Last : Natural) is 573 J : Natural := Last; 574 575 begin 576 while J >= First loop 577 Result (J) := Decimal_Element (Val mod 10); 578 579 Val := Val / 10; 580 581 if Val = 0 then 582 for K in First .. J - 1 loop 583 Result (K) := 0; 584 end loop; 585 586 return; 587 588 else 589 J := J - 1; 590 end if; 591 end loop; 592 593 raise Conversion_Error; 594 end Convert; 595 596 -- Start of processing for To_Packed 597 598 begin 599 case Packed_Representation is 600 when IBM => 601 if Format = Packed_Unsigned then 602 if Item < 0 then 603 raise Conversion_Error; 604 else 605 Result (Length) := 16#F#; 606 Val := Item; 607 end if; 608 609 elsif Item >= 0 then 610 Result (Length) := 16#C#; 611 Val := Item; 612 613 else -- Item < 0 614 Result (Length) := 16#D#; 615 Val := -Item; 616 end if; 617 618 Convert (1, Length - 1); 619 return Result; 620 end case; 621 end To_Packed; 622 623 ------------------- 624 -- Valid_Numeric -- 625 ------------------- 626 627 function Valid_Numeric 628 (Item : Numeric; 629 Format : Display_Format) return Boolean 630 is 631 begin 632 if Item'Length = 0 then 633 return False; 634 end if; 635 636 -- All character positions except first and last must be Digits. 637 -- This is true for all the formats. 638 639 for J in Item'First + 1 .. Item'Last - 1 loop 640 if Item (J) not in COBOL_Digits then 641 return False; 642 end if; 643 end loop; 644 645 case Format is 646 when Unsigned => 647 return Item (Item'First) in COBOL_Digits 648 and then Item (Item'Last) in COBOL_Digits; 649 650 when Leading_Separate => 651 return (Item (Item'First) = COBOL_Plus or else 652 Item (Item'First) = COBOL_Minus) 653 and then Item (Item'Last) in COBOL_Digits; 654 655 when Trailing_Separate => 656 return Item (Item'First) in COBOL_Digits 657 and then 658 (Item (Item'Last) = COBOL_Plus or else 659 Item (Item'Last) = COBOL_Minus); 660 661 when Leading_Nonseparate => 662 return (Item (Item'First) in COBOL_Plus_Digits or else 663 Item (Item'First) in COBOL_Minus_Digits) 664 and then Item (Item'Last) in COBOL_Digits; 665 666 when Trailing_Nonseparate => 667 return Item (Item'First) in COBOL_Digits 668 and then 669 (Item (Item'Last) in COBOL_Plus_Digits or else 670 Item (Item'Last) in COBOL_Minus_Digits); 671 672 end case; 673 end Valid_Numeric; 674 675 ------------------ 676 -- Valid_Packed -- 677 ------------------ 678 679 function Valid_Packed 680 (Item : Packed_Decimal; 681 Format : Packed_Format) 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 Unreferenced (Format); 719 begin 720 if Num'Digits <= 2 then 721 return 1; 722 elsif Num'Digits <= 4 then 723 return 2; 724 elsif Num'Digits <= 9 then 725 return 4; 726 else -- Num'Digits in 10 .. 18 727 return 8; 728 end if; 729 end Length; 730 731 ---------------------- 732 -- Length (display) -- 733 ---------------------- 734 735 function Length (Format : Display_Format) return Natural is 736 begin 737 if Format = Leading_Separate or else Format = Trailing_Separate then 738 return Num'Digits + 1; 739 else 740 return Num'Digits; 741 end if; 742 end Length; 743 744 --------------------- 745 -- Length (packed) -- 746 --------------------- 747 748 -- Note that the tests here are all compile time checks 749 750 function Length 751 (Format : Packed_Format) return Natural 752 is 753 pragma Unreferenced (Format); 754 begin 755 case Packed_Representation is 756 when IBM => 757 return (Num'Digits + 2) / 2 * 2; 758 end case; 759 end Length; 760 761 --------------- 762 -- To_Binary -- 763 --------------- 764 765 function To_Binary 766 (Item : Num; 767 Format : Binary_Format) return Byte_Array 768 is 769 begin 770 -- Note: all these tests are compile time tests 771 772 if Num'Digits <= 2 then 773 return To_B1 (Integer_8'Integer_Value (Item)); 774 775 elsif Num'Digits <= 4 then 776 declare 777 R : B2 := To_B2 (Integer_16'Integer_Value (Item)); 778 779 begin 780 Swap (R, Format); 781 return R; 782 end; 783 784 elsif Num'Digits <= 9 then 785 declare 786 R : B4 := To_B4 (Integer_32'Integer_Value (Item)); 787 788 begin 789 Swap (R, Format); 790 return R; 791 end; 792 793 else -- Num'Digits in 10 .. 18 794 declare 795 R : B8 := To_B8 (Integer_64'Integer_Value (Item)); 796 797 begin 798 Swap (R, Format); 799 return R; 800 end; 801 end if; 802 803 exception 804 when Constraint_Error => 805 raise Conversion_Error; 806 end To_Binary; 807 808 --------------------------------- 809 -- To_Binary (internal binary) -- 810 --------------------------------- 811 812 function To_Binary (Item : Num) return Binary is 813 pragma Unsuppress (Range_Check); 814 begin 815 return Binary'Integer_Value (Item); 816 exception 817 when Constraint_Error => 818 raise Conversion_Error; 819 end To_Binary; 820 821 ------------------------- 822 -- To_Decimal (binary) -- 823 ------------------------- 824 825 function To_Decimal 826 (Item : Byte_Array; 827 Format : Binary_Format) return Num 828 is 829 pragma Unsuppress (Range_Check); 830 begin 831 return Num'Fixed_Value (Binary_To_Decimal (Item, Format)); 832 exception 833 when Constraint_Error => 834 raise Conversion_Error; 835 end To_Decimal; 836 837 ---------------------------------- 838 -- To_Decimal (internal binary) -- 839 ---------------------------------- 840 841 function To_Decimal (Item : Binary) return Num is 842 pragma Unsuppress (Range_Check); 843 begin 844 return Num'Fixed_Value (Item); 845 exception 846 when Constraint_Error => 847 raise Conversion_Error; 848 end To_Decimal; 849 850 -------------------------- 851 -- To_Decimal (display) -- 852 -------------------------- 853 854 function To_Decimal 855 (Item : Numeric; 856 Format : Display_Format) return Num 857 is 858 pragma Unsuppress (Range_Check); 859 860 begin 861 return Num'Fixed_Value (Numeric_To_Decimal (Item, Format)); 862 exception 863 when Constraint_Error => 864 raise Conversion_Error; 865 end To_Decimal; 866 867 --------------------------------------- 868 -- To_Decimal (internal long binary) -- 869 --------------------------------------- 870 871 function To_Decimal (Item : Long_Binary) return Num is 872 pragma Unsuppress (Range_Check); 873 begin 874 return Num'Fixed_Value (Item); 875 exception 876 when Constraint_Error => 877 raise Conversion_Error; 878 end To_Decimal; 879 880 ------------------------- 881 -- To_Decimal (packed) -- 882 ------------------------- 883 884 function To_Decimal 885 (Item : Packed_Decimal; 886 Format : Packed_Format) return Num 887 is 888 pragma Unsuppress (Range_Check); 889 begin 890 return Num'Fixed_Value (Packed_To_Decimal (Item, Format)); 891 exception 892 when Constraint_Error => 893 raise Conversion_Error; 894 end To_Decimal; 895 896 ---------------- 897 -- To_Display -- 898 ---------------- 899 900 function To_Display 901 (Item : Num; 902 Format : Display_Format) return Numeric 903 is 904 pragma Unsuppress (Range_Check); 905 begin 906 return 907 To_Display 908 (Integer_64'Integer_Value (Item), 909 Format, 910 Length (Format)); 911 exception 912 when Constraint_Error => 913 raise Conversion_Error; 914 end To_Display; 915 916 -------------------- 917 -- To_Long_Binary -- 918 -------------------- 919 920 function To_Long_Binary (Item : Num) return Long_Binary is 921 pragma Unsuppress (Range_Check); 922 begin 923 return Long_Binary'Integer_Value (Item); 924 exception 925 when Constraint_Error => 926 raise Conversion_Error; 927 end To_Long_Binary; 928 929 --------------- 930 -- To_Packed -- 931 --------------- 932 933 function To_Packed 934 (Item : Num; 935 Format : Packed_Format) return Packed_Decimal 936 is 937 pragma Unsuppress (Range_Check); 938 begin 939 return 940 To_Packed 941 (Integer_64'Integer_Value (Item), 942 Format, 943 Length (Format)); 944 exception 945 when Constraint_Error => 946 raise Conversion_Error; 947 end To_Packed; 948 949 -------------------- 950 -- Valid (binary) -- 951 -------------------- 952 953 function Valid 954 (Item : Byte_Array; 955 Format : Binary_Format) return Boolean 956 is 957 Val : Num; 958 pragma Unreferenced (Val); 959 begin 960 Val := To_Decimal (Item, Format); 961 return True; 962 exception 963 when Conversion_Error => 964 return False; 965 end Valid; 966 967 --------------------- 968 -- Valid (display) -- 969 --------------------- 970 971 function Valid 972 (Item : Numeric; 973 Format : Display_Format) return Boolean 974 is 975 begin 976 return Valid_Numeric (Item, Format); 977 end Valid; 978 979 -------------------- 980 -- Valid (packed) -- 981 -------------------- 982 983 function Valid 984 (Item : Packed_Decimal; 985 Format : Packed_Format) return Boolean 986 is 987 begin 988 return Valid_Packed (Item, Format); 989 end Valid; 990 991 end Decimal_Conversions; 992 993end Interfaces.COBOL; 994