gcc/ada/a-tiinio.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --               A D A . T E X T _ I O . I N T E G E R _ I O                --
   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 with Ada.Text_IO.Integer_Aux;
  33
  34 package body Ada.Text_IO.Integer_IO is
  35
  36    package Aux renames Ada.Text_IO.Integer_Aux;
  37
  38    Need_LLI : constant Boolean := Num'Base'Size > Integer'Size;
  39    --  Throughout this generic body, we distinguish between the case
  40    --  where type Integer is acceptable, and where a Long_Long_Integer
  41    --  is needed. This constant Boolean is used to test for these cases
  42    --  and since it is a constant, only the code for the relevant case
  43    --  will be included in the instance.
  44
  45    ---------
  46    -- Get --
  47    ---------
  48
  49    procedure Get
  50      (File  : File_Type;
  51       Item  : out Num;
  52       Width : Field := 0)
  53    is
  54       --  We depend on a range check to get Data_Error
  55
  56       pragma Unsuppress (Range_Check);
  57       pragma Unsuppress (Overflow_Check);
  58
  59    begin
  60       if Need_LLI then
  61          Aux.Get_LLI (File, Long_Long_Integer (Item), Width);
  62       else
  63          Aux.Get_Int (File, Integer (Item), Width);
  64       end if;
  65
  66    exception
  67       when Constraint_Error => raise Data_Error;
  68    end Get;
  69
  70    procedure Get
  71      (Item  : out Num;
  72       Width : Field := 0)
  73    is
  74       --  We depend on a range check to get Data_Error
  75
  76       pragma Unsuppress (Range_Check);
  77       pragma Unsuppress (Overflow_Check);
  78
  79    begin
  80       if Need_LLI then
  81          Aux.Get_LLI (Current_In, Long_Long_Integer (Item), Width);
  82       else
  83          Aux.Get_Int (Current_In, Integer (Item), Width);
  84       end if;
  85
  86    exception
  87       when Constraint_Error => raise Data_Error;
  88    end Get;
  89
  90    procedure Get
  91      (From : String;
  92       Item : out Num;
  93       Last : out Positive)
  94    is
  95       --  We depend on a range check to get Data_Error
  96
  97       pragma Unsuppress (Range_Check);
  98       pragma Unsuppress (Overflow_Check);
  99
 100    begin
 101       if Need_LLI then
 102          Aux.Gets_LLI (From, Long_Long_Integer (Item), Last);
 103       else
 104          Aux.Gets_Int (From, Integer (Item), Last);
 105       end if;
 106
 107    exception
 108       when Constraint_Error => raise Data_Error;
 109    end Get;
 110
 111    ---------
 112    -- Put --
 113    ---------
 114
 115    procedure Put
 116      (File  : File_Type;
 117       Item  : Num;
 118       Width : Field := Default_Width;
 119       Base  : Number_Base := Default_Base)
 120    is
 121    begin
 122       if Need_LLI then
 123          Aux.Put_LLI (File, Long_Long_Integer (Item), Width, Base);
 124       else
 125          Aux.Put_Int (File, Integer (Item), Width, Base);
 126       end if;
 127    end Put;
 128
 129    procedure Put
 130      (Item  : Num;
 131       Width : Field := Default_Width;
 132       Base  : Number_Base := Default_Base)
 133    is
 134    begin
 135       if Need_LLI then
 136          Aux.Put_LLI (Current_Out, Long_Long_Integer (Item), Width, Base);
 137       else
 138          Aux.Put_Int (Current_Out, Integer (Item), Width, Base);
 139       end if;
 140    end Put;
 141
 142    procedure Put
 143      (To   : out String;
 144       Item : Num;
 145       Base : Number_Base := Default_Base)
 146    is
 147    begin
 148       if Need_LLI then
 149          Aux.Puts_LLI (To, Long_Long_Integer (Item), Base);
 150       else
 151          Aux.Puts_Int (To, Integer (Item), Base);
 152       end if;
 153    end Put;
 154
 155 end Ada.Text_IO.Integer_IO;