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