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-2002, 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 2, 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. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- As a special exception, if other files instantiate generics from this -- 23-- unit, or you link this unit with other files to produce an executable, -- 24-- this unit does not by itself cause the resulting executable to be -- 25-- covered by the GNU General Public License. This exception does not -- 26-- however invalidate any other reasons why the executable file might be -- 27-- covered by the GNU Public License. -- 28-- -- 29-- GNAT was originally developed by the GNAT team at New York University. -- 30-- Extensive contributions were provided by Ada Core Technologies Inc. -- 31-- -- 32------------------------------------------------------------------------------ 33 34with System.Case_Util; use System.Case_Util; 35 36package body System.Val_Util is 37 38 ---------------------- 39 -- Normalize_String -- 40 ---------------------- 41 42 procedure Normalize_String 43 (S : in out String; 44 F, L : out Integer) 45 is 46 begin 47 F := S'First; 48 L := S'Last; 49 50 -- Scan for leading spaces 51 52 while F <= L and then S (F) = ' ' loop 53 F := F + 1; 54 end loop; 55 56 -- Check for case when the string contained no characters 57 58 if F > L then 59 raise Constraint_Error; 60 end if; 61 62 -- Scan for trailing spaces 63 64 while S (L) = ' ' loop 65 L := L - 1; 66 end loop; 67 68 -- Except in the case of a character literal, convert to upper case 69 70 if S (F) /= ''' then 71 for J in F .. L loop 72 S (J) := To_Upper (S (J)); 73 end loop; 74 end if; 75 76 end Normalize_String; 77 78 ------------------- 79 -- Scan_Exponent -- 80 ------------------- 81 82 function Scan_Exponent 83 (Str : String; 84 Ptr : access Integer; 85 Max : Integer; 86 Real : Boolean := False) 87 return Integer 88 is 89 P : Natural := Ptr.all; 90 M : Boolean; 91 X : Integer; 92 93 begin 94 if P >= Max 95 or else (Str (P) /= 'E' and then Str (P) /= 'e') 96 then 97 return 0; 98 end if; 99 100 -- We have an E/e, see if sign follows 101 102 P := P + 1; 103 104 if Str (P) = '+' then 105 P := P + 1; 106 107 if P > Max then 108 return 0; 109 else 110 M := False; 111 end if; 112 113 elsif Str (P) = '-' then 114 P := P + 1; 115 116 if P > Max or else not Real then 117 return 0; 118 else 119 M := True; 120 end if; 121 122 else 123 M := False; 124 end if; 125 126 if Str (P) not in '0' .. '9' then 127 return 0; 128 end if; 129 130 -- Scan out the exponent value as an unsigned integer. Values larger 131 -- than (Integer'Last / 10) are simply considered large enough here. 132 -- This assumption is correct for all machines we know of (e.g. in 133 -- the case of 16 bit integers it allows exponents up to 3276, which 134 -- is large enough for the largest floating types in base 2.) 135 136 X := 0; 137 138 loop 139 if X < (Integer'Last / 10) then 140 X := X * 10 + (Character'Pos (Str (P)) - Character'Pos ('0')); 141 end if; 142 143 P := P + 1; 144 145 exit when P > Max; 146 147 if Str (P) = '_' then 148 Scan_Underscore (Str, P, Ptr, Max, False); 149 else 150 exit when Str (P) not in '0' .. '9'; 151 end if; 152 end loop; 153 154 if M then 155 X := -X; 156 end if; 157 158 Ptr.all := P; 159 return X; 160 161 end Scan_Exponent; 162 163 --------------- 164 -- Scan_Sign -- 165 --------------- 166 167 procedure Scan_Sign 168 (Str : String; 169 Ptr : access Integer; 170 Max : Integer; 171 Minus : out Boolean; 172 Start : out Positive) 173 is 174 P : Natural := Ptr.all; 175 176 begin 177 -- Deal with case of null string (all blanks!). As per spec, we 178 -- raise constraint error, with Ptr unchanged, and thus > Max. 179 180 if P > Max then 181 raise Constraint_Error; 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 raise Constraint_Error; 192 end if; 193 end loop; 194 195 Start := P; 196 197 -- Remember an initial minus sign 198 199 if Str (P) = '-' then 200 Minus := True; 201 P := P + 1; 202 203 if P > Max then 204 Ptr.all := Start; 205 raise Constraint_Error; 206 end if; 207 208 -- Skip past an initial plus sign 209 210 elsif Str (P) = '+' then 211 Minus := False; 212 P := P + 1; 213 214 if P > Max then 215 Ptr.all := Start; 216 raise Constraint_Error; 217 end if; 218 219 else 220 Minus := False; 221 end if; 222 223 Ptr.all := P; 224 end Scan_Sign; 225 226 -------------------------- 227 -- Scan_Trailing_Blanks -- 228 -------------------------- 229 230 procedure Scan_Trailing_Blanks (Str : String; P : Positive) is 231 begin 232 for J in P .. Str'Last loop 233 if Str (J) /= ' ' then 234 raise Constraint_Error; 235 end if; 236 end loop; 237 end Scan_Trailing_Blanks; 238 239 --------------------- 240 -- Scan_Underscore -- 241 --------------------- 242 243 procedure Scan_Underscore 244 (Str : String; 245 P : in out Natural; 246 Ptr : access Integer; 247 Max : Integer; 248 Ext : Boolean) 249 is 250 C : Character; 251 252 begin 253 P := P + 1; 254 255 -- If underscore is at the end of string, then this is an error and 256 -- we raise Constraint_Error, leaving the pointer past the undescore. 257 -- This seems a bit strange. It means e,g, that if the field is: 258 259 -- 345_ 260 261 -- that Constraint_Error is raised. You might think that the RM in 262 -- this case would scan out the 345 as a valid integer, leaving the 263 -- pointer at the underscore, but the ACVC suite clearly requires 264 -- an error in this situation (see for example CE3704M). 265 266 if P > Max then 267 Ptr.all := P; 268 raise Constraint_Error; 269 end if; 270 271 -- Similarly, if no digit follows the underscore raise an error. This 272 -- also catches the case of double underscore which is also an error. 273 274 C := Str (P); 275 276 if C in '0' .. '9' 277 or else 278 (Ext and then (C in 'A' .. 'F' or else C in 'a' .. 'f')) 279 then 280 return; 281 else 282 Ptr.all := P; 283 raise Constraint_Error; 284 end if; 285 end Scan_Underscore; 286 287end System.Val_Util; 288