[MLton-commit] r6299
Vesa Karvonen
vesak at mlton.org
Fri Jan 4 00:43:53 PST 2008
Refactored to perform more operations via ops.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/util/ops.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/util/ops.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/util/ops.sml 2008-01-03 08:42:40 UTC (rev 6298)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/util/ops.sml 2008-01-04 08:43:50 UTC (rev 6299)
@@ -5,30 +5,37 @@
*)
structure Ops = struct
- datatype 'a wops =
- W of {<< : 'a ShiftOp.t,
- >> : 'a ShiftOp.t,
- isoWord8 : ('a, Word8.t) Iso.t,
- isoWord8X : ('a, Word8.t) Iso.t,
- orb : 'a BinOp.t,
+ datatype 'word w =
+ W of {<< : 'word ShiftOp.t,
+ >> : 'word ShiftOp.t,
+ compare : 'word Cmp.t,
+ isoLargeInt : ('word, LargeInt.t) Iso.t,
+ isoWord : ('word, Word.t) Iso.t,
+ isoWord8 : ('word, Word8.t) Iso.t,
+ isoWord8X : ('word, Word8.t) Iso.t,
+ mod : 'word BinOp.t,
+ orb : 'word BinOp.t,
wordSize : Int.t,
- ~>> : 'a ShiftOp.t}
+ ~>> : 'word ShiftOp.t}
- datatype 'a iops =
- I of {*` : 'a BinOp.t,
- +` : 'a BinOp.t,
- div : 'a BinOp.t,
- fromInt : Int.t -> 'a,
- maxInt : 'a Option.t,
- mod : 'a BinOp.t,
+ datatype 'int i =
+ I of {*` : 'int BinOp.t,
+ +` : 'int BinOp.t,
+ div : 'int BinOp.t,
+ isoInt : ('int, Int.t) Iso.t,
+ isoLarge : ('int, LargeInt.t) Iso.t,
+ maxInt : 'int Option.t,
+ mod : 'int BinOp.t,
precision : Int.t Option.t}
- datatype 'a rops =
- R of {bytesPerElem : Int.t,
- subArr : Word8Array.t * Int.t -> 'a,
- toBytes : 'a -> Word8Vector.t}
+ datatype ('real, 'word) r =
+ R of {bitsOps : 'word w,
+ bytesPerElem : Int.t,
+ isoBits : ('real, 'word) Iso.t Option.t,
+ subArr : Word8Array.t * Int.t -> 'real,
+ toBytes : 'real -> Word8Vector.t}
- datatype ('elem, 'list, 'result, 'seq, 'slice) sops =
+ datatype ('elem, 'list, 'result, 'seq, 'slice) s =
S of {foldl : ('elem * 'result -> 'result) -> 'result -> 'seq -> 'result,
fromList : 'list -> 'seq,
getItem : 'slice -> ('elem * 'slice) Option.t,
@@ -39,7 +46,9 @@
functor MkWordOps (include WORD) = struct
val ops = Ops.W {wordSize = wordSize, orb = op orb, << = op <<, ~>> = op ~>>,
- >> = op >>, isoWord8 = isoWord8, isoWord8X = isoWord8X}
+ >> = op >>, isoLargeInt = isoLargeInt, isoWord = isoWord,
+ isoWord8 = isoWord8, isoWord8X = isoWord8X, mod = op mod,
+ compare = compare}
end
structure LargeRealWordOps = MkWordOps (CastLargeReal.Bits)
@@ -53,21 +62,25 @@
structure Word8Ops = MkWordOps (Word8)
functor MkIntOps (include INTEGER) = struct
- val ops = Ops.I {precision = precision, maxInt = maxInt, fromInt = fromInt,
- *` = op *, +` = op +, div = op div, mod = op mod}
+ val ops = Ops.I {precision = precision, maxInt = maxInt, isoInt = isoInt,
+ isoLarge = isoLarge, *` = op *, +` = op +, div = op div,
+ mod = op mod}
end
structure FixedIntOps = MkIntOps (FixedInt)
structure IntOps = MkIntOps (Int)
structure LargeIntOps = MkIntOps (LargeInt)
-functor MkRealOps (include PACK_REAL) = struct
- val ops = Ops.R {bytesPerElem = bytesPerElem, subArr = subArr,
- toBytes = toBytes}
+functor MkRealOps (include CAST_REAL PACK_REAL
+ val ops : Bits.t Ops.w
+ sharing type t = real) = struct
+ val ops = Ops.R {bitsOps = ops, bytesPerElem = bytesPerElem,
+ isoBits = isoBits, subArr = subArr, toBytes = toBytes}
end
-structure PackRealLittleOps = MkRealOps (PackRealLittle)
-structure PackLargeRealLittleOps = MkRealOps (PackLargeRealLittle)
+structure RealOps = MkRealOps (open CastReal PackRealLittle RealWordOps)
+structure LargeRealOps =
+ MkRealOps (open CastLargeReal PackLargeRealLittle LargeRealWordOps)
functor MkSeqOps (structure Seq : sig
type 'a t
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2008-01-03 08:42:40 UTC (rev 6298)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2008-01-04 08:43:50 UTC (rev 6299)
@@ -29,7 +29,7 @@
datatype 'a t = IN of {gen : 'a G.t, cog : 'a -> Univ.t G.t UnOp.t}
fun out (IN r) = r
- fun mkInt precision fromLarge aT = let
+ fun mkInt (Ops.I {precision, isoLarge = (_, fromLarge), ...}) aT = let
fun gen n =
map (fn i => fromLarge (i - IntInf.<< (1, Word.fromInt n - 0w1)))
(G.bits n)
@@ -44,7 +44,7 @@
IN {gen = G.sized ((fn r => map fromReal (G.realInRange (~r,r))) o real),
cog = G.variant o Arg.hash (aT ())}
- fun mkWord wordSize fromLargeInt aT =
+ fun mkWord (Ops.W {wordSize, isoLargeInt = (_, fromLargeInt), ...}) aT =
IN {gen = map fromLargeInt (G.bits wordSize),
cog = G.variant o Arg.hash (aT ())}
@@ -135,27 +135,24 @@
fun refc a = iso' (getT a) (!, ref)
- val fixedInt =
- mkInt FixedInt.precision FixedInt.fromLarge Arg.Open.fixedInt
- val largeInt =
- mkInt LargeInt.precision LargeInt.fromLarge Arg.Open.largeInt
+ val fixedInt = mkInt FixedIntOps.ops Arg.Open.fixedInt
+ val largeInt = mkInt LargeIntOps.ops Arg.Open.largeInt
- val largeWord =
- mkWord LargeWord.wordSize LargeWord.fromLargeInt Arg.Open.largeWord
+ val largeWord = mkWord LargeWordOps.ops Arg.Open.largeWord
val largeReal = mkReal R.toLarge Arg.Open.largeReal
val bool = IN {gen = G.bool, cog = G.variant o W.fromInt o Bool.toInt}
val char = IN {gen = map Byte.byteToChar G.word8,
cog = G.variant o Word8.toWord o Byte.charToByte}
- val int = mkInt Int.precision Int.fromLarge Arg.Open.int
+ val int = mkInt IntOps.ops Arg.Open.int
val real = mkReal id Arg.Open.real
val string = iso' (list' char) String.isoList
val word = IN {gen = G.lift G.RNG.value, cog = G.variant}
val word8 = IN {gen = G.word8, cog = G.variant o Word8.toWord}
- val word32 = mkWord Word32.wordSize Word32.fromLargeInt Arg.Open.word32
+ val word32 = mkWord Word32Ops.ops Arg.Open.word32
(*
- val word64 = mkWord Word64.wordSize Word64.fromLargeInt Arg.Open.word64
+ val word64 = mkWord Word64Ops.ops Arg.Open.word64
*)
fun hole () = IN {gen = G.lift undefined, cog = undefined}
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2008-01-03 08:42:40 UTC (rev 6298)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2008-01-04 08:43:50 UTC (rev 6299)
@@ -25,10 +25,9 @@
fun iso b (a2b, _) = BinPr.map a2b b
- fun mkReal isoBits toBytes =
- case isoBits
- of SOME isoBits => iso op = isoBits
- | NONE => iso op = (toBytes, undefined)
+ val mkReal =
+ fn Ops.R {isoBits = SOME isoBits, ...} => iso op = isoBits
+ | Ops.R {toBytes, ...} => iso op = (toBytes, undefined)
val exnHandler : Exn.t BinPr.t Ref.t = ref GenericsUtil.failExnSq
fun regExn t (_, e2to) =
@@ -82,13 +81,13 @@
val fixedInt = op = : FixedInt.t t
val largeInt = op = : LargeInt.t t
- val largeReal = mkReal CastLargeReal.isoBits PackLargeRealLittle.toBytes
+ val largeReal = mkReal LargeRealOps.ops
val largeWord = op = : LargeWord.t t
val bool = op = : Bool.t t
val char = op = : Char.t t
val int = op = : Int.t t
- val real = mkReal CastReal.isoBits PackRealLittle.toBytes
+ val real = mkReal RealOps.ops
val string = op = : String.t t
val word = op = : Word.t t
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2008-01-03 08:42:40 UTC (rev 6298)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2008-01-04 08:43:50 UTC (rev 6299)
@@ -38,13 +38,14 @@
end
end
- fun mkReal isoBits op mod isoWord toBytes =
- case isoBits
- of SOME (toBits, _) => viaWord toBits op mod isoWord
- | NONE =>
- prim (Word8Vector.foldl
- (fn (w, h) => h * 0wxFB + Word8.toWord w)
- 0w0 o toBytes)
+ val mkReal =
+ fn Ops.R {isoBits = SOME (toBits, _),
+ bitsOps = Ops.W {isoWord, mod, ...}, ...} =>
+ viaWord toBits op mod isoWord
+ | Ops.R {toBytes, ...} =>
+ prim (Word8Vector.foldl
+ (fn (w, h) => h * 0wxFB + Word8.toWord w)
+ 0w0 o toBytes)
val exns : (Exn.t * p -> Word.t Option.t) Buffer.t = Buffer.new ()
@@ -170,15 +171,13 @@
| SOME v => SOME (Word.xorb (c, t (v, p))))
val bool = prim (fn true => 0wx096DB16D | false => 0wx01B56B6D)
- val real = mkReal CastReal.isoBits CastReal.Bits.mod CastReal.Bits.isoWord
- PackRealLittle.toBytes
+ val real = mkReal RealOps.ops
val word = prim id
val fixedInt = viaWord id op mod (Iso.swap Word.isoFixedInt)
val largeInt = viaWord id op mod (Iso.swap Word.isoLargeInt)
- val largeReal = mkReal CastLargeReal.isoBits CastLargeReal.Bits.mod
- CastLargeReal.Bits.isoWord PackRealLittle.toBytes
+ val largeReal = mkReal LargeRealOps.ops
val largeWord = viaWord id op mod LargeWord.isoWord
val word8 = prim Word8.toWord
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2008-01-03 08:42:40 UTC (rev 6298)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2008-01-04 08:43:50 UTC (rev 6299)
@@ -17,10 +17,11 @@
fun iso' (IN bX) (a2b, _) = IN (fn (e, bp) => bX (e, Sq.map a2b bp))
- fun mkReal isoBits compare toBytes =
- case isoBits
- of SOME isoBits => iso' (lift compare) isoBits
- | NONE => lift (Cmp.map toBytes (Word8Vector.collate Word8.compare))
+ val mkReal =
+ fn Ops.R {isoBits = SOME isoBits, bitsOps = Ops.W {compare, ...}, ...} =>
+ iso' (lift compare) isoBits
+ | Ops.R {toBytes, ...} =>
+ lift (Cmp.map toBytes (Word8Vector.collate Word8.compare))
fun sequ (Ops.S {toSlice, getItem, ...}) (IN aO) =
IN (fn (e, (l, r)) => let
@@ -132,13 +133,11 @@
val largeInt = lift LargeInt.compare
val largeWord = lift LargeWord.compare
- val largeReal = mkReal CastLargeReal.isoBits CastLargeReal.Bits.compare
- PackLargeRealBig.toBytes
+ val largeReal = mkReal LargeRealOps.ops
val bool = lift Bool.compare
val char = lift Char.compare
val int = lift Int.compare
- val real = mkReal CastLargeReal.isoBits CastLargeReal.Bits.compare
- PackRealBig.toBytes
+ val real = mkReal RealOps.ops
val string = lift String.compare
val word = lift Word.compare
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2008-01-03 08:42:40 UTC (rev 6298)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2008-01-04 08:43:50 UTC (rev 6299)
@@ -259,12 +259,12 @@
end,
sz = SOME bytesPerElem}
- fun mkReal isoBits
- (bitOps as Ops.W {wordSize, ...})
- (packOps as Ops.R {bytesPerElem, ...}) =
- case isoBits
- of SOME isoBits => sized wordSize (bits bitOps isoBits)
- | NONE => sized (bytesPerElem * 8) (bytesAsBits packOps)
+ val mkReal =
+ fn Ops.R {isoBits = SOME isoBits,
+ bitsOps = bitsOps as Ops.W {wordSize, ...}, ...} =>
+ sized wordSize (bits bitsOps isoBits)
+ | packOps as Ops.R {bytesPerElem, ...} =>
+ sized (bytesPerElem * 8) (bytesAsBits packOps)
(* Encodes fixed size int as a size followed by little endian bytes. *)
fun mkFixedInt (Ops.W {orb, <<, ~>>, isoWord8 = (toW8, fromW8),
@@ -693,13 +693,11 @@
else if isSome Int.precision
then iso' fixedInt Int.isoFixedInt
else iso' largeInt Int.isoLargeInt
- val real = mkReal CastReal.isoBits RealWordOps.ops PackRealLittleOps.ops
+ val real = mkReal RealOps.ops
val string = string
val word = mkFixedInt WordOps.ops Iso.id
- val largeReal = mkReal CastLargeReal.isoBits
- LargeRealWordOps.ops
- PackLargeRealLittleOps.ops
+ val largeReal = mkReal LargeRealOps.ops
val largeWord = mkFixedInt LargeWordOps.ops Iso.id
val word8 = word8
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2008-01-03 08:42:40 UTC (rev 6298)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2008-01-04 08:43:50 UTC (rev 6299)
@@ -55,10 +55,9 @@
fun iso' (IN bE) (a2b, _) = IN (fn (e, bp) => bE (e, Sq.map a2b bp))
- fun mkReal isoBits toBytes =
- case isoBits
- of SOME isoBits => iso' (lift op =) isoBits
- | NONE => iso' (lift op =) (toBytes, undefined)
+ val mkReal =
+ fn Ops.R {isoBits = SOME isoBits, ...} => iso' (lift op =) isoBits
+ | Ops.R {toBytes, ...} => iso' (lift op =) (toBytes, undefined)
structure SeqRep = LayerRep
(open Arg
@@ -125,12 +124,12 @@
val largeInt = lift op = : LargeInt.t t
val largeWord = lift op = : LargeWord.t t
- val largeReal = mkReal CastLargeReal.isoBits PackLargeRealLittle.toBytes
+ val largeReal = mkReal LargeRealOps.ops
val bool = lift op = : Bool.t t
val char = lift op = : Char.t t
val int = lift op = : Int.t t
- val real = mkReal CastReal.isoBits PackRealLittle.toBytes
+ val real = mkReal RealOps.ops
val string = lift op = : String.t t
val word = lift op = : Word.t t
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml 2008-01-03 08:42:40 UTC (rev 6298)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml 2008-01-04 08:43:50 UTC (rev 6299)
@@ -37,7 +37,8 @@
IN {kids = fn (_, e, _) => e,
shrink = fn _ => []}
- fun mkInt (Ops.I {precision, fromInt, maxInt, +`, *`, div, mod, ...}) =
+ fun mkInt (Ops.I {precision, isoInt = (_, fromInt), maxInt, +`, *`, div, mod,
+ ...}) =
if isSome precision
then IN {kids = fn (_, e, _) => e,
shrink = fn i => let
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml 2008-01-03 08:42:40 UTC (rev 6298)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml 2008-01-04 08:43:50 UTC (rev 6299)
@@ -17,7 +17,7 @@
| DYNAMIC of e * 'a -> Int.t
val sz =
- fn STATIC s => const s
+ fn STATIC s => const s
| DYNAMIC f => f
fun bytes i = Word.toInt (Word.>> (Word.fromInt i + 0w7, 0w3))
@@ -44,11 +44,12 @@
fun intSize toLarge i =
bytes (IntInf.log2 (abs (toLarge i) + 1))
- fun mkInt toLarge =
- fn SOME prec => STATIC (bytes prec)
- | NONE => DYNAMIC (intSize toLarge o #2)
+ val mkInt =
+ fn Ops.I {precision = SOME prec, ...} => STATIC (bytes prec)
+ | Ops.I {isoLarge = (toLarge, _), ...} => DYNAMIC (intSize toLarge o #2)
- fun mkWord wordSize = STATIC (bytes wordSize)
+ fun mkWord (Ops.W w : 'w Ops.w) : 'w t = STATIC (bytes (#wordSize w))
+ fun mkReal (Ops.R r : ('r, 'w) Ops.r) : 'r t = STATIC (#bytesPerElem r)
val iso' =
fn STATIC s => const (STATIC s)
@@ -146,26 +147,26 @@
fun refc xT =
cyclic (Arg.Open.refc ignore xT)
(case getT xT
- of STATIC s => const (s + wordSize)
+ of STATIC s => const (s + wordSize)
| DYNAMIC f => fn (e, x) => wordSize + f (e, !x))
- val fixedInt = mkInt FixedInt.toLarge FixedInt.precision
- val largeInt = mkInt LargeInt.toLarge LargeInt.precision
+ val fixedInt = mkInt FixedIntOps.ops
+ val largeInt = mkInt LargeIntOps.ops
- val largeReal = mkWord CastLargeReal.Bits.wordSize : LargeReal.t t
- val largeWord = mkWord LargeWord.wordSize : LargeWord.t t
+ val largeReal = mkReal LargeRealOps.ops
+ val largeWord = mkWord LargeWordOps.ops
val bool = STATIC 1
val char = STATIC 1
- val int = mkInt Int.toLarge Int.precision
- val real = mkWord CastReal.Bits.wordSize : Real.t t
+ val int = mkInt IntOps.ops
+ val real = mkReal RealOps.ops
val string = DYNAMIC (fn (_, s) => size s + 2 * wordSize)
- val word = mkWord Word.wordSize : Word.t t
+ val word = mkWord WordOps.ops
- val word8 = mkWord Word8.wordSize : Word8.t t
- val word32 = mkWord Word32.wordSize : Word32.t t
+ val word8 = mkWord Word8Ops.ops
+ val word32 = mkWord Word32Ops.ops
(*
- val word64 = mkWord Word64.wordSize : Word64.t t
+ val word64 = mkWord Word64Ops.ops
*)
fun hole () = DYNAMIC undefined
More information about the MLton-commit
mailing list