[MLton-commit] r6302
Vesa Karvonen
vesak at mlton.org
Sat Jan 5 19:00:54 PST 2008
Fixed pretty printing of ints to put the sign first.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/util/ops.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml
U mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/util/ops.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/util/ops.sml 2008-01-05 17:13:09 UTC (rev 6301)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/util/ops.sml 2008-01-06 03:00:53 UTC (rev 6302)
@@ -5,11 +5,14 @@
*)
structure Ops = struct
- datatype 'word w =
+ datatype ('word, 'stream) w =
W of {<< : 'word ShiftOp.t,
>> : 'word ShiftOp.t,
compare : 'word Cmp.t,
isoLargeInt : ('word, LargeInt.t) Iso.t,
+ scan : StringCvt.radix
+ -> (Char.t, 'stream) Reader.t
+ -> ('word, 'stream) Reader.t,
isoWord : ('word, Word.t) Iso.t,
isoWord8 : ('word, Word8.t) Iso.t,
isoWord8X : ('word, Word8.t) Iso.t,
@@ -18,18 +21,23 @@
wordSize : Int.t,
~>> : 'word ShiftOp.t}
- datatype 'int i =
+ datatype ('int, 'stream) i =
I of {*` : 'int BinOp.t,
+` : 'int BinOp.t,
+ compare : 'int Cmp.t,
div : 'int BinOp.t,
+ fmt : StringCvt.radix -> 'int -> String.t,
isoInt : ('int, Int.t) Iso.t,
isoLarge : ('int, LargeInt.t) Iso.t,
maxInt : 'int Option.t,
mod : 'int BinOp.t,
- precision : Int.t Option.t}
+ precision : Int.t Option.t,
+ scan : StringCvt.radix
+ -> (Char.t, 'stream) Reader.t
+ -> ('int, 'stream) Reader.t}
- datatype ('real, 'word) r =
- R of {bitsOps : 'word w,
+ datatype ('real, 'word, 'stream) r =
+ R of {bitsOps : ('word, 'stream) w,
bytesPerElem : Int.t,
isoBits : ('real, 'word) Iso.t Option.t,
subArr : Word8Array.t * Int.t -> 'real,
@@ -48,7 +56,7 @@
val ops = Ops.W {wordSize = wordSize, orb = op orb, << = op <<, ~>> = op ~>>,
>> = op >>, isoLargeInt = isoLargeInt, isoWord = isoWord,
isoWord8 = isoWord8, isoWord8X = isoWord8X, mod = op mod,
- compare = compare}
+ compare = compare, scan = scan}
end
structure LargeRealWordOps = MkWordOps (CastLargeReal.Bits)
@@ -64,7 +72,7 @@
functor MkIntOps (include INTEGER) = struct
val ops = Ops.I {precision = precision, maxInt = maxInt, isoInt = isoInt,
isoLarge = isoLarge, *` = op *, +` = op +, div = op div,
- mod = op mod}
+ mod = op mod, scan = scan, fmt = fmt, compare = compare}
end
structure FixedIntOps = MkIntOps (FixedInt)
@@ -72,7 +80,7 @@
structure LargeIntOps = MkIntOps (LargeInt)
functor MkRealOps (include CAST_REAL PACK_REAL
- val ops : Bits.t Ops.w
+ val ops : (Bits.t, 'stream) Ops.w
sharing type t = real) = struct
val ops = Ops.R {bitsOps = ops, bytesPerElem = bytesPerElem,
isoBits = isoBits, subArr = subArr, toBytes = toBytes}
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2008-01-05 17:13:09 UTC (rev 6301)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2008-01-06 03:00:53 UTC (rev 6302)
@@ -211,8 +211,13 @@
| StringCvt.DEC => empty
| StringCvt.HEX => txt0x
- fun mkInt fmt (E ({fmt = Fmt.T {intRadix, ...}, ...}, _), i) =
- (ATOMIC, intPrefix intRadix <^> txt (fmt intRadix i))
+ fun mkInt (Ops.I {fmt, compare, isoInt = (_, fromInt), ...})
+ (E ({fmt = Fmt.T {intRadix, ...}, ...}, _), i) =
+ (ATOMIC,
+ if LESS = compare (i, fromInt 0)
+ then txt "~" <^> intPrefix intRadix <^>
+ txt (String.extract (fmt intRadix i, 1, NONE))
+ else intPrefix intRadix <^> txt (fmt intRadix i))
val wordPrefix =
fn StringCvt.BIN => txt0wb (* XXX HaMLet-S *)
@@ -418,12 +423,12 @@
fun bool (_, b) = (ATOMIC, if b then txtTrue else txtFalse)
fun char (_, x) =
(ATOMIC, txtHashDQuote <^> txt (Char.toString x) <^> dquote)
- val int = mkInt Int.fmt
+ val int = mkInt IntOps.ops
val real = mkReal Real.fmt
val word = mkWord Word.fmt
- val fixedInt = mkInt FixedInt.fmt
- val largeInt = mkInt LargeInt.fmt
+ val fixedInt = mkInt FixedIntOps.ops
+ val largeInt = mkInt LargeIntOps.ops
val largeReal = mkReal LargeReal.fmt
val largeWord = mkWord LargeWord.fmt
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml 2008-01-05 17:13:09 UTC (rev 6301)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml 2008-01-06 03:00:53 UTC (rev 6302)
@@ -48,8 +48,8 @@
fn Ops.I {precision = SOME prec, ...} => STATIC (bytes prec)
| Ops.I {isoLarge = (toLarge, _), ...} => DYNAMIC (intSize toLarge o #2)
- fun mkWord (Ops.W w : 'w Ops.w) : 'w t = STATIC (bytes (#wordSize w))
- fun mkReal (Ops.R r : ('r, 'w) Ops.r) : 'r t = STATIC (#bytesPerElem r)
+ fun mkWord (Ops.W w : ('w, 's) Ops.w) : 'w t = STATIC (bytes (#wordSize w))
+ fun mkReal (Ops.R r : ('r, 'w, 's) Ops.r) : 'r t = STATIC (#bytesPerElem r)
val iso' =
fn STATIC s => const (STATIC s)
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml 2008-01-05 17:13:09 UTC (rev 6301)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml 2008-01-06 03:00:53 UTC (rev 6302)
@@ -144,5 +144,8 @@
(BR (BR (LF, 0, LF), 1, BR (LF, 2, BR (LF, 3, LF))))
end
+ (tst NONE let open Fmt in default & intRadix := StringCvt.HEX end
+ int "~0x10" ~16)
+
$
end
More information about the MLton-commit
mailing list