1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- S Y S T E M . I M G _ D E C -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2009, 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 System.Img_Int; use System.Img_Int; 33 34package body System.Img_Dec is 35 36 ------------------- 37 -- Image_Decimal -- 38 ------------------- 39 40 procedure Image_Decimal 41 (V : Integer; 42 S : in out String; 43 P : out Natural; 44 Scale : Integer) 45 is 46 pragma Assert (S'First = 1); 47 48 begin 49 -- Add space at start for non-negative numbers 50 51 if V >= 0 then 52 S (1) := ' '; 53 P := 1; 54 else 55 P := 0; 56 end if; 57 58 Set_Image_Decimal (V, S, P, Scale, 1, Integer'Max (1, Scale), 0); 59 end Image_Decimal; 60 61 ------------------------ 62 -- Set_Decimal_Digits -- 63 ------------------------ 64 65 procedure Set_Decimal_Digits 66 (Digs : in out String; 67 NDigs : Natural; 68 S : out String; 69 P : in out Natural; 70 Scale : Integer; 71 Fore : Natural; 72 Aft : Natural; 73 Exp : Natural) 74 is 75 Minus : constant Boolean := (Digs (Digs'First) = '-'); 76 -- Set True if input is negative 77 78 Zero : Boolean := (Digs (Digs'First + 1) = '0'); 79 -- Set True if input is exactly zero (only case when a leading zero 80 -- is permitted in the input string given to this procedure). This 81 -- flag can get set later if rounding causes the value to become zero. 82 83 FD : Natural := 2; 84 -- First digit position of digits remaining to be processed 85 86 LD : Natural := NDigs; 87 -- Last digit position of digits remaining to be processed 88 89 ND : Natural := NDigs - 1; 90 -- Number of digits remaining to be processed (LD - FD + 1) 91 92 Digits_Before_Point : Integer := ND - Scale; 93 -- Number of digits before decimal point in the input value. This 94 -- value can be negative if the input value is less than 0.1, so 95 -- it is an indication of the current exponent. Digits_Before_Point 96 -- is adjusted if the rounding step generates an extra digit. 97 98 Digits_After_Point : constant Natural := Integer'Max (1, Aft); 99 -- Digit positions after decimal point in result string 100 101 Expon : Integer; 102 -- Integer value of exponent 103 104 procedure Round (N : Integer); 105 -- Round the number in Digs. N is the position of the last digit to be 106 -- retained in the rounded position (rounding is based on Digs (N + 1) 107 -- FD, LD, ND are reset as necessary if required. Note that if the 108 -- result value rounds up (e.g. 9.99 => 10.0), an extra digit can be 109 -- placed in the sign position as a result of the rounding, this is 110 -- the case in which FD is adjusted. The call to Round has no effect 111 -- if N is outside the range FD .. LD. 112 113 procedure Set (C : Character); 114 pragma Inline (Set); 115 -- Sets character C in output buffer 116 117 procedure Set_Blanks_And_Sign (N : Integer); 118 -- Sets leading blanks and minus sign if needed. N is the number of 119 -- positions to be filled (a minus sign is output even if N is zero 120 -- or negative, For a positive value, if N is non-positive, then 121 -- a leading blank is filled. 122 123 procedure Set_Digits (S, E : Natural); 124 pragma Inline (Set_Digits); 125 -- Set digits S through E from Digs, no effect if S > E 126 127 procedure Set_Zeroes (N : Integer); 128 pragma Inline (Set_Zeroes); 129 -- Set N zeroes, no effect if N is negative 130 131 ----------- 132 -- Round -- 133 ----------- 134 135 procedure Round (N : Integer) is 136 D : Character; 137 138 begin 139 -- Nothing to do if rounding past the last digit we have 140 141 if N >= LD then 142 return; 143 144 -- Cases of rounding before the initial digit 145 146 elsif N < FD then 147 148 -- The result is zero, unless we are rounding just before 149 -- the first digit, and the first digit is five or more. 150 151 if N = 1 and then Digs (Digs'First + 1) >= '5' then 152 Digs (Digs'First) := '1'; 153 else 154 Digs (Digs'First) := '0'; 155 Zero := True; 156 end if; 157 158 Digits_Before_Point := Digits_Before_Point + 1; 159 FD := 1; 160 LD := 1; 161 ND := 1; 162 163 -- Normal case of rounding an existing digit 164 165 else 166 LD := N; 167 ND := LD - 1; 168 169 if Digs (N + 1) >= '5' then 170 for J in reverse 2 .. N loop 171 D := Character'Succ (Digs (J)); 172 173 if D <= '9' then 174 Digs (J) := D; 175 return; 176 else 177 Digs (J) := '0'; 178 end if; 179 end loop; 180 181 -- Here the rounding overflows into the sign position. That's 182 -- OK, because we already captured the value of the sign and 183 -- we are in any case destroying the value in the Digs buffer 184 185 Digs (Digs'First) := '1'; 186 FD := 1; 187 ND := ND + 1; 188 Digits_Before_Point := Digits_Before_Point + 1; 189 end if; 190 end if; 191 end Round; 192 193 --------- 194 -- Set -- 195 --------- 196 197 procedure Set (C : Character) is 198 begin 199 P := P + 1; 200 S (P) := C; 201 end Set; 202 203 ------------------------- 204 -- Set_Blanks_And_Sign -- 205 ------------------------- 206 207 procedure Set_Blanks_And_Sign (N : Integer) is 208 W : Integer := N; 209 210 begin 211 if Minus then 212 W := W - 1; 213 214 for J in 1 .. W loop 215 Set (' '); 216 end loop; 217 218 Set ('-'); 219 220 else 221 for J in 1 .. W loop 222 Set (' '); 223 end loop; 224 end if; 225 end Set_Blanks_And_Sign; 226 227 ---------------- 228 -- Set_Digits -- 229 ---------------- 230 231 procedure Set_Digits (S, E : Natural) is 232 begin 233 for J in S .. E loop 234 Set (Digs (J)); 235 end loop; 236 end Set_Digits; 237 238 ---------------- 239 -- Set_Zeroes -- 240 ---------------- 241 242 procedure Set_Zeroes (N : Integer) is 243 begin 244 for J in 1 .. N loop 245 Set ('0'); 246 end loop; 247 end Set_Zeroes; 248 249 -- Start of processing for Set_Decimal_Digits 250 251 begin 252 -- Case of exponent given 253 254 if Exp > 0 then 255 Set_Blanks_And_Sign (Fore - 1); 256 Round (Digits_After_Point + 2); 257 Set (Digs (FD)); 258 FD := FD + 1; 259 ND := ND - 1; 260 Set ('.'); 261 262 if ND >= Digits_After_Point then 263 Set_Digits (FD, FD + Digits_After_Point - 1); 264 else 265 Set_Digits (FD, LD); 266 Set_Zeroes (Digits_After_Point - ND); 267 end if; 268 269 -- Calculate exponent. The number of digits before the decimal point 270 -- in the input is Digits_Before_Point, and the number of digits 271 -- before the decimal point in the output is 1, so we can get the 272 -- exponent as the difference between these two values. The one 273 -- exception is for the value zero, which by convention has an 274 -- exponent of +0. 275 276 Expon := (if Zero then 0 else Digits_Before_Point - 1); 277 Set ('E'); 278 ND := 0; 279 280 if Expon >= 0 then 281 Set ('+'); 282 Set_Image_Integer (Expon, Digs, ND); 283 else 284 Set ('-'); 285 Set_Image_Integer (-Expon, Digs, ND); 286 end if; 287 288 Set_Zeroes (Exp - ND - 1); 289 Set_Digits (1, ND); 290 return; 291 292 -- Case of no exponent given. To make these cases clear, we use 293 -- examples. For all the examples, we assume Fore = 2, Aft = 3. 294 -- A P in the example input string is an implied zero position, 295 -- not included in the input string. 296 297 else 298 -- Round at correct position 299 -- Input: 4PP => unchanged 300 -- Input: 400.03 => unchanged 301 -- Input 3.4567 => 3.457 302 -- Input: 9.9999 => 10.000 303 -- Input: 0.PPP5 => 0.001 304 -- Input: 0.PPP4 => 0 305 -- Input: 0.00003 => 0 306 307 Round (LD - (Scale - Digits_After_Point)); 308 309 -- No digits before point in input 310 -- Input: .123 Output: 0.123 311 -- Input: .PP3 Output: 0.003 312 313 if Digits_Before_Point <= 0 then 314 Set_Blanks_And_Sign (Fore - 1); 315 Set ('0'); 316 Set ('.'); 317 318 declare 319 DA : Natural := Digits_After_Point; 320 -- Digits remaining to output after point 321 322 LZ : constant Integer := 323 Integer'Max (0, Integer'Min (DA, -Digits_Before_Point)); 324 -- Number of leading zeroes after point 325 326 begin 327 Set_Zeroes (LZ); 328 DA := DA - LZ; 329 330 if DA < ND then 331 Set_Digits (FD, FD + DA - 1); 332 333 else 334 Set_Digits (FD, LD); 335 Set_Zeroes (DA - ND); 336 end if; 337 end; 338 339 -- At least one digit before point in input 340 341 else 342 -- Less digits in input than are needed before point 343 -- Input: 1PP Output: 100.000 344 345 if ND < Digits_Before_Point then 346 347 -- Special case, if the input is the single digit 0, then we 348 -- do not want 000.000, but instead 0.000. 349 350 if ND = 1 and then Digs (FD) = '0' then 351 Set_Blanks_And_Sign (Fore - 1); 352 Set ('0'); 353 354 -- Normal case where we need to output scaling zeroes 355 356 else 357 Set_Blanks_And_Sign (Fore - Digits_Before_Point); 358 Set_Digits (FD, LD); 359 Set_Zeroes (Digits_Before_Point - ND); 360 end if; 361 362 -- Set period and zeroes after the period 363 364 Set ('.'); 365 Set_Zeroes (Digits_After_Point); 366 367 -- Input has full amount of digits before decimal point 368 369 else 370 Set_Blanks_And_Sign (Fore - Digits_Before_Point); 371 Set_Digits (FD, FD + Digits_Before_Point - 1); 372 Set ('.'); 373 Set_Digits (FD + Digits_Before_Point, LD); 374 Set_Zeroes (Digits_After_Point - (ND - Digits_Before_Point)); 375 end if; 376 end if; 377 end if; 378 end Set_Decimal_Digits; 379 380 ----------------------- 381 -- Set_Image_Decimal -- 382 ----------------------- 383 384 procedure Set_Image_Decimal 385 (V : Integer; 386 S : in out String; 387 P : in out Natural; 388 Scale : Integer; 389 Fore : Natural; 390 Aft : Natural; 391 Exp : Natural) 392 is 393 Digs : String := Integer'Image (V); 394 -- Sign and digits of decimal value 395 396 begin 397 Set_Decimal_Digits (Digs, Digs'Length, S, P, Scale, Fore, Aft, Exp); 398 end Set_Image_Decimal; 399 400end System.Img_Dec; 401