gcc/ada/libgnat/i-cobol.adb

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