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