[MLton-commit] r6063
Vesa Karvonen
vesak at mlton.org
Sat Oct 6 14:29:36 PDT 2007
Simple shrinking of non-IntInf integers and words.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
A mltonlib/trunk/com/ssh/generic/unstable/detail/ops.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-10-06 21:27:10 UTC (rev 6062)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-10-06 21:29:35 UTC (rev 6063)
@@ -47,6 +47,7 @@
../../hash-univ.sml
../../layer-generic.fun
../../mk-closed-rep.fun
+ ../../ops.sml
../../opt-int.sml
../../reg-basis-exns.fun
../../root-generic.sml
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/ops.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ops.sml 2007-10-06 21:27:10 UTC (rev 6062)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ops.sml 2007-10-06 21:29:35 UTC (rev 6063)
@@ -0,0 +1,61 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+structure Ops = struct
+ datatype 'a wops =
+ W of {wordSize : Int.t,
+ orb : 'a BinOp.t,
+ << : 'a ShiftOp.t,
+ ~>> : 'a ShiftOp.t,
+ >> : 'a ShiftOp.t,
+ isoWord8 : ('a, Word8.t) Iso.t,
+ isoWord8X : ('a, Word8.t) Iso.t}
+
+ datatype 'a iops =
+ I of {precision : Int.t Option.t,
+ maxInt : 'a Option.t,
+ fromInt : Int.t -> 'a,
+ *` : 'a BinOp.t,
+ +` : 'a BinOp.t,
+ div : 'a BinOp.t,
+ mod : 'a BinOp.t}
+end
+
+functor MkWordOps (Arg : WORD) = struct
+ local
+ open Arg
+ in
+ val ops =
+ Ops.W {wordSize = wordSize, orb = op orb,
+ << = op <<, ~>> = op ~>>, >> = op >>,
+ isoWord8 = isoWord8, isoWord8X = isoWord8X}
+ end
+end
+
+structure LargeRealWordOps = MkWordOps (CastLargeReal.Bits)
+structure LargeWordOps = MkWordOps (LargeWord)
+structure RealWordOps = MkWordOps (CastReal.Bits)
+structure WordOps = MkWordOps (Word)
+structure Word32Ops = MkWordOps (Word32)
+structure Word64Ops = MkWordOps (Word64)
+structure Word8Ops = MkWordOps (Word8)
+
+functor MkIntOps (Arg : INTEGER) = struct
+ local
+ open Arg
+ in
+ val ops =
+ Ops.I {precision = precision,
+ maxInt = maxInt,
+ fromInt = fromInt,
+ *` = op *, +` = op +,
+ div = op div, mod = op mod}
+ end
+end
+
+structure FixedIntOps = MkIntOps (FixedInt)
+structure IntOps = MkIntOps (Int)
+structure LargeIntOps = MkIntOps (LargeInt)
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/ops.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2007-10-06 21:27:10 UTC (rev 6062)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2007-10-06 21:29:35 UTC (rev 6063)
@@ -75,22 +75,6 @@
(************************************************************************)
-datatype 'a ops =
- OPS of {wordSize : Int.t,
- orb : 'a BinOp.t,
- << : 'a ShiftOp.t,
- ~>> : 'a ShiftOp.t,
- isoWord8 : ('a, Word8.t) Iso.t,
- isoWord8X : ('a, Word8.t) Iso.t}
-
-functor WordWithOps (Arg : WORD) = struct
- open Arg
- val ops = OPS {wordSize = wordSize, orb = op orb, << = op <<, ~>> = op ~>>,
- isoWord8 = isoWord8, isoWord8X = isoWord8X}
-end
-
-(************************************************************************)
-
functor WithPickle (Arg : WITH_PICKLE_DOM) : PICKLE_CASES = struct
(* <-- SML/NJ workaround *)
open TopLevel
@@ -110,13 +94,6 @@
infixr 0 -->
(* SML/NJ workaround --> *)
- structure Word = WordWithOps (Word)
- structure Word32 = WordWithOps (Word32)
- structure Word64 = WordWithOps (Word64)
- structure LargeWord = WordWithOps (LargeWord)
- structure LargeRealWord = WordWithOps (CastLargeReal.Bits)
- structure RealWord = WordWithOps (CastReal.Bits)
-
structure Dyn = HashUniv
structure I = let
@@ -219,7 +196,7 @@
(* Encodes either 8, 16, 32, or 64 bits of data and an optional size. *)
fun bits sized
- (OPS {wordSize = n, orb, <<, ~>>, isoWord8 = (toW8, fromW8), ...})
+ (Ops.W {wordSize = n, orb, <<, ~>>, isoWord8 = (toW8, fromW8), ...})
(toBits, fromBits) = let
fun alts ` op o =
if n <= 8 then `0w0
@@ -252,11 +229,11 @@
sz = SOME ((n + 7) div 8 + Bool.toInt sized)}
end
- val word32 = bits false Word32.ops Iso.id
+ val word32 = bits false Word32Ops.ops Iso.id
(* Encodes fixed size int as a size followed by little endian bytes. *)
- fun mkFixedInt (OPS {orb, <<, ~>>, isoWord8 = (toW8, fromW8),
- isoWord8X = (_, fromW8X), ...})
+ fun mkFixedInt (Ops.W {orb, <<, ~>>, isoWord8 = (toW8, fromW8),
+ isoWord8X = (_, fromW8X), ...})
(fromBitsX, toBits) =
P {rd = let
open I
@@ -292,7 +269,7 @@
val () = if LargeWord.wordSize < valOf FixedInt.precision
then fail "LargeWord can't hold a FixedInt"
else ()
- val fixedInt = mkFixedInt LargeWord.ops LargeWord.isoFixedIntX
+ val fixedInt = mkFixedInt LargeWordOps.ops LargeWord.isoFixedIntX
fun cyclic {readProxy, readBody, writeWhole, self} = let
val (toDyn, fromDyn) = Dyn.new {eq = Arg.eq self, hash = Arg.hash self}
@@ -657,20 +634,20 @@
val bool = iso' char (swap Char.isoInt <--> Bool.isoInt)
val int =
if case Int.precision of NONE => false | SOME n => n <= Word.wordSize
- then mkFixedInt Word.ops Word.isoIntX
+ then mkFixedInt WordOps.ops Word.isoIntX
else if isSome Int.precision
then iso' fixedInt Int.isoFixedInt
else iso' largeInt Int.isoLargeInt
- val real = bits true RealWord.ops CastReal.isoBits
+ val real = bits true RealWordOps.ops CastReal.isoBits
val string = string
- val word = mkFixedInt Word.ops Iso.id
+ val word = mkFixedInt WordOps.ops Iso.id
- val largeReal = bits true LargeRealWord.ops CastLargeReal.isoBits
- val largeWord = mkFixedInt LargeWord.ops Iso.id
+ val largeReal = bits true LargeRealWordOps.ops CastLargeReal.isoBits
+ val largeWord = mkFixedInt LargeWordOps.ops Iso.id
val word8 = word8
val word32 = word32
- val word64 = bits false Word64.ops Iso.id
+ val word64 = bits false Word64Ops.ops Iso.id
open Arg PickleRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml 2007-10-06 21:27:10 UTC (rev 6062)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml 2007-10-06 21:29:35 UTC (rev 6063)
@@ -7,6 +7,9 @@
functor WithShrink (Arg : WITH_SHRINK_DOM) : SHRINK_CASES = struct
(* <-- SML/NJ workaround *)
open TopLevel
+ infix 7 >> << *`
+ infix 6 +`
+ infix 4 orb
infix 0 &
(* SML/NJ workaround --> *)
@@ -34,6 +37,41 @@
IN {kids = fn (_, e, _) => e,
shrink = fn _ => []}
+ fun mkInt (Ops.I {precision, fromInt, maxInt, +`, *`, div, mod, ...}) =
+ if isSome precision
+ then IN {kids = fn (_, e, _) => e,
+ shrink = fn i => let
+ val m = valOf maxInt div fromInt 2 +` fromInt 1
+ fun lp (d, is) = let
+ val h = (i div d) div fromInt 2 *` d
+ val l = i mod d
+ val i' = h+`l
+ in
+ if i' = i then is
+ else if d = m then i'::is
+ else lp (d *` fromInt 2, i'::is)
+ end
+ in
+ lp (fromInt 1, [])
+ end}
+ else none
+
+ fun mkWord (Ops.W {wordSize, <<, >>, orb, ...}) =
+ IN {kids = fn (_, e, _) => e,
+ shrink = fn w => let
+ fun lp (s, ws) =
+ if s = Word.fromInt wordSize then ws else let
+ val h = (w >> (s + 0w1)) << s
+ val s' = Word.fromInt wordSize - s
+ val l = (w << s') >> s'
+ val w' = h orb l
+ in
+ if w' = w then ws else lp (s+0w1, w'::ws)
+ end
+ in
+ lp (0w0, [])
+ end}
+
structure ShrinkRep = LayerRep
(open Arg
structure Rep = MkClosedRep (type 'a t = 'a t))
@@ -142,22 +180,22 @@
fun refc _ = none
- val fixedInt = none
- val largeInt = none
+ val fixedInt = mkInt FixedIntOps.ops
+ val largeInt = mkInt LargeIntOps.ops
val largeReal = none
- val largeWord = none
+ val largeWord = mkWord LargeWordOps.ops
val bool = none
val char = none
- val int = none
+ val int = mkInt IntOps.ops
val real = none
val string = iso' (list' char) String.isoList
- val word = none
+ val word = mkWord WordOps.ops
- val word8 = none
- val word32 = none
- val word64 = none
+ val word8 = mkWord Word8Ops.ops
+ val word32 = mkWord Word32Ops.ops
+ val word64 = mkWord Word64Ops.ops
open Arg ShrinkRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-10-06 21:27:10 UTC (rev 6062)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-10-06 21:29:35 UTC (rev 6063)
@@ -48,6 +48,8 @@
public/generics-util.sig
detail/generics-util.sml
+ detail/ops.sml
+
detail/mk-closed-rep.fun
detail/opt-int.sml (* XXX Should really go to Extended Basis? *)
More information about the MLton-commit
mailing list