URL https://opencores.org/ocsvn/scarts/scarts/trunk
Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [ada/] [i-cobol.adb] - Blame information for rev 27

Go to most recent revision | Details | Compare with Previous | View Log

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--                     I N T E R F A C E S . C O B O L                      --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2005 Free Software Foundation, Inc.          --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
--  The body of Interfaces.COBOL is implementation independent (i.e. the same
--  version is used with all versions of GNAT). The specialization to a
--  particular COBOL format is completely contained in the private part of
--  the spec.
 
with Interfaces; use Interfaces;
with System;     use System;
with Unchecked_Conversion;
 
package body Interfaces.COBOL is
 
   -----------------------------------------------
   -- Declarations for External Binary Handling --
   -----------------------------------------------
 
   subtype B1 is Byte_Array (1 .. 1);
   subtype B2 is Byte_Array (1 .. 2);
   subtype B4 is Byte_Array (1 .. 4);
   subtype B8 is Byte_Array (1 .. 8);
   --  Representations for 1,2,4,8 byte binary values
 
   function To_B1 is new Unchecked_Conversion (Integer_8,  B1);
   function To_B2 is new Unchecked_Conversion (Integer_16, B2);
   function To_B4 is new Unchecked_Conversion (Integer_32, B4);
   function To_B8 is new Unchecked_Conversion (Integer_64, B8);
   --  Conversions from native binary to external binary
 
   function From_B1 is new Unchecked_Conversion (B1, Integer_8);
   function From_B2 is new Unchecked_Conversion (B2, Integer_16);
   function From_B4 is new Unchecked_Conversion (B4, Integer_32);
   function From_B8 is new Unchecked_Conversion (B8, Integer_64);
   --  Conversions from external binary to signed native binary
 
   function From_B1U is new Unchecked_Conversion (B1, Unsigned_8);
   function From_B2U is new Unchecked_Conversion (B2, Unsigned_16);
   function From_B4U is new Unchecked_Conversion (B4, Unsigned_32);
   function From_B8U is new Unchecked_Conversion (B8, Unsigned_64);
   --  Conversions from external binary to unsigned native binary
 
   -----------------------
   -- Local Subprograms --
   -----------------------
 
   function Binary_To_Decimal
     (Item   : Byte_Array;
      Format : Binary_Format) return Integer_64;
   --  This function converts a numeric value in the given format to its
   --  corresponding integer value. This is the non-generic implementation
   --  of Decimal_Conversions.To_Decimal. The generic routine does the
   --  final conversion to the fixed-point format.
 
   function Numeric_To_Decimal
     (Item   : Numeric;
      Format : Display_Format) return Integer_64;
   --  This function converts a numeric value in the given format to its
   --  corresponding integer value. This is the non-generic implementation
   --  of Decimal_Conversions.To_Decimal. The generic routine does the
   --  final conversion to the fixed-point format.
 
   function Packed_To_Decimal
     (Item   : Packed_Decimal;
      Format : Packed_Format) return Integer_64;
   --  This function converts a packed value in the given format to its
   --  corresponding integer value. This is the non-generic implementation
   --  of Decimal_Conversions.To_Decimal. The generic routine does the
   --  final conversion to the fixed-point format.
 
   procedure Swap (B : in out Byte_Array; F : Binary_Format);
   --  Swaps the bytes if required by the binary format F
 
   function To_Display
     (Item   : Integer_64;
      Format : Display_Format;
      Length : Natural) return Numeric;
   --  This function converts the given integer value into display format,
   --  using the given format, with the length in bytes of the result given
   --  by the last parameter. This is the non-generic implementation of
   --  Decimal_Conversions.To_Display. The conversion of the item from its
   --  original decimal format to Integer_64 is done by the generic routine.
 
   function To_Packed
     (Item   : Integer_64;
      Format : Packed_Format;
      Length : Natural) return Packed_Decimal;
   --  This function converts the given integer value into packed format,
   --  using the given format, with the length in digits of the result given
   --  by the last parameter. This is the non-generic implementation of
   --  Decimal_Conversions.To_Display. The conversion of the item from its
   --  original decimal format to Integer_64 is done by the generic routine.
 
   function Valid_Numeric
     (Item   : Numeric;
      Format : Display_Format) return Boolean;
   --  This is the non-generic implementation of Decimal_Conversions.Valid
   --  for the display case.
 
   function Valid_Packed
     (Item   : Packed_Decimal;
      Format : Packed_Format) return Boolean;
   --  This is the non-generic implementation of Decimal_Conversions.Valid
   --  for the packed case.
 
   -----------------------
   -- Binary_To_Decimal --
   -----------------------
 
   function Binary_To_Decimal
     (Item   : Byte_Array;
      Format : Binary_Format) return Integer_64
   is
      Len : constant Natural := Item'Length;
 
   begin
      if Len = 1 then
         if Format in Binary_Unsigned_Format then
            return Integer_64 (From_B1U (Item));
         else
            return Integer_64 (From_B1 (Item));
         end if;
 
      elsif Len = 2 then
         declare
            R : B2 := Item;
 
         begin
            Swap (R, Format);
 
            if Format in Binary_Unsigned_Format then
               return Integer_64 (From_B2U (R));
            else
               return Integer_64 (From_B2 (R));
            end if;
         end;
 
      elsif Len = 4 then
         declare
            R : B4 := Item;
 
         begin
            Swap (R, Format);
 
            if Format in Binary_Unsigned_Format then
               return Integer_64 (From_B4U (R));
            else
               return Integer_64 (From_B4 (R));
            end if;
         end;
 
      elsif Len = 8 then
         declare
            R : B8 := Item;
 
         begin
            Swap (R, Format);
 
            if Format in Binary_Unsigned_Format then
               return Integer_64 (From_B8U (R));
            else
               return Integer_64 (From_B8 (R));
            end if;
         end;
 
      --  Length is not 1, 2, 4 or 8
 
      else
         raise Conversion_Error;
      end if;
   end Binary_To_Decimal;
 
   ------------------------
   -- Numeric_To_Decimal --
   ------------------------
 
   --  The following assumptions are made in the coding of this routine:
 
   --    The range of COBOL_Digits is compact and the ten values
   --    represent the digits 0-9 in sequence
 
   --    The range of COBOL_Plus_Digits is compact and the ten values
   --    represent the digits 0-9 in sequence with a plus sign.
 
   --    The range of COBOL_Minus_Digits is compact and the ten values
   --    represent the digits 0-9 in sequence with a minus sign.
 
   --    The COBOL_Minus_Digits set is disjoint from COBOL_Digits
 
   --  These assumptions are true for all COBOL representations we know of
 
   function Numeric_To_Decimal
     (Item   : Numeric;
      Format : Display_Format) return Integer_64
   is
      pragma Unsuppress (Range_Check);
      Sign   : COBOL_Character := COBOL_Plus;
      Result : Integer_64 := 0;
 
   begin
      if not Valid_Numeric (Item, Format) then
         raise Conversion_Error;
      end if;
 
      for J in Item'Range loop
         declare
            K : constant COBOL_Character := Item (J);
 
         begin
            if K in COBOL_Digits then
               Result := Result * 10 +
                           (COBOL_Character'Pos (K) -
                             COBOL_Character'Pos (COBOL_Digits'First));
 
            elsif K in COBOL_Plus_Digits then
               Result := Result * 10 +
                           (COBOL_Character'Pos (K) -
                             COBOL_Character'Pos (COBOL_Plus_Digits'First));
 
            elsif K in COBOL_Minus_Digits then
               Result := Result * 10 +
                           (COBOL_Character'Pos (K) -
                             COBOL_Character'Pos (COBOL_Minus_Digits'First));
               Sign := COBOL_Minus;
 
            --  Only remaining possibility is COBOL_Plus or COBOL_Minus
 
            else
               Sign := K;
            end if;
         end;
      end loop;
 
      if Sign = COBOL_Plus then
         return Result;
      else
         return -Result;
      end if;
 
   exception
      when Constraint_Error =>
         raise Conversion_Error;
 
   end Numeric_To_Decimal;
 
   -----------------------
   -- Packed_To_Decimal --
   -----------------------
 
   function Packed_To_Decimal
     (Item   : Packed_Decimal;
      Format : Packed_Format) return Integer_64
   is
      pragma Unsuppress (Range_Check);
      Result : Integer_64 := 0;
      Sign   : constant Decimal_Element := Item (Item'Last);
 
   begin
      if not Valid_Packed (Item, Format) then
         raise Conversion_Error;
      end if;
 
      case Packed_Representation is
         when IBM =>
            for J in Item'First .. Item'Last - 1 loop
               Result := Result * 10 + Integer_64 (Item (J));
            end loop;
 
            if Sign = 16#0B# or else Sign = 16#0D# then
               return -Result;
            else
               return +Result;
            end if;
      end case;
 
   exception
      when Constraint_Error =>
         raise Conversion_Error;
   end Packed_To_Decimal;
 
   ----------
   -- Swap --
   ----------
 
   procedure Swap (B : in out Byte_Array; F : Binary_Format) is
      Little_Endian : constant Boolean :=
                        System.Default_Bit_Order = System.Low_Order_First;
 
   begin
      --  Return if no swap needed
 
      case F is
         when H | HU =>
            if not Little_Endian then
               return;
            end if;
 
         when L | LU =>
            if Little_Endian then
               return;
            end if;
 
         when N | NU =>
            return;
      end case;
 
      --  Here a swap is needed
 
      declare
         Len  : constant Natural := B'Length;
 
      begin
         for J in 1 .. Len / 2 loop
            declare
               Temp : constant Byte := B (J);
 
            begin
               B (J) := B (Len + 1 - J);
               B (Len + 1 - J) := Temp;
            end;
         end loop;
      end;
   end Swap;
 
   -----------------------
   -- To_Ada (function) --
   -----------------------
 
   function To_Ada (Item : Alphanumeric) return String is
      Result : String (Item'Range);
 
   begin
      for J in Item'Range loop
         Result (J) := COBOL_To_Ada (Item (J));
      end loop;
 
      return Result;
   end To_Ada;
 
   ------------------------
   -- To_Ada (procedure) --
   ------------------------
 
   procedure To_Ada
     (Item   : Alphanumeric;
      Target : out String;
      Last   : out Natural)
   is
      Last_Val : Integer;
 
   begin
      if Item'Length > Target'Length then
         raise Constraint_Error;
      end if;
 
      Last_Val := Target'First - 1;
      for J in Item'Range loop
         Last_Val := Last_Val + 1;
         Target (Last_Val) := COBOL_To_Ada (Item (J));
      end loop;
 
      Last := Last_Val;
   end To_Ada;
 
   -------------------------
   -- To_COBOL (function) --
   -------------------------
 
   function To_COBOL (Item : String) return Alphanumeric is
      Result : Alphanumeric (Item'Range);
 
   begin
      for J in Item'Range loop
         Result (J) := Ada_To_COBOL (Item (J));
      end loop;
 
      return Result;
   end To_COBOL;
 
   --------------------------
   -- To_COBOL (procedure) --
   --------------------------
 
   procedure To_COBOL
     (Item   : String;
      Target : out Alphanumeric;
      Last   : out Natural)
   is
      Last_Val : Integer;
 
   begin
      if Item'Length > Target'Length then
         raise Constraint_Error;
      end if;
 
      Last_Val := Target'First - 1;
      for J in Item'Range loop
         Last_Val := Last_Val + 1;
         Target (Last_Val) := Ada_To_COBOL (Item (J));
      end loop;
 
      Last := Last_Val;
   end To_COBOL;
 
   ----------------
   -- To_Display --
   ----------------
 
   function To_Display
     (Item   : Integer_64;
      Format : Display_Format;
      Length : Natural) return Numeric
   is
      Result : Numeric (1 .. Length);
      Val    : Integer_64 := Item;
 
      procedure Convert (First, Last : Natural);
      --  Convert the number in Val into COBOL_Digits, storing the result
      --  in Result (First .. Last). Raise Conversion_Error if too large.
 
      procedure Embed_Sign (Loc : Natural);
      --  Used for the nonseparate formats to embed the appropriate sign
      --  at the specified location (i.e. at Result (Loc))
 
      procedure Convert (First, Last : Natural) is
         J : Natural := Last;
 
      begin
         while J >= First loop
            Result (J) :=
              COBOL_Character'Val
                (COBOL_Character'Pos (COBOL_Digits'First) +
                                                   Integer (Val mod 10));
            Val := Val / 10;
 
            if Val = 0 then
               for K in First .. J - 1 loop
                  Result (J) := COBOL_Digits'First;
               end loop;
 
               return;
 
            else
               J := J - 1;
            end if;
         end loop;
 
         raise Conversion_Error;
      end Convert;
 
      procedure Embed_Sign (Loc : Natural) is
         Digit : Natural range 0 .. 9;
 
      begin
         Digit := COBOL_Character'Pos (Result (Loc)) -
                  COBOL_Character'Pos (COBOL_Digits'First);
 
         if Item >= 0 then
            Result (Loc) :=
              COBOL_Character'Val
                (COBOL_Character'Pos (COBOL_Plus_Digits'First) + Digit);
         else
            Result (Loc) :=
              COBOL_Character'Val
                (COBOL_Character'Pos (COBOL_Minus_Digits'First) + Digit);
         end if;
      end Embed_Sign;
 
   --  Start of processing for To_Display
 
   begin
      case Format is
         when Unsigned =>
            if Val < 0 then
               raise Conversion_Error;
            else
               Convert (1, Length);
            end if;
 
         when Leading_Separate =>
            if Val < 0 then
               Result (1) := COBOL_Minus;
               Val := -Val;
            else
               Result (1) := COBOL_Plus;
            end if;
 
            Convert (2, Length);
 
         when Trailing_Separate =>
            if Val < 0 then
               Result (Length) := COBOL_Minus;
               Val := -Val;
            else
               Result (Length) := COBOL_Plus;
            end if;
 
            Convert (1, Length - 1);
 
         when Leading_Nonseparate =>
            Val := abs Val;
            Convert (1, Length);
            Embed_Sign (1);
 
         when Trailing_Nonseparate =>
            Val := abs Val;
            Convert (1, Length);
            Embed_Sign (Length);
 
      end case;
 
      return Result;
   end To_Display;
 
   ---------------
   -- To_Packed --
   ---------------
 
   function To_Packed
     (Item   : Integer_64;
      Format : Packed_Format;
      Length : Natural) return Packed_Decimal
   is
      Result : Packed_Decimal (1 .. Length);
      Val    : Integer_64;
 
      procedure Convert (First, Last : Natural);
      --  Convert the number in Val into a sequence of Decimal_Element values,
      --  storing the result in Result (First .. Last). Raise Conversion_Error
      --  if the value is too large to fit.
 
      procedure Convert (First, Last : Natural) is
         J : Natural := Last;
 
      begin
         while J >= First loop
            Result (J) := Decimal_Element (Val mod 10);
 
            Val := Val / 10;
 
            if Val = 0 then
               for K in First .. J - 1 loop
                  Result (K) := 0;
               end loop;
 
               return;
 
            else
               J := J - 1;
            end if;
         end loop;
 
         raise Conversion_Error;
      end Convert;
 
   --  Start of processing for To_Packed
 
   begin
      case Packed_Representation is
         when IBM =>
            if Format = Packed_Unsigned then
               if Item < 0 then
                  raise Conversion_Error;
               else
                  Result (Length) := 16#F#;
                  Val := Item;
               end if;
 
            elsif Item >= 0 then
               Result (Length) := 16#C#;
               Val := Item;
 
            else -- Item < 0
               Result (Length) := 16#D#;
               Val := -Item;
            end if;
 
            Convert (1, Length - 1);
            return Result;
      end case;
   end To_Packed;
 
   -------------------
   -- Valid_Numeric --
   -------------------
 
   function Valid_Numeric
     (Item   : Numeric;
      Format : Display_Format) return Boolean
   is
   begin
      if Item'Length = 0 then
         return False;
      end if;
 
      --  All character positions except first and last must be Digits.
      --  This is true for all the formats.
 
      for J in Item'First + 1 .. Item'Last - 1 loop
         if Item (J) not in COBOL_Digits then
            return False;
         end if;
      end loop;
 
      case Format is
         when Unsigned =>
            return Item (Item'First) in COBOL_Digits
              and then Item (Item'Last) in COBOL_Digits;
 
         when Leading_Separate =>
            return (Item (Item'First) = COBOL_Plus or else
                    Item (Item'First) = COBOL_Minus)
              and then Item (Item'Last) in COBOL_Digits;
 
         when Trailing_Separate =>
            return Item (Item'First) in COBOL_Digits
              and then
                (Item (Item'Last) = COBOL_Plus or else
                 Item (Item'Last) = COBOL_Minus);
 
         when Leading_Nonseparate =>
            return (Item (Item'First) in COBOL_Plus_Digits or else
                    Item (Item'First) in COBOL_Minus_Digits)
              and then Item (Item'Last) in COBOL_Digits;
 
         when Trailing_Nonseparate =>
            return Item (Item'First) in COBOL_Digits
              and then
                (Item (Item'Last) in COBOL_Plus_Digits or else
                 Item (Item'Last) in COBOL_Minus_Digits);
 
      end case;
   end Valid_Numeric;
 
   ------------------
   -- Valid_Packed --
   ------------------
 
   function Valid_Packed
     (Item   : Packed_Decimal;
      Format : Packed_Format) return Boolean
   is
   begin
      case Packed_Representation is
         when IBM =>
            for J in Item'First .. Item'Last - 1 loop
               if Item (J) > 9 then
                  return False;
               end if;
            end loop;
 
            --  For unsigned, sign digit must be F
 
            if Format = Packed_Unsigned then
               return Item (Item'Last) = 16#F#;
 
            --  For signed, accept all standard and non-standard signs
 
            else
               return Item (Item'Last) in 16#A# .. 16#F#;
            end if;
      end case;
   end Valid_Packed;
 
   -------------------------
   -- Decimal_Conversions --
   -------------------------
 
   package body Decimal_Conversions is
 
      ---------------------
      -- Length (binary) --
      ---------------------
 
      --  Note that the tests here are all compile time tests
 
      function Length (Format : Binary_Format) return Natural is
         pragma Unreferenced (Format);
      begin
         if Num'Digits <= 2 then
            return 1;
         elsif Num'Digits <= 4 then
            return 2;
         elsif Num'Digits <= 9 then
            return 4;
         else -- Num'Digits in 10 .. 18
            return 8;
         end if;
      end Length;
 
      ----------------------
      -- Length (display) --
      ----------------------
 
      function Length (Format : Display_Format) return Natural is
      begin
         if Format = Leading_Separate or else Format = Trailing_Separate then
            return Num'Digits + 1;
         else
            return Num'Digits;
         end if;
      end Length;
 
      ---------------------
      -- Length (packed) --
      ---------------------
 
      --  Note that the tests here are all compile time checks
 
      function Length
        (Format : Packed_Format) return Natural
      is
         pragma Unreferenced (Format);
      begin
         case Packed_Representation is
            when IBM =>
               return (Num'Digits + 2) / 2 * 2;
         end case;
      end Length;
 
      ---------------
      -- To_Binary --
      ---------------
 
      function To_Binary
        (Item   : Num;
         Format : Binary_Format) return Byte_Array
      is
      begin
         --  Note: all these tests are compile time tests
 
         if Num'Digits <= 2 then
            return To_B1 (Integer_8'Integer_Value (Item));
 
         elsif Num'Digits <= 4 then
            declare
               R : B2 := To_B2 (Integer_16'Integer_Value (Item));
 
            begin
               Swap (R, Format);
               return R;
            end;
 
         elsif Num'Digits <= 9 then
            declare
               R : B4 := To_B4 (Integer_32'Integer_Value (Item));
 
            begin
               Swap (R, Format);
               return R;
            end;
 
         else -- Num'Digits in 10 .. 18
            declare
               R : B8 := To_B8 (Integer_64'Integer_Value (Item));
 
            begin
               Swap (R, Format);
               return R;
            end;
         end if;
 
      exception
         when Constraint_Error =>
            raise Conversion_Error;
      end To_Binary;
 
      ---------------------------------
      -- To_Binary (internal binary) --
      ---------------------------------
 
      function To_Binary (Item : Num) return Binary is
         pragma Unsuppress (Range_Check);
      begin
         return Binary'Integer_Value (Item);
      exception
         when Constraint_Error =>
            raise Conversion_Error;
      end To_Binary;
 
      -------------------------
      -- To_Decimal (binary) --
      -------------------------
 
      function To_Decimal
        (Item   : Byte_Array;
         Format : Binary_Format) return Num
      is
         pragma Unsuppress (Range_Check);
      begin
         return Num'Fixed_Value (Binary_To_Decimal (Item, Format));
      exception
         when Constraint_Error =>
            raise Conversion_Error;
      end To_Decimal;
 
      ----------------------------------
      -- To_Decimal (internal binary) --
      ----------------------------------
 
      function To_Decimal (Item : Binary) return Num is
         pragma Unsuppress (Range_Check);
      begin
         return Num'Fixed_Value (Item);
      exception
         when Constraint_Error =>
            raise Conversion_Error;
      end To_Decimal;
 
      --------------------------
      -- To_Decimal (display) --
      --------------------------
 
      function To_Decimal
        (Item   : Numeric;
         Format : Display_Format) return Num
      is
         pragma Unsuppress (Range_Check);
 
      begin
         return Num'Fixed_Value (Numeric_To_Decimal (Item, Format));
      exception
         when Constraint_Error =>
            raise Conversion_Error;
      end To_Decimal;
 
      ---------------------------------------
      -- To_Decimal (internal long binary) --
      ---------------------------------------
 
      function To_Decimal (Item : Long_Binary) return Num is
         pragma Unsuppress (Range_Check);
      begin
         return Num'Fixed_Value (Item);
      exception
         when Constraint_Error =>
            raise Conversion_Error;
      end To_Decimal;
 
      -------------------------
      -- To_Decimal (packed) --
      -------------------------
 
      function To_Decimal
        (Item   : Packed_Decimal;
         Format : Packed_Format) return Num
      is
         pragma Unsuppress (Range_Check);
      begin
         return Num'Fixed_Value (Packed_To_Decimal (Item, Format));
      exception
         when Constraint_Error =>
            raise Conversion_Error;
      end To_Decimal;
 
      ----------------
      -- To_Display --
      ----------------
 
      function To_Display
        (Item   : Num;
         Format : Display_Format) return Numeric
      is
         pragma Unsuppress (Range_Check);
      begin
         return
           To_Display
             (Integer_64'Integer_Value (Item),
              Format,
              Length (Format));
      exception
         when Constraint_Error =>
            raise Conversion_Error;
      end To_Display;
 
      --------------------
      -- To_Long_Binary --
      --------------------
 
      function To_Long_Binary (Item : Num) return Long_Binary is
         pragma Unsuppress (Range_Check);
      begin
         return Long_Binary'Integer_Value (Item);
      exception
         when Constraint_Error =>
            raise Conversion_Error;
      end To_Long_Binary;
 
      ---------------
      -- To_Packed --
      ---------------
 
      function To_Packed
        (Item   : Num;
         Format : Packed_Format) return Packed_Decimal
      is
         pragma Unsuppress (Range_Check);
      begin
         return
           To_Packed
             (Integer_64'Integer_Value (Item),
              Format,
              Length (Format));
      exception
         when Constraint_Error =>
            raise Conversion_Error;
      end To_Packed;
 
      --------------------
      -- Valid (binary) --
      --------------------
 
      function Valid
        (Item   : Byte_Array;
         Format : Binary_Format) return Boolean
      is
         Val : Num;
         pragma Unreferenced (Val);
      begin
         Val := To_Decimal (Item, Format);
         return True;
      exception
         when Conversion_Error =>
            return False;
      end Valid;
 
      ---------------------
      -- Valid (display) --
      ---------------------
 
      function Valid
        (Item   : Numeric;
         Format : Display_Format) return Boolean
      is
      begin
         return Valid_Numeric (Item, Format);
      end Valid;
 
      --------------------
      -- Valid (packed) --
      --------------------
 
      function Valid
        (Item   : Packed_Decimal;
         Format : Packed_Format) return Boolean
      is
      begin
         return Valid_Packed (Item, Format);
      end Valid;
 
   end Decimal_Conversions;
 
end Interfaces.COBOL;
Browse

Tools

Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [ada/] [i-cobol.adb] - Blame information for rev 27

Line No.	Rev	Author	Line
1	12	jlechner	`------------------------------------------------------------------------------`
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 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;`