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       --  All character positions except first and last must be Digits.
 636       --  This is true for all the formats.
 637
 638       for J in Item'First + 1 .. Item'Last - 1 loop
 639          if Item (J) not in COBOL_Digits then
 640             return False;
 641          end if;
 642       end loop;
 643
 644       case Format is
 645          when Unsigned =>
 646             return Item (Item'First) in COBOL_Digits
 647               and then Item (Item'Last) in COBOL_Digits;
 648
 649          when Leading_Separate =>
 650             return (Item (Item'First) = COBOL_Plus or else
 651                     Item (Item'First) = COBOL_Minus)
 652               and then Item (Item'Last) in COBOL_Digits;
 653
 654          when Trailing_Separate =>
 655             return Item (Item'First) in COBOL_Digits
 656               and then
 657                 (Item (Item'Last) = COBOL_Plus or else
 658                  Item (Item'Last) = COBOL_Minus);
 659
 660          when Leading_Nonseparate =>
 661             return (Item (Item'First) in COBOL_Plus_Digits or else
 662                     Item (Item'First) in COBOL_Minus_Digits)
 663               and then Item (Item'Last) in COBOL_Digits;
 664
 665          when Trailing_Nonseparate =>
 666             return Item (Item'First) in COBOL_Digits
 667               and then
 668                 (Item (Item'Last) in COBOL_Plus_Digits or else
 669                  Item (Item'Last) in COBOL_Minus_Digits);
 670
 671       end case;
 672    end Valid_Numeric;
 673
 674    ------------------
 675    -- Valid_Packed --
 676    ------------------
 677
 678    function Valid_Packed
 679      (Item   : Packed_Decimal;
 680       Format : Packed_Format)
 681       return   Boolean
 682    is
 683    begin
 684       case Packed_Representation is
 685          when IBM =>
 686             for J in Item'First .. Item'Last - 1 loop
 687                if Item (J) > 9 then
 688                   return False;
 689                end if;
 690             end loop;
 691
 692             --  For unsigned, sign digit must be F
 693
 694             if Format = Packed_Unsigned then
 695                return Item (Item'Last) = 16#F#;
 696
 697             --  For signed, accept all standard and non-standard signs
 698
 699             else
 700                return Item (Item'Last) in 16#A# .. 16#F#;
 701             end if;
 702       end case;
 703    end Valid_Packed;
 704
 705    -------------------------
 706    -- Decimal_Conversions --
 707    -------------------------
 708
 709    package body Decimal_Conversions is
 710
 711       ---------------------
 712       -- Length (binary) --
 713       ---------------------
 714
 715       --  Note that the tests here are all compile time tests
 716
 717       function Length (Format : Binary_Format) return Natural is
 718          pragma Warnings (Off, Format);
 719
 720       begin
 721          if Num'Digits <= 2 then
 722             return 1;
 723
 724          elsif Num'Digits <= 4 then
 725             return 2;
 726
 727          elsif Num'Digits <= 9 then
 728             return 4;
 729
 730          else -- Num'Digits in 10 .. 18
 731             return 8;
 732          end if;
 733       end Length;
 734
 735       ----------------------
 736       -- Length (display) --
 737       ----------------------
 738
 739       function Length (Format : Display_Format) return Natural is
 740       begin
 741          if Format = Leading_Separate or else Format = Trailing_Separate then
 742             return Num'Digits + 1;
 743          else
 744             return Num'Digits;
 745          end if;
 746       end Length;
 747
 748       ---------------------
 749       -- Length (packed) --
 750       ---------------------
 751
 752       --  Note that the tests here are all compile time checks
 753
 754       function Length
 755         (Format : Packed_Format)
 756          return   Natural
 757       is
 758          pragma Warnings (Off, Format);
 759
 760       begin
 761          case Packed_Representation is
 762             when IBM =>
 763                return (Num'Digits + 2) / 2 * 2;
 764          end case;
 765       end Length;
 766
 767       ---------------
 768       -- To_Binary --
 769       ---------------
 770
 771       function To_Binary
 772         (Item   : Num;
 773          Format : Binary_Format)
 774          return   Byte_Array
 775       is
 776       begin
 777          --  Note: all these tests are compile time tests
 778
 779          if Num'Digits <= 2 then
 780             return To_B1 (Integer_8'Integer_Value (Item));
 781
 782          elsif Num'Digits <= 4 then
 783             declare
 784                R : B2 := To_B2 (Integer_16'Integer_Value (Item));
 785
 786             begin
 787                Swap (R, Format);
 788                return R;
 789             end;
 790
 791          elsif Num'Digits <= 9 then
 792             declare
 793                R : B4 := To_B4 (Integer_32'Integer_Value (Item));
 794
 795             begin
 796                Swap (R, Format);
 797                return R;
 798             end;
 799
 800          else -- Num'Digits in 10 .. 18
 801             declare
 802                R : B8 := To_B8 (Integer_64'Integer_Value (Item));
 803
 804             begin
 805                Swap (R, Format);
 806                return R;
 807             end;
 808          end if;
 809
 810       exception
 811          when Constraint_Error =>
 812             raise Conversion_Error;
 813       end To_Binary;
 814
 815       ---------------------------------
 816       -- To_Binary (internal binary) --
 817       ---------------------------------
 818
 819       function To_Binary (Item : Num) return Binary is
 820          pragma Unsuppress (Range_Check);
 821       begin
 822          return Binary'Integer_Value (Item);
 823
 824       exception
 825          when Constraint_Error =>
 826             raise Conversion_Error;
 827       end To_Binary;
 828
 829       -------------------------
 830       -- To_Decimal (binary) --
 831       -------------------------
 832
 833       function To_Decimal
 834         (Item   : Byte_Array;
 835          Format : Binary_Format)
 836          return   Num
 837       is
 838          pragma Unsuppress (Range_Check);
 839
 840       begin
 841          return Num'Fixed_Value (Binary_To_Decimal (Item, Format));
 842
 843       exception
 844          when Constraint_Error =>
 845             raise Conversion_Error;
 846       end To_Decimal;
 847
 848       ----------------------------------
 849       -- To_Decimal (internal binary) --
 850       ----------------------------------
 851
 852       function To_Decimal (Item : Binary) return Num is
 853          pragma Unsuppress (Range_Check);
 854
 855       begin
 856          return Num'Fixed_Value (Item);
 857
 858       exception
 859          when Constraint_Error =>
 860             raise Conversion_Error;
 861       end To_Decimal;
 862
 863       --------------------------
 864       -- To_Decimal (display) --
 865       --------------------------
 866
 867       function To_Decimal
 868         (Item   : Numeric;
 869          Format : Display_Format)
 870          return   Num
 871       is
 872          pragma Unsuppress (Range_Check);
 873
 874       begin
 875          return Num'Fixed_Value (Numeric_To_Decimal (Item, Format));
 876
 877       exception
 878          when Constraint_Error =>
 879             raise Conversion_Error;
 880       end To_Decimal;
 881
 882       ---------------------------------------
 883       -- To_Decimal (internal long binary) --
 884       ---------------------------------------
 885
 886       function To_Decimal (Item : Long_Binary) return Num is
 887          pragma Unsuppress (Range_Check);
 888
 889       begin
 890          return Num'Fixed_Value (Item);
 891
 892       exception
 893          when Constraint_Error =>
 894             raise Conversion_Error;
 895       end To_Decimal;
 896
 897       -------------------------
 898       -- To_Decimal (packed) --
 899       -------------------------
 900
 901       function To_Decimal
 902         (Item   : Packed_Decimal;
 903          Format : Packed_Format)
 904          return   Num
 905       is
 906          pragma Unsuppress (Range_Check);
 907
 908       begin
 909          return Num'Fixed_Value (Packed_To_Decimal (Item, Format));
 910
 911       exception
 912          when Constraint_Error =>
 913             raise Conversion_Error;
 914       end To_Decimal;
 915
 916       ----------------
 917       -- To_Display --
 918       ----------------
 919
 920       function To_Display
 921         (Item   : Num;
 922          Format : Display_Format)
 923          return   Numeric
 924       is
 925          pragma Unsuppress (Range_Check);
 926
 927       begin
 928          return
 929            To_Display
 930              (Integer_64'Integer_Value (Item),
 931               Format,
 932               Length (Format));
 933
 934       exception
 935          when Constraint_Error =>
 936             raise Conversion_Error;
 937       end To_Display;
 938
 939       --------------------
 940       -- To_Long_Binary --
 941       --------------------
 942
 943       function To_Long_Binary (Item : Num) return Long_Binary is
 944          pragma Unsuppress (Range_Check);
 945
 946       begin
 947          return Long_Binary'Integer_Value (Item);
 948
 949       exception
 950          when Constraint_Error =>
 951             raise Conversion_Error;
 952       end To_Long_Binary;
 953
 954       ---------------
 955       -- To_Packed --
 956       ---------------
 957
 958       function To_Packed
 959         (Item   : Num;
 960          Format : Packed_Format)
 961          return   Packed_Decimal
 962       is
 963          pragma Unsuppress (Range_Check);
 964
 965       begin
 966          return
 967            To_Packed
 968              (Integer_64'Integer_Value (Item),
 969               Format,
 970               Length (Format));
 971
 972       exception
 973          when Constraint_Error =>
 974             raise Conversion_Error;
 975       end To_Packed;
 976
 977       --------------------
 978       -- Valid (binary) --
 979       --------------------
 980
 981       function Valid
 982         (Item   : Byte_Array;
 983          Format : Binary_Format)
 984          return   Boolean
 985       is
 986          Val : Num;
 987          pragma Unreferenced (Val);
 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;