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