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