[MLton-commit] r5932
Vesa Karvonen
vesak at mlton.org
Thu Aug 23 01:22:27 PDT 2007
Added a generic type hash value.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
A mltonlib/trunk/com/ssh/generic/unstable/public/value/type-hash.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml 2007-08-23 04:47:52 UTC (rev 5931)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml 2007-08-23 08:22:22 UTC (rev 5932)
@@ -14,6 +14,7 @@
include PICKLE sharing Open.Rep = Pickle
include PRETTY sharing Open.Rep = Pretty
include SOME sharing Open.Rep = Some
+ include TYPE_HASH sharing Open.Rep = TypeHash
include TYPE_INFO sharing Open.Rep = TypeInfo
end = struct
structure Open = RootGeneric
@@ -22,6 +23,7 @@
structure Open = WithEq (Open) open Open structure Eq=Open
structure Open = WithOrd (Open) open Open
structure Open = WithPretty (Open) open Open
+ structure Open = WithTypeHash (Open) open Open
structure Open = WithTypeInfo (Open) open Open structure TypeInfo=Open
structure Open = WithDataRecInfo (Open) open Open structure DataRecInfo=Open
@@ -53,14 +55,15 @@
(* Make type representations equal: *)
structure Arbitrary = Rep
+ structure DataRecInfo = Rep
structure Eq = Rep
structure Hash = Rep
structure Ord = Rep
structure Pickle = Rep
structure Pretty = Rep
structure Some = Rep
+ structure TypeHash = Rep
structure TypeInfo = Rep
- structure DataRecInfo = Rep
(* Close the combination for use: *)
structure Generic = struct
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-08-23 04:47:52 UTC (rev 5931)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-08-23 08:22:22 UTC (rev 5932)
@@ -32,6 +32,7 @@
../../../public/value/seq.sig
../../../public/value/some.sig
../../../public/value/transform.sig
+ ../../../public/value/type-hash.sig
../../../public/value/type-info.sig
../../close-generic.fun
../../generics-util.sml
@@ -52,6 +53,7 @@
../../value/seq.sml
../../value/some.sml
../../value/transform.sml
+ ../../value/type-hash.sml
../../value/type-info.sml
../../with-extra.fun
extensions.cm
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml 2007-08-23 04:47:52 UTC (rev 5931)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml 2007-08-23 08:22:22 UTC (rev 5932)
@@ -0,0 +1,80 @@
+(* 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.
+ *)
+
+functor WithTypeHash (Arg : OPEN_CASES) : TYPE_HASH_CASES = struct
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ (* SML/NJ workaround --> *)
+
+ local
+ open Word32
+ in
+ fun unary c h = h * 0w19 + c
+ fun binary c (l, r) = l * 0w13 + r * 0w17 + c
+ fun text toString =
+ String.foldl (fn (c, h) => h * 0w33 + fromInt (ord c)) 0w5381 o
+ toString
+ end
+
+ structure TypeHash = LayerRep
+ (structure Outer = Arg.Rep
+ structure Closed = MkClosedRep (type 'a t = Word32.t))
+
+ val typeHash = TypeHash.This.getT
+
+ structure Layered = LayerCases
+ (structure Outer = Arg and Result = TypeHash and Rep = TypeHash.Closed
+
+ fun iso ? _ = unary 0wxD00B6B6B ?
+ fun isoProduct ? _ = unary 0wxC01B56DB ?
+ fun isoSum ? _ = unary 0wxB006B6DB ?
+
+ fun op *` ? = binary 0wx00ADB6DB ?
+ fun T ? = unary 0wx00B6DB6B ?
+ fun R l = unary (text Generics.Label.toString l)
+ fun tuple ? = unary 0wx00DB6DB5 ?
+ fun record ? = unary 0wx01B6DB55 ?
+
+ fun op +` ? = binary 0wx02DB6D4D ?
+ val unit = 0wx036DB6C5 : Word32.t
+ fun C0 ? = text Generics.Con.toString ?
+ fun C1 c = unary (text Generics.Con.toString c)
+ fun data ? = unary 0wx04DB6D63 ?
+
+ fun Y ? = Tie.id (0wx05B6DB51 : Word32.t) ?
+
+ fun op --> ? = binary 0wx06DB6D61 ?
+
+ val exn = 0wx08DB6B69 : Word32.t
+ fun regExn0 _ _ = ()
+ fun regExn1 _ _ _ = ()
+
+ fun list ? = unary 0wx09B6DB29 ?
+
+ fun vector ? = unary 0wx0ADB6D29 ?
+
+ fun array ? = unary 0wx0B6DB651 ?
+ fun refc ? = unary 0wx0CDB6D51 ?
+
+ val fixedInt = 0wx0DB6DAA1 : Word32.t
+ val largeInt = 0wx1B6DB541 : Word32.t
+
+ val largeReal = 0wx2DB6D851 : Word32.t
+ val largeWord = 0wx36DB6D01 : Word32.t
+
+ val bool = 0wx4DB6DA41 : Word32.t
+ val char = 0wx5B6DB085 : Word32.t
+ val int = 0wx6DB6D405 : Word32.t
+ val real = 0wx8DB6D605 : Word32.t
+ val string = 0wx9B6DB141 : Word32.t
+ val word = 0wxADB6D441 : Word32.t
+
+ val word8 = 0wxB6DB6809 : Word32.t
+ val word32 = 0wxCDB6D501 : Word32.t
+ val word64 = 0wxDB6DB101 : Word32.t)
+
+ open Layered
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-08-23 04:47:52 UTC (rev 5931)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-08-23 08:22:22 UTC (rev 5932)
@@ -109,6 +109,9 @@
public/value/transform.sig
detail/value/transform.sml
+
+ public/value/type-hash.sig
+ detail/value/type-hash.sml
in
public/export.sml
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-08-23 04:47:52 UTC (rev 5931)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-08-23 08:22:22 UTC (rev 5932)
@@ -144,3 +144,6 @@
signature TRANSFORM = TRANSFORM and TRANSFORM_CASES = TRANSFORM_CASES
functor WithTransform (Arg : OPEN_CASES) : TRANSFORM_CASES = WithTransform (Arg)
+
+signature TYPE_HASH = TYPE_HASH and TYPE_HASH_CASES = TYPE_HASH_CASES
+functor WithTypeHash (Arg : OPEN_CASES) : TYPE_HASH_CASES = WithTypeHash (Arg)
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/type-hash.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/type-hash.sig 2007-08-23 04:47:52 UTC (rev 5931)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/type-hash.sig 2007-08-23 08:22:22 UTC (rev 5932)
@@ -0,0 +1,22 @@
+(* 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 for a generic type hash value.
+ *
+ * WARNING: The hash function is not designed to be secure in any way.
+ *)
+signature TYPE_HASH = sig
+ structure TypeHash : OPEN_REP
+
+ val typeHash : ('a, 'x) TypeHash.t -> Word32.t
+ (** Returns a hash value specific to the type. *)
+end
+
+signature TYPE_HASH_CASES = sig
+ include OPEN_CASES TYPE_HASH
+ sharing Rep = TypeHash
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/type-hash.sig
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list