Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/system/Basis/Implementation/num-scan.sml
ViewVC logotype

Annotation of /sml/trunk/src/system/Basis/Implementation/num-scan.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 416 - (view) (download)

1 : monnier 416 (* num-scan.sml
2 :     *
3 :     * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
4 :     *
5 :     * The string conversion for the largest int and word types.
6 :     * All of the other scan functions can be implemented in terms of them.
7 :     *
8 :     *)
9 :    
10 :     structure NumScan : sig
11 :    
12 :     val scanWord : StringCvt.radix
13 :     -> (char, 'a) StringCvt.reader -> (word32, 'a) StringCvt.reader
14 :     val scanInt : StringCvt.radix
15 :     -> (char, 'a) StringCvt.reader -> (int32, 'a) StringCvt.reader
16 :     val scanReal : (char, 'a) StringCvt.reader -> (real, 'a) StringCvt.reader
17 :     (** should be to LargeReal.real **)
18 :    
19 :     end = struct
20 :    
21 :     structure W = InlineT.Word32
22 :     structure I = InlineT.Int31
23 :     structure I32 = InlineT.Int32
24 :     structure R = InlineT.Real64
25 :     type word = word32
26 :    
27 :     val op < = W.<
28 :     val op >= = W.>=
29 :     val op + = W.+
30 :     val op - = W.-
31 :     val op * = W.*
32 :    
33 :     val largestWordDiv10 : word = 0w429496729 (* 2^32-1 divided by 10 *)
34 :     val largestWordMod10 : word = 0w5 (* remainder *)
35 :    
36 :     val largestNegInt32 : word = 0wx80000000
37 :     val largestPosInt32 : word = 0wx7fffffff
38 :     val minInt32 : int32 = ~2147483648
39 :    
40 :     (* A table for mapping digits to values. Whitespace characters map to
41 :     * 128, "+" maps to 129, "-","~" map to 130, "." maps to 131, and the
42 :     * characters 0-9,A-Z,a-z map to their * base-36 value. All other
43 :     * characters map to 255.
44 :     *)
45 :     local
46 :     val cvtTable = "\
47 :     \\255\255\255\255\255\255\255\255\255\128\128\255\255\255\255\255\
48 :     \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
49 :     \\128\255\255\255\255\255\255\255\255\255\255\129\255\130\131\255\
50 :     \\000\001\002\003\004\005\006\007\008\009\255\255\255\255\255\255\
51 :     \\255\010\011\012\013\014\015\016\017\018\019\020\021\022\023\024\
52 :     \\025\026\027\028\029\030\031\255\033\034\035\255\255\255\255\255\
53 :     \\255\010\011\012\013\014\015\016\017\018\019\020\021\022\023\024\
54 :     \\025\026\027\028\029\030\031\032\033\034\035\255\255\255\130\255\
55 :     \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
56 :     \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
57 :     \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
58 :     \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
59 :     \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
60 :     \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
61 :     \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
62 :     \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
63 :     \"
64 :     val ord = InlineT.Char.ord
65 :     in
66 :     fun code (c : char) =
67 :     W.fromInt(ord(InlineT.CharVector.sub(cvtTable, ord c)))
68 :     val wsCode : word = 0w128 (* code for whitespace *)
69 :     val plusCode : word = 0w129 (* code for #"+" *)
70 :     val minusCode : word = 0w130 (* code for #"-" and #"~" *)
71 :     val ptCode : word = 0w131 (* code for #"." *)
72 :     val eCode : word = 0w14 (* code for #"e" and #"E" *)
73 :     val wCode : word = 0w32 (* code for #"w" *)
74 :     val xCode : word = 0w33 (* code for #"X" and #"X" *)
75 :     end (* local *)
76 :    
77 :     type prefix_pat = {
78 :     wOkay : bool, (* true if 0[wW] prefix is okay; if this is
79 :     * true, then signs (+, -, ~) are not okay.
80 :     *)
81 :     xOkay : bool, (* true if 0[xX] prefix is okay *)
82 :     ptOkay: bool, (* true if can start with point *)
83 :     isDigit : word -> bool (* returns true for allowed digits *)
84 :     }
85 :    
86 :     (* scanPrefix : prefix_pat -> (char,'a) reader -> 'a
87 :     -> {neg: bool, next: word (* code *), rest: 'a} option
88 :     scans prefix for a number:
89 :     binPat(true) {wOkay=true, xOkay=false, ptOkay=false, isBinDigit} =>
90 :     (0[wW])?b (b binary digit)
91 :     binPat(false) {wOkay=true, xOkay=false, ptOkay=false, isBinDigit} =>
92 :     [-~+]?b
93 :     octPat(true) {wOkay=true, xOkay=false, ptOkay=false, isOctDigit} =>
94 :     (0[wW])?o (o octal digit)
95 :     octPat(false) {wOkay=false, xOkay=false, ptOkay=false, isOctDigit} =>
96 :     [-~+]?o
97 :     hexPat(true) {wOkay=true, xOkay=true, ptOkay=false, isHexDigit} =>
98 :     (0[wW][xX])?h (h hex digit)
99 :     hexPat(false) {wOkay=false, xOkay=true, ptOkay=false, isHexDigit} =>
100 :     [-~+]?(0[xX])?h
101 :     decPat(true,false) {wOkay=true, xOkay=false, ptOkay=false, isDecDigit} =>
102 :     (0[wW][xX])?d (d decimal digit)
103 :     decPat(false,false){wOkay=false, xOkay=false, ptOkay=false, isDecDigit} =>
104 :     [-~+]?d
105 :     decPat(false,true) {wOkay=false, xOkay=false, ptOkay=true, isDecDigit} =>
106 :     [-~+]?[.d]
107 :    
108 :     Sign characters, initial 0x, 0w, etc are consumed. The initial
109 :     digit or point code is returned as the value of next.
110 :     *)
111 :     fun scanPrefix (p : prefix_pat) getc cs = let
112 :     fun getNext cs = (case (getc cs)
113 :     of NONE => NONE
114 :     | (SOME(c, cs)) => SOME(code c, cs)
115 :     (* end case *))
116 :     fun skipWS cs = (case (getNext cs)
117 :     of NONE => NONE
118 :     | (SOME(c, cs')) =>
119 :     if (c = wsCode) then skipWS cs' else SOME(c, cs')
120 :     (* end case *))
121 :     fun getOptSign NONE = NONE
122 :     | getOptSign (next as SOME(c, cs)) =
123 :     if (#wOkay p)
124 :     then getOpt0 (false, SOME(c, cs))
125 :     else if (c = plusCode)
126 :     then getOpt0 (false, getNext cs)
127 :     else if (c = minusCode)
128 :     then getOpt0 (true, getNext cs)
129 :     else getOpt0 (false, next)
130 :     and getOpt0 (neg, NONE) = NONE
131 :     | getOpt0 (neg, SOME(c, cs)) =
132 :     if ((c = 0w0) andalso ((#wOkay p) orelse (#xOkay p)))
133 :     then getOptW (neg, (c, cs), getNext cs)
134 :     else finish (neg, (c, cs))
135 :     and getOptW (neg, savedCS, NONE) = finish (neg, savedCS)
136 :     | getOptW (neg, savedCS, arg as SOME(c, cs)) =
137 :     if ((c = wCode) andalso (#wOkay p))
138 :     then getOptX (neg, savedCS, getNext cs)
139 :     else getOptX (neg, savedCS, arg)
140 :     and getOptX (neg, savedCS, NONE) = finish (neg, savedCS)
141 :     | getOptX (neg, savedCS, arg as SOME(c, cs)) =
142 :     if ((c = xCode) andalso (#xOkay p))
143 :     then chkDigit (neg, savedCS, getNext cs)
144 :     else chkDigit (neg, savedCS, arg)
145 :     and chkDigit (neg, savedCS, NONE) = finish (neg, savedCS)
146 :     | chkDigit (neg, savedCS, SOME(c, cs)) =
147 :     if ((#isDigit p) c)
148 :     then SOME{neg=neg, next = c, rest = cs}
149 :     else finish (neg, savedCS)
150 :     and finish (neg, (c, cs)) =
151 :     if ((#isDigit p) c) orelse ((c = ptCode) andalso (#ptOkay p))
152 :     then SOME{neg=neg, next = c, rest = cs}
153 :     else NONE
154 :     in
155 :     getOptSign (skipWS cs)
156 :     end
157 :    
158 :     (* for power of 2 bases (2, 8 & 16), we can check for overflow by looking
159 :     * at the hi (1, 3 or 4) bits.
160 :     *)
161 :     fun chkOverflow mask w =
162 :     if (W.andb(mask, w) = 0w0) then () else raise Overflow
163 :    
164 :     fun isBinDigit d = (d < 0w2)
165 :     fun isOctDigit d = (d < 0w8)
166 :     fun isDecDigit d = (d < 0w10)
167 :     fun isHexDigit d = (d < 0w16)
168 :    
169 :     fun binPat wOkay = {wOkay=wOkay, xOkay=false, ptOkay=false, isDigit=isBinDigit}
170 :     fun octPat wOkay = {wOkay=wOkay, xOkay=false, ptOkay=false, isDigit=isOctDigit}
171 :     fun hexPat wOkay = {wOkay=wOkay, xOkay=true, ptOkay=false, isDigit=isHexDigit}
172 :     fun decPat (wOkay,ptOkay) = {wOkay=wOkay, xOkay=false, ptOkay=ptOkay,
173 :     isDigit=isDecDigit}
174 :    
175 :     fun scanBin isWord getc cs = (case (scanPrefix (binPat isWord) getc cs)
176 :     of NONE => NONE
177 :     | (SOME{neg, next, rest}) => let
178 :     val chkOverflow = chkOverflow 0wx80000000
179 :     fun cvt (w, rest) = (case (getc rest)
180 :     of NONE => SOME{neg=neg, word=w, rest=rest}
181 :     | SOME(c, rest') => let val d = code c
182 :     in
183 :     if (isBinDigit d)
184 :     then (
185 :     chkOverflow w;
186 :     cvt(W.+(W.lshift(w, 0w1), d), rest'))
187 :     else SOME{neg=neg, word=w, rest=rest}
188 :     end
189 :     (* end case *))
190 :     in
191 :     cvt (next, rest)
192 :     end
193 :     (* end case *))
194 :    
195 :     fun scanOct isWord getc cs = (case (scanPrefix (octPat isWord) getc cs)
196 :     of NONE => NONE
197 :     | (SOME{neg, next, rest}) => let
198 :     val chkOverflow = chkOverflow 0wxE0000000
199 :     fun cvt (w, rest) = (case (getc rest)
200 :     of NONE => SOME{neg=neg, word=w, rest=rest}
201 :     | SOME(c, rest') => let val d = code c
202 :     in
203 :     if (isOctDigit d)
204 :     then (
205 :     chkOverflow w;
206 :     cvt(W.+(W.lshift(w, 0w3), d), rest'))
207 :     else SOME{neg=neg, word=w, rest=rest}
208 :     end
209 :     (* end case *))
210 :     in
211 :     cvt (next, rest)
212 :     end
213 :     (* end case *))
214 :    
215 :     fun scanDec isWord getc cs = (case (scanPrefix (decPat(isWord,false)) getc cs)
216 :     of NONE => NONE
217 :     | (SOME{neg, next, rest}) => let
218 :     fun cvt (w, rest) = (case (getc rest)
219 :     of NONE => SOME{neg=neg, word=w, rest=rest}
220 :     | SOME(c, rest') => let val d = code c
221 :     in
222 :     if (isDecDigit d)
223 :     then (
224 :     if ((w >= largestWordDiv10)
225 :     andalso ((largestWordDiv10 < w)
226 :     orelse (largestWordMod10 < d)))
227 :     then raise Overflow
228 :     else ();
229 :     cvt (0w10*w+d, rest'))
230 :     else SOME{neg=neg, word=w, rest=rest}
231 :     end
232 :     (* end case *))
233 :     in
234 :     cvt (next, rest)
235 :     end
236 :     (* end case *))
237 :    
238 :     fun scanHex isWord getc cs = (case (scanPrefix (hexPat isWord) getc cs)
239 :     of NONE => NONE
240 :     | (SOME{neg, next, rest}) => let
241 :     val chkOverflow = chkOverflow 0wxF0000000
242 :     fun cvt (w, rest) = (case (getc rest)
243 :     of NONE => SOME{neg=neg, word=w, rest=rest}
244 :     | SOME(c, rest') => let val d = code c
245 :     in
246 :     if (isHexDigit d)
247 :     then (
248 :     chkOverflow w;
249 :     cvt(W.+(W.lshift(w, 0w4), d), rest'))
250 :     else SOME{neg=neg, word=w, rest=rest}
251 :     end
252 :     (* end case *))
253 :     in
254 :     cvt (next, rest)
255 :     end
256 :     (* end case *))
257 :    
258 :     fun finalWord scanFn getc cs = (case (scanFn true getc cs)
259 :     of NONE => NONE
260 :     | (SOME{neg, word, rest}) => SOME(word, rest)
261 :     (* end case *))
262 :    
263 :     fun scanWord StringCvt.BIN = finalWord scanBin
264 :     | scanWord StringCvt.OCT = finalWord scanOct
265 :     | scanWord StringCvt.DEC = finalWord scanDec
266 :     | scanWord StringCvt.HEX = finalWord scanHex
267 :    
268 :     local
269 :     val fromword32 = W.toLargeIntX
270 :     in
271 :     fun finalInt scanFn getc cs = (case (scanFn false getc cs)
272 :     of NONE => NONE
273 :     | (SOME{neg=true, word, rest}) =>
274 :     if (word < largestNegInt32) then
275 :     SOME(InlineT.Int32.~(fromword32 word), rest)
276 :     else if (largestNegInt32 < word) then
277 :     raise Overflow
278 :     else
279 :     SOME(minInt32, rest)
280 :     | (SOME{word, rest, ...}) =>
281 :     if (largestPosInt32 < word) then
282 :     raise Overflow
283 :     else
284 :     SOME(fromword32 word, rest)
285 :     (* end case *))
286 :     end
287 :    
288 :     fun scanInt StringCvt.BIN = finalInt scanBin
289 :     | scanInt StringCvt.OCT = finalInt scanOct
290 :     | scanInt StringCvt.DEC = finalInt scanDec
291 :     | scanInt StringCvt.HEX = finalInt scanHex
292 :    
293 :     (* scan a string of decimal digits (starting with d), and return their
294 :     * value as a real number. Also return the number of digits, and the
295 :     * rest of the stream.
296 :     *)
297 :     fun fscan10 getc (d, cs) = let
298 :     fun wordToReal w = InlineT.real(W.toIntX w)
299 :     fun scan (accum, n, cs) = (case (getc cs)
300 :     of (SOME(c, cs')) => let val d = code c
301 :     in
302 :     if (isDecDigit d)
303 :     then scan(R.+(R.*(10.0, accum), wordToReal d), I.+(n, 1), cs')
304 :     else SOME(accum, n, cs)
305 :     end
306 :     | NONE => SOME(accum, n, cs)
307 :     (* end case *))
308 :     in
309 :     if (isDecDigit d) then scan(wordToReal d, 1, cs) else NONE
310 :     end
311 :    
312 :     local
313 :     val negTbl = #[
314 :     1.0E~0, 1.0E~1, 1.0E~2, 1.0E~3, 1.0E~4,
315 :     1.0E~5, 1.0E~6, 1.0E~7, 1.0E~8, 1.0E~9
316 :     ]
317 :     val posTbl = #[
318 :     1.0E0, 1.0E1, 1.0E2, 1.0E3, 1.0E4,
319 :     1.0E5, 1.0E6, 1.0E7, 1.0E8, 1.0E9
320 :     ]
321 :     fun scale (tbl, step10 : real) = let
322 :     fun f (r, 0) = r
323 :     | f (r, exp) = if (I.<(exp, 10))
324 :     then (R.*(r, InlineT.PolyVector.sub(tbl, exp)))
325 :     else f (R.*(step10, r), I.-(exp, 10))
326 :     in
327 :     f
328 :     end
329 :     in
330 :     val scaleUp = scale (posTbl, 1.0E10)
331 :     val scaleDown = scale (negTbl, 1.0E~10)
332 :     end
333 :    
334 :     fun scanReal getc cs = let
335 :     fun scan10 cs = (case (getc cs)
336 :     of (SOME(c, cs)) => fscan10 getc (code c, cs)
337 :     | NONE => NONE
338 :     (* end case *))
339 :     fun getFrac rest = (case (scan10 rest)
340 :     of SOME(frac, n, rest) => SOME(scaleDown(frac, n), rest)
341 :     | NONE => NONE
342 :     (* end case *))
343 :     fun negate (true, num) = R.~ num
344 :     | negate (false, num) = num
345 :     fun scanExp cs = (case (getc cs)
346 :     of SOME(c, cs) => let
347 :     val d = code c
348 :     fun scan (accum, cs) = (case (getc cs)
349 :     of SOME(c, cs') => let val d = code c
350 :     in
351 :     if (isDecDigit d)
352 :     then scan (I.+(I.*(accum, 10), W.toIntX d), cs')
353 :     else (accum, cs)
354 :     end
355 :     | NONE => (accum, cs)
356 :     (* end case *))
357 :     in
358 :     if (isDecDigit d)
359 :     then SOME (scan (W.toIntX d, cs))
360 :     else NONE
361 :     end
362 :     | NONE => NONE
363 :     (* end case *))
364 :     fun getExp(num,cs) =
365 :     case (getc cs)
366 :     of (SOME(c, cs1)) =>
367 :     if (code c = eCode)
368 :     then (case (getc cs1)
369 :     of SOME(c, cs2) =>
370 :     let val codeC = code c
371 :     val (isNeg, cs3) =
372 :     if (codeC = minusCode) then (true, cs2)
373 :     else if (codeC = plusCode)
374 :     then (false, cs2)
375 :     else (false, cs1) (* no sign *)
376 :     in case scanExp cs3
377 :     of SOME(exp, cs4) =>
378 :     SOME(if isNeg
379 :     then scaleDown(num, exp)
380 :     else scaleUp(num, exp),
381 :     cs4)
382 :     | NONE => SOME(num, cs)
383 :     (* end case *)
384 :     end
385 :     | NONE => SOME(num, cs)
386 :     (* end case *))
387 :     else SOME(num, cs)
388 :     | NONE => SOME(num, cs)
389 :     (* end case *)
390 :     in
391 :     case (scanPrefix (decPat(false,true)) getc cs)
392 :     of NONE => NONE
393 :     | (SOME{neg, next, rest}) =>
394 :     if (next = ptCode) (* initial point after prefix *)
395 :     then (case getFrac rest
396 :     of SOME(frac, rest) =>
397 :     getExp(negate(neg,frac),rest)
398 :     | NONE => NONE (* initial point not followed by digit *)
399 :     (* end case *))
400 :     else (* ASSERT: next must be a digit *)
401 :     (* get whole number part *)
402 :     (case fscan10 getc (next, rest)
403 :     of SOME(whole, _, rest) =>
404 :     (case (getc rest)
405 :     of SOME(#".", rest') =>
406 :     (* whole part followed by point, get fraction *)
407 :     (case getFrac rest'
408 :     of SOME(frac,rest'') => (* fraction exists *)
409 :     getExp(negate(neg,R.+(whole,frac)),rest'')
410 :     | NONE =>
411 :     (* no fraction -- point terminates num *)
412 :     SOME(negate(neg,whole), rest)
413 :     (* end case *))
414 :     | _ => getExp(negate(neg,whole),rest)
415 :     (* end case *))
416 :     | NONE => NONE (* ASSERT: this case can't happen *)
417 :     (* end case *))
418 :     end
419 :    
420 :     end;
421 :    
422 :    

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0