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