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-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_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
33
34with System.Img_Real;  use System.Img_Real;
35with System.Val_Real;  use System.Val_Real;
36
37package body Ada.Wide_Text_IO.Float_Aux is
38
39   ---------
40   -- Get --
41   ---------
42
43   procedure Get
44     (File  : File_Type;
45      Item  : out Long_Long_Float;
46      Width : Field)
47   is
48      Buf  : String (1 .. Field'Last);
49      Stop : Integer := 0;
50      Ptr  : aliased Integer := 1;
51
52   begin
53      if Width /= 0 then
54         Load_Width (File, Width, Buf, Stop);
55         String_Skip (Buf, Ptr);
56      else
57         Load_Real (File, Buf, Stop);
58      end if;
59
60      Item := Scan_Real (Buf, Ptr'Access, Stop);
61
62      Check_End_Of_Field (Buf, Stop, Ptr, Width);
63   end Get;
64
65   ----------
66   -- Gets --
67   ----------
68
69   procedure Gets
70     (From : String;
71      Item : out Long_Long_Float;
72      Last : out Positive)
73   is
74      Pos : aliased Integer;
75
76   begin
77      String_Skip (From, Pos);
78      Item := Scan_Real (From, Pos'Access, From'Last);
79      Last := Pos - 1;
80
81   exception
82      when Constraint_Error =>
83         raise Data_Error;
84   end Gets;
85
86   ---------------
87   -- Load_Real --
88   ---------------
89
90   procedure Load_Real
91     (File : File_Type;
92      Buf  : out String;
93      Ptr  : in out Natural)
94   is
95      Loaded   : Boolean;
96
97   begin
98      --  Skip initial blanks and load possible sign
99
100      Load_Skip (File);
101      Load (File, Buf, Ptr, '+', '-');
102
103      --  Case of .nnnn
104
105      Load (File, Buf, Ptr, '.', Loaded);
106
107      if Loaded then
108         Load_Digits (File, Buf, Ptr, Loaded);
109
110         --  Hopeless junk if no digits loaded
111
112         if not Loaded then
113            return;
114         end if;
115
116      --  Otherwise must have digits to start
117
118      else
119         Load_Digits (File, Buf, Ptr, Loaded);
120
121         --  Hopeless junk if no digits loaded
122
123         if not Loaded then
124            return;
125         end if;
126
127         --  Based cases
128
129         Load (File, Buf, Ptr, '#', ':', Loaded);
130
131         if Loaded then
132
133            --  Case of nnn#.xxx#
134
135            Load (File, Buf, Ptr, '.', Loaded);
136
137            if Loaded then
138               Load_Extended_Digits (File, Buf, Ptr);
139               Load (File, Buf, Ptr, '#', ':');
140
141            --  Case of nnn#xxx.[xxx]# or nnn#xxx#
142
143            else
144               Load_Extended_Digits (File, Buf, Ptr);
145               Load (File, Buf, Ptr, '.', Loaded);
146
147               if Loaded then
148                  Load_Extended_Digits (File, Buf, Ptr);
149               end if;
150
151               --  As usual, it seems strange to allow mixed base characters,
152               --  but that is what ACVC tests expect, see CE3804M, case (3).
153
154               Load (File, Buf, Ptr, '#', ':');
155            end if;
156
157         --  Case of nnn.[nnn] or nnn
158
159         else
160            --  Prevent the potential processing of '.' in cases where the
161            --  initial digits have a trailing underscore.
162
163            if Buf (Ptr) = '_' then
164               return;
165            end if;
166
167            Load (File, Buf, Ptr, '.', Loaded);
168
169            if Loaded then
170               Load_Digits (File, Buf, Ptr);
171            end if;
172         end if;
173      end if;
174
175      --  Deal with exponent
176
177      Load (File, Buf, Ptr, 'E', 'e', Loaded);
178
179      if Loaded then
180         Load (File, Buf, Ptr, '+', '-');
181         Load_Digits (File, Buf, Ptr);
182      end if;
183   end Load_Real;
184
185   ---------
186   -- Put --
187   ---------
188
189   procedure Put
190     (File : File_Type;
191      Item : Long_Long_Float;
192      Fore : Field;
193      Aft  : Field;
194      Exp  : Field)
195   is
196      Buf : String (1 .. Field'Last);
197      Ptr : Natural := 0;
198
199   begin
200      Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp);
201      Put_Item (File, Buf (1 .. Ptr));
202   end Put;
203
204   ----------
205   -- Puts --
206   ----------
207
208   procedure Puts
209     (To   : out String;
210      Item : Long_Long_Float;
211      Aft  : Field;
212      Exp  : Field)
213   is
214      Buf : String (1 .. Field'Last);
215      Ptr : Natural := 0;
216
217   begin
218      Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp);
219
220      if Ptr > To'Length then
221         raise Layout_Error;
222
223      else
224         for J in 1 .. Ptr loop
225            To (To'Last - Ptr + J) := Buf (J);
226         end loop;
227
228         for J in To'First .. To'Last - Ptr loop
229            To (J) := ' ';
230         end loop;
231      end if;
232   end Puts;
233
234end Ada.Wide_Text_IO.Float_Aux;
235