Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/a-tiflau.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- A D A . 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-2017, 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
32 with Ada.Text_IO.Generic_Aux; use Ada.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.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. 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 .. 3 * Field'Last + 2);
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 .. 3 * Field'Last + 2);
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.Text_IO.Float_Aux;