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/branches/FLINT/src/compiler/PervEnv/Basis/int-inf.sml
ViewVC logotype

Annotation of /sml/branches/FLINT/src/compiler/PervEnv/Basis/int-inf.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 227 - (view) (download)

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

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