|
111
|
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 . F L O A T _ A U X --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
|
|
111
|
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
|
|
|
32 with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
|
|
|
33
|
|
|
34 with System.Img_Real; use System.Img_Real;
|
|
|
35 with System.Val_Real; use System.Val_Real;
|
|
|
36
|
|
|
37 package body Ada.Wide_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
|
|
|
235 end Ada.Wide_Wide_Text_IO.Float_Aux;
|
