1------------------------------------------------------------------------------
2--                                                                          --
3--                        GNAT RUN-TIME COMPONENTS                          --
4--                                                                          --
5--           A D A . W I D E _ T E X T _ I O . F L O A T _ A U X            --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2003 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 2,  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.  See the GNU General Public License --
17-- for  more details.  You should have  received  a copy of the GNU General --
18-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
19-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
20-- MA 02111-1307, USA.                                                      --
21--                                                                          --
22-- As a special exception,  if other files  instantiate  generics from this --
23-- unit, or you link  this unit with other files  to produce an executable, --
24-- this  unit  does not  by itself cause  the resulting  executable  to  be --
25-- covered  by the  GNU  General  Public  License.  This exception does not --
26-- however invalidate  any other reasons why  the executable file  might be --
27-- covered by the  GNU Public License.                                      --
28--                                                                          --
29-- GNAT was originally developed  by the GNAT team at  New York University. --
30-- Extensive contributions were provided by Ada Core Technologies Inc.      --
31--                                                                          --
32------------------------------------------------------------------------------
33
34with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
35
36with System.Img_Real;  use System.Img_Real;
37with System.Val_Real;  use System.Val_Real;
38
39package body Ada.Wide_Text_IO.Float_Aux is
40
41   ---------
42   -- Get --
43   ---------
44
45   procedure Get
46     (File  : in File_Type;
47      Item  : out Long_Long_Float;
48      Width : in Field)
49   is
50      Buf  : String (1 .. Field'Last);
51      Stop : Integer := 0;
52      Ptr  : aliased Integer := 1;
53
54   begin
55      if Width /= 0 then
56         Load_Width (File, Width, Buf, Stop);
57         String_Skip (Buf, Ptr);
58      else
59         Load_Real (File, Buf, Stop);
60      end if;
61
62      Item := Scan_Real (Buf, Ptr'Access, Stop);
63
64      Check_End_Of_Field (Buf, Stop, Ptr, Width);
65   end Get;
66
67   ----------
68   -- Gets --
69   ----------
70
71   procedure Gets
72     (From : in String;
73      Item : out Long_Long_Float;
74      Last : out Positive)
75   is
76      Pos : aliased Integer;
77
78   begin
79      String_Skip (From, Pos);
80      Item := Scan_Real (From, Pos'Access, From'Last);
81      Last := Pos - 1;
82
83   exception
84      when Constraint_Error =>
85         raise Data_Error;
86   end Gets;
87
88   ---------------
89   -- Load_Real --
90   ---------------
91
92   procedure Load_Real
93     (File : in File_Type;
94      Buf  : out String;
95      Ptr  : in out Natural)
96   is
97      Loaded   : Boolean;
98
99   begin
100      --  Skip initial blanks and load possible sign
101
102      Load_Skip (File);
103      Load (File, Buf, Ptr, '+', '-');
104
105      --  Case of .nnnn
106
107      Load (File, Buf, Ptr, '.', Loaded);
108
109      if Loaded then
110         Load_Digits (File, Buf, Ptr, Loaded);
111
112         --  Hopeless junk if no digits loaded
113
114         if not Loaded then
115            return;
116         end if;
117
118      --  Otherwise must have digits to start
119
120      else
121         Load_Digits (File, Buf, Ptr, Loaded);
122
123         --  Hopeless junk if no digits loaded
124
125         if not Loaded then
126            return;
127         end if;
128
129         --  Based cases
130
131         Load (File, Buf, Ptr, '#', ':', Loaded);
132
133         if Loaded then
134
135            --  Case of nnn#.xxx#
136
137            Load (File, Buf, Ptr, '.', Loaded);
138
139            if Loaded then
140               Load_Extended_Digits (File, Buf, Ptr);
141
142            --  Case of nnn#xxx.[xxx]# or nnn#xxx#
143
144            else
145               Load_Extended_Digits (File, Buf, Ptr);
146               Load (File, Buf, Ptr, '.', Loaded);
147
148               if Loaded then
149                  Load_Extended_Digits (File, Buf, Ptr);
150               end if;
151
152               --  As usual, it seems strange to allow mixed base characters,
153               --  but that is what ACVC tests expect, see CE3804M, case (3).
154
155               Load (File, Buf, Ptr, '#', ':');
156            end if;
157
158         --  Case of nnn.[nnn] or nnn
159
160         else
161            Load (File, Buf, Ptr, '.', Loaded);
162
163            if Loaded then
164               Load_Digits (File, Buf, Ptr);
165            end if;
166         end if;
167      end if;
168
169      --  Deal with exponent
170
171      Load (File, Buf, Ptr, 'E', 'e', Loaded);
172
173      if Loaded then
174         Load (File, Buf, Ptr, '+', '-');
175         Load_Digits (File, Buf, Ptr);
176      end if;
177   end Load_Real;
178
179   ---------
180   -- Put --
181   ---------
182
183   procedure Put
184     (File : in File_Type;
185      Item : in Long_Long_Float;
186      Fore : in Field;
187      Aft  : in Field;
188      Exp  : in Field)
189   is
190      Buf : String (1 .. Field'Last);
191      Ptr : Natural := 0;
192
193   begin
194      Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp);
195      Put_Item (File, Buf (1 .. Ptr));
196   end Put;
197
198   ----------
199   -- Puts --
200   ----------
201
202   procedure Puts
203     (To   : out String;
204      Item : in Long_Long_Float;
205      Aft  : in Field;
206      Exp  : in Field)
207   is
208      Buf    : String (1 .. Field'Last);
209      Ptr    : Natural := 0;
210
211   begin
212      Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp);
213
214      if Ptr > To'Length then
215         raise Layout_Error;
216
217      else
218         for J in 1 .. Ptr loop
219            To (To'Last - Ptr + J) := Buf (J);
220         end loop;
221
222         for J in To'First .. To'Last - Ptr loop
223            To (J) := ' ';
224         end loop;
225      end if;
226   end Puts;
227
228end Ada.Wide_Text_IO.Float_Aux;
229