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-2014, 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         --  Deal with based case. We recognize either the standard '#' or the
128         --  allowed alternative replacement ':' (see RM J.2(3)).
129
130         Load (File, Buf, Ptr, '#', ':', Loaded);
131
132         if Loaded then
133
134            --  Case of nnn#.xxx#
135
136            Load (File, Buf, Ptr, '.', Loaded);
137
138            if Loaded then
139               Load_Extended_Digits (File, Buf, Ptr);
140               Load (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            --  Prevent the potential processing of '.' in cases where the
162            --  initial digits have a trailing underscore.
163
164            if Buf (Ptr) = '_' then
165               return;
166            end if;
167
168            Load (File, Buf, Ptr, '.', Loaded);
169
170            if Loaded then
171               Load_Digits (File, Buf, Ptr);
172            end if;
173         end if;
174      end if;
175
176      --  Deal with exponent
177
178      Load (File, Buf, Ptr, 'E', 'e', Loaded);
179
180      if Loaded then
181         Load (File, Buf, Ptr, '+', '-');
182         Load_Digits (File, Buf, Ptr);
183      end if;
184   end Load_Real;
185
186   ---------
187   -- Put --
188   ---------
189
190   procedure Put
191     (File : File_Type;
192      Item : Long_Long_Float;
193      Fore : Field;
194      Aft  : Field;
195      Exp  : Field)
196   is
197      Buf : String (1 .. Field'Last);
198      Ptr : Natural := 0;
199
200   begin
201      Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp);
202      Put_Item (File, Buf (1 .. Ptr));
203   end Put;
204
205   ----------
206   -- Puts --
207   ----------
208
209   procedure Puts
210     (To   : out String;
211      Item : Long_Long_Float;
212      Aft  : Field;
213      Exp  : Field)
214   is
215      Buf : String (1 .. Field'Last);
216      Ptr : Natural := 0;
217
218   begin
219      Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp);
220
221      if Ptr > To'Length then
222         raise Layout_Error;
223
224      else
225         for J in 1 .. Ptr loop
226            To (To'Last - Ptr + J) := Buf (J);
227         end loop;
228
229         for J in To'First .. To'Last - Ptr loop
230            To (J) := ' ';
231         end loop;
232      end if;
233   end Puts;
234
235end Ada.Wide_Text_IO.Float_Aux;
236