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