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: 1.14 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-1999 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
 700             --  For signed, accept all standard and non-standard signs
 701
 702             else
 703                return Item (Item'Last) in 16#A# .. 16#F#;
 704             end if;
 705       end case;
 706    end Valid_Packed;
 707
 708    -------------------------
 709    -- Decimal_Conversions --
 710    -------------------------
 711
 712    package body Decimal_Conversions is
 713
 714       ---------------------
 715       -- Length (binary) --
 716       ---------------------
 717
 718       --  Note that the tests here are all compile time tests
 719
 720       function Length (Format : Binary_Format) return Natural is
 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       begin
 760          case Packed_Representation is
 761             when IBM =>
 762                return (Num'Digits + 2) / 2 * 2;
 763          end case;
 764       end Length;
 765
 766       ---------------
 767       -- To_Binary --
 768       ---------------
 769
 770       function To_Binary
 771         (Item   : Num;
 772          Format : Binary_Format)
 773          return   Byte_Array
 774       is
 775       begin
 776          --  Note: all these tests are compile time tests
 777
 778          if Num'Digits <= 2 then
 779             return To_B1 (Integer_8'Integer_Value (Item));
 780
 781          elsif Num'Digits <= 4 then
 782             declare
 783                R : B2 := To_B2 (Integer_16'Integer_Value (Item));
 784
 785             begin
 786                Swap (R, Format);
 787                return R;
 788             end;
 789
 790          elsif Num'Digits <= 9 then
 791             declare
 792                R : B4 := To_B4 (Integer_32'Integer_Value (Item));
 793
 794             begin
 795                Swap (R, Format);
 796                return R;
 797             end;
 798
 799          else -- Num'Digits in 10 .. 18
 800             declare
 801                R : B8 := To_B8 (Integer_64'Integer_Value (Item));
 802
 803             begin
 804                Swap (R, Format);
 805                return R;
 806             end;
 807          end if;
 808
 809       exception
 810          when Constraint_Error =>
 811             raise Conversion_Error;
 812       end To_Binary;
 813
 814       ---------------------------------
 815       -- To_Binary (internal binary) --
 816       ---------------------------------
 817
 818       function To_Binary (Item : Num) return Binary is
 819          pragma Unsuppress (Range_Check);
 820       begin
 821          return Binary'Integer_Value (Item);
 822
 823       exception
 824          when Constraint_Error =>
 825             raise Conversion_Error;
 826       end To_Binary;
 827
 828       -------------------------
 829       -- To_Decimal (binary) --
 830       -------------------------
 831
 832       function To_Decimal
 833         (Item   : Byte_Array;
 834          Format : Binary_Format)
 835          return   Num
 836       is
 837          pragma Unsuppress (Range_Check);
 838
 839       begin
 840          return Num'Fixed_Value (Binary_To_Decimal (Item, Format));
 841
 842       exception
 843          when Constraint_Error =>
 844             raise Conversion_Error;
 845       end To_Decimal;
 846
 847       ----------------------------------
 848       -- To_Decimal (internal binary) --
 849       ----------------------------------
 850
 851       function To_Decimal (Item : Binary) return Num is
 852          pragma Unsuppress (Range_Check);
 853
 854       begin
 855          return Num'Fixed_Value (Item);
 856
 857       exception
 858          when Constraint_Error =>
 859             raise Conversion_Error;
 860       end To_Decimal;
 861
 862       --------------------------
 863       -- To_Decimal (display) --
 864       --------------------------
 865
 866       function To_Decimal
 867         (Item   : Numeric;
 868          Format : Display_Format)
 869          return   Num
 870       is
 871          pragma Unsuppress (Range_Check);
 872
 873       begin
 874          return Num'Fixed_Value (Numeric_To_Decimal (Item, Format));
 875
 876       exception
 877          when Constraint_Error =>
 878             raise Conversion_Error;
 879       end To_Decimal;
 880
 881       ---------------------------------------
 882       -- To_Decimal (internal long binary) --
 883       ---------------------------------------
 884
 885       function To_Decimal (Item : Long_Binary) return Num is
 886          pragma Unsuppress (Range_Check);
 887
 888       begin
 889          return Num'Fixed_Value (Item);
 890
 891       exception
 892          when Constraint_Error =>
 893             raise Conversion_Error;
 894       end To_Decimal;
 895
 896       -------------------------
 897       -- To_Decimal (packed) --
 898       -------------------------
 899
 900       function To_Decimal
 901         (Item   : Packed_Decimal;
 902          Format : Packed_Format)
 903          return   Num
 904       is
 905          pragma Unsuppress (Range_Check);
 906
 907       begin
 908          return Num'Fixed_Value (Packed_To_Decimal (Item, Format));
 909
 910       exception
 911          when Constraint_Error =>
 912             raise Conversion_Error;
 913       end To_Decimal;
 914
 915       ----------------
 916       -- To_Display --
 917       ----------------
 918
 919       function To_Display
 920         (Item   : Num;
 921          Format : Display_Format)
 922          return   Numeric
 923       is
 924          pragma Unsuppress (Range_Check);
 925
 926       begin
 927          return
 928            To_Display
 929              (Integer_64'Integer_Value (Item),
 930               Format,
 931               Length (Format));
 932
 933       exception
 934          when Constraint_Error =>
 935             raise Conversion_Error;
 936       end To_Display;
 937
 938       --------------------
 939       -- To_Long_Binary --
 940       --------------------
 941
 942       function To_Long_Binary (Item : Num) return Long_Binary is
 943          pragma Unsuppress (Range_Check);
 944
 945       begin
 946          return Long_Binary'Integer_Value (Item);
 947
 948       exception
 949          when Constraint_Error =>
 950             raise Conversion_Error;
 951       end To_Long_Binary;
 952
 953       ---------------
 954       -- To_Packed --
 955       ---------------
 956
 957       function To_Packed
 958         (Item   : Num;
 959          Format : Packed_Format)
 960          return   Packed_Decimal
 961       is
 962          pragma Unsuppress (Range_Check);
 963
 964       begin
 965          return
 966            To_Packed
 967              (Integer_64'Integer_Value (Item),
 968               Format,
 969               Length (Format));
 970
 971       exception
 972          when Constraint_Error =>
 973             raise Conversion_Error;
 974       end To_Packed;
 975
 976       --------------------
 977       -- Valid (binary) --
 978       --------------------
 979
 980       function Valid
 981         (Item   : Byte_Array;
 982          Format : Binary_Format)
 983          return   Boolean
 984       is
 985          Val : Num;
 986
 987       begin
 988          Val := To_Decimal (Item, Format);
 989          return True;
 990
 991       exception
 992          when Conversion_Error =>
 993             return False;
 994       end Valid;
 995
 996       ---------------------
 997       -- Valid (display) --
 998       ---------------------
 999
1000       function Valid
1001         (Item   : Numeric;
1002          Format : Display_Format)
1003          return   Boolean
1004       is
1005       begin
1006          return Valid_Numeric (Item, Format);
1007       end Valid;
1008
1009       --------------------
1010       -- Valid (packed) --
1011       --------------------
1012
1013       function Valid
1014         (Item   : Packed_Decimal;
1015          Format : Packed_Format)
1016          return   Boolean
1017       is
1018       begin
1019          return Valid_Packed (Item, Format);
1020       end Valid;
1021
1022    end Decimal_Conversions;
1023
1024 end Interfaces.COBOL;