[MLton-commit] r6117
Vesa Karvonen
vesak at mlton.org
Fri Nov 2 05:48:36 PST 2007
Allow operations to be implemented through either CastReal or PackReal,
because CastReal may be impossible to support on some compilers.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/common/cast-real.sig
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlkit/cast-real.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlton/cast-real.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlton/extensions.mlb
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/cast-real.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/extensions.cm
A mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/pack-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/detail/value/pickle.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
----------------------------------------------------------------------
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-11-02 13:44:48 UTC (rev 6116)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/common/cast-real.sig 2007-11-02 13:48:34 UTC (rev 6117)
@@ -7,5 +7,5 @@
signature CAST_REAL = sig
type t
structure Bits : WORD
- val isoBits : (t, Bits.t) Iso.t
+ val isoBits : (t, Bits.t) Iso.t Option.t
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlkit/cast-real.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlkit/cast-real.sml 2007-11-02 13:44:48 UTC (rev 6116)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlkit/cast-real.sml 2007-11-02 13:48:34 UTC (rev 6117)
@@ -7,7 +7,7 @@
structure CastReal : CAST_REAL where type t = Real.t = struct
open Real
structure Bits = Word
- val isoBits = (undefined, undefined)
+ val isoBits = NONE
end
structure CastLargeReal : CAST_REAL where type t = LargeReal.t = CastReal
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-11-02 13:44:48 UTC (rev 6116)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlton/cast-real.sml 2007-11-02 13:48:34 UTC (rev 6117)
@@ -7,7 +7,7 @@
structure CastReal : CAST_REAL where type t = Real.t = struct
open Real64 MLton.Real64
structure Bits = Word64
- val isoBits = (castToWord, castFromWord)
+ val isoBits = SOME (castToWord, castFromWord)
end
structure CastLargeReal : CAST_REAL where type t = LargeReal.t = CastReal
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlton/extensions.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlton/extensions.mlb 2007-11-02 13:44:48 UTC (rev 6116)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/mlton/extensions.mlb 2007-11-02 13:48:34 UTC (rev 6117)
@@ -10,4 +10,5 @@
in
../common/cast-real.sig
cast-real.sml
+ pack-real.sml
end
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-11-02 13:44:48 UTC (rev 6116)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/cast-real.sml 2007-11-02 13:48:34 UTC (rev 6117)
@@ -28,7 +28,7 @@
set = C.Set.double',
get = C.Get.double'}
in
- val isoBits = (cast real64 word64, cast word64 real64)
+ val isoBits = SOME (cast real64 word64, cast word64 real64)
end
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/extensions.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/extensions.cm 2007-11-02 13:44:48 UTC (rev 6116)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/extensions.cm 2007-11-02 13:48:34 UTC (rev 6117)
@@ -9,3 +9,4 @@
../../../../../extended-basis/unstable/basis.cm
../common/cast-real.sig
cast-real.sml
+ pack-real.sml
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/pack-real.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/pack-real.sml 2007-11-02 13:44:48 UTC (rev 6116)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/pack-real.sml 2007-11-02 13:48:34 UTC (rev 6117)
@@ -0,0 +1,59 @@
+(* Copyright (C) 2007 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+local
+ functor MkPackReal (include CAST_REAL
+ val isBigEndian : bool) : PACK_REAL = struct
+ val (toBits, fromBits) = valOf isoBits
+ type real = t
+ val bytesPerElem = Bits.wordSize div 8
+ val isBigEndian = isBigEndian
+ val shift = if isBigEndian
+ then fn i => Word.fromInt Bits.wordSize - 0w8 -
+ Word.<< (Word.fromInt i, 0w3)
+ else fn i => Word.<< (Word.fromInt i, 0w3)
+ fun tabulator r = let
+ val w = toBits r
+ in
+ fn i => Word8.fromInt (Bits.toIntX (Bits.andb (Bits.>> (w, shift i),
+ Bits.fromInt 0xFF)))
+ end
+ fun sub sub = let
+ fun lp (w, i) =
+ if i = bytesPerElem
+ then fromBits w
+ else lp (Bits.orb (w,
+ Bits.<< (Bits.fromInt (Word8.toInt (sub i)),
+ shift i)),
+ i + 1)
+ in
+ lp (Bits.fromInt 0, 0)
+ end
+ fun toBytes r = Word8Vector.tabulate (bytesPerElem, tabulator r)
+ fun fromBytes b = sub (fn i => Word8Vector.sub (b, i))
+ fun subVec (v, i) =
+ sub let val s = i*bytesPerElem in fn i => Word8Vector.sub (v, s+i) end
+ fun subArr (a, i) =
+ sub let val s = i*bytesPerElem in fn i => Word8Array.sub (a, s+i) end
+ fun update (a, i, r) =
+ Word8ArraySlice.modifyi
+ (tabulator r o #1)
+ (Word8ArraySlice.slice (a, i*bytesPerElem, SOME bytesPerElem))
+ end
+in
+ structure PackReal64Big : PACK_REAL where type real = Real64.real =
+ MkPackReal (open CastReal val isBigEndian = true)
+ structure PackReal64Little : PACK_REAL where type real = Real64.real =
+ MkPackReal (open CastReal val isBigEndian = false)
+ structure PackRealBig : PACK_REAL where type real = Real.real =
+ PackReal64Big
+ structure PackRealLittle : PACK_REAL where type real = Real.real =
+ PackReal64Little
+ structure PackLargeRealBig : PACK_REAL where type real = LargeReal.real =
+ PackReal64Big
+ structure PackLargeRealLittle : PACK_REAL where type real = LargeReal.real =
+ PackReal64Little
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/pack-real.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-11-02 13:44:48 UTC (rev 6116)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-11-02 13:48:34 UTC (rev 6117)
@@ -23,6 +23,13 @@
lL = lR andalso lp lL
end
+ 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 exnHandler : Exn.t BinPr.t Ref.t = ref GenericsUtil.failExnSq
fun regExn t (_, e2to) =
Ref.modify (fn exnHandler =>
@@ -41,7 +48,7 @@
fun withEq eq = mapT (const eq)
structure Open = LayerCases
- (fun iso b (a2b, _) = BinPr.map a2b b
+ (val iso = iso
val isoProduct = iso
val isoSum = iso
@@ -75,13 +82,13 @@
val fixedInt = op = : FixedInt.t t
val largeInt = op = : LargeInt.t t
- val largeReal = iso op = CastLargeReal.isoBits
+ val largeReal = mkReal CastLargeReal.isoBits PackLargeRealLittle.toBytes
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 = iso op = CastReal.isoBits
+ val real = mkReal CastReal.isoBits PackRealLittle.toBytes
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 2007-11-02 13:44:48 UTC (rev 6116)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2007-11-02 13:48:34 UTC (rev 6117)
@@ -38,6 +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 exns : (Exn.t * p -> Word.t Option.t) Buffer.t = Buffer.new ()
structure HashRep = LayerRep
@@ -162,15 +170,15 @@
| SOME v => SOME (Word.xorb (c, t (v, p))))
val bool = prim (fn true => 0wx096DB16D | false => 0wx01B56B6D)
- val real =
- let open CastReal in viaWord (#1 isoBits) op mod Bits.isoWord end
+ val real = mkReal CastReal.isoBits CastReal.Bits.mod CastReal.Bits.isoWord
+ PackRealLittle.toBytes
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 =
- let open CastLargeReal in viaWord (#1 isoBits) op mod Bits.isoWord end
+ val largeReal = mkReal CastLargeReal.isoBits CastLargeReal.Bits.mod
+ CastLargeReal.Bits.isoWord PackRealLittle.toBytes
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 2007-11-02 13:44:48 UTC (rev 6116)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-11-02 13:48:34 UTC (rev 6117)
@@ -15,6 +15,13 @@
fun lift (cmp : 'a Cmp.t) : 'a t = IN (cmp o #2)
+ 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))
+
fun sequ (Ops.S {toSlice, getItem, ...}) (IN aO) =
IN (fn (e, (l, r)) => let
fun lp (e, l, r) =
@@ -56,8 +63,6 @@
| NONE & SOME _ => SOME LESS
| NONE & NONE => NONE)
- fun iso' (IN bX) (a2b, _) = IN (fn (e, bp) => bX (e, Sq.map a2b bp))
-
structure OrdRep = LayerRep
(open Arg
structure Rep = MkClosedRep (type 'a t = 'a t))
@@ -127,13 +132,13 @@
val largeInt = lift LargeInt.compare
val largeWord = lift LargeWord.compare
- val largeReal =
- iso' (lift CastLargeReal.Bits.compare) CastLargeReal.isoBits
-
+ val largeReal = mkReal CastLargeReal.isoBits CastLargeReal.Bits.compare
+ PackLargeRealBig.toBytes
val bool = lift Bool.compare
val char = lift Char.compare
val int = lift Int.compare
- val real = iso' (lift CastReal.Bits.compare) CastReal.isoBits
+ val real = mkReal CastLargeReal.isoBits CastLargeReal.Bits.compare
+ PackRealBig.toBytes
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 2007-11-02 13:44:48 UTC (rev 6116)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2007-11-02 13:48:34 UTC (rev 6117)
@@ -229,205 +229,214 @@
val word32 = bits false Word32Ops.ops Iso.id
- (* Encodes fixed size int as a size followed by little endian bytes. *)
- fun mkFixedInt (Ops.W {orb, <<, ~>>, isoWord8 = (toW8, fromW8),
- isoWord8X = (_, fromW8X), ...})
- (fromBitsX, toBits) =
- P {rd = let
- open I
- fun lp (1, s, w) =
- rd word8 >>= (fn b =>
- return (fromBitsX (fromW8X b << s orb w)))
- | lp (n, s, w) =
- rd word8 >>= (fn b =>
- lp (n - 1, s + 0w8, fromW8 b << s orb w))
- in
- rd size >>= (fn 0 => return (fromBitsX (fromW8 0w0))
- | n => lp (n, 0w0, fromW8 0w0))
- end,
- wr = let
- open O
- fun lp (n, w, wr') = let
- val n = n+1
- val b = toW8 w
- val wr' = wr' >> wr word8 b
+ fun mkReal isoBits ops =
+ case isoBits
+ of SOME isoBits => bits true ops isoBits
+ | NONE => fail "Pickle.mkReal" (* XXX *)
+
+ (* Encodes fixed size int as a size followed by little endian bytes. *)
+ fun mkFixedInt (Ops.W {orb, <<, ~>>, isoWord8 = (toW8, fromW8),
+ isoWord8X = (_, fromW8X), ...})
+ (fromBitsX, toBits) =
+ P {rd = let
+ open I
+ fun lp (1, s, w) =
+ rd word8 >>= (fn b =>
+ return (fromBitsX (fromW8X b << s orb w)))
+ | lp (n, s, w) =
+ rd word8 >>= (fn b =>
+ lp (n - 1, s + 0w8, fromW8 b << s orb w))
in
- if fromW8X b = w
- then wr size n >> wr'
- else lp (n, w ~>> 0w8, wr')
- end
- in
- fn i => case toBits i
- of w => if w = fromW8 0w0
- then wr size 0
- else lp (0, w, return ())
- end,
- sz = SOME 4}
+ rd size >>= (fn 0 => return (fromBitsX (fromW8 0w0))
+ | n => lp (n, 0w0, fromW8 0w0))
+ end,
+ wr = let
+ open O
+ fun lp (n, w, wr') = let
+ val n = n+1
+ val b = toW8 w
+ val wr' = wr' >> wr word8 b
+ in
+ if fromW8X b = w
+ then wr size n >> wr'
+ else lp (n, w ~>> 0w8, wr')
+ end
+ in
+ fn i => case toBits i
+ of w => if w = fromW8 0w0
+ then wr size 0
+ else lp (0, w, return ())
+ end,
+ sz = SOME 4}
- val () = if LargeWord.wordSize < valOf FixedInt.precision
- then fail "LargeWord can't hold a FixedInt"
- else ()
- val fixedInt = mkFixedInt LargeWordOps.ops LargeWord.isoFixedIntX
+ val () = if LargeWord.wordSize < valOf FixedInt.precision
+ then fail "LargeWord can't hold a FixedInt"
+ else ()
+ 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}
- open I
- in
- P {rd = rd size >>& Map.get >>= (fn key & arr =>
- if 0 = key
- then Key.alloc >>& readProxy >>= (fn key & proxy =>
- (ResizableArray.update (arr, key-1, toDyn proxy)
- ; readBody proxy >> return proxy))
- else return (fromDyn (ResizableArray.sub (arr, key-1)))),
- wr = fn v => let
- val d = toDyn v
- open O
- in
- Map.get >>= (fn mp =>
- case HashMap.find mp d
- of SOME key => wr size key
- | NONE => Key.alloc >>= (fn key =>
- (HashMap.insert mp (d, key)
- ; wr size 0 >> writeWhole v)))
- end,
- sz = NONE}
- end
+ fun cyclic {readProxy, readBody, writeWhole, self} = let
+ val (toDyn, fromDyn) = Dyn.new {eq = Arg.eq self, hash = Arg.hash self}
+ open I
+ in
+ P {rd = rd size >>& Map.get >>= (fn key & arr =>
+ if 0 = key
+ then Key.alloc >>& readProxy >>= (fn key & proxy =>
+ (ResizableArray.update (arr, key-1, toDyn proxy)
+ ; readBody proxy >> return proxy))
+ else return (fromDyn (ResizableArray.sub (arr, key-1)))),
+ wr = fn v => let
+ val d = toDyn v
+ open O
+ in
+ Map.get >>= (fn mp =>
+ case HashMap.find mp d
+ of SOME key => wr size key
+ | NONE => Key.alloc >>= (fn key =>
+ (HashMap.insert mp (d, key)
+ ; wr size 0 >> writeWhole v)))
+ end,
+ sz = NONE}
+ end
- fun share aT (P {rd = aR, wr = aW, ...}) = let
- val (toDyn, fromDyn) = Dyn.new {eq = Arg.eq aT, hash = Arg.hash aT}
- open I
- in
- P {rd = rd size >>& Map.get >>= (fn key & arr =>
- if 0 = key
- then Key.alloc >>& aR >>= (fn key & v =>
- (ResizableArray.update (arr, key-1, toDyn v)
- ; return v))
- else return (fromDyn (ResizableArray.sub (arr, key-1)))),
- wr = fn v => let
- val d = toDyn v
- open O
- in
- Map.get >>= (fn mp =>
- case HashMap.find mp d
- of SOME key => wr size key
- | NONE => wr size 0 >> Key.alloc >>= (fn key =>
- aW v >>= (fn () =>
- (if isSome (HashMap.find mp d) then () else
- HashMap.insert mp (d, key)
- ; return ()))))
- end,
- sz = SOME 5}
- end
+ fun share aT (P {rd = aR, wr = aW, ...}) = let
+ val (toDyn, fromDyn) = Dyn.new {eq = Arg.eq aT, hash = Arg.hash aT}
+ open I
+ in
+ P {rd = rd size >>& Map.get >>= (fn key & arr =>
+ if 0 = key
+ then Key.alloc >>& aR >>= (fn key & v =>
+ (ResizableArray.update (arr, key-1, toDyn v)
+ ; return v))
+ else return (fromDyn (ResizableArray.sub (arr, key-1)))),
+ wr = fn v => let
+ val d = toDyn v
+ open O
+ in
+ Map.get >>= (fn mp =>
+ case HashMap.find mp d
+ of SOME key => wr size key
+ | NONE => wr size 0 >> Key.alloc >>= (fn key =>
+ aW v >>= (fn () =>
+ (if isSome (HashMap.find mp d)
+ then ()
+ else HashMap.insert mp (d, key)
+ ; return ()))))
+ end,
+ sz = SOME 5}
+ end
- fun mutable (methods as {readProxy, readBody, writeWhole, self}) =
- if Arg.mayBeCyclic self
- then cyclic methods
- else share self (P {rd = let open I in readProxy >>= (fn p =>
- readBody p >> return p) end,
- wr = writeWhole,
- sz = NONE})
+ fun mutable (methods as {readProxy, readBody, writeWhole, self}) =
+ if Arg.mayBeCyclic self
+ then cyclic methods
+ else share self (P {rd = let open I in readProxy >>= (fn p =>
+ readBody p >> return p) end,
+ wr = writeWhole,
+ sz = NONE})
- fun sequ (Ops.S {length, toSlice, getItem, fromList, ...})
- (P {rd = aR, wr = aW, ...}) =
- P {rd = let
- open I
+ fun sequ (Ops.S {length, toSlice, getItem, fromList, ...})
+ (P {rd = aR, wr = aW, ...}) =
+ P {rd = let
+ open I
fun lp (0, es) = return (fromList (rev es))
| lp (n, es) = aR >>= (fn e => lp (n-1, e::es))
- in
- rd size >>= lp /> []
- end,
- wr = let
- open O
- fun lp sl =
- case getItem sl
- of NONE => return ()
- | SOME (e, sl) => aW e >>= (fn () => lp sl)
- in
- fn seq => wr size (length seq) >>= (fn () =>
- lp (toSlice seq))
- end,
- sz = NONE : OptInt.t}
+ in
+ rd size >>= lp /> []
+ end,
+ wr = let
+ open O
+ fun lp sl =
+ case getItem sl
+ of NONE => return ()
+ | SOME (e, sl) => aW e >>= (fn () => lp sl)
+ in
+ fn seq => wr size (length seq) >>= (fn () =>
+ lp (toSlice seq))
+ end,
+ sz = NONE : OptInt.t}
- val string = share (Arg.Open.string ()) (sequ StringOps.ops char)
+ val string = share (Arg.Open.string ()) (sequ StringOps.ops char)
- val c2b = Byte.charToByte
- val b2c = Byte.byteToChar
- fun h2n c =
- c2b c - (if Char.inRange (#"0", #"9") c then c2b #"0"
- else if Char.inRange (#"a", #"f") c then c2b #"a" - 0w10
- else if Char.inRange (#"A", #"F") c then c2b #"A" - 0w10
- else fail "Bug in fmt")
- fun n2h n = b2c (n + (if n < 0w10 then c2b #"0" else c2b #"a" - 0w10))
- local
- fun makePos8 i =
- i + IntInf.<<
- (1,
- Word.andb (Word.fromInt (IntInf.log2 (IntInf.notb i)) + 0w9,
- Word.~ 0w8))
- in
- fun i2h i =
- if i < 0
- then if i = ~1 then "ff" else IntInf.fmt StringCvt.HEX (makePos8 i)
- else let
- val s = IntInf.fmt StringCvt.HEX i
- val (t, f) =
- if Int.isOdd (String.size s) then ("0", "0") else ("00", "")
+ val c2b = Byte.charToByte
+ val b2c = Byte.byteToChar
+ fun h2n c =
+ c2b c - (if Char.inRange (#"0", #"9") c then c2b #"0"
+ else if Char.inRange (#"a", #"f") c then c2b #"a" - 0w10
+ else if Char.inRange (#"A", #"F") c then c2b #"A" - 0w10
+ else fail "Bug in fmt")
+ fun n2h n = b2c (n + (if n < 0w10 then c2b #"0" else c2b #"a" - 0w10))
+ local
+ fun makePos8 i =
+ i + IntInf.<<
+ (1,
+ Word.andb
+ (Word.fromInt (IntInf.log2 (IntInf.notb i)) + 0w9,
+ Word.~ 0w8))
+ in
+ fun i2h i =
+ if i < 0
+ then if i = ~1 then "ff" else IntInf.fmt StringCvt.HEX (makePos8 i)
+ else let
+ val s = IntInf.fmt StringCvt.HEX i
+ val (t, f) = if Int.isOdd (String.size s)
+ then ("0", "0")
+ else ("00", "")
+ in
+ (if 0w8 <= h2n (String.sub (s, 0)) then t else f) ^ s
+ end
+ end
+ fun h2i h = let
+ val i = valOf (StringCvt.scanString (IntInf.scan StringCvt.HEX) h)
+ in
+ if 0w8 <= h2n (String.sub (h, 0))
+ then i - IntInf.<< (1, Word.fromInt (IntInf.log2 i + 1))
+ else i
+ end
+
+ val intInf =
+ P {wr = let
+ open O
+ fun lp (_, 0) = return ()
+ | lp (s, i) =
+ case i - 1 of i => pl (s, i, h2n (String.sub (s, i)))
+ and pl (_, 0, b) = wr word8 b
+ | pl (s, i, b) = let
+ val i = i - 1
+ in
+ wr word8 (b + Word8.<< (h2n (String.sub (s, i)), 0w4))
+ >>= (fn () => lp (s, i))
+ end
in
- (if 0w8 <= h2n (String.sub (s, 0)) then t else f) ^ s
- end
- end
- fun h2i h = let
- val i = valOf (StringCvt.scanString (IntInf.scan StringCvt.HEX) h)
- in
- if 0w8 <= h2n (String.sub (h, 0))
- then i - IntInf.<< (1, Word.fromInt (IntInf.log2 i + 1))
- else i
- end
+ fn i => if 0 = i then wr size 0 else let
+ val s = i2h i
+ val n = String.length s
+ in
+ wr size (Int.quot (n, 2)) >>= (fn () => lp (s, n))
+ end
+ end,
+ rd = let
+ open I
+ fun lp (cs, 0) = return (h2i (implode cs))
+ | lp (cs, n) =
+ rd word8 >>= (fn b =>
+ lp (n2h (Word8.>> (b, 0w4))::
+ n2h (Word8.andb (b, 0wxF))::cs, n-1))
+ in
+ rd size >>= (fn 0 => return 0 | n => lp ([], n))
+ end,
+ sz = NONE : OptInt.t}
- val intInf =
- P {wr = let
- open O
- fun lp (_, 0) = return ()
- | lp (s, i) =
- case i - 1 of i => pl (s, i, h2n (String.sub (s, i)))
- and pl (_, 0, b) = wr word8 b
- | pl (s, i, b) = let
- val i = i - 1
- in
- wr word8 (b + Word8.<< (h2n (String.sub (s, i)), 0w4)) >>=
- (fn () => lp (s, i))
- end
- in
- fn i => if 0 = i then wr size 0 else let
- val s = i2h i
- val n = String.length s
- in
- wr size (Int.quot (n, 2)) >>= (fn () => lp (s, n))
- end
- end,
- rd = let
- open I
- fun lp (cs, 0) = return (h2i (implode cs))
- | lp (cs, n) =
- rd word8 >>= (fn b =>
- lp (n2h (Word8.>> (b, 0w4))::
- n2h (Word8.andb (b, 0wxF))::cs, n-1))
- in
- rd size >>= (fn 0 => return 0 | n => lp ([], n))
- end,
- sz = NONE : OptInt.t}
+ val exns : {rd : String.t -> Exn.t I.monad Option.t,
+ wr : Exn.t -> Unit.t O.monad Option.t} Buffer.t =
+ Buffer.new ()
+ fun regExn c (P {rd = aR, wr = aW, ...}) (a2e, e2a) = let
+ val c = Generics.Con.toString c
+ val eR = I.map a2e aR
+ in
+ (Buffer.push exns)
+ {rd = fn c' => if c' = c then SOME eR else NONE,
+ wr = Option.map (fn a => O.>> (wr string c, aW a)) o e2a}
+ end
- val exns : {rd : String.t -> Exn.t I.monad Option.t,
- wr : Exn.t -> Unit.t O.monad Option.t} Buffer.t = Buffer.new ()
- fun regExn c (P {rd = aR, wr = aW, ...}) (a2e, e2a) = let
- val c = Generics.Con.toString c
- val eR = I.map a2e aR
- in
- (Buffer.push exns)
- {rd = fn c' => if c' = c then SOME eR else NONE,
- wr = Option.map (fn a => O.>> (wr string c, aW a)) o e2a}
- end
-
structure PickleRep = LayerRep
(open Arg
structure Rep = struct
@@ -652,11 +661,11 @@
else if isSome Int.precision
then iso' fixedInt Int.isoFixedInt
else iso' largeInt Int.isoLargeInt
- val real = bits true RealWordOps.ops CastReal.isoBits
+ val real = mkReal CastReal.isoBits RealWordOps.ops
val string = string
val word = mkFixedInt WordOps.ops Iso.id
- val largeReal = bits true LargeRealWordOps.ops CastLargeReal.isoBits
+ val largeReal = mkReal CastLargeReal.isoBits LargeRealWordOps.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 2007-11-02 13:44:48 UTC (rev 6116)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2007-11-02 13:48:34 UTC (rev 6117)
@@ -55,6 +55,11 @@
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)
+
structure SeqRep = LayerRep
(open Arg
structure Rep = MkClosedRep (type 'a t = 'a t))
@@ -120,12 +125,12 @@
val largeInt = lift op = : LargeInt.t t
val largeWord = lift op = : LargeWord.t t
- val largeReal = iso' (lift op =) CastLargeReal.isoBits
+ val largeReal = mkReal CastLargeReal.isoBits PackLargeRealLittle.toBytes
val bool = lift op = : Bool.t t
val char = lift op = : Char.t t
val int = lift op = : Int.t t
- val real = iso' (lift op =) CastReal.isoBits
+ val real = mkReal CastReal.isoBits PackRealLittle.toBytes
val string = lift op = : String.t t
val word = lift op = : Word.t t
More information about the MLton-commit
mailing list