Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/libgnat/a-ztdeau.adb @ 111:04ced10e8804
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 . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ 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.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; | |
33 with Ada.Wide_Wide_Text_IO.Float_Aux; use Ada.Wide_Wide_Text_IO.Float_Aux; | |
34 | |
35 with System.Img_Dec; use System.Img_Dec; | |
36 with System.Img_LLD; use System.Img_LLD; | |
37 with System.Val_Dec; use System.Val_Dec; | |
38 with System.Val_LLD; use System.Val_LLD; | |
39 | |
40 package body Ada.Wide_Wide_Text_IO.Decimal_Aux is | |
41 | |
42 ------------- | |
43 -- Get_Dec -- | |
44 ------------- | |
45 | |
46 function Get_Dec | |
47 (File : File_Type; | |
48 Width : Field; | |
49 Scale : Integer) return Integer | |
50 is | |
51 Buf : String (1 .. Field'Last); | |
52 Ptr : aliased Integer; | |
53 Stop : Integer := 0; | |
54 Item : Integer; | |
55 | |
56 begin | |
57 if Width /= 0 then | |
58 Load_Width (File, Width, Buf, Stop); | |
59 String_Skip (Buf, Ptr); | |
60 else | |
61 Load_Real (File, Buf, Stop); | |
62 Ptr := 1; | |
63 end if; | |
64 | |
65 Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale); | |
66 Check_End_Of_Field (Buf, Stop, Ptr, Width); | |
67 return Item; | |
68 end Get_Dec; | |
69 | |
70 ------------- | |
71 -- Get_LLD -- | |
72 ------------- | |
73 | |
74 function Get_LLD | |
75 (File : File_Type; | |
76 Width : Field; | |
77 Scale : Integer) return Long_Long_Integer | |
78 is | |
79 Buf : String (1 .. Field'Last); | |
80 Ptr : aliased Integer; | |
81 Stop : Integer := 0; | |
82 Item : Long_Long_Integer; | |
83 | |
84 begin | |
85 if Width /= 0 then | |
86 Load_Width (File, Width, Buf, Stop); | |
87 String_Skip (Buf, Ptr); | |
88 else | |
89 Load_Real (File, Buf, Stop); | |
90 Ptr := 1; | |
91 end if; | |
92 | |
93 Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale); | |
94 Check_End_Of_Field (Buf, Stop, Ptr, Width); | |
95 return Item; | |
96 end Get_LLD; | |
97 | |
98 -------------- | |
99 -- Gets_Dec -- | |
100 -------------- | |
101 | |
102 function Gets_Dec | |
103 (From : String; | |
104 Last : not null access Positive; | |
105 Scale : Integer) return Integer | |
106 is | |
107 Pos : aliased Integer; | |
108 Item : Integer; | |
109 | |
110 begin | |
111 String_Skip (From, Pos); | |
112 Item := Scan_Decimal (From, Pos'Access, From'Last, Scale); | |
113 Last.all := Pos - 1; | |
114 return Item; | |
115 | |
116 exception | |
117 when Constraint_Error => | |
118 Last.all := Pos - 1; | |
119 raise Data_Error; | |
120 | |
121 end Gets_Dec; | |
122 | |
123 -------------- | |
124 -- Gets_LLD -- | |
125 -------------- | |
126 | |
127 function Gets_LLD | |
128 (From : String; | |
129 Last : not null access Positive; | |
130 Scale : Integer) return Long_Long_Integer | |
131 is | |
132 Pos : aliased Integer; | |
133 Item : Long_Long_Integer; | |
134 | |
135 begin | |
136 String_Skip (From, Pos); | |
137 Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale); | |
138 Last.all := Pos - 1; | |
139 return Item; | |
140 | |
141 exception | |
142 when Constraint_Error => | |
143 Last.all := Pos - 1; | |
144 raise Data_Error; | |
145 | |
146 end Gets_LLD; | |
147 | |
148 ------------- | |
149 -- Put_Dec -- | |
150 ------------- | |
151 | |
152 procedure Put_Dec | |
153 (File : File_Type; | |
154 Item : Integer; | |
155 Fore : Field; | |
156 Aft : Field; | |
157 Exp : Field; | |
158 Scale : Integer) | |
159 is | |
160 Buf : String (1 .. Field'Last); | |
161 Ptr : Natural := 0; | |
162 | |
163 begin | |
164 Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); | |
165 Put_Item (File, Buf (1 .. Ptr)); | |
166 end Put_Dec; | |
167 | |
168 ------------- | |
169 -- Put_LLD -- | |
170 ------------- | |
171 | |
172 procedure Put_LLD | |
173 (File : File_Type; | |
174 Item : Long_Long_Integer; | |
175 Fore : Field; | |
176 Aft : Field; | |
177 Exp : Field; | |
178 Scale : Integer) | |
179 is | |
180 Buf : String (1 .. Field'Last); | |
181 Ptr : Natural := 0; | |
182 | |
183 begin | |
184 Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); | |
185 Put_Item (File, Buf (1 .. Ptr)); | |
186 end Put_LLD; | |
187 | |
188 -------------- | |
189 -- Puts_Dec -- | |
190 -------------- | |
191 | |
192 procedure Puts_Dec | |
193 (To : out String; | |
194 Item : Integer; | |
195 Aft : Field; | |
196 Exp : Field; | |
197 Scale : Integer) | |
198 is | |
199 Buf : String (1 .. Field'Last); | |
200 Fore : Integer; | |
201 Ptr : Natural := 0; | |
202 | |
203 begin | |
204 -- Compute Fore, allowing for Aft digits and the decimal dot | |
205 | |
206 Fore := To'Length - Field'Max (1, Aft) - 1; | |
207 | |
208 -- Allow for Exp and two more for E+ or E- if exponent present | |
209 | |
210 if Exp /= 0 then | |
211 Fore := Fore - 2 - Exp; | |
212 end if; | |
213 | |
214 -- Make sure we have enough room | |
215 | |
216 if Fore < 1 then | |
217 raise Layout_Error; | |
218 end if; | |
219 | |
220 -- Do the conversion and check length of result | |
221 | |
222 Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); | |
223 | |
224 if Ptr > To'Length then | |
225 raise Layout_Error; | |
226 else | |
227 To := Buf (1 .. Ptr); | |
228 end if; | |
229 end Puts_Dec; | |
230 | |
231 -------------- | |
232 -- Puts_Dec -- | |
233 -------------- | |
234 | |
235 procedure Puts_LLD | |
236 (To : out String; | |
237 Item : Long_Long_Integer; | |
238 Aft : Field; | |
239 Exp : Field; | |
240 Scale : Integer) | |
241 is | |
242 Buf : String (1 .. Field'Last); | |
243 Fore : Integer; | |
244 Ptr : Natural := 0; | |
245 | |
246 begin | |
247 Fore := | |
248 (if Exp = 0 then To'Length - 1 - Aft else To'Length - 2 - Aft - Exp); | |
249 | |
250 if Fore < 1 then | |
251 raise Layout_Error; | |
252 end if; | |
253 | |
254 Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); | |
255 | |
256 if Ptr > To'Length then | |
257 raise Layout_Error; | |
258 else | |
259 To := Buf (1 .. Ptr); | |
260 end if; | |
261 end Puts_LLD; | |
262 | |
263 end Ada.Wide_Wide_Text_IO.Decimal_Aux; |