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