1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT RUN-TIME COMPONENTS                         --
4--                                                                          --
5--    A D A . W I D E _ 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
32with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
33with Ada.Wide_Wide_Text_IO.Float_Aux;   use Ada.Wide_Wide_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.Wide_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 then To'Length - 1 - Aft else To'Length - 2 - Aft - Exp);
249
250      if Fore < 1 then
251         raise Layout_Error;
252      end if;
253
254      Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
255
256      if Ptr > To'Length then
257         raise Layout_Error;
258      else
259         To := Buf (1 .. Ptr);
260      end if;
261   end Puts_LLD;
262
263end Ada.Wide_Wide_Text_IO.Decimal_Aux;
264