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/compiler/PervEnv/Basis/num-scan.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/PervEnv/Basis/num-scan.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 89 - (view) (download)

1 : monnier 89 (* 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 :     isDigit : word -> bool (* returns true for allowed digits *)
83 :     }
84 :    
85 :     fun scanPrefix (p : prefix_pat) getc cs = let
86 :     fun getNext cs = (case (getc cs)
87 :     of NONE => NONE
88 :     | (SOME(c, cs)) => SOME(code c, cs)
89 :     (* end case *))
90 :     fun skipWS cs = (case (getNext cs)
91 :     of NONE => NONE
92 :     | (SOME(c, cs')) =>
93 :     if (c = wsCode) then skipWS cs' else SOME(c, cs')
94 :     (* end case *))
95 :     fun getOptSign NONE = NONE
96 :     | getOptSign (next as SOME(c, cs)) =
97 :     if (#wOkay p)
98 :     then getOpt0 (false, SOME(c, cs))
99 :     else if (c = plusCode)
100 :     then getOpt0 (false, getNext cs)
101 :     else if (c = minusCode)
102 :     then getOpt0 (true, getNext cs)
103 :     else getOpt0 (false, next)
104 :     and getOpt0 (neg, NONE) = NONE
105 :     | getOpt0 (neg, SOME(c, cs)) =
106 :     if ((c = 0w0) andalso ((#wOkay p) orelse (#xOkay p)))
107 :     then getOptW (neg, (c, cs), getNext cs)
108 :     else finish (neg, (c, cs))
109 :     and getOptW (neg, savedCS, NONE) = finish (neg, savedCS)
110 :     | getOptW (neg, savedCS, arg as SOME(c, cs)) =
111 :     if ((c = wCode) andalso (#wOkay p))
112 :     then getOptX (neg, savedCS, getNext cs)
113 :     else getOptX (neg, savedCS, arg)
114 :     and getOptX (neg, savedCS, NONE) = finish (neg, savedCS)
115 :     | getOptX (neg, savedCS, arg as SOME(c, cs)) =
116 :     if ((c = xCode) andalso (#xOkay p))
117 :     then chkDigit (neg, savedCS, getNext cs)
118 :     else chkDigit (neg, savedCS, arg)
119 :     and chkDigit (neg, savedCS, NONE) = finish (neg, savedCS)
120 :     | chkDigit (neg, savedCS, SOME(c, cs)) =
121 :     if ((#isDigit p) c)
122 :     then SOME{neg=neg, next = c, rest = cs}
123 :     else finish (neg, savedCS)
124 :     and finish (neg, (c, cs)) =
125 :     if ((#isDigit p) c)
126 :     then SOME{neg=neg, next = c, rest = cs}
127 :     else NONE
128 :     in
129 :     getOptSign (skipWS cs)
130 :     end
131 :    
132 :     (* for power of 2 bases (2, 8 & 16), we can check for overflow by looking
133 :     * at the hi (1, 3 or 4) bits.
134 :     *)
135 :     fun chkOverflow mask w =
136 :     if (W.andb(mask, w) = 0w0) then () else raise Overflow
137 :    
138 :     fun isBinDigit d = (d < 0w2)
139 :     fun isOctDigit d = (d < 0w8)
140 :     fun isDecDigit d = (d < 0w10)
141 :     fun isHexDigit d = (d < 0w16)
142 :    
143 :     fun binPat wOkay = {wOkay=wOkay, xOkay=false, isDigit=isBinDigit}
144 :     fun octPat wOkay = {wOkay=wOkay, xOkay=false, isDigit=isOctDigit}
145 :     fun decPat wOkay = {wOkay=wOkay, xOkay=false, isDigit=isDecDigit}
146 :     fun hexPat wOkay = {wOkay=wOkay, xOkay=true, isDigit=isHexDigit}
147 :    
148 :     fun scanBin isWord getc cs = (case (scanPrefix (binPat isWord) getc cs)
149 :     of NONE => NONE
150 :     | (SOME{neg, next, rest}) => let
151 :     val chkOverflow = chkOverflow 0wx80000000
152 :     fun cvt (w, rest) = (case (getc rest)
153 :     of NONE => SOME{neg=neg, word=w, rest=rest}
154 :     | SOME(c, rest') => let val d = code c
155 :     in
156 :     if (isBinDigit d)
157 :     then (
158 :     chkOverflow w;
159 :     cvt(W.+(W.lshift(w, 0w1), d), rest'))
160 :     else SOME{neg=neg, word=w, rest=rest}
161 :     end
162 :     (* end case *))
163 :     in
164 :     cvt (next, rest)
165 :     end
166 :     (* end case *))
167 :    
168 :     fun scanOct isWord getc cs = (case (scanPrefix (octPat isWord) getc cs)
169 :     of NONE => NONE
170 :     | (SOME{neg, next, rest}) => let
171 :     val chkOverflow = chkOverflow 0wxE0000000
172 :     fun cvt (w, rest) = (case (getc rest)
173 :     of NONE => SOME{neg=neg, word=w, rest=rest}
174 :     | SOME(c, rest') => let val d = code c
175 :     in
176 :     if (isOctDigit d)
177 :     then (
178 :     chkOverflow w;
179 :     cvt(W.+(W.lshift(w, 0w3), d), rest'))
180 :     else SOME{neg=neg, word=w, rest=rest}
181 :     end
182 :     (* end case *))
183 :     in
184 :     cvt (next, rest)
185 :     end
186 :     (* end case *))
187 :    
188 :     fun scanDec isWord getc cs = (case (scanPrefix (decPat isWord) getc cs)
189 :     of NONE => NONE
190 :     | (SOME{neg, next, rest}) => let
191 :     fun cvt (w, rest) = (case (getc rest)
192 :     of NONE => SOME{neg=neg, word=w, rest=rest}
193 :     | SOME(c, rest') => let val d = code c
194 :     in
195 :     if (isDecDigit d)
196 :     then (
197 :     if ((w >= largestWordDiv10)
198 :     andalso ((largestWordDiv10 < w)
199 :     orelse (largestWordMod10 < d)))
200 :     then raise Overflow
201 :     else ();
202 :     cvt (0w10*w+d, rest'))
203 :     else SOME{neg=neg, word=w, rest=rest}
204 :     end
205 :     (* end case *))
206 :     in
207 :     cvt (next, rest)
208 :     end
209 :     (* end case *))
210 :    
211 :     fun scanHex isWord getc cs = (case (scanPrefix (hexPat isWord) getc cs)
212 :     of NONE => NONE
213 :     | (SOME{neg, next, rest}) => let
214 :     val chkOverflow = chkOverflow 0wxF0000000
215 :     fun cvt (w, rest) = (case (getc rest)
216 :     of NONE => SOME{neg=neg, word=w, rest=rest}
217 :     | SOME(c, rest') => let val d = code c
218 :     in
219 :     if (isHexDigit d)
220 :     then (
221 :     chkOverflow w;
222 :     cvt(W.+(W.lshift(w, 0w4), d), rest'))
223 :     else SOME{neg=neg, word=w, rest=rest}
224 :     end
225 :     (* end case *))
226 :     in
227 :     cvt (next, rest)
228 :     end
229 :     (* end case *))
230 :    
231 :     fun finalWord scanFn getc cs = (case (scanFn true getc cs)
232 :     of NONE => NONE
233 :     | (SOME{neg, word, rest}) => SOME(word, rest)
234 :     (* end case *))
235 :    
236 :     fun scanWord StringCvt.BIN = finalWord scanBin
237 :     | scanWord StringCvt.OCT = finalWord scanOct
238 :     | scanWord StringCvt.DEC = finalWord scanDec
239 :     | scanWord StringCvt.HEX = finalWord scanHex
240 :    
241 :     local
242 :     val fromword32 = W.toLargeIntX
243 :     in
244 :     fun finalInt scanFn getc cs = (case (scanFn false getc cs)
245 :     of NONE => NONE
246 :     | (SOME{neg=true, word, rest}) =>
247 :     if (word < largestNegInt32) then
248 :     SOME(InlineT.Int32.~(fromword32 word), rest)
249 :     else if (largestNegInt32 < word) then
250 :     raise Overflow
251 :     else
252 :     SOME(minInt32, rest)
253 :     | (SOME{word, rest, ...}) =>
254 :     if (largestPosInt32 < word) then
255 :     raise Overflow
256 :     else
257 :     SOME(fromword32 word, rest)
258 :     (* end case *))
259 :     end
260 :    
261 :     fun scanInt StringCvt.BIN = finalInt scanBin
262 :     | scanInt StringCvt.OCT = finalInt scanOct
263 :     | scanInt StringCvt.DEC = finalInt scanDec
264 :     | scanInt StringCvt.HEX = finalInt scanHex
265 :    
266 :     (* scan a string of decimal digits (starting with d), and return their
267 :     * value as a real number. Also return the number of digits, and the
268 :     * rest of the stream.
269 :     *)
270 :     fun fscan10 getc (d, cs) = let
271 :     fun wordToReal w = InlineT.real(W.toIntX w)
272 :     fun scan (accum, n, cs) = (case (getc cs)
273 :     of (SOME(c, cs')) => let val d = code c
274 :     in
275 :     if (isDecDigit d)
276 :     then scan(R.+(R.*(10.0, accum), wordToReal d), I.+(n, 1), cs')
277 :     else SOME(accum, n, cs)
278 :     end
279 :     | NONE => SOME(accum, n, cs)
280 :     (* end case *))
281 :     in
282 :     if (isDecDigit d) then scan(wordToReal d, 1, cs) else NONE
283 :     end
284 :    
285 :     local
286 :     val negTbl = #[
287 :     1.0E~0, 1.0E~1, 1.0E~2, 1.0E~3, 1.0E~4,
288 :     1.0E~5, 1.0E~6, 1.0E~7, 1.0E~8, 1.0E~9
289 :     ]
290 :     val posTbl = #[
291 :     1.0E0, 1.0E1, 1.0E2, 1.0E3, 1.0E4,
292 :     1.0E5, 1.0E6, 1.0E7, 1.0E8, 1.0E9
293 :     ]
294 :     fun scale (tbl, step10 : real) = let
295 :     fun f (r, 0) = r
296 :     | f (r, exp) = if (I.<(exp, 10))
297 :     then (R.*(r, InlineT.PolyVector.sub(tbl, exp)))
298 :     else f (R.*(step10, r), I.-(exp, 10))
299 :     in
300 :     f
301 :     end
302 :     in
303 :     val scaleUp = scale (posTbl, 1.0E10)
304 :     val scaleDown = scale (negTbl, 1.0E~10)
305 :     end
306 :    
307 :     fun scanReal getc cs = let
308 :     fun scan10 cs = (case (getc cs)
309 :     of (SOME(c, cs)) => fscan10 getc (code c, cs)
310 :     | NONE => NONE
311 :     (* end case *))
312 :     fun getFrac rest = (case (scan10 rest)
313 :     of SOME(frac, n, rest) => (SOME(scaleDown(frac, n)), rest)
314 :     | NONE => (NONE, rest)
315 :     (* end case *))
316 :     fun combine (SOME whole, SOME frac) = R.+(whole, frac)
317 :     | combine (SOME whole, NONE) = whole
318 :     | combine (NONE, SOME frac) = frac
319 :     | combine _ = raise Option.Option
320 :     fun negate (true, num) = R.~ num
321 :     | negate (false, num) = num
322 :     fun scanExp cs = (case (getc cs)
323 :     of SOME(c, cs) => let
324 :     val d = code c
325 :     fun scan (accum, cs) = (case (getc cs)
326 :     of SOME(c, cs') => let val d = code c
327 :     in
328 :     if (isDecDigit d)
329 :     then scan (I.+(I.*(accum, 10), W.toIntX d), cs')
330 :     else (accum, cs)
331 :     end
332 :     | NONE => (accum, cs)
333 :     (* end case *))
334 :     in
335 :     if (isDecDigit d)
336 :     then SOME (scan (W.toIntX d, cs))
337 :     else NONE
338 :     end
339 :     | NONE => NONE
340 :     (* end case *))
341 :     fun getExp cs = (case (getc cs)
342 :     of (SOME(c, cs)) => if (code c = eCode)
343 :     then (case (getc cs)
344 :     of SOME(c, cs') => let
345 :     val codeC = code c
346 :     val (isNeg, cs) = if (codeC = minusCode)
347 :     then (true, cs')
348 :     else if (codeC = plusCode)
349 :     then (false, cs')
350 :     else (false, cs)
351 :     in
352 :     case scanExp cs
353 :     of SOME(exp, cs) => SOME(isNeg, exp, cs)
354 :     | NONE => NONE
355 :     (* end case *)
356 :     end
357 :     | NONE => NONE
358 :     (* end case *))
359 :     else NONE
360 :     | NONE => NONE
361 :     (* end case *))
362 :     in
363 :     case (scanPrefix (decPat false) getc cs)
364 :     of NONE => NONE
365 :     | (SOME{neg, next, rest}) => let
366 :     val (whole, hasPt, rest) = if (next = ptCode)
367 :     then (NONE, true, rest)
368 :     else let
369 :     val (whole, rest) = (case fscan10 getc (next, rest)
370 :     of SOME(whole, _, rest) => (SOME whole, rest)
371 :     | NONE => (NONE, rest)
372 :     (* end case *))
373 :     in
374 :     case (getc rest)
375 :     of SOME(#".", rest) => (whole, true, rest)
376 :     | _ => (whole, false, rest)
377 :     (* end case *)
378 :     end
379 :     val (frac, rest) = if hasPt then getFrac rest else (NONE, rest)
380 :     val num = negate (neg, combine (whole, frac))
381 :     in
382 :     case (getExp rest)
383 :     of (SOME(isNeg, exp, rest)) =>
384 :     if isNeg
385 :     then SOME(scaleDown(num, exp), rest)
386 :     else SOME(scaleUp(num, exp), rest)
387 :     | NONE => SOME(num, rest)
388 :     (* end case *)
389 :     end
390 :     (* end case *)
391 :     end
392 :     handle Option => NONE
393 :    
394 :     end;
395 :    
396 :    
397 :     (*
398 :     * $Log: num-scan.sml,v $
399 :     * Revision 1.1.1.1 1998/04/08 18:40:04 george
400 :     * Version 110.5
401 :     *
402 :     *)
403 :    
404 :    

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