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