int-inf.sml

这是我们参加06年全国开源软件的竞赛作品

(* int-inf.sml
 *
 * COPYRIGHT (c) 1995 by AT&T Bell Laboratories. See COPYRIGHT file for details.
 *
 * This package is derived from Andrzej Filinski's bignum package.  It is very
 * close to the definition of the optional IntInf structure in the SML'97 basis.
 * 
 * It is implemented almost totally on the abstraction presented by
 * the BigNat structure. The only concrete type information it assumes 
 * is that BigNat.bignat = 'a list and that BigNat.zero = [].
 * Some trivial additional efficiency could be obtained by assuming that
 * type bignat is really int list, and that if (v : bignat) = [d], then
 * bignat d = [d].
 *
 * At some point, this should be reimplemented to make use of Word32, or
 * have compiler/runtime support.
 *
 * Also, for booting, this module could be broken into one that has
 * all the types and arithmetic functions, but doesn't use NumScan,
 * constructing values from strings using bignum arithmetic. Various
 * integer and word scanning, such as NumScan, could then be constructed 
 * from IntInf. Finally, a user-level IntInf could be built by 
 * importing the basic IntInf, but replacing the scanning functions
 * by more efficient ones based on the functions in NumScan.
 *
 *)

structure IntInf :> INT_INF =
  struct

  (* It is not clear what advantage there is to having NumFormat as
   * a submodule.
   *)

    structure NumScan : sig

        val skipWS : (char, 'a) StringCvt.reader -> 'a -> 'a

        val scanWord : StringCvt.radix
	      ->  (char, 'a) StringCvt.reader
	        -> 'a -> (Word32.word * 'a) option
        val scanInt : StringCvt.radix
	      ->  (char, 'a) StringCvt.reader
	        -> 'a -> (int * 'a) option
	    (** should be to int32 **)

      end = struct

        structure W = Word32
        structure I = Int31
    
        val op <  = W.<
        val op >= = W.>=
        val op +  = W.+
        val op -  = W.-
        val op *  = W.*
    
        val largestWordDiv10 : Word32.word = 0w429496729(* 2^32-1 divided by 10 *)
        val largestWordMod10 : Word32.word = 0w5	(* remainder *)
        val largestNegInt : Word32.word = 0w1073741824	(* absolute value of ~2^30 *)
        val largestPosInt : Word32.word = 0w1073741823	(* 2^30-1 *)
    
        type 'a chr_strm = {getc : (char, 'a) StringCvt.reader}
    
      (* A table for mapping digits to values.  Whitespace characters map to
       * 128, "+" maps to 129, "-","~" map to 130, "." maps to 131, and the
       * characters 0-9,A-Z,a-z map to their * base-36 value.  All other
       * characters map to 255.
       *)
        local
          val cvtTable = "\
    	    \\255\255\255\255\255\255\255\255\255\128\128\255\255\255\255\255\
    	    \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    	    \\128\255\255\255\255\255\255\255\255\255\255\129\255\130\131\255\
    	    \\000\001\002\003\004\005\006\007\008\009\255\255\255\255\255\255\
    	    \\255\010\011\012\013\014\015\016\017\018\019\020\021\022\023\024\
    	    \\025\026\027\028\029\030\031\032\033\034\035\255\255\255\255\255\
    	    \\255\010\011\012\013\014\015\016\017\018\019\020\021\022\023\024\
    	    \\025\026\027\028\029\030\031\032\033\034\035\255\255\255\130\255\
    	    \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    	    \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    	    \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    	    \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    	    \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    	    \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    	    \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    	    \\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
    	  \"
        val ord = Char.ord
        in
	fun code (c : char) = W.fromInt(ord(CharVector.sub(cvtTable, ord c)))
        val wsCode : Word32.word = 0w128
        val plusCode : Word32.word = 0w129
        val minusCode : Word32.word = 0w130
        end (* local *)
    
        fun skipWS (getc : (char, 'a) StringCvt.reader) cs = let
              fun skip cs = (case (getc cs)
		     of NONE => cs
		      | (SOME(c, cs')) => if (code c = wsCode) then skip cs' else cs
		    (* end case *))
              in
                skip cs
              end
    
      (* skip leading whitespace and any sign (+, -, or ~) *)
        fun scanPrefix (getc : (char, 'a) StringCvt.reader) cs = let
    	  fun skipWS cs = (case (getc cs)
    		 of NONE => NONE
    		  | (SOME(c, cs')) => let val c' = code c
    		      in
    			if (c' = wsCode) then skipWS cs' else SOME(c', cs')
    		      end
    		(* end case *))
    	  fun getNext (neg, cs) = (case (getc cs)
    		 of NONE => NONE
    		  | (SOME(c, cs)) => SOME{neg=neg, next=code c, rest=cs}
    		(* end case *))
    	  in
    	    case (skipWS cs)
    	     of NONE => NONE
    	      | (SOME(c, cs')) =>
    		  if (c = plusCode) then getNext(false, cs')
    		  else if (c = minusCode) then getNext(true, cs')
    		  else SOME{neg=false, next=c, rest=cs'}
    	    (* end case *)
    	  end
    
      (* for power of 2 bases (2, 8 & 16), we can check for overflow by looking
       * at the hi (1, 3 or 4) bits.
       *)
        fun chkOverflow mask w =
    	  if (W.andb(mask, w) = 0w0) then () else raise Overflow
    
        fun scanBin (getc : (char, 'a) StringCvt.reader) cs = (case (scanPrefix getc cs)
    	   of NONE => NONE
    	    | (SOME{neg, next, rest}) => let
    		fun isDigit (d : Word32.word) = (d < 0w2)
    		val chkOverflow = chkOverflow 0wx80000000
    		fun cvt (w, rest) = (case (getc rest)
    		       of NONE => SOME{neg=neg, word=w, rest=rest}
    			| SOME(c, rest') => let val d = code c
    			    in
    			      if (isDigit d)
    				then (
    				  chkOverflow w;
    				  cvt(W.+(W.<<(w, 0w1), d), rest'))
    				else SOME{neg=neg, word=w, rest=rest}
    			    end
    		      (* end case *))
    		in
    		  if (isDigit next)
    		    then cvt(next, rest)
    		    else NONE
    		end
    	  (* end case *))
    
        fun scanOct getc cs = (case (scanPrefix getc cs)
    	   of NONE => NONE
    	    | (SOME{neg, next, rest}) => let
    		fun isDigit (d : Word32.word) = (d < 0w8)
    		val chkOverflow = chkOverflow 0wxE0000000
    		fun cvt (w, rest) = (case (getc rest)
    		       of NONE => SOME{neg=neg, word=w, rest=rest}
    			| SOME(c, rest') => let val d = code c
    			    in
    			      if (isDigit d)
    				then (
    				  chkOverflow w;
    				  cvt(W.+(W.<<(w, 0w3), d), rest'))
    				else SOME{neg=neg, word=w, rest=rest}
    			    end
    		      (* end case *))
    		in
    		  if (isDigit next)
    		    then cvt(next, rest)
    		    else NONE
    		end
    	  (* end case *))
    
        fun scanDec getc cs = (case (scanPrefix getc cs)
    	   of NONE => NONE
    	    | (SOME{neg, next, rest}) => let
    		fun isDigit (d : Word32.word) = (d < 0w10)
    		fun cvt (w, rest) = (case (getc rest)
    		       of NONE => SOME{neg=neg, word=w, rest=rest}
    			| SOME(c, rest') => let val d = code c
    			    in
    			      if (isDigit d)
    				then (
    				  if ((w >= largestWordDiv10)
    				  andalso ((largestWordDiv10 < w)
    				    orelse (largestWordMod10 < d)))
    				    then raise Overflow
    				    else ();
    				  cvt (0w10*w+d, rest'))
    				else SOME{neg=neg, word=w, rest=rest}
    			    end
    		      (* end case *))
    		in
    		  if (isDigit next)
    		    then cvt(next, rest)
    		    else NONE
    		end
    	  (* end case *))
    
        fun scanHex getc cs = (case (scanPrefix getc cs)
    	   of NONE => NONE
    	    | (SOME{neg, next, rest}) => let
    		fun isDigit (d : Word32.word) = (d < 0w16)
    		val chkOverflow = chkOverflow 0wxF0000000
    		fun cvt (w, rest) = (case (getc rest)
    		       of NONE => SOME{neg=neg, word=w, rest=rest}
    			| SOME(c, rest') => let val d = code c
    			    in
    			      if (isDigit d)
    				then (
    				  chkOverflow w;
    				  cvt(W.+(W.<<(w, 0w4), d), rest'))
    				else SOME{neg=neg, word=w, rest=rest}
    			    end
    		      (* end case *))
    		in
    		  if (isDigit next)
    		    then cvt(next, rest)
    		    else NONE
    		end
    	  (* end case *))
    
        fun finalWord scanFn getc cs = (case (scanFn getc cs)
    	   of NONE => NONE
    	    | (SOME{neg=true, ...}) => NONE
    	    | (SOME{neg=false, word, rest}) => SOME(word, rest)
    	  (* end case *))
    
        fun scanWord StringCvt.BIN = finalWord scanBin
          | scanWord StringCvt.OCT = finalWord scanOct
          | scanWord StringCvt.DEC = finalWord scanDec
          | scanWord StringCvt.HEX = finalWord scanHex
    
        fun finalInt scanFn getc cs = (case (scanFn getc cs)
    	   of NONE => NONE
    	    | (SOME{neg=true, word, rest}) =>
    		if (largestNegInt < word)
    		  then raise Overflow
    		  else SOME(I.~(W.toInt word), rest)
    	    | (SOME{word, rest, ...}) =>
    		if (largestPosInt < word)
    		  then raise Overflow
    		  else SOME(W.toInt word, rest)
    	  (* end case *))
    
        fun scanInt StringCvt.BIN = finalInt scanBin
          | scanInt StringCvt.OCT = finalInt scanOct
          | scanInt StringCvt.DEC = finalInt scanDec
          | scanInt StringCvt.HEX = finalInt scanHex
    
      end (* structure NumScan *)

    structure NumFormat : sig

        val fmtWord : StringCvt.radix -> Word32.word -> string
        val fmtInt : StringCvt.radix -> int -> string	(** should be int32 **)

      end = struct

        structure W = Word32
        structure I = Int
    
        val op < = W.<
        val op - = W.-
        val op * = W.*
        val op div = W.div
    
        fun mkDigit (w : Word32.word) =
    	  CharVector.sub("0123456789abcdef", W.toInt w)
    
        fun wordToBin w = let
    	  fun mkBit w = if (W.andb(w, 0w1) = 0w0) then #"0" else #"1"
    	  fun f (0w0, n, l) = (I.+(n, 1), #"0" :: l)
    	    | f (0w1, n, l) = (I.+(n, 1), #"1" :: l)
    	    | f (w, n, l) = f(W.>>(w, 0w1), I.+(n, 1), (mkBit w) :: l)
    	  in
    	    f (w, 0, [])
    	  end
        fun wordToOct w = let
    	  fun f (w, n, l) = if (w < 0w8)
    		then (I.+(n, 1), (mkDigit w) :: l)
    		else f(W.>>(w, 0w3), I.+(n, 1), mkDigit(W.andb(w, 0w7)) :: l)
    	  in
    	    f (w, 0, [])
    	  end
        fun wordToDec w = let
    	  fun f (w, n, l) = if (w < 0w10)
    		then (I.+(n, 1), (mkDigit w) :: l)
    		else let val j = w div 0w10
    		  in
    		    f (j,  I.+(n, 1), mkDigit(w - 0w10*j) :: l)
    		  end
    	  in
    	    f (w, 0, [])
    	  end
        fun wordToHex w = let
    	  fun f (w, n, l) = if (w < 0w16)
    		then (I.+(n, 1), (mkDigit w) :: l)
    		else f(W.>>(w, 0w4), I.+(n, 1), mkDigit(W.andb(w, 0w15)) :: l)
    	  in
    	    f (w, 0, [])
    	  end
    
        fun fmtW StringCvt.BIN = #2 o wordToBin
          | fmtW StringCvt.OCT = #2 o wordToOct
          | fmtW StringCvt.DEC = #2 o wordToDec
          | fmtW StringCvt.HEX = #2 o wordToHex
    
        fun fmtWord radix = String.implode o (fmtW radix)
    
    (** NOTE: this currently uses 31-bit integers, but really should use 32-bit
     ** ints (once they are supported).
     **)
        fun fmtInt radix = let
    	  val fmtW = fmtW radix
    	  val itow = W.fromInt
    	  fun fmt i = if I.<(i, 0)
    		then let
    		  val (digits) = fmtW(itow(I.~ i))
    		  in
    		    String.implode(#"~"::digits)
    		  end
    		    handle _ => (case radix
    		       of StringCvt.BIN => "~1111111111111111111111111111111"
    			| StringCvt.OCT => "~7777777777"
    			| StringCvt.DEC => "~1073741824"
    			| StringCvt.HEX => "~3fffffff"
    		      (* end case *))
    		else String.implode(fmtW(itow i))
    	  in
    	    fmt
    	  end
    
      end (* structure NumFormat *)

    structure BigNat =
      struct

	exception Negative

        val itow = Word.fromInt
	val wtoi = Word.toIntX

	val lgBase = 30             (* No. of bits per digit; must be even *)
	val nbase = ~0x40000000     (* = ~2^lgBase *)

	val maxDigit = ~(nbase + 1)
	val realBase = (real maxDigit) + 1.0

	val lgHBase = Int.quot (lgBase, 2)    (* half digits *)
	val hbase = Word.<<(0w1, itow lgHBase)
	val hmask = hbase-0w1

	fun quotrem (i, j) = (Int.quot (i, j), Int.rem (i, j))
	fun scale i = if i = maxDigit then 1 else nbase div (~(i+1))

	type bignat = int list (* least significant digit first *)

	val zero = []
	val one = [1]

	fun bignat 0 = zero
	  | bignat i = let
	      val notNbase = Word.notb(itow nbase)
              fun bn 0w0 = []
        	| bn i = let
		    fun dmbase n = 
		      (Word.>> (n, itow lgBase), Word.andb (n, notNbase))
		    val (q,r) = dmbase i
		  in
		    (wtoi r)::(bn q)
		  end
              in
        	if i > 0 
        	  then if i <= maxDigit then [i] else bn (itow i)
        	  else raise Negative
              end

	fun int [] = 0
	  | int [d] = d
	  | int [d,e] = ~(nbase*e) + d
	  | int (d::r) = ~(nbase*int r) + d

	fun consd (0, []) = []
	  | consd (d, r) = d::r

	fun hl i = let
	  val w = itow i
        in
	  (wtoi(Word.~>> (w, itow lgHBase)),  (* MUST sign-extend *)
	   wtoi(Word.andb(w, hmask)))
        end

	fun sh i = wtoi(Word.<< (itow i, itow lgHBase))

	fun addOne [] = [1]
	  | addOne (m::rm) = let
              val c = nbase+m+1
              in
        	if c < 0 then (c-nbase)::rm else c::(addOne rm)
              end

	fun add ([], digits) = digits
	  | add (digits, []) = digits
	  | add (dm::rm, dn::rn) = addd (nbase+dm+dn, rm, rn)
	and addd (s, m, n) = 
              if s < 0 then (s-nbase) :: add (m, n) else (s :: addc (m, n))
	and addc (m, []) = addOne m
	  | addc ([], n) = addOne n
	  | addc (dm::rm, dn::rn) = addd (nbase+dm+dn+1, rm, rn)

	fun subtOne (0::mr) = maxDigit::(subtOne mr)
	  | subtOne [1] = []
	  | subtOne (n::mr) = (n-1)::mr
	  | subtOne [] = raise Fail ""

	fun subt (m, []) = m
	  | subt ([], n) = raise Negative
	  | subt (dm::rm, dn::rn) = subd(dm-dn,rm,rn)
	and subb ([], n) = raise Negative
	  | subb (dm::rm, []) = subd (dm-1, rm, [])
	  | subb (dm::rm, dn::rn) = subd (dm-dn-1, rm, rn)
	and subd (d, m, n) =