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/smlnj-lib/Util/int-inf.sml
ViewVC logotype

Annotation of /sml/trunk/src/smlnj-lib/Util/int-inf.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 651 - (view) (download)

1 : monnier 26 (* int-inf.sml
2 :     *
3 :     * COPYRIGHT (c) 1995 by AT&T Bell Laboratories. See COPYRIGHT file for details.
4 :     *
5 : monnier 411 * This package is derived from Andrzej Filinski's bignum package. It is very
6 : monnier 26 * close to the definition of the optional IntInf structure in the SML'97 basis.
7 :     *
8 :     * It is implemented almost totally on the abstraction presented by
9 :     * the BigNat structure. The only concrete type information it assumes
10 :     * is that BigNat.bignat = 'a list and that BigNat.zero = [].
11 :     * Some trivial additional efficiency could be obtained by assuming that
12 :     * type bignat is really int list, and that if (v : bignat) = [d], then
13 :     * bignat d = [d].
14 :     *
15 :     * At some point, this should be reimplemented to make use of Word32, or
16 :     * have compiler/runtime support.
17 :     *
18 :     * Also, for booting, this module could be broken into one that has
19 :     * all the types and arithmetic functions, but doesn't use NumScan,
20 :     * constructing values from strings using bignum arithmetic. Various
21 :     * integer and word scanning, such as NumScan, could then be constructed
22 :     * from IntInf. Finally, a user-level IntInf could be built by
23 :     * importing the basic IntInf, but replacing the scanning functions
24 :     * by more efficient ones based on the functions in NumScan.
25 :     *
26 :     *)
27 :    
28 :     structure IntInf :> INT_INF =
29 :     struct
30 :    
31 :     (* It is not clear what advantage there is to having NumFormat as
32 :     * a submodule.
33 :     *)
34 :    
35 :     structure NumScan : sig
36 :    
37 :     val skipWS : (char, 'a) StringCvt.reader -> 'a -> 'a
38 :    
39 : monnier 411 val scanWord : StringCvt.radix
40 :     -> (char, 'a) StringCvt.reader
41 :     -> 'a -> (Word32.word * 'a) option
42 : monnier 26 val scanInt : StringCvt.radix
43 :     -> (char, 'a) StringCvt.reader
44 :     -> 'a -> (int * 'a) option
45 :     (** should be to int32 **)
46 :    
47 :     end = struct
48 :    
49 :     structure W = Word32
50 :     structure I = Int31
51 :    
52 :     val op < = W.<
53 :     val op >= = W.>=
54 :     val op + = W.+
55 :     val op - = W.-
56 :     val op * = W.*
57 :    
58 :     val largestWordDiv10 : Word32.word = 0w429496729(* 2^32-1 divided by 10 *)
59 :     val largestWordMod10 : Word32.word = 0w5 (* remainder *)
60 :     val largestNegInt : Word32.word = 0w1073741824 (* absolute value of ~2^30 *)
61 :     val largestPosInt : Word32.word = 0w1073741823 (* 2^30-1 *)
62 :    
63 :     type 'a chr_strm = {getc : (char, 'a) StringCvt.reader}
64 :    
65 :     (* A table for mapping digits to values. Whitespace characters map to
66 : monnier 411 * 128, "+" maps to 129, "-","~" map to 130, "." maps to 131, and the
67 :     * characters 0-9,A-Z,a-z map to their * base-36 value. All other
68 :     * characters map to 255.
69 : monnier 26 *)
70 :     local
71 :     val cvtTable = "\
72 :     \\255\255\255\255\255\255\255\255\255\128\128\255\255\255\255\255\
73 :     \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
74 : monnier 411 \\128\255\255\255\255\255\255\255\255\255\255\129\255\130\131\255\
75 : monnier 26 \\000\001\002\003\004\005\006\007\008\009\255\255\255\255\255\255\
76 :     \\255\010\011\012\013\014\015\016\017\018\019\020\021\022\023\024\
77 :     \\025\026\027\028\029\030\031\032\033\034\035\255\255\255\255\255\
78 :     \\255\010\011\012\013\014\015\016\017\018\019\020\021\022\023\024\
79 : monnier 411 \\025\026\027\028\029\030\031\032\033\034\035\255\255\255\130\255\
80 : monnier 26 \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
81 :     \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
82 :     \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
83 :     \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
84 :     \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
85 :     \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
86 :     \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
87 :     \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
88 :     \"
89 :     val ord = Char.ord
90 :     in
91 :     fun code (c : char) = W.fromInt(ord(CharVector.sub(cvtTable, ord c)))
92 :     val wsCode : Word32.word = 0w128
93 : monnier 411 val plusCode : Word32.word = 0w129
94 :     val minusCode : Word32.word = 0w130
95 : monnier 26 end (* local *)
96 :    
97 :     fun skipWS (getc : (char, 'a) StringCvt.reader) cs = let
98 :     fun skip cs = (case (getc cs)
99 :     of NONE => cs
100 :     | (SOME(c, cs')) => if (code c = wsCode) then skip cs' else cs
101 :     (* end case *))
102 :     in
103 :     skip cs
104 :     end
105 :    
106 : monnier 411 (* skip leading whitespace and any sign (+, -, or ~) *)
107 :     fun scanPrefix (getc : (char, 'a) StringCvt.reader) cs = let
108 :     fun skipWS cs = (case (getc cs)
109 :     of NONE => NONE
110 :     | (SOME(c, cs')) => let val c' = code c
111 :     in
112 :     if (c' = wsCode) then skipWS cs' else SOME(c', cs')
113 :     end
114 :     (* end case *))
115 :     fun getNext (neg, cs) = (case (getc cs)
116 :     of NONE => NONE
117 :     | (SOME(c, cs)) => SOME{neg=neg, next=code c, rest=cs}
118 :     (* end case *))
119 :     in
120 :     case (skipWS cs)
121 :     of NONE => NONE
122 :     | (SOME(c, cs')) =>
123 :     if (c = plusCode) then getNext(false, cs')
124 :     else if (c = minusCode) then getNext(true, cs')
125 :     else SOME{neg=false, next=c, rest=cs'}
126 :     (* end case *)
127 :     end
128 :    
129 : monnier 26 (* for power of 2 bases (2, 8 & 16), we can check for overflow by looking
130 :     * at the hi (1, 3 or 4) bits.
131 :     *)
132 :     fun chkOverflow mask w =
133 :     if (W.andb(mask, w) = 0w0) then () else raise Overflow
134 :    
135 : monnier 411 fun scanBin (getc : (char, 'a) StringCvt.reader) cs = (case (scanPrefix getc cs)
136 : monnier 26 of NONE => NONE
137 : monnier 411 | (SOME{neg, next, rest}) => let
138 : monnier 26 fun isDigit (d : Word32.word) = (d < 0w2)
139 :     val chkOverflow = chkOverflow 0wx80000000
140 :     fun cvt (w, rest) = (case (getc rest)
141 : monnier 411 of NONE => SOME{neg=neg, word=w, rest=rest}
142 : monnier 26 | SOME(c, rest') => let val d = code c
143 :     in
144 :     if (isDigit d)
145 :     then (
146 :     chkOverflow w;
147 :     cvt(W.+(W.<<(w, 0w1), d), rest'))
148 : monnier 411 else SOME{neg=neg, word=w, rest=rest}
149 : monnier 26 end
150 :     (* end case *))
151 :     in
152 :     if (isDigit next)
153 :     then cvt(next, rest)
154 :     else NONE
155 :     end
156 :     (* end case *))
157 :    
158 : monnier 411 fun scanOct getc cs = (case (scanPrefix getc cs)
159 : monnier 26 of NONE => NONE
160 : monnier 411 | (SOME{neg, next, rest}) => let
161 : monnier 26 fun isDigit (d : Word32.word) = (d < 0w8)
162 :     val chkOverflow = chkOverflow 0wxE0000000
163 :     fun cvt (w, rest) = (case (getc rest)
164 : monnier 411 of NONE => SOME{neg=neg, word=w, rest=rest}
165 : monnier 26 | SOME(c, rest') => let val d = code c
166 :     in
167 :     if (isDigit d)
168 :     then (
169 :     chkOverflow w;
170 :     cvt(W.+(W.<<(w, 0w3), d), rest'))
171 : monnier 411 else SOME{neg=neg, word=w, rest=rest}
172 : monnier 26 end
173 :     (* end case *))
174 :     in
175 :     if (isDigit next)
176 :     then cvt(next, rest)
177 :     else NONE
178 :     end
179 :     (* end case *))
180 :    
181 : monnier 411 fun scanDec getc cs = (case (scanPrefix getc cs)
182 : monnier 26 of NONE => NONE
183 : monnier 411 | (SOME{neg, next, rest}) => let
184 : monnier 26 fun isDigit (d : Word32.word) = (d < 0w10)
185 :     fun cvt (w, rest) = (case (getc rest)
186 : monnier 411 of NONE => SOME{neg=neg, word=w, rest=rest}
187 : monnier 26 | SOME(c, rest') => let val d = code c
188 :     in
189 :     if (isDigit d)
190 :     then (
191 :     if ((w >= largestWordDiv10)
192 :     andalso ((largestWordDiv10 < w)
193 :     orelse (largestWordMod10 < d)))
194 :     then raise Overflow
195 :     else ();
196 :     cvt (0w10*w+d, rest'))
197 : monnier 411 else SOME{neg=neg, word=w, rest=rest}
198 : monnier 26 end
199 :     (* end case *))
200 :     in
201 :     if (isDigit next)
202 :     then cvt(next, rest)
203 :     else NONE
204 :     end
205 :     (* end case *))
206 :    
207 : monnier 411 fun scanHex getc cs = (case (scanPrefix getc cs)
208 : monnier 26 of NONE => NONE
209 : monnier 411 | (SOME{neg, next, rest}) => let
210 : monnier 26 fun isDigit (d : Word32.word) = (d < 0w16)
211 :     val chkOverflow = chkOverflow 0wxF0000000
212 :     fun cvt (w, rest) = (case (getc rest)
213 : monnier 411 of NONE => SOME{neg=neg, word=w, rest=rest}
214 : monnier 26 | SOME(c, rest') => let val d = code c
215 :     in
216 :     if (isDigit d)
217 :     then (
218 :     chkOverflow w;
219 :     cvt(W.+(W.<<(w, 0w4), d), rest'))
220 : monnier 411 else SOME{neg=neg, word=w, rest=rest}
221 : monnier 26 end
222 :     (* end case *))
223 :     in
224 :     if (isDigit next)
225 :     then cvt(next, rest)
226 :     else NONE
227 :     end
228 :     (* end case *))
229 :    
230 : monnier 411 fun finalWord scanFn getc cs = (case (scanFn getc cs)
231 :     of NONE => NONE
232 :     | (SOME{neg=true, ...}) => NONE
233 :     | (SOME{neg=false, 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 : monnier 26 fun finalInt scanFn getc cs = (case (scanFn getc cs)
242 :     of NONE => NONE
243 : monnier 411 | (SOME{neg=true, word, rest}) =>
244 :     if (largestNegInt < word)
245 :     then raise Overflow
246 :     else SOME(I.~(W.toInt word), rest)
247 :     | (SOME{word, rest, ...}) =>
248 : monnier 26 if (largestPosInt < word)
249 :     then raise Overflow
250 :     else SOME(W.toInt word, rest)
251 :     (* end case *))
252 :    
253 :     fun scanInt StringCvt.BIN = finalInt scanBin
254 :     | scanInt StringCvt.OCT = finalInt scanOct
255 :     | scanInt StringCvt.DEC = finalInt scanDec
256 :     | scanInt StringCvt.HEX = finalInt scanHex
257 :    
258 :     end (* structure NumScan *)
259 :    
260 :     structure NumFormat : sig
261 :    
262 :     val fmtWord : StringCvt.radix -> Word32.word -> string
263 :     val fmtInt : StringCvt.radix -> int -> string (** should be int32 **)
264 :    
265 :     end = struct
266 :    
267 :     structure W = Word32
268 :     structure I = Int
269 :    
270 :     val op < = W.<
271 :     val op - = W.-
272 :     val op * = W.*
273 :     val op div = W.div
274 :    
275 :     fun mkDigit (w : Word32.word) =
276 :     CharVector.sub("0123456789abcdef", W.toInt w)
277 :    
278 :     fun wordToBin w = let
279 :     fun mkBit w = if (W.andb(w, 0w1) = 0w0) then #"0" else #"1"
280 :     fun f (0w0, n, l) = (I.+(n, 1), #"0" :: l)
281 :     | f (0w1, n, l) = (I.+(n, 1), #"1" :: l)
282 :     | f (w, n, l) = f(W.>>(w, 0w1), I.+(n, 1), (mkBit w) :: l)
283 :     in
284 :     f (w, 0, [])
285 :     end
286 :     fun wordToOct w = let
287 :     fun f (w, n, l) = if (w < 0w8)
288 :     then (I.+(n, 1), (mkDigit w) :: l)
289 :     else f(W.>>(w, 0w3), I.+(n, 1), mkDigit(W.andb(w, 0w7)) :: l)
290 :     in
291 :     f (w, 0, [])
292 :     end
293 :     fun wordToDec w = let
294 :     fun f (w, n, l) = if (w < 0w10)
295 :     then (I.+(n, 1), (mkDigit w) :: l)
296 :     else let val j = w div 0w10
297 :     in
298 :     f (j, I.+(n, 1), mkDigit(w - 0w10*j) :: l)
299 :     end
300 :     in
301 :     f (w, 0, [])
302 :     end
303 :     fun wordToHex w = let
304 :     fun f (w, n, l) = if (w < 0w16)
305 :     then (I.+(n, 1), (mkDigit w) :: l)
306 :     else f(W.>>(w, 0w4), I.+(n, 1), mkDigit(W.andb(w, 0w15)) :: l)
307 :     in
308 :     f (w, 0, [])
309 :     end
310 :    
311 :     fun fmtW StringCvt.BIN = #2 o wordToBin
312 :     | fmtW StringCvt.OCT = #2 o wordToOct
313 :     | fmtW StringCvt.DEC = #2 o wordToDec
314 :     | fmtW StringCvt.HEX = #2 o wordToHex
315 :    
316 :     fun fmtWord radix = String.implode o (fmtW radix)
317 :    
318 :     (** NOTE: this currently uses 31-bit integers, but really should use 32-bit
319 :     ** ints (once they are supported).
320 :     **)
321 :     fun fmtInt radix = let
322 :     val fmtW = fmtW radix
323 :     val itow = W.fromInt
324 :     fun fmt i = if I.<(i, 0)
325 :     then let
326 :     val (digits) = fmtW(itow(I.~ i))
327 :     in
328 :     String.implode(#"~"::digits)
329 :     end
330 :     handle _ => (case radix
331 :     of StringCvt.BIN => "~1111111111111111111111111111111"
332 :     | StringCvt.OCT => "~7777777777"
333 :     | StringCvt.DEC => "~1073741824"
334 :     | StringCvt.HEX => "~3fffffff"
335 :     (* end case *))
336 :     else String.implode(fmtW(itow i))
337 :     in
338 :     fmt
339 :     end
340 :    
341 :     end (* structure NumFormat *)
342 :    
343 :     structure BigNat =
344 :     struct
345 :    
346 :     exception Negative
347 :    
348 :     val itow = Word.fromInt
349 :     val wtoi = Word.toIntX
350 :    
351 :     val lgBase = 30 (* No. of bits per digit; must be even *)
352 :     val nbase = ~0x40000000 (* = ~2^lgBase *)
353 :    
354 :     val maxDigit = ~(nbase + 1)
355 :     val realBase = (real maxDigit) + 1.0
356 :    
357 :     val lgHBase = Int.quot (lgBase, 2) (* half digits *)
358 :     val hbase = Word.<<(0w1, itow lgHBase)
359 :     val hmask = hbase-0w1
360 :    
361 :     fun quotrem (i, j) = (Int.quot (i, j), Int.rem (i, j))
362 :     fun scale i = if i = maxDigit then 1 else nbase div (~(i+1))
363 :    
364 :     type bignat = int list (* least significant digit first *)
365 :    
366 :     val zero = []
367 :     val one = [1]
368 :    
369 :     fun bignat 0 = zero
370 :     | bignat i = let
371 :     val notNbase = Word.notb(itow nbase)
372 :     fun bn 0w0 = []
373 :     | bn i = let
374 :     fun dmbase n =
375 :     (Word.>> (n, itow lgBase), Word.andb (n, notNbase))
376 :     val (q,r) = dmbase i
377 :     in
378 :     (wtoi r)::(bn q)
379 :     end
380 :     in
381 :     if i > 0
382 :     then if i <= maxDigit then [i] else bn (itow i)
383 :     else raise Negative
384 :     end
385 :    
386 :     fun int [] = 0
387 :     | int [d] = d
388 :     | int [d,e] = ~(nbase*e) + d
389 :     | int (d::r) = ~(nbase*int r) + d
390 :    
391 :     fun consd (0, []) = []
392 :     | consd (d, r) = d::r
393 :    
394 :     fun hl i = let
395 :     val w = itow i
396 :     in
397 :     (wtoi(Word.~>> (w, itow lgHBase)), (* MUST sign-extend *)
398 :     wtoi(Word.andb(w, hmask)))
399 :     end
400 :    
401 :     fun sh i = wtoi(Word.<< (itow i, itow lgHBase))
402 :    
403 :     fun addOne [] = [1]
404 :     | addOne (m::rm) = let
405 :     val c = nbase+m+1
406 :     in
407 :     if c < 0 then (c-nbase)::rm else c::(addOne rm)
408 :     end
409 :    
410 :     fun add ([], digits) = digits
411 :     | add (digits, []) = digits
412 :     | add (dm::rm, dn::rn) = addd (nbase+dm+dn, rm, rn)
413 :     and addd (s, m, n) =
414 :     if s < 0 then (s-nbase) :: add (m, n) else (s :: addc (m, n))
415 :     and addc (m, []) = addOne m
416 :     | addc ([], n) = addOne n
417 :     | addc (dm::rm, dn::rn) = addd (nbase+dm+dn+1, rm, rn)
418 :    
419 :     fun subtOne (0::mr) = maxDigit::(subtOne mr)
420 :     | subtOne [1] = []
421 :     | subtOne (n::mr) = (n-1)::mr
422 :     | subtOne [] = raise Fail ""
423 :    
424 :     fun subt (m, []) = m
425 :     | subt ([], n) = raise Negative
426 :     | subt (dm::rm, dn::rn) = subd(dm-dn,rm,rn)
427 :     and subb ([], n) = raise Negative
428 :     | subb (dm::rm, []) = subd (dm-1, rm, [])
429 :     | subb (dm::rm, dn::rn) = subd (dm-dn-1, rm, rn)
430 :     and subd (d, m, n) =
431 :     if d >= 0 then consd(d, subt (m, n)) else consd(d-nbase, subb (m, n))
432 :    
433 :     (* multiply 2 digits *)
434 :     fun mul2 (m, n) = let
435 :     val (mh, ml) = hl m
436 :     val (nh, nl) = hl n
437 :     val x = mh*nh
438 :     val y = (mh-ml)*(nh-nl) (* x-y+z = mh*nl + ml*nh *)
439 :     val z = ml*nl
440 :     val (zh, zl) = hl z
441 :     val (uh,ul) = hl (nbase+x+z-y+zh) (* can't overflow *)
442 :     in (x+uh+wtoi hbase, sh ul+zl) end
443 :    
444 :     (* multiply bigint by digit *)
445 :     fun muld (m, 0) = []
446 :     | muld (m, 1) = m (* speedup *)
447 :     | muld (m, i) = let
448 :     fun muldc ([], 0) = []
449 :     | muldc ([], c) = [c]
450 :     | muldc (d::r, c) = let
451 :     val (h, l) = mul2 (d, i)
452 :     val l1 = l+nbase+c
453 :     in
454 :     if l1 >= 0
455 :     then l1::muldc (r, h+1)
456 :     else (l1-nbase)::muldc (r, h)
457 :     end
458 :     in muldc (m, 0) end
459 :    
460 :     fun mult (m, []) = []
461 :     | mult (m, [d]) = muld (m, d) (* speedup *)
462 :     | mult (m, 0::r) = consd (0, mult (m, r)) (* speedup *)
463 :     | mult (m, n) = let
464 :     fun muln [] = []
465 :     | muln (d::r) = add (muld (n, d), consd (0, muln r))
466 :     in muln m end
467 :    
468 :     (* divide DP number by digit; assumes u < i , i >= base/2 *)
469 :     fun divmod2 ((u,v), i) = let
470 :     val (vh,vl) = hl v
471 :     val (ih,il) = hl i
472 :     fun adj (q,r) = if r<0 then adj (q-1, r+i) else (q, r)
473 :     val (q1,r1) = quotrem (u, ih)
474 :     val (q1,r1) = adj (q1, sh r1+vh-q1*il)
475 :     val (q0,r0) = quotrem (r1, ih)
476 :     val (q0,r0) = adj (q0, sh r0+vl-q0*il)
477 :     in (sh q1+q0, r0) end
478 :    
479 :     (* divide bignat by digit>0 *)
480 :     fun divmodd (m, 1) = (m, 0) (* speedup *)
481 :     | divmodd (m, i) = let
482 :     val scale = scale i
483 :     val i' = i * scale
484 :     val m' = muld (m, scale)
485 :     fun dmi [] = ([], 0)
486 :     | dmi (d::r) = let
487 :     val (qt,rm) = dmi r
488 :     val (q1,r1) = divmod2 ((rm,d), i')
489 :     in (consd (q1,qt), r1) end
490 :     val (q,r) = dmi m'
491 :     in (q, r div scale) end
492 :    
493 :     (* From Knuth Vol II, 4.3.1, but without opt. in step D3 *)
494 :     fun divmod (m, []) = raise Div
495 :     | divmod ([], n) = ([], []) (* speedup *)
496 :     | divmod (d::r, 0::s) = let
497 :     val (qt,rm) = divmod (r,s)
498 :     in (qt, consd (d, rm)) end (* speedup *)
499 :     | divmod (m, [d]) = let
500 :     val (qt, rm) = divmodd (m, d)
501 :     in (qt, if rm=0 then [] else [rm]) end
502 :     | divmod (m, n) = let
503 :     val ln = length n (* >= 2 *)
504 :     val scale = scale(List.nth (n,ln-1))
505 :     val m' = muld (m, scale)
506 :     val n' = muld (n, scale)
507 :     val n1 = List.nth (n', ln-1) (* >= base/2 *)
508 :     fun divl [] = ([], [])
509 :     | divl (d::r) = let
510 :     val (qt,rm) = divl r
511 :     val m = consd (d, rm)
512 :     fun msds ([],_) = (0,0)
513 :     | msds ([d],1) = (0,d)
514 :     | msds ([d2,d1],1) = (d1,d2)
515 :     | msds (d::r,i) = msds (r,i-1)
516 :     val (m1,m2) = msds (m, ln)
517 :     val tq = if m1 = n1 then maxDigit
518 :     else #1 (divmod2 ((m1,m2), n1))
519 :     fun try (q,qn') = (q, subt (m,qn'))
520 :     handle Negative => try (q-1, subt (qn', n'))
521 :     val (q,rr) = try (tq, muld (n',tq))
522 :     in (consd (q,qt), rr) end
523 :     val (qt,rm') = divl m'
524 :     val (rm,_(*0*)) = divmodd (rm',scale)
525 :     in (qt,rm) end
526 :    
527 :     fun cmp ([],[]) = EQUAL
528 :     | cmp (_,[]) = GREATER
529 :     | cmp ([],_) = LESS
530 :     | cmp ((i : int)::ri,j::rj) =
531 :     case cmp (ri,rj) of
532 :     EQUAL => if i = j then EQUAL
533 :     else if i < j then LESS
534 :     else GREATER
535 :     | c => c
536 :    
537 :     fun exp (_, 0) = one
538 :     | exp ([], n) = if n > 0 then zero else raise Div
539 :     | exp (m, n) =
540 :     if n < 0 then zero
541 :     else let
542 :     fun expm 0 = [1]
543 :     | expm 1 = m
544 :     | expm i = let
545 :     val r = expm (i div 2)
546 :     val r2 = mult (r,r)
547 :     in
548 :     if i mod 2 = 0 then r2 else mult (r2, m)
549 :     end
550 :     in expm n end
551 :    
552 :     local
553 :     fun try n = if n >= lgHBase then n else try (2*n)
554 :     val pow2lgHBase = try 1
555 :     in
556 :     fun log2 [] = raise Domain
557 :     | log2 (h::t) = let
558 :     fun qlog (x,0) = 0
559 :     | qlog (x,b) =
560 :     if x >= wtoi(Word.<< (0w1, itow b)) then
561 :     b+qlog (wtoi(Word.>> (itow x, itow b)), b div 2)
562 :     else qlog (x, b div 2)
563 :     fun loop (d,[],lg) = lg + qlog (d,pow2lgHBase)
564 :     | loop (_,h::t,lg) = loop (h,t,lg + lgBase)
565 :     in
566 :     loop (h,t,0)
567 :     end
568 :     end (* local *)
569 :    
570 :     (* find maximal maxpow s.t. radix^maxpow < base
571 :     * basepow = radix^maxpow
572 :     *)
573 :     fun mkPowers radix = let
574 :     val powers = let
575 :     val bnd = Int.quot (nbase, (~radix))
576 :     fun try (tp,l) =
577 :     (if tp <= bnd then try (radix*tp,tp::l)
578 :     else (tp::l))
579 :     handle _ => tp::l
580 :     in Vector.fromList(rev(try (radix,[1]))) end
581 :     val maxpow = Vector.length powers - 1
582 :     in
583 :     (maxpow, Vector.sub(powers,maxpow), powers)
584 :     end
585 :     val powers2 = mkPowers 2
586 :     val powers8 = mkPowers 8
587 :     val powers10 = mkPowers 10
588 :     val powers16 = mkPowers 16
589 :    
590 :     fun fmt (pow, radpow, puti) n = let
591 :     val pad = StringCvt.padLeft #"0" pow
592 :     fun ms0 (0,a) = (pad "")::a
593 :     | ms0 (i,a) = (pad (puti i))::a
594 :     fun ml (n,a) =
595 :     case divmodd (n, radpow) of
596 :     ([],d) => (puti d)::a
597 :     | (q,d) => ml (q, ms0 (d, a))
598 :     in
599 :     concat (ml (n,[]))
600 :     end
601 :    
602 :     val fmt2 = fmt (#1 powers2, #2 powers2, NumFormat.fmtInt StringCvt.BIN)
603 :     val fmt8 = fmt (#1 powers8, #2 powers8, NumFormat.fmtInt StringCvt.OCT)
604 :     val fmt10 = fmt (#1 powers10, #2 powers10, NumFormat.fmtInt StringCvt.DEC)
605 :     val fmt16 = fmt (#1 powers16, #2 powers16, NumFormat.fmtInt StringCvt.HEX)
606 :    
607 :     fun scan (bound,powers,geti) getc cs = let
608 :     fun get (l,cs) = if l = bound then NONE
609 :     else case getc cs of
610 :     NONE => NONE
611 :     | SOME(c,cs') => SOME(c, (l+1,cs'))
612 :     fun loop (acc,cs) =
613 :     case geti get (0,cs) of
614 :     NONE => (acc,cs)
615 :     | SOME(0,(sh,cs')) =>
616 :     loop(add(muld(acc,Vector.sub(powers,sh)),[]),cs')
617 :     | SOME(i,(sh,cs')) =>
618 :     loop(add(muld(acc,Vector.sub(powers,sh)),[i]),cs')
619 :     in
620 :     case geti get (0,cs) of
621 :     NONE => NONE
622 :     | SOME(0,(_,cs')) => SOME (loop([],cs'))
623 :     | SOME(i,(_,cs')) => SOME (loop([i],cs'))
624 :     end
625 :    
626 :     fun scan2 getc = scan(#1 powers2, #3 powers2, NumScan.scanInt StringCvt.BIN) getc
627 :     fun scan8 getc = scan(#1 powers8, #3 powers8, NumScan.scanInt StringCvt.OCT) getc
628 :     fun scan10 getc = scan(#1 powers10, #3 powers10, NumScan.scanInt StringCvt.DEC) getc
629 :     fun scan16 getc = scan(#1 powers16, #3 powers16, NumScan.scanInt StringCvt.HEX) getc
630 :    
631 :     end (* structure BigNat *)
632 :    
633 :     structure BN = BigNat
634 :    
635 :     datatype sign = POS | NEG
636 :     datatype int = BI of {
637 :     sign : sign,
638 :     digits : BN.bignat
639 :     }
640 :    
641 :     val zero = BI{sign=POS, digits=BN.zero}
642 :     val one = BI{sign=POS, digits=BN.one}
643 :     val minus_one = BI{sign=NEG, digits=BN.one}
644 :     fun posi digits = BI{sign=POS, digits=digits}
645 :     fun negi digits = BI{sign=NEG, digits=digits}
646 :     fun zneg [] = zero
647 :     | zneg digits = BI{sign=NEG, digits=digits}
648 :    
649 :     local
650 :     val minNeg = valOf Int.minInt
651 :     val bigNatMinNeg = BN.addOne (BN.bignat (~(minNeg+1)))
652 :     val bigIntMinNeg = negi bigNatMinNeg
653 :     in
654 :    
655 :     fun toInt (BI{digits=[], ...}) = 0
656 :     | toInt (BI{sign=POS, digits}) = BN.int digits
657 :     | toInt (BI{sign=NEG, digits}) =
658 :     (~(BN.int digits)) handle _ =>
659 :     if digits = bigNatMinNeg then minNeg else raise Overflow
660 :    
661 :     fun fromInt 0 = zero
662 :     | fromInt i =
663 :     if i < 0
664 :     then if (i = minNeg)
665 :     then bigIntMinNeg
666 :     else BI{sign=NEG, digits= BN.bignat (~i)}
667 :     else BI{sign=POS, digits= BN.bignat i}
668 :     end (* local *)
669 :    
670 :     (* The following assumes LargeInt = Int32.
671 :     * If IntInf is provided, it will be LargeInt and toLarge and fromLarge
672 :     * will be the identity function.
673 :     *)
674 :     local
675 :     val minNeg = valOf LargeInt.minInt
676 :     val maxDigit = LargeInt.fromInt BN.maxDigit
677 :     val nbase = LargeInt.fromInt BN.nbase
678 :     val lgBase = Word.fromInt BN.lgBase
679 :     val notNbase = Word32.notb(Word32.fromInt BN.nbase)
680 :     fun largeNat (0 : LargeInt.int) = []
681 :     | largeNat i = let
682 :     fun bn (0w0 : Word32.word) = []
683 :     | bn i = let
684 :     fun dmbase n = (Word32.>> (n, lgBase), Word32.andb (n, notNbase))
685 :     val (q,r) = dmbase i
686 :     in
687 :     (Word32.toInt r)::(bn q)
688 :     end
689 :     in
690 :     if i <= maxDigit then [LargeInt.toInt i] else bn (Word32.fromLargeInt i)
691 :     end
692 :    
693 :     fun large [] = 0
694 :     | large [d] = LargeInt.fromInt d
695 :     | large [d,e] = ~(nbase*(LargeInt.fromInt e)) + (LargeInt.fromInt d)
696 :     | large (d::r) = ~(nbase*large r) + (LargeInt.fromInt d)
697 :    
698 :     val bigNatMinNeg = BN.addOne (largeNat (~(minNeg+1)))
699 :     val bigIntMinNeg = negi bigNatMinNeg
700 :     in
701 :    
702 :     fun toLarge (BI{digits=[], ...}) = 0
703 :     | toLarge (BI{sign=POS, digits}) = large digits
704 :     | toLarge (BI{sign=NEG, digits}) =
705 :     (~(large digits)) handle _ =>
706 :     if digits = bigNatMinNeg then minNeg else raise Overflow
707 :    
708 :     fun fromLarge 0 = zero
709 :     | fromLarge i =
710 :     if i < 0
711 :     then if (i = minNeg)
712 :     then bigIntMinNeg
713 :     else BI{sign=NEG, digits= largeNat (~i)}
714 :     else BI{sign=POS, digits= largeNat i}
715 :     end (* local *)
716 :    
717 :     fun negSign POS = NEG
718 :     | negSign NEG = POS
719 :    
720 :     fun subtNat (m, []) = {sign=POS, digits=m}
721 :     | subtNat ([], n) = {sign=NEG, digits=n}
722 :     | subtNat (m,n) =
723 :     ({sign=POS,digits = BN.subt(m,n)})
724 :     handle BN.Negative => ({sign=NEG,digits = BN.subt(n,m)})
725 :    
726 :     val precision = NONE
727 :     val minInt = NONE
728 :     val maxInt = NONE
729 :    
730 :     fun ~ (i as BI{digits=[], ...}) = i
731 :     | ~ (BI{sign=POS, digits}) = BI{sign=NEG, digits=digits}
732 :     | ~ (BI{sign=NEG, digits}) = BI{sign=POS, digits=digits}
733 :    
734 :     fun op * (_,BI{digits=[], ...}) = zero
735 :     | op * (BI{digits=[], ...},_) = zero
736 :     | op * (BI{sign=POS, digits=d1}, BI{sign=NEG, digits=d2}) =
737 :     BI{sign=NEG,digits=BN.mult(d1,d2)}
738 :     | op * (BI{sign=NEG, digits=d1}, BI{sign=POS, digits=d2}) =
739 :     BI{sign=NEG,digits=BN.mult(d1,d2)}
740 :     | op * (BI{digits=d1,...}, BI{digits=d2,...}) =
741 :     BI{sign=POS,digits=BN.mult(d1,d2)}
742 :    
743 :     fun op + (BI{digits=[], ...}, i2) = i2
744 :     | op + (i1, BI{digits=[], ...}) = i1
745 :     | op + (BI{sign=POS, digits=d1}, BI{sign=NEG, digits=d2}) =
746 :     BI(subtNat(d1, d2))
747 :     | op + (BI{sign=NEG, digits=d1}, BI{sign=POS, digits=d2}) =
748 :     BI(subtNat(d2, d1))
749 :     | op + (BI{sign, digits=d1}, BI{digits=d2, ...}) =
750 :     BI{sign=sign, digits=BN.add(d1, d2)}
751 :    
752 :     fun op - (i1, BI{digits=[], ...}) = i1
753 :     | op - (BI{digits=[], ...}, BI{sign, digits}) =
754 :     BI{sign=negSign sign, digits=digits}
755 :     | op - (BI{sign=POS, digits=d1}, BI{sign=POS, digits=d2}) =
756 :     BI(subtNat(d1, d2))
757 :     | op - (BI{sign=NEG, digits=d1}, BI{sign=NEG, digits=d2}) =
758 :     BI(subtNat(d2, d1))
759 :     | op - (BI{sign, digits=d1}, BI{digits=d2, ...}) =
760 :     BI{sign=sign, digits=BN.add(d1, d2)}
761 :    
762 :     fun quotrem (BI{sign=POS,digits=m},BI{sign=POS,digits=n}) =
763 :     (case BN.divmod (m,n) of (q,r) => (posi q, posi r))
764 :     | quotrem (BI{sign=POS,digits=m},BI{sign=NEG,digits=n}) =
765 :     (case BN.divmod (m,n) of (q,r) => (zneg q, posi r))
766 :     | quotrem (BI{sign=NEG,digits=m},BI{sign=POS,digits=n}) =
767 :     (case BN.divmod (m,n) of (q,r) => (zneg q, zneg r))
768 :     | quotrem (BI{sign=NEG,digits=m},BI{sign=NEG,digits=n}) =
769 :     (case BN.divmod (m,n) of (q,r) => (posi q, zneg r))
770 :    
771 :     fun divmod (BI{sign=POS,digits=m},BI{sign=POS,digits=n}) =
772 :     (case BN.divmod (m,n) of (q,r) => (posi q, posi r))
773 :     | divmod (BI{sign=POS,digits=[]},BI{sign=NEG,digits=n}) = (zero,zero)
774 :     | divmod (BI{sign=POS,digits=m},BI{sign=NEG,digits=n}) = let
775 :     val (q,r) = BN.divmod (BN.subtOne m, n)
776 :     in (negi(BN.addOne q), zneg(BN.subtOne(BN.subt(n,r)))) end
777 :     | divmod (BI{sign=NEG,digits=m},BI{sign=POS,digits=n}) = let
778 :     val (q,r) = BN.divmod (BN.subtOne m, n)
779 :     in (negi(BN.addOne q), posi(BN.subtOne(BN.subt(n,r)))) end
780 :     | divmod (BI{sign=NEG,digits=m},BI{sign=NEG,digits=n}) =
781 :     (case BN.divmod (m,n) of (q,r) => (posi q, zneg r))
782 :    
783 :     fun op div arg = #1(divmod arg)
784 :     fun op mod arg = #2(divmod arg)
785 :     fun op quot arg = #1(quotrem arg)
786 :     fun op rem arg = #2(quotrem arg)
787 :    
788 :     fun compare (BI{sign=NEG,...},BI{sign=POS,...}) = LESS
789 :     | compare (BI{sign=POS,...},BI{sign=NEG,...}) = GREATER
790 :     | compare (BI{sign=POS,digits=d},BI{sign=POS,digits=d'}) = BN.cmp (d,d')
791 :     | compare (BI{sign=NEG,digits=d},BI{sign=NEG,digits=d'}) = BN.cmp (d',d)
792 :    
793 :     fun op < arg = case compare arg of LESS => true | _ => false
794 :     fun op > arg = case compare arg of GREATER => true | _ => false
795 :     fun op <= arg = case compare arg of GREATER => false | _ => true
796 :     fun op >= arg = case compare arg of LESS => false | _ => true
797 :    
798 :     fun abs (BI{sign=NEG, digits}) = BI{sign=POS, digits=digits}
799 :     | abs i = i
800 :    
801 :     fun max arg = case compare arg of GREATER => #1 arg | _ => #2 arg
802 :     fun min arg = case compare arg of LESS => #1 arg | _ => #2 arg
803 :    
804 :     fun sign (BI{sign=NEG,...}) = ~1
805 :     | sign (BI{digits=[],...}) = 0
806 :     | sign _ = 1
807 :    
808 :     fun sameSign (i,j) = sign i = sign j
809 :    
810 :     local
811 :     fun fmt' fmtFn i =
812 :     case i of
813 :     (BI{digits=[],...}) => "0"
814 :     | (BI{sign=NEG,digits}) => "~"^(fmtFn digits)
815 :     | (BI{sign=POS,digits}) => fmtFn digits
816 :     in
817 :     fun fmt StringCvt.BIN = fmt' (BN.fmt2)
818 :     | fmt StringCvt.OCT = fmt' (BN.fmt8)
819 :     | fmt StringCvt.DEC = fmt' (BN.fmt10)
820 :     | fmt StringCvt.HEX = fmt' (BN.fmt16)
821 :     end
822 :    
823 :     val toString = fmt StringCvt.DEC
824 :    
825 :     local
826 :     fun scan' scanFn getc cs = let
827 :     val cs' = NumScan.skipWS getc cs
828 :     fun cvt (NONE,_) = NONE
829 :     | cvt (SOME(i,cs),wr) = SOME(wr i, cs)
830 :     in
831 :     case (getc cs')
832 :     of (SOME((#"~" | #"-"), cs'')) => cvt(scanFn getc cs'',zneg)
833 :     | (SOME(#"+", cs'')) => cvt(scanFn getc cs'',posi)
834 :     | (SOME _) => cvt(scanFn getc cs',posi)
835 :     | NONE => NONE
836 :     (* end case *)
837 :     end
838 :     in
839 :     fun scan StringCvt.BIN = scan' (BN.scan2)
840 :     | scan StringCvt.OCT = scan' (BN.scan8)
841 :     | scan StringCvt.DEC = scan' (BN.scan10)
842 :     | scan StringCvt.HEX = scan' (BN.scan16)
843 :     end
844 :    
845 :     fun fromString s = StringCvt.scanString (scan StringCvt.DEC) s
846 :    
847 :     fun pow (_, 0) = one
848 :     | pow (BI{sign=POS,digits}, n) = posi(BN.exp(digits,n))
849 :     | pow (BI{sign=NEG,digits}, n) =
850 :     if Int.mod (n, 2) = 0
851 :     then posi(BN.exp(digits,n))
852 :     else zneg(BN.exp(digits,n))
853 :    
854 :     fun log2 (BI{sign=POS,digits}) = BN.log2 digits
855 :     | log2 _ = raise Domain
856 :    
857 :     end (* structure IntInf *)
858 : monnier 411

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