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 106 - (view) (download)
Original Path: sml/branches/SMLNJ/src/smlnj-lib/Util/int-inf.sml

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

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