1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S Y S T E M . V A L _ U N S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2015, 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.Unsigned_Types; use System.Unsigned_Types; 33with System.Val_Util; use System.Val_Util; 34 35package body System.Val_Uns is 36 37 ----------------------- 38 -- Scan_Raw_Unsigned -- 39 ----------------------- 40 41 function Scan_Raw_Unsigned 42 (Str : String; 43 Ptr : not null access Integer; 44 Max : Integer) return Unsigned 45 is 46 P : Integer; 47 -- Local copy of the pointer 48 49 Uval : Unsigned; 50 -- Accumulated unsigned integer result 51 52 Expon : Integer; 53 -- Exponent value 54 55 Overflow : Boolean := False; 56 -- Set True if overflow is detected at any point 57 58 Base_Char : Character; 59 -- Base character (# or :) in based case 60 61 Base : Unsigned := 10; 62 -- Base value (reset in based case) 63 64 Digit : Unsigned; 65 -- Digit value 66 67 begin 68 -- We do not tolerate strings with Str'Last = Positive'Last 69 70 if Str'Last = Positive'Last then 71 raise Program_Error with 72 "string upper bound is Positive'Last, not supported"; 73 end if; 74 75 P := Ptr.all; 76 Uval := Character'Pos (Str (P)) - Character'Pos ('0'); 77 P := P + 1; 78 79 -- Scan out digits of what is either the number or the base. 80 -- In either case, we are definitely scanning out in base 10. 81 82 declare 83 Umax : constant := (Unsigned'Last - 9) / 10; 84 -- Max value which cannot overflow on accumulating next digit 85 86 Umax10 : constant := Unsigned'Last / 10; 87 -- Numbers bigger than Umax10 overflow if multiplied by 10 88 89 begin 90 -- Loop through decimal digits 91 loop 92 exit when P > Max; 93 94 Digit := Character'Pos (Str (P)) - Character'Pos ('0'); 95 96 -- Non-digit encountered 97 98 if Digit > 9 then 99 if Str (P) = '_' then 100 Scan_Underscore (Str, P, Ptr, Max, False); 101 else 102 exit; 103 end if; 104 105 -- Accumulate result, checking for overflow 106 107 else 108 if Uval <= Umax then 109 Uval := 10 * Uval + Digit; 110 111 elsif Uval > Umax10 then 112 Overflow := True; 113 114 else 115 Uval := 10 * Uval + Digit; 116 117 if Uval < Umax10 then 118 Overflow := True; 119 end if; 120 end if; 121 122 P := P + 1; 123 end if; 124 end loop; 125 end; 126 127 Ptr.all := P; 128 129 -- Deal with based case. We recognize either the standard '#' or the 130 -- allowed alternative replacement ':' (see RM J.2(3)). 131 132 if P < Max and then (Str (P) = '#' or else Str (P) = ':') then 133 Base_Char := Str (P); 134 P := P + 1; 135 Base := Uval; 136 Uval := 0; 137 138 -- Check base value. Overflow is set True if we find a bad base, or 139 -- a digit that is out of range of the base. That way, we scan out 140 -- the numeral that is still syntactically correct, though illegal. 141 -- We use a safe base of 16 for this scan, to avoid zero divide. 142 143 if Base not in 2 .. 16 then 144 Overflow := True; 145 Base := 16; 146 end if; 147 148 -- Scan out based integer 149 150 declare 151 Umax : constant Unsigned := (Unsigned'Last - Base + 1) / Base; 152 -- Max value which cannot overflow on accumulating next digit 153 154 UmaxB : constant Unsigned := Unsigned'Last / Base; 155 -- Numbers bigger than UmaxB overflow if multiplied by base 156 157 begin 158 -- Loop to scan out based integer value 159 160 loop 161 -- We require a digit at this stage 162 163 if Str (P) in '0' .. '9' then 164 Digit := Character'Pos (Str (P)) - Character'Pos ('0'); 165 166 elsif Str (P) in 'A' .. 'F' then 167 Digit := 168 Character'Pos (Str (P)) - (Character'Pos ('A') - 10); 169 170 elsif Str (P) in 'a' .. 'f' then 171 Digit := 172 Character'Pos (Str (P)) - (Character'Pos ('a') - 10); 173 174 -- If we don't have a digit, then this is not a based number 175 -- after all, so we use the value we scanned out as the base 176 -- (now in Base), and the pointer to the base character was 177 -- already stored in Ptr.all. 178 179 else 180 Uval := Base; 181 exit; 182 end if; 183 184 -- If digit is too large, just signal overflow and continue. 185 -- The idea here is to keep scanning as long as the input is 186 -- syntactically valid, even if we have detected overflow 187 188 if Digit >= Base then 189 Overflow := True; 190 191 -- Here we accumulate the value, checking overflow 192 193 elsif Uval <= Umax then 194 Uval := Base * Uval + Digit; 195 196 elsif Uval > UmaxB then 197 Overflow := True; 198 199 else 200 Uval := Base * Uval + Digit; 201 202 if Uval < UmaxB then 203 Overflow := True; 204 end if; 205 end if; 206 207 -- If at end of string with no base char, not a based number 208 -- but we signal Constraint_Error and set the pointer past 209 -- the end of the field, since this is what the ACVC tests 210 -- seem to require, see CE3704N, line 204. 211 212 P := P + 1; 213 214 if P > Max then 215 Ptr.all := P; 216 Bad_Value (Str); 217 end if; 218 219 -- If terminating base character, we are done with loop 220 221 if Str (P) = Base_Char then 222 Ptr.all := P + 1; 223 exit; 224 225 -- Deal with underscore 226 227 elsif Str (P) = '_' then 228 Scan_Underscore (Str, P, Ptr, Max, True); 229 end if; 230 231 end loop; 232 end; 233 end if; 234 235 -- Come here with scanned unsigned value in Uval. The only remaining 236 -- required step is to deal with exponent if one is present. 237 238 Expon := Scan_Exponent (Str, Ptr, Max); 239 240 if Expon /= 0 and then Uval /= 0 then 241 242 -- For non-zero value, scale by exponent value. No need to do this 243 -- efficiently, since use of exponent in integer literals is rare, 244 -- and in any case the exponent cannot be very large. 245 246 declare 247 UmaxB : constant Unsigned := Unsigned'Last / Base; 248 -- Numbers bigger than UmaxB overflow if multiplied by base 249 250 begin 251 for J in 1 .. Expon loop 252 if Uval > UmaxB then 253 Overflow := True; 254 exit; 255 end if; 256 257 Uval := Uval * Base; 258 end loop; 259 end; 260 end if; 261 262 -- Return result, dealing with sign and overflow 263 264 if Overflow then 265 Bad_Value (Str); 266 else 267 return Uval; 268 end if; 269 end Scan_Raw_Unsigned; 270 271 ------------------- 272 -- Scan_Unsigned -- 273 ------------------- 274 275 function Scan_Unsigned 276 (Str : String; 277 Ptr : not null access Integer; 278 Max : Integer) return Unsigned 279 is 280 Start : Positive; 281 -- Save location of first non-blank character 282 283 begin 284 Scan_Plus_Sign (Str, Ptr, Max, Start); 285 286 if Str (Ptr.all) not in '0' .. '9' then 287 Ptr.all := Start; 288 Bad_Value (Str); 289 end if; 290 291 return Scan_Raw_Unsigned (Str, Ptr, Max); 292 end Scan_Unsigned; 293 294 -------------------- 295 -- Value_Unsigned -- 296 -------------------- 297 298 function Value_Unsigned (Str : String) return Unsigned is 299 begin 300 -- We have to special case Str'Last = Positive'Last because the normal 301 -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We 302 -- deal with this by converting to a subtype which fixes the bounds. 303 304 if Str'Last = Positive'Last then 305 declare 306 subtype NT is String (1 .. Str'Length); 307 begin 308 return Value_Unsigned (NT (Str)); 309 end; 310 311 -- Normal case where Str'Last < Positive'Last 312 313 else 314 declare 315 V : Unsigned; 316 P : aliased Integer := Str'First; 317 begin 318 V := Scan_Unsigned (Str, P'Access, Str'Last); 319 Scan_Trailing_Blanks (Str, P); 320 return V; 321 end; 322 end if; 323 end Value_Unsigned; 324 325end System.Val_Uns; 326