[hcoop/debian/mlton.git] / basis-library / integer / int-inf.sml

(* Copyright (C) 2013-2014 Matthew Fluet.
 * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 * Copyright (C) 1997-2000 NEC Research Institute.
 *
 * MLton is released under a BSD-style license.
 * See the file MLton-LICENSE for details.
 *)

structure IntInf: INT_INF_EXTRA =
   struct
      open Primitive.IntInf
      type t = int

      structure BigWord = C_MPLimb
      structure SmallInt = ObjptrInt

      structure W = ObjptrWord
      structure I = ObjptrInt
      structure MPLimb = C_MPLimb

      val precision: Int.int option = NONE

      fun sign (arg: int): Int.int =
         case compare (arg, zero) of
            LESS => ~1
          | EQUAL => 0
          | GREATER => 1

      fun sameSign (x, y) = sign x = sign y

      local
         val maxShift32 = Word32.<< (0wx1, 0w30)
         val maxShift = Word32.toWord maxShift32
         fun make f (arg, shift) =
            let
               fun body loop (arg, shift) =
                  if Word.<= (shift, maxShift)
                     then f (arg, Word32.fromWord shift)
                     else loop (f (arg, maxShift32),
                                Word.- (shift, maxShift))
               fun loop (arg, shift) = body loop (arg, shift)
            in
               body loop (arg, shift)
            end
      in
         val << = make <<
         val ~>> = make ~>>
      end

      val fromInt = schckFromInt
      val toInt = schckToInt
      val fromLarge = schckFromLargeInt
      val toLarge = schckToLargeInt

      local
         open StringCvt

         val binCvt = mkCvt {base = 2, smallCvt = I.fmt BIN}
         val octCvt = mkCvt {base = 8, smallCvt = I.fmt OCT}
         val decCvt = mkCvt {base = 10, smallCvt = I.fmt DEC}
         val hexCvt = mkCvt {base = 16, smallCvt = I.fmt HEX}
      in
         fun fmt radix =
            case radix of
               BIN => binCvt
             | OCT => octCvt
             | DEC => decCvt
             | HEX => hexCvt
         val toString = fmt DEC
      end

      local
         open StringCvt

         (*
          * Given a char, if it is a digit in the appropriate base,
          * convert it to a word.  Otherwise, return NONE.
          * Note, both a-f and A-F are accepted as hexadecimal digits.
          *)
         fun binDig (ch: char): W.word option =
            case ch of
               #"0" => SOME 0w0
             | #"1" => SOME 0w1
             | _ => NONE

         local
            val op <= = Char.<=
         in
            fun octDig (ch: char): W.word option =
               if #"0" <= ch andalso ch <= #"7"
                  then SOME (W.fromInt (Int.- (Char.ord ch, 
                                               Char.ord #"0")))
               else NONE

            fun decDig (ch: char): W.word option =
               if #"0" <= ch andalso ch <= #"9"
                  then SOME (W.fromInt (Int.- (Char.ord ch, 
                                               Char.ord #"0")))
               else NONE

            fun hexDig (ch: char): W.word option =
               if #"0" <= ch andalso ch <= #"9"
                  then SOME (W.fromInt (Int.- (Char.ord ch, 
                                               Char.ord #"0")))
               else if #"a" <= ch andalso ch <= #"f"
                  then SOME (W.fromInt (Int.- (Char.ord ch, 
                                               Int.- (Char.ord #"a", 0xa))))
               else if #"A" <= ch andalso ch <= #"F"
                  then SOME (W.fromInt (Int.- (Char.ord ch, 
                                               Int.- (Char.ord #"A", 0xA))))
               else NONE
         end

         (*
          * Given a digit converter and a char reader, return a digit
          * reader.
          *)
         fun toDigR (charToDig: char -> W.word option,
                     cread: (char, 'a) reader)
                    (s: 'a)
                    : (W.word * 'a) option =
            case cread s of
               NONE => NONE
             | SOME (ch, s') =>
                  case charToDig ch of
                     NONE => NONE
                   | SOME dig => SOME (dig, s')

         (*
          * A chunk represents the result of processing some digits.
          * more is a bool indicating if there might be more digits.
          * shift is base raised to the number-of-digits-seen power.
          * chunk is the value of the digits seen.
          *)
         type chunk = {more: bool,
                       shift: W.word,
                       chunk: W.word}
         (*
          * Given the base and a digit reader, 
          * return a chunk reader.
          *)
         fun toChunkR (base: W.word,
                       dread: (W.word, 'a) reader)
                      : (chunk, 'a) reader =
            let 
               fun loop {left: Int32.int,
                         shift: W.word,
                         chunk: W.word,
                         s: 'a}
                        : chunk * 'a =
                  if Int32.<= (left, 0)
                     then ({more = true,
                            shift = shift,
                            chunk = chunk},
                           s)
                     else
                        case dread s of
                           NONE => ({more = false,
                                     shift = shift,
                                     chunk = chunk},
                                    s)
                         | SOME (dig, s') =>
                              loop {left = Int32.- (left, 1),
                                    shift = W.* (base, shift),
                                    chunk = W.+ (W.* (base, chunk), dig),
                                    s = s'}
               (* digitsPerChunk = floor((W.wordSize - 3) / (log2 base)) *)
               val digitsPerChunk : Int32.t =
                  case (W.wordSize, base) of
                     (64, 0w16) => 15
                   | (64, 0w10) => 18
                   | (64, 0w8) => 20
                   | (64, 0w2) => 61
                   | (32, 0w16) => 7
                   | (32, 0w10) => 8
                   | (32, 0w8) => 9
                   | (32, 0w2) => 29
                   | _ => raise (Fail "IntInf.scan:digitsPerChunk")
               fun reader (s: 'a): (chunk * 'a) option =
                  case dread s of
                     NONE => NONE
                   | SOME (dig, next) =>
                        SOME (loop {left = Int32.- (digitsPerChunk, 1),
                                    shift = base,
                                    chunk = dig,
                                    s = next})
            in 
               reader
            end

         (*
          * Given a chunk reader, return an unsigned reader.
          *)
         fun toUnsR (ckread: (chunk, 'a) reader): (int, 'a) reader =
            let 
               fun loop (more: bool, acc: int, s: 'a) =
                  if more
                     then case ckread s of
                             NONE => (acc, s)
                           | SOME ({more, shift, chunk}, s') =>
                                loop (more,
                                      ((W.toLargeInt shift) * acc)
                                      + (W.toLargeInt chunk),
                                      s')
                     else (acc, s)
               fun reader (s: 'a): (int * 'a) option =
                  case ckread s of
                     NONE => NONE
                   | SOME ({more, chunk, ...}, s') =>
                        SOME (loop (more,
                                    W.toLargeInt chunk,
                                    s'))
            in 
               reader
            end

         (*
          * Given a char reader and an unsigned reader, return an unsigned
          * reader that includes skipping the option hex '0x'.
          *)
         fun toHexR (cread: (char, 'a) reader, uread: (int, 'a) reader) s =
            case cread s of
               NONE => NONE
             | SOME (c1, s1) =>
                  if c1 = #"0" then
                     case cread s1 of
                        NONE => SOME (zero, s1)
                      | SOME (c2, s2) =>
                           if c2 = #"x" orelse c2 = #"X" then
                              case uread s2 of 
                                 NONE => SOME (zero, s1)
                               | SOME x => SOME x
                              else uread s
                     else uread s

         (*
          * Given a char reader and an unsigned reader, return a signed
          * reader.  This includes skipping any initial white space.
          *)
         fun toSign (cread: (char, 'a) reader, uread: (int, 'a) reader)
                    : (int, 'a) reader =
            let
               fun reader (s: 'a): (int * 'a) option =
                  let val s = StringCvt.skipWS cread s in
                  case cread s of
                     NONE => NONE
                   | SOME (ch, s') =>
                       let
                          val (isNeg, s'') =
                             case ch of
                                #"+" => (false, s')
                              | #"-" => (true, s')
                              | #"~" => (true, s')
                              | _ => (false, s)
                       in
                          if isNeg 
                             then case uread s'' of
                                     NONE => NONE
                                   | SOME (abs, s''') => SOME (~ abs, s''')
                             else uread s''
                       end
                  end
            in
               reader
            end

         (*
          * Base-specific conversions from char readers to
          * int readers.
          *)
         local
            fun reader (base, dig)
                       (cread: (char, 'a) reader)
                       : (int, 'a) reader =
               let 
                  val dread = toDigR (dig, cread)
                  val ckread = toChunkR (base, dread)
                  val uread = toUnsR ckread
                  val hread = if base = 0w16 then toHexR (cread, uread) else uread
                  val reader = toSign (cread, hread)
               in 
                  reader
               end
         in
            fun binReader z = reader (0w2, binDig) z
            fun octReader z = reader (0w8, octDig) z
            fun decReader z = reader (0w10, decDig) z
            fun hexReader z = reader (0w16, hexDig) z
         end     
      in
         fun scan radix =
            case radix of
               BIN => binReader
             | OCT => octReader
             | DEC => decReader
             | HEX => hexReader
      end

      val fromString = StringCvt.scanString (scan StringCvt.DEC)

      local
         fun isEven (n: Int.int) = Int.andb (n, 0x1) = 0
      in
         fun pow (i: int, j: Int.int): int =
            if Int.< (j, 0) then
               if i = zero then
                  raise Div
               else
                  if i = one then one
                  else if i = negOne then if isEven j then one else negOne
                  else zero
            else
               if j = 0 then one
               else
                  let
                     fun square (n: int): int = n * n
                     (* pow (j) returns (i ^ j) *)
                     fun pow (j: Int.int): int =
                        if Int.<= (j, 0) then one
                        else if isEven j then evenPow j
                        else i * evenPow (Int.- (j, 1))
                     (* evenPow (j) returns (i ^ j), assuming j is even *)
                     and evenPow (j: Int.int): int =
                        square (pow (Int.div (j, 2)))
                  in 
                     pow j
                  end
      end

      val log2 = 
         mkLog2 {fromSmall = fn {smallLog2} => Int32.toInt smallLog2,
                 fromLarge = fn {numLimbsMinusOne, mostSigLimbLog2} =>
                 Int.+ (Int.* (MPLimb.wordSize, SeqIndex.toInt numLimbsMinusOne),
                        Int32.toInt mostSigLimbLog2)}
   end
Commit	Line	Data
7f918cf1 CE	1	(* Copyright (C) 2013-2014 Matthew Fluet.
	2	* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
	3	* Jagannathan, and Stephen Weeks.
	4	* Copyright (C) 1997-2000 NEC Research Institute.
	5	*
	6	* MLton is released under a BSD-style license.
	7	* See the file MLton-LICENSE for details.
	8	*)
	9
	10	structure IntInf: INT_INF_EXTRA =
	11	struct
	12	open Primitive.IntInf
	13	type t = int
	14
	15	structure BigWord = C_MPLimb
	16	structure SmallInt = ObjptrInt
	17
	18	structure W = ObjptrWord
	19	structure I = ObjptrInt
	20	structure MPLimb = C_MPLimb
	21
	22	val precision: Int.int option = NONE
	23
	24	fun sign (arg: int): Int.int =
	25	case compare (arg, zero) of
	26	LESS => ~1
	27	\| EQUAL => 0
	28	\| GREATER => 1
	29
	30	fun sameSign (x, y) = sign x = sign y
	31
	32	local
	33	val maxShift32 = Word32.<< (0wx1, 0w30)
	34	val maxShift = Word32.toWord maxShift32
	35	fun make f (arg, shift) =
	36	let
	37	fun body loop (arg, shift) =
	38	if Word.<= (shift, maxShift)
	39	then f (arg, Word32.fromWord shift)
	40	else loop (f (arg, maxShift32),
	41	Word.- (shift, maxShift))
	42	fun loop (arg, shift) = body loop (arg, shift)
	43	in
	44	body loop (arg, shift)
	45	end
	46	in
	47	val << = make <<
	48	val ~>> = make ~>>
	49	end
	50
	51	val fromInt = schckFromInt
	52	val toInt = schckToInt
	53	val fromLarge = schckFromLargeInt
	54	val toLarge = schckToLargeInt
	55
	56	local
	57	open StringCvt
	58
	59	val binCvt = mkCvt {base = 2, smallCvt = I.fmt BIN}
	60	val octCvt = mkCvt {base = 8, smallCvt = I.fmt OCT}
	61	val decCvt = mkCvt {base = 10, smallCvt = I.fmt DEC}
	62	val hexCvt = mkCvt {base = 16, smallCvt = I.fmt HEX}
	63	in
	64	fun fmt radix =
65	case radix of
66	BIN => binCvt
67	\| OCT => octCvt
68	\| DEC => decCvt
69	\| HEX => hexCvt
70	val toString = fmt DEC
71	end
72
73	local
74	open StringCvt
75
76	(*
77	* Given a char, if it is a digit in the appropriate base,
78	* convert it to a word. Otherwise, return NONE.
79	* Note, both a-f and A-F are accepted as hexadecimal digits.
80	*)
81	fun binDig (ch: char): W.word option =
82	case ch of
83	#"0" => SOME 0w0
84	\| #"1" => SOME 0w1
85	\| _ => NONE
86
87	local
88	val op <= = Char.<=
89	in
90	fun octDig (ch: char): W.word option =
91	if #"0" <= ch andalso ch <= #"7"
92	then SOME (W.fromInt (Int.- (Char.ord ch,
93	Char.ord #"0")))
94	else NONE
95
96	fun decDig (ch: char): W.word option =
97	if #"0" <= ch andalso ch <= #"9"
98	then SOME (W.fromInt (Int.- (Char.ord ch,
99	Char.ord #"0")))
100	else NONE
101
102	fun hexDig (ch: char): W.word option =
103	if #"0" <= ch andalso ch <= #"9"
104	then SOME (W.fromInt (Int.- (Char.ord ch,
105	Char.ord #"0")))
106	else if #"a" <= ch andalso ch <= #"f"
107	then SOME (W.fromInt (Int.- (Char.ord ch,
108	Int.- (Char.ord #"a", 0xa))))
109	else if #"A" <= ch andalso ch <= #"F"
110	then SOME (W.fromInt (Int.- (Char.ord ch,
111	Int.- (Char.ord #"A", 0xA))))
112	else NONE
113	end
114
115	(*
116	* Given a digit converter and a char reader, return a digit
117	* reader.
118	*)
119	fun toDigR (charToDig: char -> W.word option,
120	cread: (char, 'a) reader)
121	(s: 'a)
122	: (W.word * 'a) option =
123	case cread s of
124	NONE => NONE
125	\| SOME (ch, s') =>
126	case charToDig ch of
127	NONE => NONE
128	\| SOME dig => SOME (dig, s')
129
130	(*
131	* A chunk represents the result of processing some digits.
132	* more is a bool indicating if there might be more digits.
133	* shift is base raised to the number-of-digits-seen power.
134	* chunk is the value of the digits seen.
135	*)
136	type chunk = {more: bool,
137	shift: W.word,
138	chunk: W.word}
139	(*
140	* Given the base and a digit reader,
141	* return a chunk reader.
142	*)
143	fun toChunkR (base: W.word,
144	dread: (W.word, 'a) reader)
145	: (chunk, 'a) reader =
146	let
147	fun loop {left: Int32.int,
148	shift: W.word,
149	chunk: W.word,
150	s: 'a}
151	: chunk * 'a =
152	if Int32.<= (left, 0)
153	then ({more = true,
154	shift = shift,
155	chunk = chunk},
156	s)
157	else
158	case dread s of
159	NONE => ({more = false,
160	shift = shift,
161	chunk = chunk},
162	s)
163	\| SOME (dig, s') =>
164	loop {left = Int32.- (left, 1),
165	shift = W.* (base, shift),
166	chunk = W.+ (W.* (base, chunk), dig),
167	s = s'}
168	(* digitsPerChunk = floor((W.wordSize - 3) / (log2 base)) *)
169	val digitsPerChunk : Int32.t =
170	case (W.wordSize, base) of
171	(64, 0w16) => 15
172	\| (64, 0w10) => 18
173	\| (64, 0w8) => 20
174	\| (64, 0w2) => 61
175	\| (32, 0w16) => 7
176	\| (32, 0w10) => 8
177	\| (32, 0w8) => 9
178	\| (32, 0w2) => 29
179	\| _ => raise (Fail "IntInf.scan:digitsPerChunk")
180	fun reader (s: 'a): (chunk * 'a) option =
181	case dread s of
182	NONE => NONE
183	\| SOME (dig, next) =>
184	SOME (loop {left = Int32.- (digitsPerChunk, 1),
185	shift = base,
186	chunk = dig,
187	s = next})
188	in
189	reader
190	end
191
192	(*
193	* Given a chunk reader, return an unsigned reader.
194	*)
195	fun toUnsR (ckread: (chunk, 'a) reader): (int, 'a) reader =
196	let
197	fun loop (more: bool, acc: int, s: 'a) =
198	if more
199	then case ckread s of
200	NONE => (acc, s)
201	\| SOME ({more, shift, chunk}, s') =>
202	loop (more,
203	((W.toLargeInt shift) * acc)
204	+ (W.toLargeInt chunk),
205	s')
206	else (acc, s)
207	fun reader (s: 'a): (int * 'a) option =
208	case ckread s of
209	NONE => NONE
210	\| SOME ({more, chunk, ...}, s') =>
211	SOME (loop (more,
212	W.toLargeInt chunk,
213	s'))
214	in
215	reader
216	end
217
218	(*
219	* Given a char reader and an unsigned reader, return an unsigned
220	* reader that includes skipping the option hex '0x'.
221	*)
222	fun toHexR (cread: (char, 'a) reader, uread: (int, 'a) reader) s =
223	case cread s of
224	NONE => NONE
225	\| SOME (c1, s1) =>
226	if c1 = #"0" then
227	case cread s1 of
228	NONE => SOME (zero, s1)
229	\| SOME (c2, s2) =>
230	if c2 = #"x" orelse c2 = #"X" then
231	case uread s2 of
232	NONE => SOME (zero, s1)
233	\| SOME x => SOME x
234	else uread s
235	else uread s
236
237	(*
238	* Given a char reader and an unsigned reader, return a signed
239	* reader. This includes skipping any initial white space.
240	*)
241	fun toSign (cread: (char, 'a) reader, uread: (int, 'a) reader)
242	: (int, 'a) reader =
243	let
244	fun reader (s: 'a): (int * 'a) option =
245	let val s = StringCvt.skipWS cread s in
246	case cread s of
247	NONE => NONE
248	\| SOME (ch, s') =>
249	let
250	val (isNeg, s'') =
251	case ch of
252	#"+" => (false, s')
253	\| #"-" => (true, s')
254	\| #"~" => (true, s')
255	\| _ => (false, s)
256	in
257	if isNeg
258	then case uread s'' of
259	NONE => NONE
260	\| SOME (abs, s''') => SOME (~ abs, s''')
261	else uread s''
262	end
263	end
264	in
265	reader
266	end
267
268	(*
269	* Base-specific conversions from char readers to
270	* int readers.
271	*)
272	local
273	fun reader (base, dig)
274	(cread: (char, 'a) reader)
275	: (int, 'a) reader =
276	let
277	val dread = toDigR (dig, cread)
278	val ckread = toChunkR (base, dread)
279	val uread = toUnsR ckread
280	val hread = if base = 0w16 then toHexR (cread, uread) else uread
281	val reader = toSign (cread, hread)
282	in
283	reader
284	end
285	in
286	fun binReader z = reader (0w2, binDig) z
287	fun octReader z = reader (0w8, octDig) z
288	fun decReader z = reader (0w10, decDig) z
289	fun hexReader z = reader (0w16, hexDig) z
290	end
291	in
292	fun scan radix =
293	case radix of
294	BIN => binReader
295	\| OCT => octReader
296	\| DEC => decReader
297	\| HEX => hexReader
298	end
299
300	val fromString = StringCvt.scanString (scan StringCvt.DEC)
301
302	local
303	fun isEven (n: Int.int) = Int.andb (n, 0x1) = 0
304	in
305	fun pow (i: int, j: Int.int): int =
306	if Int.< (j, 0) then
307	if i = zero then
308	raise Div
309	else
310	if i = one then one
311	else if i = negOne then if isEven j then one else negOne
312	else zero
313	else
314	if j = 0 then one
315	else
316	let
317	fun square (n: int): int = n * n
318	(* pow (j) returns (i ^ j) *)
319	fun pow (j: Int.int): int =
320	if Int.<= (j, 0) then one
321	else if isEven j then evenPow j
322	else i * evenPow (Int.- (j, 1))
323	(* evenPow (j) returns (i ^ j), assuming j is even *)
324	and evenPow (j: Int.int): int =
325	square (pow (Int.div (j, 2)))
326	in
327	pow j
328	end
329	end
330
331	val log2 =
332	mkLog2 {fromSmall = fn {smallLog2} => Int32.toInt smallLog2,
333	fromLarge = fn {numLimbsMinusOne, mostSigLimbLog2} =>
334	Int.+ (Int.* (MPLimb.wordSize, SeqIndex.toInt numLimbsMinusOne),
335	Int32.toInt mostSigLimbLog2)}
336	end