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-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
  37 with Interfaces; use Interfaces;
  38 with System;     use System;
  39 with Ada.Unchecked_Conversion;
  40
  41 package 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
 993 end Interfaces.COBOL;