[MLton-commit] r5669
Vesa Karvonen
vesak at mlton.org
Sat Jun 23 16:42:27 PDT 2007
Bitwise equality for reals.
----------------------------------------------------------------------
A mltonlib/trunk/com/ssh/generic/unstable/detail/ml/common/
A mltonlib/trunk/com/ssh/generic/unstable/detail/ml/common/cast-real.sig
A mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlton/
A mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlton/cast-real.sml
A mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlton/extensions.mlb
A mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/cast-real.sml
A mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/extensions.cm
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig
----------------------------------------------------------------------
Added: 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-06-23 00:35:19 UTC (rev 5668)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/common/cast-real.sig 2007-06-23 23:42:25 UTC (rev 5669)
@@ -0,0 +1,12 @@
+(* 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.
+ *)
+
+signature CAST_REAL = sig
+ type t
+ structure Word : WORD
+ val castToWord : t -> Word.t
+ val castFromWord : Word.t -> t
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/common/cast-real.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Added: 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-06-23 00:35:19 UTC (rev 5668)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlton/cast-real.sml 2007-06-23 23:42:25 UTC (rev 5669)
@@ -0,0 +1,12 @@
+(* 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 CastReal : CAST_REAL where type t = Real.t = struct
+ open Real64 MLton.Real64
+ structure Word = Word64
+end
+
+structure CastLargeReal : CAST_REAL where type t = LargeReal.t = CastReal
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlton/cast-real.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlton/extensions.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlton/extensions.mlb 2007-06-23 00:35:19 UTC (rev 5668)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlton/extensions.mlb 2007-06-23 23:42:25 UTC (rev 5669)
@@ -0,0 +1,13 @@
+(* 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.
+ *)
+
+local
+ $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+ $(MLTON_ROOT)/basis/mlton.mlb
+in
+ ../common/cast-real.sig
+ cast-real.sml
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlton/extensions.mlb
___________________________________________________________________
Name: svn:eol-style
+ native
Added: 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-06-23 00:35:19 UTC (rev 5668)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/cast-real.sml 2007-06-23 23:42:25 UTC (rev 5669)
@@ -0,0 +1,35 @@
+(* 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 CastReal : CAST_REAL where type t = Real.t = struct
+ type t = Real64.t
+ structure Word = Word64
+ local
+ fun cast {size=sizeF, set=setF, get=_ }
+ {size=sizeT, set=_, get=getT} vF =
+ if C.S.toWord sizeF <> C.S.toWord sizeT then
+ raise Fail "CastReal: sizes do not match"
+ else let
+ val objF = C.new' sizeF
+ val objT =
+ let open C.Ptr in |*! (cast' (inject' (|&! objF))) end
+ in
+ setF (objF, vF)
+ ; getT objT before C.discard' objF
+ end
+ val word64 = {size = C.S.ulonglong,
+ set = C.Set.ulonglong',
+ get = C.Get.ulonglong'}
+ val real64 = {size = C.S.double,
+ set = C.Set.double',
+ get = C.Get.double'}
+ in
+ val castToWord = cast real64 word64
+ val castFromWord = cast word64 real64
+ end
+end
+
+structure CastLargeReal : CAST_REAL where type t = LargeReal.t = CastReal
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/cast-real.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/extensions.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/extensions.cm 2007-06-23 00:35:19 UTC (rev 5668)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/extensions.cm 2007-06-23 23:42:25 UTC (rev 5669)
@@ -0,0 +1,11 @@
+(* 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.
+ *)
+
+group is
+ $c/c.cm
+ ../../../../../extended-basis/unstable/basis.cm
+ ../common/cast-real.sig
+ cast-real.sml
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-06-23 00:35:19 UTC (rev 5668)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-06-23 23:42:25 UTC (rev 5669)
@@ -45,3 +45,4 @@
../../value/pretty.sml
../../value/type-info.sml
../../with-extra.fun
+ extensions.cm
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-06-23 00:35:19 UTC (rev 5668)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-06-23 23:42:25 UTC (rev 5669)
@@ -71,16 +71,18 @@
fun refc _ = op =
val largeInt = op =
- val largeReal = LargeReal.==
val largeWord = op =
val bool = op =
val char = op =
val int = op =
- val real = Real.==
val string = op =
val word = op =
+ fun mk cast = BinPr.map cast op =
+ val largeReal = mk CastLargeReal.castToWord
+ val real = mk CastReal.castToWord
+
val word8 = op =
val word32 = op =
val word64 = op =)
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-06-23 00:35:19 UTC (rev 5668)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-06-23 23:42:25 UTC (rev 5669)
@@ -15,6 +15,9 @@
"warnUnused true"
in
local
+ (* Extensions *)
+ detail/ml/$(SML_COMPILER)/extensions.mlb
+
(* Support *)
public/generics.sig
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig 2007-06-23 00:35:19 UTC (rev 5668)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig 2007-06-23 23:42:25 UTC (rev 5669)
@@ -9,25 +9,26 @@
*
* For equality types the semantics is the same as SML's equality. For
* mutable types (refs and arrays) this means that two objects are
- * considered equal if they have the same identity. User defined
+ * considered equal iff they have the same identity. User defined
* datatypes and exceptions are given a structural semantics of equality.
- * Specifically, two datatypes or exceptions are considered equal if they
+ * Specifically, two datatypes or exceptions are considered equal iff they
* have the same constructor and the arguments of the constructors are
- * considered equal.
+ * considered equal. (Of course, all of this is modulo user specified
+ * morphisms.)
*
- * Currently, the equality of reals is the same as the {LargeReal.==}
- * function. This differs disturbingly from the equality for other types.
- * In particular, {~0.0} and {0.0} are considered equal even though they
- * are different values and {nan} is not considered equal to any value,
- * including itself. This is problematic for a number of important
- * non-numerical applications such as serialization.
+ * The equality of reals is bitwise equality. While this matches the
+ * notion of equality provided for other types, this differs from the
+ * notions of equality 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 of equality is important for
+ * a number of non-numerical applications such as serialization.
*)
signature EQ = sig
structure Eq : OPEN_GENERIC_REP
val eq : ('a, 'x) Eq.t -> 'a BinPr.t
(**
- * Extracts the equality relation. Note that the type parameter {'a}
+ * Extracts the equality relation. Note that the type variable {'a}
* isn't an equality type variable.
*)
More information about the MLton-commit
mailing list