gcc/ada/libgnat/a-tideau.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --              A D A . 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-2017, 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.Generic_Aux; use Ada.Text_IO.Generic_Aux;
  33 with Ada.Text_IO.Float_Aux;   use Ada.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.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    end Gets_Dec;
 121
 122    --------------
 123    -- Gets_LLD --
 124    --------------
 125
 126    function Gets_LLD
 127      (From  : String;
 128       Last  : not null access Positive;
 129       Scale : Integer) return Long_Long_Integer
 130    is
 131       Pos  : aliased Integer;
 132       Item : Long_Long_Integer;
 133
 134    begin
 135       String_Skip (From, Pos);
 136       Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale);
 137       Last.all := Pos - 1;
 138       return Item;
 139
 140    exception
 141       when Constraint_Error =>
 142          Last.all := Pos - 1;
 143          raise Data_Error;
 144    end Gets_LLD;
 145
 146    -------------
 147    -- Put_Dec --
 148    -------------
 149
 150    procedure Put_Dec
 151      (File  : File_Type;
 152       Item  : Integer;
 153       Fore  : Field;
 154       Aft   : Field;
 155       Exp   : Field;
 156       Scale : Integer)
 157    is
 158       Buf : String (1 .. Field'Last);
 159       Ptr : Natural := 0;
 160
 161    begin
 162       Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
 163       Put_Item (File, Buf (1 .. Ptr));
 164    end Put_Dec;
 165
 166    -------------
 167    -- Put_LLD --
 168    -------------
 169
 170    procedure Put_LLD
 171      (File  : File_Type;
 172       Item  : Long_Long_Integer;
 173       Fore  : Field;
 174       Aft   : Field;
 175       Exp   : Field;
 176       Scale : Integer)
 177    is
 178       Buf : String (1 .. Field'Last);
 179       Ptr : Natural := 0;
 180
 181    begin
 182       Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
 183       Put_Item (File, Buf (1 .. Ptr));
 184    end Put_LLD;
 185
 186    --------------
 187    -- Puts_Dec --
 188    --------------
 189
 190    procedure Puts_Dec
 191      (To    : out String;
 192       Item  : Integer;
 193       Aft   : Field;
 194       Exp   : Field;
 195       Scale : Integer)
 196    is
 197       Buf  : String (1 .. Field'Last);
 198       Fore : Integer;
 199       Ptr  : Natural := 0;
 200
 201    begin
 202       --  Compute Fore, allowing for Aft digits and the decimal dot
 203
 204       Fore := To'Length - Field'Max (1, Aft) - 1;
 205
 206       --  Allow for Exp and two more for E+ or E- if exponent present
 207
 208       if Exp /= 0 then
 209          Fore := Fore - 2 - Exp;
 210       end if;
 211
 212       --  Make sure we have enough room
 213
 214       if Fore < 1 then
 215          raise Layout_Error;
 216       end if;
 217
 218       --  Do the conversion and check length of result
 219
 220       Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
 221
 222       if Ptr > To'Length then
 223          raise Layout_Error;
 224       else
 225          To := Buf (1 .. Ptr);
 226       end if;
 227    end Puts_Dec;
 228
 229    --------------
 230    -- Puts_Dec --
 231    --------------
 232
 233    procedure Puts_LLD
 234      (To    : out String;
 235       Item  : Long_Long_Integer;
 236       Aft   : Field;
 237       Exp   : Field;
 238       Scale : Integer)
 239    is
 240       Buf  : String (1 .. Field'Last);
 241       Fore : Integer;
 242       Ptr  : Natural := 0;
 243
 244    begin
 245       Fore :=
 246         (if Exp = 0 then To'Length - 1 - Aft else To'Length - 2 - Aft - Exp);
 247
 248       if Fore < 1 then
 249          raise Layout_Error;
 250       end if;
 251
 252       Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
 253
 254       if Ptr > To'Length then
 255          raise Layout_Error;
 256       else
 257          To := Buf (1 .. Ptr);
 258       end if;
 259    end Puts_LLD;
 260
 261 end Ada.Text_IO.Decimal_Aux;