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-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
32with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
33with Ada.Text_IO.Float_Aux;   use Ada.Text_IO.Float_Aux;
34
35with System.Img_Dec; use System.Img_Dec;
36with System.Img_LLD; use System.Img_LLD;
37with System.Val_Dec; use System.Val_Dec;
38with System.Val_LLD; use System.Val_LLD;
39
40package 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
261end Ada.Text_IO.Decimal_Aux;
262