1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- A D A . 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-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 Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; 33with Ada.Text_IO.Float_Aux; use Ada.Text_IO.Float_Aux; 34 35with System.Img_Dec; use System.Img_Dec; 36with System.Img_LLD; use System.Img_LLD; 37with System.Val_Dec; use System.Val_Dec; 38with System.Val_LLD; use System.Val_LLD; 39 40package body Ada.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 end Gets_Dec; 121 122 -------------- 123 -- Gets_LLD -- 124 -------------- 125 126 function Gets_LLD 127 (From : String; 128 Last : not null access Positive; 129 Scale : Integer) return Long_Long_Integer 130 is 131 Pos : aliased Integer; 132 Item : Long_Long_Integer; 133 134 begin 135 String_Skip (From, Pos); 136 Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale); 137 Last.all := Pos - 1; 138 return Item; 139 140 exception 141 when Constraint_Error => 142 Last.all := Pos - 1; 143 raise Data_Error; 144 end Gets_LLD; 145 146 ------------- 147 -- Put_Dec -- 148 ------------- 149 150 procedure Put_Dec 151 (File : File_Type; 152 Item : Integer; 153 Fore : Field; 154 Aft : Field; 155 Exp : Field; 156 Scale : Integer) 157 is 158 Buf : String (1 .. Field'Last); 159 Ptr : Natural := 0; 160 161 begin 162 Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); 163 Put_Item (File, Buf (1 .. Ptr)); 164 end Put_Dec; 165 166 ------------- 167 -- Put_LLD -- 168 ------------- 169 170 procedure Put_LLD 171 (File : File_Type; 172 Item : Long_Long_Integer; 173 Fore : Field; 174 Aft : Field; 175 Exp : Field; 176 Scale : Integer) 177 is 178 Buf : String (1 .. Field'Last); 179 Ptr : Natural := 0; 180 181 begin 182 Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); 183 Put_Item (File, Buf (1 .. Ptr)); 184 end Put_LLD; 185 186 -------------- 187 -- Puts_Dec -- 188 -------------- 189 190 procedure Puts_Dec 191 (To : out String; 192 Item : Integer; 193 Aft : Field; 194 Exp : Field; 195 Scale : Integer) 196 is 197 Buf : String (1 .. Field'Last); 198 Fore : Integer; 199 Ptr : Natural := 0; 200 201 begin 202 -- Compute Fore, allowing for Aft digits and the decimal dot 203 204 Fore := To'Length - Field'Max (1, Aft) - 1; 205 206 -- Allow for Exp and two more for E+ or E- if exponent present 207 208 if Exp /= 0 then 209 Fore := Fore - 2 - Exp; 210 end if; 211 212 -- Make sure we have enough room 213 214 if Fore < 1 then 215 raise Layout_Error; 216 end if; 217 218 -- Do the conversion and check length of result 219 220 Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); 221 222 if Ptr > To'Length then 223 raise Layout_Error; 224 else 225 To := Buf (1 .. Ptr); 226 end if; 227 end Puts_Dec; 228 229 -------------- 230 -- Puts_Dec -- 231 -------------- 232 233 procedure Puts_LLD 234 (To : out String; 235 Item : Long_Long_Integer; 236 Aft : Field; 237 Exp : Field; 238 Scale : Integer) 239 is 240 Buf : String (1 .. Field'Last); 241 Fore : Integer; 242 Ptr : Natural := 0; 243 244 begin 245 Fore := 246 (if Exp = 0 then To'Length - 1 - Aft else To'Length - 2 - Aft - Exp); 247 248 if Fore < 1 then 249 raise Layout_Error; 250 end if; 251 252 Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); 253 254 if Ptr > To'Length then 255 raise Layout_Error; 256 else 257 To := Buf (1 .. Ptr); 258 end if; 259 end Puts_LLD; 260 261end Ada.Text_IO.Decimal_Aux; 262