gcc/ada/a-wtdeau.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --         A D A . W I D E _ T E X T _ I O . D E C I M A L _ A U X          --
   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.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
  33 with Ada.Wide_Text_IO.Float_Aux;   use Ada.Wide_Text_IO.Float_Aux;
  34
  35 with System.Img_Dec; use System.Img_Dec;
  36 with System.Img_LLD; use System.Img_LLD;
  37 with System.Val_Dec; use System.Val_Dec;
  38 with System.Val_LLD; use System.Val_LLD;
  39
  40 package body Ada.Wide_Text_IO.Decimal_Aux is
  41
  42    -------------
  43    -- Get_Dec --
  44    -------------
  45
  46    function Get_Dec
  47      (File  : File_Type;
  48       Width : Field;
  49       Scale : Integer) return Integer
  50    is
  51       Buf  : String (1 .. Field'Last);
  52       Ptr  : aliased Integer;
  53       Stop : Integer := 0;
  54       Item : Integer;
  55
  56    begin
  57       if Width /= 0 then
  58          Load_Width (File, Width, Buf, Stop);
  59          String_Skip (Buf, Ptr);
  60       else
  61          Load_Real (File, Buf, Stop);
  62          Ptr := 1;
  63       end if;
  64
  65       Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale);
  66       Check_End_Of_Field (Buf, Stop, Ptr, Width);
  67       return Item;
  68    end Get_Dec;
  69
  70    -------------
  71    -- Get_LLD --
  72    -------------
  73
  74    function Get_LLD
  75      (File  : File_Type;
  76       Width : Field;
  77       Scale : Integer) return Long_Long_Integer
  78    is
  79       Buf  : String (1 .. Field'Last);
  80       Ptr  : aliased Integer;
  81       Stop : Integer := 0;
  82       Item : Long_Long_Integer;
  83
  84    begin
  85       if Width /= 0 then
  86          Load_Width (File, Width, Buf, Stop);
  87          String_Skip (Buf, Ptr);
  88       else
  89          Load_Real (File, Buf, Stop);
  90          Ptr := 1;
  91       end if;
  92
  93       Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale);
  94       Check_End_Of_Field (Buf, Stop, Ptr, Width);
  95       return Item;
  96    end Get_LLD;
  97
  98    --------------
  99    -- Gets_Dec --
 100    --------------
 101
 102    function Gets_Dec
 103      (From  : String;
 104       Last  : not null access Positive;
 105       Scale : Integer) return Integer
 106    is
 107       Pos  : aliased Integer;
 108       Item : Integer;
 109
 110    begin
 111       String_Skip (From, Pos);
 112       Item := Scan_Decimal (From, Pos'Access, From'Last, Scale);
 113       Last.all := Pos - 1;
 114       return Item;
 115
 116    exception
 117       when Constraint_Error =>
 118          Last.all := Pos - 1;
 119          raise Data_Error;
 120
 121    end Gets_Dec;
 122
 123    --------------
 124    -- Gets_LLD --
 125    --------------
 126
 127    function Gets_LLD
 128      (From  : String;
 129       Last  : not null access Positive;
 130       Scale : Integer) return Long_Long_Integer
 131    is
 132       Pos  : aliased Integer;
 133       Item : Long_Long_Integer;
 134
 135    begin
 136       String_Skip (From, Pos);
 137       Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale);
 138       Last.all := Pos - 1;
 139       return Item;
 140
 141    exception
 142       when Constraint_Error =>
 143          Last.all := Pos - 1;
 144          raise Data_Error;
 145
 146    end Gets_LLD;
 147
 148    -------------
 149    -- Put_Dec --
 150    -------------
 151
 152    procedure Put_Dec
 153      (File  : File_Type;
 154       Item  : Integer;
 155       Fore  : Field;
 156       Aft   : Field;
 157       Exp   : Field;
 158       Scale : Integer)
 159    is
 160       Buf : String (1 .. Field'Last);
 161       Ptr : Natural := 0;
 162
 163    begin
 164       Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
 165       Put_Item (File, Buf (1 .. Ptr));
 166    end Put_Dec;
 167
 168    -------------
 169    -- Put_LLD --
 170    -------------
 171
 172    procedure Put_LLD
 173      (File  : File_Type;
 174       Item  : Long_Long_Integer;
 175       Fore  : Field;
 176       Aft   : Field;
 177       Exp   : Field;
 178       Scale : Integer)
 179    is
 180       Buf : String (1 .. Field'Last);
 181       Ptr : Natural := 0;
 182
 183    begin
 184       Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
 185       Put_Item (File, Buf (1 .. Ptr));
 186    end Put_LLD;
 187
 188    --------------
 189    -- Puts_Dec --
 190    --------------
 191
 192    procedure Puts_Dec
 193      (To    : out String;
 194       Item  : Integer;
 195       Aft   : Field;
 196       Exp   : Field;
 197       Scale : Integer)
 198    is
 199       Buf  : String (1 .. Field'Last);
 200       Fore : Integer;
 201       Ptr  : Natural := 0;
 202
 203    begin
 204       --  Compute Fore, allowing for Aft digits and the decimal dot
 205
 206       Fore := To'Length - Field'Max (1, Aft) - 1;
 207
 208       --  Allow for Exp and two more for E+ or E- if exponent present
 209
 210       if Exp /= 0 then
 211          Fore := Fore - 2 - Exp;
 212       end if;
 213
 214       --  Make sure we have enough room
 215
 216       if Fore < 1 then
 217          raise Layout_Error;
 218       end if;
 219
 220       --  Do the conversion and check length of result
 221
 222       Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
 223
 224       if Ptr > To'Length then
 225          raise Layout_Error;
 226       else
 227          To := Buf (1 .. Ptr);
 228       end if;
 229    end Puts_Dec;
 230
 231    --------------
 232    -- Puts_Dec --
 233    --------------
 234
 235    procedure Puts_LLD
 236      (To    : out String;
 237       Item  : Long_Long_Integer;
 238       Aft   : Field;
 239       Exp   : Field;
 240       Scale : Integer)
 241    is
 242       Buf  : String (1 .. Field'Last);
 243       Fore : Integer;
 244       Ptr  : Natural := 0;
 245
 246    begin
 247       Fore :=
 248         (if Exp = 0
 249          then To'Length - 1 - Aft
 250          else To'Length - 2 - Aft - Exp);
 251
 252       if Fore < 1 then
 253          raise Layout_Error;
 254       end if;
 255
 256       Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
 257
 258       if Ptr > To'Length then
 259          raise Layout_Error;
 260       else
 261          To := Buf (1 .. Ptr);
 262       end if;
 263    end Puts_LLD;
 264
 265 end Ada.Wide_Text_IO.Decimal_Aux;