1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S Y S T E M . V A L _ U T I L -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2013, 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.Case_Util; use System.Case_Util; 33 34package body System.Val_Util is 35 36 --------------- 37 -- Bad_Value -- 38 --------------- 39 40 procedure Bad_Value (S : String) is 41 begin 42 raise Constraint_Error with "bad input for 'Value: """ & S & '"'; 43 end Bad_Value; 44 45 ---------------------- 46 -- Normalize_String -- 47 ---------------------- 48 49 procedure Normalize_String 50 (S : in out String; 51 F, L : out Integer) 52 is 53 begin 54 F := S'First; 55 L := S'Last; 56 57 -- Scan for leading spaces 58 59 while F <= L and then S (F) = ' ' loop 60 F := F + 1; 61 end loop; 62 63 -- Check for case when the string contained no characters 64 65 if F > L then 66 Bad_Value (S); 67 end if; 68 69 -- Scan for trailing spaces 70 71 while S (L) = ' ' loop 72 L := L - 1; 73 end loop; 74 75 -- Except in the case of a character literal, convert to upper case 76 77 if S (F) /= ''' then 78 for J in F .. L loop 79 S (J) := To_Upper (S (J)); 80 end loop; 81 end if; 82 end Normalize_String; 83 84 ------------------- 85 -- Scan_Exponent -- 86 ------------------- 87 88 function Scan_Exponent 89 (Str : String; 90 Ptr : not null access Integer; 91 Max : Integer; 92 Real : Boolean := False) return Integer 93 is 94 P : Natural := Ptr.all; 95 M : Boolean; 96 X : Integer; 97 98 begin 99 if P >= Max 100 or else (Str (P) /= 'E' and then Str (P) /= 'e') 101 then 102 return 0; 103 end if; 104 105 -- We have an E/e, see if sign follows 106 107 P := P + 1; 108 109 if Str (P) = '+' then 110 P := P + 1; 111 112 if P > Max then 113 return 0; 114 else 115 M := False; 116 end if; 117 118 elsif Str (P) = '-' then 119 P := P + 1; 120 121 if P > Max or else not Real then 122 return 0; 123 else 124 M := True; 125 end if; 126 127 else 128 M := False; 129 end if; 130 131 if Str (P) not in '0' .. '9' then 132 return 0; 133 end if; 134 135 -- Scan out the exponent value as an unsigned integer. Values larger 136 -- than (Integer'Last / 10) are simply considered large enough here. 137 -- This assumption is correct for all machines we know of (e.g. in the 138 -- case of 16 bit integers it allows exponents up to 3276, which is 139 -- large enough for the largest floating types in base 2.) 140 141 X := 0; 142 143 loop 144 if X < (Integer'Last / 10) then 145 X := X * 10 + (Character'Pos (Str (P)) - Character'Pos ('0')); 146 end if; 147 148 P := P + 1; 149 150 exit when P > Max; 151 152 if Str (P) = '_' then 153 Scan_Underscore (Str, P, Ptr, Max, False); 154 else 155 exit when Str (P) not in '0' .. '9'; 156 end if; 157 end loop; 158 159 if M then 160 X := -X; 161 end if; 162 163 Ptr.all := P; 164 return X; 165 end Scan_Exponent; 166 167 -------------------- 168 -- Scan_Plus_Sign -- 169 -------------------- 170 171 procedure Scan_Plus_Sign 172 (Str : String; 173 Ptr : not null access Integer; 174 Max : Integer; 175 Start : out Positive) 176 is 177 P : Natural := Ptr.all; 178 179 begin 180 if P > Max then 181 Bad_Value (Str); 182 end if; 183 184 -- Scan past initial blanks 185 186 while Str (P) = ' ' loop 187 P := P + 1; 188 189 if P > Max then 190 Ptr.all := P; 191 Bad_Value (Str); 192 end if; 193 end loop; 194 195 Start := P; 196 197 -- Skip past an initial plus sign 198 199 if Str (P) = '+' then 200 P := P + 1; 201 202 if P > Max then 203 Ptr.all := Start; 204 Bad_Value (Str); 205 end if; 206 end if; 207 208 Ptr.all := P; 209 end Scan_Plus_Sign; 210 211 --------------- 212 -- Scan_Sign -- 213 --------------- 214 215 procedure Scan_Sign 216 (Str : String; 217 Ptr : not null access Integer; 218 Max : Integer; 219 Minus : out Boolean; 220 Start : out Positive) 221 is 222 P : Natural := Ptr.all; 223 224 begin 225 -- Deal with case of null string (all blanks). As per spec, we raise 226 -- constraint error, with Ptr unchanged, and thus > Max. 227 228 if P > Max then 229 Bad_Value (Str); 230 end if; 231 232 -- Scan past initial blanks 233 234 while Str (P) = ' ' loop 235 P := P + 1; 236 237 if P > Max then 238 Ptr.all := P; 239 Bad_Value (Str); 240 end if; 241 end loop; 242 243 Start := P; 244 245 -- Remember an initial minus sign 246 247 if Str (P) = '-' then 248 Minus := True; 249 P := P + 1; 250 251 if P > Max then 252 Ptr.all := Start; 253 Bad_Value (Str); 254 end if; 255 256 -- Skip past an initial plus sign 257 258 elsif Str (P) = '+' then 259 Minus := False; 260 P := P + 1; 261 262 if P > Max then 263 Ptr.all := Start; 264 Bad_Value (Str); 265 end if; 266 267 else 268 Minus := False; 269 end if; 270 271 Ptr.all := P; 272 end Scan_Sign; 273 274 -------------------------- 275 -- Scan_Trailing_Blanks -- 276 -------------------------- 277 278 procedure Scan_Trailing_Blanks (Str : String; P : Positive) is 279 begin 280 for J in P .. Str'Last loop 281 if Str (J) /= ' ' then 282 Bad_Value (Str); 283 end if; 284 end loop; 285 end Scan_Trailing_Blanks; 286 287 --------------------- 288 -- Scan_Underscore -- 289 --------------------- 290 291 procedure Scan_Underscore 292 (Str : String; 293 P : in out Natural; 294 Ptr : not null access Integer; 295 Max : Integer; 296 Ext : Boolean) 297 is 298 C : Character; 299 300 begin 301 P := P + 1; 302 303 -- If underscore is at the end of string, then this is an error and we 304 -- raise Constraint_Error, leaving the pointer past the underscore. This 305 -- seems a bit strange. It means e.g. that if the field is: 306 307 -- 345_ 308 309 -- that Constraint_Error is raised. You might think that the RM in this 310 -- case would scan out the 345 as a valid integer, leaving the pointer 311 -- at the underscore, but the ACVC suite clearly requires an error in 312 -- this situation (see for example CE3704M). 313 314 if P > Max then 315 Ptr.all := P; 316 Bad_Value (Str); 317 end if; 318 319 -- Similarly, if no digit follows the underscore raise an error. This 320 -- also catches the case of double underscore which is also an error. 321 322 C := Str (P); 323 324 if C in '0' .. '9' 325 or else (Ext and then (C in 'A' .. 'F' or else C in 'a' .. 'f')) 326 then 327 return; 328 else 329 Ptr.all := P; 330 Bad_Value (Str); 331 end if; 332 end Scan_Underscore; 333 334end System.Val_Util; 335