[MLton-commit] r5824
Vesa Karvonen
vesak at mlton.org
Sun Aug 5 05:21:25 PDT 2007
Allow users to provide an ad-hoc case for Ord. Changed compare -> ord, to
avoid overlap with compare. Express Real <-> Word casts as an isomorphism
Real <-> Bits.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/common/cast-real.sig
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlton/cast-real.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/cast-real.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/public/value/ord.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/common/cast-real.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/common/cast-real.sig 2007-08-05 12:15:49 UTC (rev 5823)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/common/cast-real.sig 2007-08-05 12:21:24 UTC (rev 5824)
@@ -6,7 +6,6 @@
signature CAST_REAL = sig
type t
- structure Word : WORD
- val castToWord : t -> Word.t
- val castFromWord : Word.t -> t
+ structure Bits : WORD
+ val isoBits : (t, Bits.t) Iso.t
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlton/cast-real.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlton/cast-real.sml 2007-08-05 12:15:49 UTC (rev 5823)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlton/cast-real.sml 2007-08-05 12:21:24 UTC (rev 5824)
@@ -6,7 +6,8 @@
structure CastReal : CAST_REAL where type t = Real.t = struct
open Real64 MLton.Real64
- structure Word = Word64
+ structure Bits = Word64
+ val isoBits = (castToWord, castFromWord)
end
structure CastLargeReal : CAST_REAL where type t = LargeReal.t = CastReal
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/cast-real.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/cast-real.sml 2007-08-05 12:15:49 UTC (rev 5823)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/cast-real.sml 2007-08-05 12:21:24 UTC (rev 5824)
@@ -6,7 +6,7 @@
structure CastReal : CAST_REAL where type t = Real.t = struct
type t = Real64.t
- structure Word = Word64
+ structure Bits = Word64
local
fun cast {size=sizeF, set=setF, get=_ }
{size=sizeT, set=_, get=getT} =
@@ -28,8 +28,7 @@
set = C.Set.double',
get = C.Get.double'}
in
- val castToWord = cast real64 word64
- val castFromWord = cast word64 real64
+ val isoBits = (cast real64 word64, cast word64 real64)
end
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-08-05 12:15:49 UTC (rev 5823)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-08-05 12:21:24 UTC (rev 5824)
@@ -23,15 +23,15 @@
lL = lR andalso lp lL
end
- fun viaCast cast = BinPr.map cast op =
-
structure Eq =
LayerGenericRep (structure Outer = Arg.Rep
structure Closed = MkClosedGenericRep (BinPr))
- val eq = Eq.This.getT
+ open Eq.This
+
+ val eq = getT
fun notEq t = not o eq t
- fun withEq eq = Eq.This.mapT (const eq)
+ fun withEq eq = mapT (const eq)
structure Layered = LayerGeneric
(structure Outer = Arg and Result = Eq and Rep = Eq.Closed
@@ -74,13 +74,13 @@
fun refc _ = op =
val largeInt = op =
- val largeReal = viaCast CastLargeReal.castToWord
+ val largeReal = iso op = CastLargeReal.isoBits
val largeWord = op =
val bool = op =
val char = op =
val int = op =
- val real = viaCast CastReal.castToWord
+ val real = iso op = CastReal.isoBits
val string = op =
val word = op =
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2007-08-05 12:15:49 UTC (rev 5823)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2007-08-05 12:21:24 UTC (rev 5824)
@@ -14,6 +14,11 @@
fun prim f : 'a t = const o f
+ fun viaWord x2V op mod (v2w, w2v) =
+ prim (fn x => v2w (x2V x mod w2v Word.largestPrime))
+
+ fun iso' bH (a2b, _) = bH o a2b
+
structure Hash =
LayerGenericRep (structure Outer = Arg.Rep
structure Closed = MkClosedGenericRep (type 'a t = 'a t))
@@ -30,7 +35,6 @@
structure Layered = LayerDepGeneric
(structure Outer = Arg and Result = Hash
- fun iso' bH (a2b, _) = bH o a2b
fun iso ? = iso' (getT ?)
fun isoProduct ? = iso' (getP ?)
fun isoSum ? = iso' (getS ?)
@@ -75,14 +79,18 @@
val m = Int.quot (totWidth, 2)
fun len n [] = n
| len n (_::xs) = if m <= n then n else len (n+1) xs
- val n = len 0 xs
- val p = {totWidth = Int.quot (totWidth, n),
- maxDepth = maxDepth - 1}
- fun lp h _ [] = h
- | lp h n (x::xs) =
- if n = 0 then h else lp (h * 0w17 + getT xT x p) (n-1) xs
in
- lp (Word.fromInt n) n xs
+ case len 0 xs of
+ 0 => 0wx2A4C7A
+ | n => let
+ val p = {totWidth = Int.quot (totWidth, n),
+ maxDepth = maxDepth - 1}
+ fun lp h _ [] = h
+ | lp h n (x::xs) =
+ if n = 0 then h else lp (h * 0w17 + getT xT x p) (n-1) xs
+ in
+ lp (Word.fromInt n) n xs
+ end
end
fun hashSeq length sub hashElem s {totWidth, maxDepth} = let
@@ -111,22 +119,18 @@
fun regExn _ _ = ()
val bool = prim (fn true => 0wx2DA745 | false => 0wx3C24A62)
+ val real =
+ let open CastReal in viaWord (#1 isoBits) op mod Bits.isoWord end
val word = const
- fun mk x2V op mod (v2w, w2v) =
- prim (fn x => v2w (x2V x mod w2v Word.largestPrime))
-
- val largeInt = mk id op mod (Iso.swap Word.isoLargeInt)
- val largeWord = mk id op mod LargeWord.isoWord
-
+ val largeInt = viaWord id op mod (Iso.swap Word.isoLargeInt)
val largeReal =
- let open CastLargeReal open Word in mk castToWord op mod isoWord end
- val real =
- let open CastReal open Word in mk castToWord op mod isoWord end
+ let open CastLargeReal in viaWord (#1 isoBits) op mod Bits.isoWord end
+ val largeWord = viaWord id op mod LargeWord.isoWord
val word8 = prim Word8.toWord
val word32 = prim Word32.toWord
- val word64 = mk id op mod Word64.isoWord)
+ val word64 = viaWord id op mod Word64.isoWord)
open Layered
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-08-05 12:15:49 UTC (rev 5823)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-08-05 12:21:24 UTC (rev 5824)
@@ -14,8 +14,11 @@
LayerGenericRep (structure Outer = Arg.Rep
structure Closed = MkClosedGenericRep (Cmp))
- val compare = Ord.This.getT
+ open Ord.This
+ val ord = getT
+ fun withOrd cmp = mapT (const cmp)
+
structure Layered = LayerGeneric
(structure Outer = Arg and Result = Ord and Rep = Ord.Closed
@@ -37,18 +40,17 @@
val Y = Tie.function
- fun op --> _ = failing "Compare.--> unsupported"
+ fun op --> _ = failing "Ord.--> unsupported"
val exns : (Exn.t Sq.t -> Order.t Option.t) Buffer.t = Buffer.new ()
fun exn lr =
recur 0 (fn lp =>
fn i =>
- if i = Buffer.length exns then
- GenericsUtil.failExnSq lr
- else
- case Buffer.sub (exns, i) lr of
- SOME r => r
- | NONE => lp (i+1))
+ if i = Buffer.length exns
+ then GenericsUtil.failExnSq lr
+ else case Buffer.sub (exns, i) lr of
+ SOME r => r
+ | NONE => lp (i+1))
fun regExn cA (_, e2a) =
(Buffer.push exns)
(fn (l, r) =>
@@ -58,25 +60,23 @@
| NONE & SOME _ => SOME LESS
| NONE & NONE => NONE)
+ val array = Array.collate
val list = List.collate
- val array = Array.collate
val vector = Vector.collate
fun refc t = Cmp.map ! t
+ val largeInt = LargeInt.compare
+ val largeWord = LargeWord.compare
+ val largeReal = iso CastLargeReal.Bits.compare CastLargeReal.isoBits
+
val bool = Bool.compare
val char = Char.compare
val int = Int.compare
+ val real = iso CastReal.Bits.compare CastReal.isoBits
val string = String.compare
val word = Word.compare
- val largeInt = LargeInt.compare
- val largeWord = LargeWord.compare
-
- fun mk cast = Cmp.map cast
- val largeReal = mk CastLargeReal.castToWord CastLargeReal.Word.compare
- val real = mk CastReal.castToWord CastReal.Word.compare
-
val word8 = Word8.compare
val word32 = Word32.compare
val word64 = Word64.compare)
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig 2007-08-05 12:15:49 UTC (rev 5823)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig 2007-08-05 12:21:24 UTC (rev 5824)
@@ -7,35 +7,38 @@
(**
* Signature for a generic linear ordering.
*
- * The semantics is an unspecified, structural, linear ordering, suitable
- * for use in applications such as search trees. The ordering does not
- * necessarily correspond to a "natural" ordering for any type.
+ * The default semantics is an unspecified, structural, linear ordering,
+ * suitable for use in applications such as search trees. The ordering
+ * does not necessarily correspond to a "natural" ordering for any type.
*
- * Mutable types (refs and arrays) are ordered structurally and the
- * ordering does not coincide with SML's notion of equality. More
+ * By default, mutable types (refs and arrays) are ordered structurally
+ * and the ordering does not coincide with SML's notion of equality. More
* precisely, two mutable object {a} and {b} may compare {EQUAL}, but it
* is not necessarily the case that {a} and {b} have the same identity.
* This means that the ordering of mutable objects is not invariant with
* respect to mutation.
*
- * The comparison of reals is done bitwise. While this matches the notion
- * of ordering for other types, this differs from the notions of ordering
- * provided for reals by the Basis library. In particular, {~0.0} and
- * {0.0} are considered unequal and {nan} is considered equal to {nan}.
- * This treatment is important for a number of non-numerical applications
- * such as serialization.
+ * By default, the comparison of reals is done bitwise. While this
+ * matches the notion of ordering for other types, this differs from the
+ * notions of ordering provided for reals by the Basis library. In
+ * particular, {~0.0} and {0.0} are considered unequal and {nan} is
+ * considered equal to {nan}. This treatment is important for a number of
+ * non-numerical applications such as serialization.
*
- * Comparison of exceptions only works when at least one of the exception
- * constructors involved in a comparison has been registered with
- * {regExn}.
+ * By default, comparison of exceptions only works when at least one of
+ * the exception constructors involved in a comparison has been registered
+ * with {regExn}.
*
* Comparison of functions is impossible and fails at run-time.
*)
signature ORD = sig
structure Ord : OPEN_GENERIC_REP
- val compare : ('a, 'x) Ord.t -> 'a Cmp.t
+ val ord : ('a, 'x) Ord.t -> 'a Cmp.t
(** Extracts the linear ordering. *)
+
+ val withOrd : 'a Cmp.t -> ('a, 'x) Ord.t UnOp.t
+ (** Functionally updates the comparison function. *)
end
signature ORD_GENERIC = sig
More information about the MLton-commit
mailing list