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