[MLton-commit] r5883
Vesa Karvonen
vesak at mlton.org
Wed Aug 15 08:33:47 PDT 2007
Added explicit support for FixedInt.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/close-generic.fun
U mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/layer-generic.fun
U mltonlib/trunk/com/ssh/generic/unstable/detail/root-generic.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/data-rec-info.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.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/pretty.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun
U mltonlib/trunk/com/ssh/generic/unstable/public/closed-cases.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/generic-extra.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/open-cases.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/close-generic.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/close-generic.fun 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/close-generic.fun 2007-08-15 15:33:44 UTC (rev 5883)
@@ -49,6 +49,7 @@
fun array ? = Arg.array ignore ?
fun refc ? = Arg.refc ignore ?
fun vector ? = Arg.vector ignore ?
+ val fixedInt = Arg.fixedInt ()
val largeInt = Arg.largeInt ()
val largeReal = Arg.largeReal ()
val largeWord = Arg.largeWord ()
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml 2007-08-15 15:33:44 UTC (rev 5883)
@@ -6,10 +6,6 @@
structure Generic :> sig
include GENERIC_EXTRA
- where type Label.t = Generics.Label.t
- where type Con.t = Generics.Con.t
- where type Record.t = Generics.Record.t
- where type Tuple.t = Generics.Tuple.t
include ARBITRARY sharing Open.Rep = Arbitrary
include DATA_REC_INFO sharing Open.Rep = DataRecInfo
include EQ sharing Open.Rep = Eq
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/layer-generic.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/layer-generic.fun 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/layer-generic.fun 2007-08-15 15:33:44 UTC (rev 5883)
@@ -100,6 +100,7 @@
fun array ? = op1t Outer.array Arg.array ?
fun refc ? = op1t Outer.refc Arg.refc ?
fun vector ? = op1t Outer.vector Arg.vector ?
+ fun fixedInt ? = op0t Outer.fixedInt Arg.fixedInt ?
fun largeInt ? = op0t Outer.largeInt Arg.largeInt ?
fun largeReal ? = op0t Outer.largeReal Arg.largeReal ?
fun largeWord ? = op0t Outer.largeWord Arg.largeWord ?
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/root-generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/root-generic.sml 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/root-generic.sml 2007-08-15 15:33:44 UTC (rev 5883)
@@ -43,6 +43,7 @@
val array = id
val refc = id
val vector = id
+ val fixedInt = id
val largeInt = id
val largeReal = id
val largeWord = id
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2007-08-15 15:33:44 UTC (rev 5883)
@@ -20,7 +20,7 @@
structure RandomGen = Arg.RandomGen
- structure G = RandomGen and I = Int and R = Real and W = Word
+ structure G = RandomGen and R = Real and W = Word
fun universally ? = G.mapUnOp (Univ.Iso.new ()) ?
val map = G.Monad.map
@@ -114,15 +114,17 @@
val bool = IN {gen = G.bool, cog = G.variant o W.fromInt o Bool.toInt}
- val int = IN {gen = map (fn w => W.toIntX (w - G.RNG.maxValue div 0w2))
- (* XXX result may not fit an Int.t *)
- (G.lift G.RNG.value),
- cog = G.variant o W.fromInt}
+ val fixedInt =
+ IN {gen = map (fn w => W.toFixedIntX (w - G.RNG.maxValue div 0w2))
+ (G.lift G.RNG.value),
+ cog = G.variant o W.fromFixedInt}
val word = IN {gen = G.lift G.RNG.value, cog = G.variant}
val real = IN {gen = G.sized ((fn r => G.realInRange (~r, r)) o real),
cog = stringCog o R.toString} (* XXX Real cog *)
- val largeInt = iso' int (Iso.swap I.isoLarge)
+ val int = iso' fixedInt Int.isoFixedInt
+ val largeInt = iso' fixedInt LargeInt.isoFixedInt
+
val largeWord = iso' word (Iso.swap W.isoLarge)
val largeReal = iso' real (Iso.swap (R.isoLarge IEEEReal.TO_NEAREST))
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/data-rec-info.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/data-rec-info.sml 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/data-rec-info.sml 2007-08-15 15:33:44 UTC (rev 5883)
@@ -96,7 +96,9 @@
val vector = pure
val list = pure
- val largeInt = base
+ val fixedInt = base
+ val largeInt = base
+
val largeReal = base
val largeWord = base
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml 2007-08-15 15:33:44 UTC (rev 5883)
@@ -60,7 +60,9 @@
val array = ignore
val refc = ignore
- val largeInt = ()
+ val fixedInt = ()
+ val largeInt = ()
+
val largeReal = ()
val largeWord = ()
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml 2007-08-15 15:33:44 UTC (rev 5883)
@@ -19,6 +19,7 @@
| EXN of Exn.t
| LIST of t List.t
| VECTOR of t Vector.t
+ | FIXED_INT of FixedInt.t
| LARGE_INT of LargeInt.t
| LARGE_WORD of LargeWord.t
| LARGE_REAL of LargeReal.t
@@ -82,7 +83,9 @@
fun array _ = isoUnsupported "Dyn.array unsupported"
fun refc _ = isoUnsupported "Dyn.refc unsupported"
- val largeInt = (LARGE_INT, fn LARGE_INT ? => ? | _ => raise Dyn)
+ val fixedInt = (FIXED_INT, fn FIXED_INT ? => ? | _ => raise Dyn)
+ val largeInt = (LARGE_INT, fn LARGE_INT ? => ? | _ => raise Dyn)
+
val largeWord = (LARGE_WORD, fn LARGE_WORD ? => ? | _ => raise Dyn)
val largeReal = (LARGE_REAL, fn LARGE_REAL ? => ? | _ => raise Dyn)
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-08-15 15:33:44 UTC (rev 5883)
@@ -73,7 +73,9 @@
fun array _ = op = : 'a Array.t Rep.t
fun refc _ = op = : 'a Ref.t Rep.t
- val largeInt = op = : LargeInt.t Rep.t
+ val fixedInt = op = : FixedInt.t Rep.t
+ val largeInt = op = : LargeInt.t Rep.t
+
val largeReal = iso op = CastLargeReal.isoBits
val largeWord = op = : LargeWord.t Rep.t
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2007-08-15 15:33:44 UTC (rev 5883)
@@ -123,7 +123,9 @@
let open CastReal in viaWord (#1 isoBits) op mod Bits.isoWord end
val word = const
- val largeInt = viaWord id op mod (Iso.swap Word.isoLargeInt)
+ 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 largeWord = viaWord id op mod LargeWord.isoWord
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-08-15 15:33:44 UTC (rev 5883)
@@ -66,7 +66,9 @@
fun refc t = Cmp.map ! t
- val largeInt = LargeInt.compare
+ val fixedInt = FixedInt.compare
+ val largeInt = LargeInt.compare
+
val largeWord = LargeWord.compare
val largeReal = iso CastLargeReal.Bits.compare CastLargeReal.isoBits
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2007-08-15 15:33:44 UTC (rev 5883)
@@ -448,13 +448,7 @@
val exn : Exn.t t = fake "Pickle.exn unimplemented"
fun regExn _ _ = ()
- val char = char
- val bool = bool
- val int = int
- val real = bits RealWord.ops CastReal.isoBits
- val string = share (Arg.string ()) string'
- val word = bits Word.ops Iso.id
-
+ val fixedInt = bits LargeWord.ops (swap LargeWord.isoFixedIntX)
val largeInt = let
fun to i = let
val buffer = Buffer.new ()
@@ -504,6 +498,14 @@
in
share (Arg.largeInt ()) (iso' id string' (to, from))
end
+
+ val char = char
+ val bool = bool
+ val int = int
+ val real = bits RealWord.ops CastReal.isoBits
+ val string = share (Arg.string ()) string'
+ val word = bits Word.ops Iso.id
+
val largeReal = bits LargeRealWord.ops CastLargeReal.isoBits
val largeWord = bits LargeWord.ops Iso.id
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-08-15 15:33:44 UTC (rev 5883)
@@ -185,7 +185,9 @@
val unit = mk (Thunk.mk "()")
val word = mkWord Word.toString
- val largeInt = mk LargeInt.toString
+ val fixedInt = mk FixedInt.toString
+ val largeInt = mk LargeInt.toString
+
val largeReal = mk LargeReal.toString
val largeWord = mkWord LargeWord.toString
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml 2007-08-15 15:33:44 UTC (rev 5883)
@@ -65,7 +65,9 @@
fun refc rA c = rA c o !
- val largeInt = default
+ val fixedInt = default
+ val largeInt = default
+
val largeReal = default
val largeWord = default
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml 2007-08-15 15:33:44 UTC (rev 5883)
@@ -70,7 +70,9 @@
fun refc a = ref o getT a
- val largeInt = fn () => 0 : LargeInt.t
+ val fixedInt = fn () => 0 : FixedInt.t
+ val largeInt = fn () => 0 : LargeInt.t
+
val largeReal = fn () => 0.0 : LargeReal.t
val largeWord = fn () => 0w0 : LargeWord.t
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml 2007-08-15 15:33:44 UTC (rev 5883)
@@ -52,7 +52,9 @@
fun array tA x = (Array.modify tA x ; x)
fun refc tA x = (Ref.modify tA x ; x)
- val largeInt = id
+ val fixedInt = id
+ val largeInt = id
+
val largeReal = id
val largeWord = id
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2007-08-15 15:33:44 UTC (rev 5883)
@@ -68,7 +68,9 @@
val vector = pure
val list = pure
- val largeInt = base
+ val fixedInt = base
+ val largeInt = base
+
val largeReal = base
val largeWord = base
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun 2007-08-15 15:33:44 UTC (rev 5883)
@@ -31,19 +31,17 @@
end
local
- fun mk precision int' large' =
- if isSome Int.precision andalso
- valOf precision <= valOf Int.precision then
- iso int int'
- else
- iso largeInt large'
+ val fits = fn (SOME n, SOME m) => n <= m
+ | _ => false
+ fun mk precision int' fixed' large' =
+ if fits (precision, Int.precision) then iso int int'
+ else if fits (precision, FixedInt.precision) then iso fixedInt fixed'
+ else iso largeInt large'
in
- (* val int8 = mk Int8.precision Int8.isoInt Int8.isoLarge
- (* Int8 not provided by SML/NJ *) *)
- (* val int16 = mk Int16.precision Int16.isoInt Int16.isoLarge
- (* Int16 not provided by SML/NJ *) *)
- val int32 = mk Int32.precision Int32.isoInt Int32.isoLarge
- val int64 = mk Int64.precision Int64.isoInt Int64.isoLarge
+ val int32 = let open Int32 in mk precision isoInt isoFixedInt isoLarge end
+ val int64 = let open Int64 in mk precision isoInt isoFixedInt isoLarge end
+ val position =
+ let open Position in mk precision isoInt isoFixedInt isoLarge end
end
local
@@ -106,7 +104,7 @@
; regExn0 Subscript (fn Subscript => su | _ => n) "Subscript"
; regExn0 Time (fn Time => su | _ => n) "Time.Time"
; regExn0 Unordered (fn Unordered => su | _ => n) "IEEEReal.Unordered"
- ; regExn1 Fail (fn Fail ? => s? | _ => n) "Fail" string
+ ; regExn1 Fail (fn Fail ? => s? | _ => n) "Fail" string
(* Handlers for some extended-basis exceptions: *)
; regExn0 Sum.Sum (fn Sum.Sum => su | _ => n) "Sum"
; regExn0 Fix.Fix (fn Fix.Fix => su | _ => n) "Fix"
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/closed-cases.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/closed-cases.sig 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/closed-cases.sig 2007-08-15 15:33:44 UTC (rev 5883)
@@ -101,7 +101,9 @@
(** == Support for Arbitrary Integers, Words, And Reals == *)
- val largeInt : LargeInt.t Rep.t
+ val fixedInt : FixedInt.t Rep.t
+ val largeInt : LargeInt.t Rep.t
+
val largeReal : LargeReal.t Rep.t
val largeWord : LargeWord.t Rep.t
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/generic-extra.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/generic-extra.sig 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/generic-extra.sig 2007-08-15 15:33:44 UTC (rev 5883)
@@ -8,7 +8,12 @@
* Signature for frequently used derived type representations.
*)
signature GENERIC_EXTRA = sig
- include GENERICS GENERIC
+ include GENERICS
+ where type Label.t = Generics.Label.t
+ where type Con.t = Generics.Con.t
+ where type Record.t = Generics.Record.t
+ where type Tuple.t = Generics.Tuple.t
+ include GENERIC
(** == Shorthands for Types with Labels or Constructors ==
*
@@ -18,7 +23,7 @@
val C0' : String.t -> Unit.t Rep.s
val C1' : String.t -> 'a Rep.t -> 'a Rep.s
- val R' : String.t -> 'a Rep.t -> ('a, Generics.Record.t) Rep.p
+ val R' : String.t -> 'a Rep.t -> ('a, Record.t) Rep.p
val regExn0 : Exn.t -> (Exn.t -> Unit.t Option.t) -> String.t Effect.t
val regExn1 : ('a -> Exn.t) -> (Exn.t -> 'a Option.t) -> String.t
@@ -33,17 +38,13 @@
val tuple4 : 'a Rep.t * 'b Rep.t * 'c Rep.t * 'd Rep.t
-> ('a * 'b * 'c * 'd) Rep.t
- (** == Integer Types ==
- *
- * WARNING: The encodings of sized integer types are not optimal for
- * serialization. (They do work, however.) For serialization, one
- * should encode sized integer types in terms of the corresponding
- * sized word types.
- *)
+ (** == Integer Types == *)
val int32 : Int32.t Rep.t
val int64 : Int64.t Rep.t
+ val position : Position.t Rep.t
+
(** == Some Standard Datatypes == *)
val option : 'a Rep.t -> 'a Option.t Rep.t
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig 2007-08-15 15:33:44 UTC (rev 5883)
@@ -31,6 +31,7 @@
val array : ('a, 'x) Result.t -> 'a Array.t Result.Closed.t
val refc : ('a, 'x) Result.t -> 'a Ref.t Result.Closed.t
val vector : ('a, 'x) Result.t -> 'a Vector.t Result.Closed.t
+ val fixedInt : FixedInt.t Result.Closed.t
val largeInt : LargeInt.t Result.Closed.t
val largeReal : LargeReal.t Result.Closed.t
val largeWord : LargeWord.t Result.Closed.t
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/open-cases.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/open-cases.sig 2007-08-15 14:30:17 UTC (rev 5882)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/open-cases.sig 2007-08-15 15:33:44 UTC (rev 5883)
@@ -31,6 +31,7 @@
val array : ('x -> 'y) -> ('a, 'x) Rep.t -> ('a Array.t, 'y) Rep.t
val refc : ('x -> 'y) -> ('a, 'x) Rep.t -> ('a Ref.t, 'y) Rep.t
val vector : ('x -> 'y) -> ('a, 'x) Rep.t -> ('a Vector.t, 'y) Rep.t
+ val fixedInt : 'x -> (FixedInt.t, 'x) Rep.t
val largeInt : 'x -> (LargeInt.t, 'x) Rep.t
val largeReal : 'x -> (LargeReal.t, 'x) Rep.t
val largeWord : 'x -> (LargeWord.t, 'x) Rep.t
More information about the MLton-commit
mailing list