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