]>
Commit | Line | Data |
---|---|---|
4c2d6a70 AC |
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 | -- -- | |
4b490c1e | 9 | -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- |
4c2d6a70 AC |
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- -- | |
748086b7 | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
4c2d6a70 AC |
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 -- | |
748086b7 JJ |
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/>. -- | |
4c2d6a70 AC |
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 | ||
72eaa365 AC |
127 | -- Deal with based case. We recognize either the standard '#' or the |
128 | -- allowed alternative replacement ':' (see RM J.2(3)). | |
4c2d6a70 AC |
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); | |
a01f0296 | 140 | Load (File, Buf, Ptr, '#', ':'); |
4c2d6a70 AC |
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 | |
a01f0296 HK |
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 | ||
4c2d6a70 AC |
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; |