mlton-commit Mailing List for MLton

Eliminated memoization of character classification and case conversion
functions.  The new versions are implemented and optimized assuming ASCII
ordering.  The most expensive classification functions are isAlphaNum and
isHexDigit, which both perform a maximum of 3 comparisons, which is
unlikely to be significantly slower than a checked table lookup.  In fact,
according to a simple benchmark (read a large file into a vector, then
repeatedly count all chars in the vector that satisfy the predicate), the
new version isAlphaNum was slightly faster (with the native amd64
codegen).  The main advantages of the new implementations are that they
(apparently) compile to smaller code (no table setup code) and that they
are subject to further optimizations such as constant folding.

----------------------------------------------------------------------

U   mlton/trunk/basis-library/text/char.sml

----------------------------------------------------------------------

Modified: mlton/trunk/basis-library/text/char.sml
===================================================================
--- mlton/trunk/basis-library/text/char.sml	2008-12-21 00:57:12 UTC (rev 7007)
+++ mlton/trunk/basis-library/text/char.sml	2008-12-21 02:27:03 UTC (rev 7008)
@@ -74,51 +74,38 @@
       fun notContains s = not o contains s
 
       val c = fromChar
-      val (  la,    lA,    lf,    lF,    lz,    lZ,    l0,    l9,  lSPACE,lBANG, lTIL,  lDEL) =
-          (c#"a", c#"A", c#"f", c#"F", c#"z", c#"Z", c#"0", c#"9", c#" ", c#"!", c#"~", c#"\127")
+      val (  la,    lA,    lf,    lF,    lz,    lZ,    l0,    l9,  lSPACE,lBANG, lTIL,  lTAB,   lCR,    lDEL) =
+          (c#"a", c#"A", c#"f", c#"F", c#"z", c#"Z", c#"0", c#"9", c#" ", c#"!", c#"~", c#"\t", c#"\r", c#"\127")
 
       (* Range comparisons don't need tables! It's faster to just compare. *)
-      fun isLower c = c >= la andalso c <= lz
-      fun isUpper c = c >= lA andalso c <= lZ
-      fun isDigit c = c >= l0 andalso c <= l9
-      fun isGraph c = c >= lBANG  andalso c <= lTIL
-      fun isPrint c = c >= lSPACE andalso c <= lTIL
-      fun isCntrl c = c <  lSPACE orelse  c  = lDEL
+      fun isLower c = la <= c andalso c <= lz
+      fun isUpper c = c <= lZ andalso lA <= c (* More discriminating first! *)
+      fun isDigit c = c <= l9 andalso l0 <= c (* More discriminating first! *)
+      fun isGraph c = lBANG <= c andalso c <= lTIL
+      fun isPrint c = lSPACE <= c andalso c <= lTIL
+      fun isCntrl c = c < lSPACE orelse c = lDEL
       fun isAscii c = c <= lDEL
 
-      local
-         (* We can use a table for small ranges *)
-         val limit = 128
-         fun memoize (f: char -> 'a, g: char -> 'a): char -> 'a =
-            let
-               val v = Vector.tabulate (limit, f o chrUnsafe)
-               val limit = chr limit
-            in
-               fn c => if c >= limit then g c else
-                       Vector.sub (v, ord c)
-            end
+      (* These take advantage of ASCII ordering to minimize comparisons. *)
+      fun isAlpha c = if la <= c then c <= lz else lA <= c andalso c <= lZ
+      fun isAlphaNum c =
+          if lA <= c then
+             if la <= c then c <= lz else c <= lZ
+          else
+             l0 <= c andalso c <= l9
+      fun isHexDigit c =
+          if lA <= c then
+             if la <= c then c <= lf else c <= lF
+          else
+             l0 <= c andalso c <= l9
+      fun isSpace c = if lCR < c then c = lSPACE else lTAB <= c
+      fun isPunct c = isGraph c andalso not (isAlphaNum c)
 
-         fun make (test, diff) =
-            memoize (fn c => if test c then chrUnsafe (Int.+? (ord c, diff))
-                                       else c,
-                     fn c => c)
+      local
+         fun make (test, diff) c =
+             if test c then chrUnsafe (Int.+? (ord c, diff)) else c
          val diff = Int.- (ord lA, ord la)
-
-         infix || &&
-         fun f || g = memoize (fn c => f c orelse  g c, fn _ => false)
-         fun f && g = memoize (fn c => f c andalso g c, fn _ => false)
-
-         val WS = fromString " \t\r\n\v\f"
-
-         fun laf c = (c >= la andalso c <= lf) orelse
-                     (c >= lA andalso c <= lF)
       in
-         val isAlpha = isUpper || isLower
-         val isHexDigit = isDigit || laf
-         val isAlphaNum = isAlpha || isDigit
-         val isSpace = memoize (contains WS, fn _ => false)
-         val isPunct = isGraph && (not o isAlphaNum)
-
          val toLower = make (isUpper, Int.~ diff)
          val toUpper = make (isLower, diff)
       end

Minor optimization.

----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml

----------------------------------------------------------------------

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml	2008-12-20 16:56:40 UTC (rev 7006)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml	2008-12-21 00:57:12 UTC (rev 7007)
@@ -71,8 +71,7 @@
    fun id first rest = map implode (many1Satisfy2 first rest)
 
    val alphaId = id Char.isAlpha
-                    (fn c => Char.isAlpha c
-                             orelse Char.isDigit c
+                    (fn c => Char.isAlphaNum c
                              orelse #"'" = c orelse #"_" = c)
    val isSymbolic = Char.contains "!#$%&*+-/:<=>?@\\^`|~"
    val symbolicId = map implode (many1Satisfy isSymbolic)

Whitespace cleanup.

----------------------------------------------------------------------

U   mlton/trunk/basis-library/text/char.sml

----------------------------------------------------------------------

Modified: mlton/trunk/basis-library/text/char.sml
===================================================================
--- mlton/trunk/basis-library/text/char.sml	2008-12-20 16:39:32 UTC (rev 7005)
+++ mlton/trunk/basis-library/text/char.sml	2008-12-20 16:56:40 UTC (rev 7006)
@@ -15,34 +15,34 @@
       sharing type PreChar.string = CharVector.vector = CharArray.vector
    end
 
-functor CharFn(Arg : CHAR_ARG) 
-        :> CHAR_EXTRA 
-            where type char   = Arg.PreChar.char 
+functor CharFn(Arg : CHAR_ARG)
+        :> CHAR_EXTRA
+            where type char   = Arg.PreChar.char
             where type string = Arg.PreChar.string =
    struct
       open Arg.PreChar
-      
+
       type string = Arg.CharVector.vector
       val maxOrd: int = numChars - 1
-      
-      val fromString = Arg.CharVector.fromPoly o 
+
+      val fromString = Arg.CharVector.fromPoly o
                        Vector.map (fn x => fromChar x) o
                        String.toPoly
 
       fun succ c =
-         if Primitive.Controls.safe 
+         if Primitive.Controls.safe
             andalso c = maxChar
             then raise Chr
          else chrUnsafe (Int.+ (ord c, 1))
 
       fun pred c =
-         if Primitive.Controls.safe 
+         if Primitive.Controls.safe
             andalso c = minChar
             then raise Chr
          else chrUnsafe (Int.- (ord c, 1))
 
       fun chrOpt c =
-         if Primitive.Controls.safe 
+         if Primitive.Controls.safe
             andalso Int.gtu (c, maxOrd)
             then NONE
          else SOME (chrUnsafe c)
@@ -51,14 +51,14 @@
          case chrOpt c of
             NONE => raise Chr
           | SOME c => c
-      
+
       (* To implement character classes, we cannot use lookup tables on the
        * order of the number of characters. We don't want to scan the string
        * each time, so instead we'll sort it and use binary search.
        *)
       fun contains s =
          let
-            val a = Array.tabulate (Arg.CharVector.length s, 
+            val a = Array.tabulate (Arg.CharVector.length s,
                                     fn i => Arg.CharVector.sub (s, i))
             val () = Heap.heapSort (a, op <)
          in
@@ -70,13 +70,13 @@
                   Array.sub (a, x) = c
                end
          end
-      
+
       fun notContains s = not o contains s
-      
+
       val c = fromChar
       val (  la,    lA,    lf,    lF,    lz,    lZ,    l0,    l9,  lSPACE,lBANG, lTIL,  lDEL) =
           (c#"a", c#"A", c#"f", c#"F", c#"z", c#"Z", c#"0", c#"9", c#" ", c#"!", c#"~", c#"\127")
-      
+
       (* Range comparisons don't need tables! It's faster to just compare. *)
       fun isLower c = c >= la andalso c <= lz
       fun isUpper c = c >= lA andalso c <= lZ
@@ -85,7 +85,7 @@
       fun isPrint c = c >= lSPACE andalso c <= lTIL
       fun isCntrl c = c <  lSPACE orelse  c  = lDEL
       fun isAscii c = c <= lDEL
-      
+
       local
          (* We can use a table for small ranges *)
          val limit = 128
@@ -94,22 +94,22 @@
                val v = Vector.tabulate (limit, f o chrUnsafe)
                val limit = chr limit
             in
-               fn c => if c >= limit then g c else 
+               fn c => if c >= limit then g c else
                        Vector.sub (v, ord c)
             end
-         
+
          fun make (test, diff) =
-            memoize (fn c => if test c then chrUnsafe (Int.+? (ord c, diff)) 
+            memoize (fn c => if test c then chrUnsafe (Int.+? (ord c, diff))
                                        else c,
                      fn c => c)
          val diff = Int.- (ord lA, ord la)
-      
+
          infix || &&
          fun f || g = memoize (fn c => f c orelse  g c, fn _ => false)
          fun f && g = memoize (fn c => f c andalso g c, fn _ => false)
-         
+
          val WS = fromString " \t\r\n\v\f"
-         
+
          fun laf c = (c >= la andalso c <= lf) orelse
                      (c >= lA andalso c <= lF)
       in
@@ -118,11 +118,11 @@
          val isAlphaNum = isAlpha || isDigit
          val isSpace = memoize (contains WS, fn _ => false)
          val isPunct = isGraph && (not o isAlphaNum)
-         
+
          val toLower = make (isUpper, Int.~ diff)
          val toUpper = make (isLower, diff)
       end
-      
+
       fun control reader state =
          case reader state of
             NONE => NONE
@@ -226,9 +226,9 @@
          in
             main
          end
-      
+
       val fromString = StringCvt.scanString scan
-      
+
       fun 'a scanC (reader: (Char.char, 'a) StringCvt.reader)
         : (char, 'a) StringCvt.reader =
          let
@@ -294,14 +294,14 @@
                     then s
                  else raise Fail "padLeft"
          end
-      
+
       fun unicodeEscape ord =
           if Int.< (ord, 65536)
              then String.concat
                   ["\\u", padLeft (Int.fmt StringCvt.HEX ord, 4)]
           else String.concat
                ["\\U", padLeft (Int.fmt StringCvt.HEX ord, 8)]
-      
+
       fun toString c =
          let
             val ord = ord c
@@ -325,15 +325,15 @@
                 | _ =>
                    if Int.< (ord, 32)
                       then String.concat
-                           ["\\^", String.new 
-                                   (1, Char.chrUnsafe 
+                           ["\\^", String.new
+                                   (1, Char.chrUnsafe
                                        (Int.+? (ord, 64 (* #"@" *) )))]
                    else if Int.< (ord, 256)
                       then String.concat
                            ["\\", padLeft (Int.fmt StringCvt.DEC ord, 3)]
                    else unicodeEscape ord
          end
-      
+
       fun toCString c =
          let
             val ord = ord c
@@ -355,7 +355,7 @@
                 | 11 (* #"\v" *) => "\\v"
                 | 12 (* #"\f" *) => "\\f"
                 | 13 (* #"\r" *) => "\\r"
-                | _ => 
+                | _ =>
                    if Int.< (ord, 256)
                       then String.concat
                            ["\\", padLeft (Int.fmt StringCvt.OCT ord, 3)]

Renamed drop -> skipManySatisfy and take -> manySatisfy and added several
variants of those as in FParsec.

----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml
U   mltonlib/trunk/org/mlton/vesak/parsec/unstable/detail/mk-parsec.fun
U   mltonlib/trunk/org/mlton/vesak/parsec/unstable/public/parsec.sig

----------------------------------------------------------------------

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml	2008-12-16 10:21:30 UTC (rev 7004)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml	2008-12-20 16:39:32 UTC (rev 7005)
@@ -52,7 +52,9 @@
       lp 0
    end
 
-   fun ignored 0 = drop Char.isSpace >> (L"(*" >> eta ignored 1 <|> return ())
+   val skipSpaces = skipManySatisfy Char.isSpace
+
+   fun ignored 0 = skipSpaces >> (L"(*" >> eta ignored 1 <|> return ())
      | ignored n = L"*)" >> eta ignored (n-1) <|>
                    L"(*" >> eta ignored (n+1) <|>
                    elem  >> eta ignored n
@@ -66,15 +68,14 @@
 
    datatype radix = datatype StringCvt.radix
 
-   fun id first rest =
-       sat first >>= (fn c => take rest >>= (fn cs => return (implode (c::cs))))
+   fun id first rest = map implode (many1Satisfy2 first rest)
 
    val alphaId = id Char.isAlpha
                     (fn c => Char.isAlpha c
                              orelse Char.isDigit c
                              orelse #"'" = c orelse #"_" = c)
    val isSymbolic = Char.contains "!#$%&*+-/:<=>?@\\^`|~"
-   val symbolicId = id isSymbolic isSymbolic
+   val symbolicId = map implode (many1Satisfy isSymbolic)
 
    val shortId = alphaId <|> symbolicId
    val longId = sepBy1 shortId (E#".")
@@ -304,7 +305,7 @@
          <|> E#"u" >> satN Char.isHexDigit 4 >>= (fn ds => scan (#"u" :: ds) cs)
          <|> E#"U" >> satN Char.isHexDigit 8 >>= (fn ds => scan (#"U" :: ds) cs)
          <|> sat Char.isGraph >>= (fn c => scan [c] cs)
-         <|> sat Char.isSpace >> drop Char.isSpace >> E#"\\" >>= (fn _ =>
+         <|> sat Char.isSpace >> skipSpaces >> E#"\\" >>= (fn _ =>
              chars cs)
          and scan c cs =
              case Char.scan List.getItem (#"\\" :: c)

Modified: mltonlib/trunk/org/mlton/vesak/parsec/unstable/detail/mk-parsec.fun
===================================================================
--- mltonlib/trunk/org/mlton/vesak/parsec/unstable/detail/mk-parsec.fun	2008-12-16 10:21:30 UTC (rev 7004)
+++ mltonlib/trunk/org/mlton/vesak/parsec/unstable/detail/mk-parsec.fun	2008-12-20 16:39:32 UTC (rev 7005)
@@ -26,6 +26,7 @@
    (* SML/NJ workaround --> *)
 
    open Arg
+   open Sequence
    type 'a etaexp_dom = Sequence.t * State.t
    type msg = Sequence.Pos.t
    datatype 'a reply =
@@ -110,16 +111,34 @@
         of NONE        => EMPTY (FAIL (pos s))
          | SOME (c, s) => taste (OK (c, s, pos s))
 
-   fun drop p s = let
-      fun done f s = f (OK ((), s, pos s))
-      fun some (c, s') s = if p c then lp s' else done taste s
-      and body f s =
-          case get s
-           of NONE    => done f s
-            | SOME cs => some cs s
-      and lp s = body taste s
+   local
+      fun mk isZero zero plus finish req1 q p s = let
+         fun ok v s = OK (finish v, s, pos s)
+         fun done v =
+             if isZero v
+             then EMPTY o (if req1 then FAIL o pos else ok v)
+             else taste o ok v
+         fun step p es s =
+             case get s
+              of NONE        => done es s
+               | SOME (e, t) => if p e then body (plus (e, es)) t else done es s
+         and body es = step p es
+      in
+         case q
+          of NONE   => body zero s
+           | SOME q => step q zero s
+      end
+      val mkMany = mk null [] op :: rev
+      val mkSkip = mk id true (const false) General.ignore
    in
-      body EMPTY s
+      val many1Satisfy = mkMany true NONE
+      val many1Satisfy2 = mkMany true o SOME
+      val manySatisfy = mkMany false NONE
+      val manySatisfy2 = mkMany false o SOME
+      val skipMany1Satisfy = mkSkip true NONE
+      val skipMany1Satisfy2 = mkSkip true o SOME
+      val skipManySatisfy = mkSkip false NONE
+      val skipManySatisfy2 = mkSkip false o SOME
    end
 
    fun sat p s =
@@ -128,21 +147,6 @@
          | SOME (c, s') =>
            if p c then taste (OK (c, s', pos s')) else EMPTY (FAIL (pos s))
 
-   fun take p = let
-      fun done s =
-       fn [] => EMPTY (OK ([], s, pos s))
-        | cs => taste (OK (rev cs, s, pos s))
-      fun lp cs s =
-          case get s
-           of NONE => done s cs
-            | SOME (c, s') =>
-              if p c
-              then lp (c::cs) s'
-              else done s cs
-   in
-      lp []
-   end
-
    fun peek p s =
        case p s
         of EMPTY (OK (x, _, m)) => EMPTY (OK (x, s, m))

Modified: mltonlib/trunk/org/mlton/vesak/parsec/unstable/public/parsec.sig
===================================================================
--- mltonlib/trunk/org/mlton/vesak/parsec/unstable/public/parsec.sig	2008-12-16 10:21:30 UTC (rev 7004)
+++ mltonlib/trunk/org/mlton/vesak/parsec/unstable/public/parsec.sig	2008-12-20 16:39:32 UTC (rev 7005)
@@ -12,6 +12,9 @@
 signature PARSEC = sig
    include MK_PARSEC_DOM
 
+   structure Elem : T
+   sharing Elem = Sequence.Elem
+
    include ETAEXP'
    include MONADP where type 'a monad = 'a etaexp
 
@@ -23,17 +26,26 @@
    val getState : State.t t
    val setState : State.t -> Unit.t t
 
-   val fromScan : ((Sequence.Elem.t, Sequence.t) Reader.t
-                   -> ('a, Sequence.t) Reader.t) -> 'a t
+   val fromScan :
+       ((Elem.t, Sequence.t) Reader.t -> ('a, Sequence.t) Reader.t) -> 'a t
    val fromReader : ('a, Sequence.t) Reader.t -> 'a t
 
    val guess : 'a t UnOp.t
 
-   val elem : Sequence.Elem.t t
-   val drop : Sequence.Elem.t UnPr.t -> Unit.t t
-   val sat : Sequence.Elem.t UnPr.t -> Sequence.Elem.t t
-   val take : Sequence.Elem.t UnPr.t -> Sequence.Elem.t List.t t
+   val elem : Elem.t t
 
+   val sat : Elem.t UnPr.t -> Elem.t t
+
+   val manySatisfy : Elem.t UnPr.t -> Elem.t List.t t
+   val manySatisfy2 : Elem.t UnPr.t -> Elem.t UnPr.t -> Elem.t List.t t
+   val many1Satisfy : Elem.t UnPr.t -> Elem.t List.t t
+   val many1Satisfy2 : Elem.t UnPr.t -> Elem.t UnPr.t -> Elem.t List.t t
+
+   val skipManySatisfy : Elem.t UnPr.t -> Unit.t t
+   val skipManySatisfy2 : Elem.t UnPr.t -> Elem.t UnPr.t -> Unit.t t
+   val skipMany1Satisfy : Elem.t UnPr.t -> Unit.t t
+   val skipMany1Satisfy2 : Elem.t UnPr.t -> Elem.t UnPr.t -> Unit.t t
+
    val ->> : 'a t * 'b t -> 'b t
    val >>- : 'a t * 'b t -> 'a t
 

Added ad-hoc tests for sepEndBy and sepEndBy1 and fixed a bug in
sepEndBy1.

----------------------------------------------------------------------

U   mltonlib/trunk/org/mlton/vesak/parsec/unstable/detail/mk-parsec.fun
U   mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/parsec.sml

----------------------------------------------------------------------

Modified: mltonlib/trunk/org/mlton/vesak/parsec/unstable/detail/mk-parsec.fun
===================================================================
--- mltonlib/trunk/org/mlton/vesak/parsec/unstable/detail/mk-parsec.fun	2008-12-14 22:46:44 UTC (rev 7003)
+++ mltonlib/trunk/org/mlton/vesak/parsec/unstable/detail/mk-parsec.fun	2008-12-16 10:21:30 UTC (rev 7004)
@@ -195,14 +195,16 @@
    fun sepBy1 p s = oneMany p (s ->> p)
    fun sepBy p s = sepBy1 p s <|> return []
 
-   fun sepEndBy p s = let
+   fun sepEndBy' p s = let
       fun done xs ? = return (rev xs) ?
       fun pee xs = p >>= (fn x => ess (x::xs)) <|> done xs
       and ess xs = s >>= (fn _ => pee xs) <|> done xs
    in
-      pee []
+      pee
    end
 
+   fun sepEndBy p s = sepEndBy' p s []
+
    fun sepEndBy1 p s =
-       p >>= (fn x => s >>= (fn _ => map (fn xs => x::xs) (sepEndBy p s)))
+       p >>= (fn x => s >>= (fn _ => sepEndBy' p s [x]) <|> return [x])
 end

Modified: mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/parsec.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/parsec.sml	2008-12-14 22:46:44 UTC (rev 7003)
+++ mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/parsec.sml	2008-12-16 10:21:30 UTC (rev 7004)
@@ -84,5 +84,10 @@
     (chk (sepBy1 l u |>> implode) String.t
          [F "-" 0, S "aXb-" "ab" "-", F "aXbY" 4])
 
+    (chk (sepEndBy l u |>> implode) String.t
+         [S"x-""x""-", S"xA-""x""-", S"aXb-""ab""-", S"bXaY-""ba""-"])
+    (chk (sepEndBy1 l u |>> implode) String.t
+         [S"x-""x""-", S"xA-""x""-", S"aXb-""ab""-", S"bXaY-""ba""-", F"-"0])
+
     $
 end

Use ge rather than eq comparison to make overflow check elimination
easier.

----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml

----------------------------------------------------------------------

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml	2008-12-14 20:34:09 UTC (rev 7002)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml	2008-12-14 22:46:44 UTC (rev 7003)
@@ -40,7 +40,7 @@
 
    fun L l = fromReader let
       fun lp i s =
-          if i = size l
+          if i >= size l
           then SOME ((), s)
           else case Sequence.get s
                 of NONE         => NONE
@@ -200,7 +200,7 @@
          val {fromLabel, fromArray} = getP aP 0
          val n = Arg.numElems aP
          fun pl a i =
-             if i = n
+             if i >= n
              then E#")" >> return (fromArray a)
              else case fromLabel i
                    of NONE        => fail "impossible"
@@ -211,7 +211,7 @@
                         then ignored
                         else ignored >> E#"," >> ignored) >> pl a (i+1)))
          fun rl a i =
-             if i = n
+             if i >= n
              then E#"}" >> return (fromArray a)
              else numLabel >>= (fn l =>
                   case fromLabel (valOf (Int.fromString l) - 1)

Try the most likely alternative first.

----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml

----------------------------------------------------------------------

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml	2008-12-14 18:00:05 UTC (rev 7001)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml	2008-12-14 20:34:09 UTC (rev 7002)
@@ -81,7 +81,7 @@
    fun I s = shortId >>= (fn i => if i = s then return () else zero)
 
    val numLabel = id (Char.inRange (#"1", #"9")) Char.isDigit
-   val label = numLabel <|> shortId
+   val label = shortId <|> numLabel
 
    fun mkSequ pre suf (Ops.S {fromList, ...}) p = let
       fun fin xs _ = return (fromList (rev xs))

Some minor simplifications.

----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml

----------------------------------------------------------------------

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml	2008-12-14 17:59:06 UTC (rev 7000)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml	2008-12-14 18:00:05 UTC (rev 7001)
@@ -20,7 +20,7 @@
    infixr 0 -->
    (* SML/NJ workaround --> *)
 
-   infix 1 << >> <<< >>>
+   infix 1 ->> >>- <<< >>>
 
    structure Parsec = MkParsec
      (structure Sequence = struct
@@ -59,7 +59,6 @@
 
    val ignored = ignored 0
 
-   fun l << r = l >>= (fn l => r >> return l)
    fun l >>> r = l >> ignored >> r
    fun l <<< r = l >>= (fn l => ignored >> r >> return l)
 
@@ -78,7 +77,7 @@
    val symbolicId = id isSymbolic isSymbolic
 
    val shortId = alphaId <|> symbolicId
-   val longId = map op :: (shortId >>* many (E#"." >> shortId))
+   val longId = sepBy1 shortId (E#".")
    fun I s = shortId >>= (fn i => if i = s then return () else zero)
 
    val numLabel = id (Char.inRange (#"1", #"9")) Char.isDigit
@@ -154,7 +153,7 @@
               then x
               else error s
             | INL s => error s) o
-          reader' (getT t << ignored)
+          reader' (getT t >>- ignored)
                   StringSequence.get o
           StringSequence.full
    end
@@ -233,7 +232,7 @@
          val {fromLabel, fromArray} = getP aP 0
          val n = Arg.numElems aP
          fun lp a i =
-             if i = n
+             if i >= n
              then E#"}" >> return (fromArray a)
              else label >>= (fn l =>
                   case fromLabel l
@@ -290,17 +289,11 @@
       val bool = parens (alphaId >>= (fn "true"  => return true
                                        | "false" => return false
                                        | _       => zero))
-      val char = parens (L"#\"" >> fromScan Char.scan << E#"\"")
+      val char = parens (between (L"#\"") (E#"\"") (fromScan Char.scan))
       val int = mkInt IntOps.ops
 
       val string = let
-         fun satN p n = let
-            fun lp cs =
-             fn 0 => return (rev cs)
-              | n => sat p >>= (fn c => lp (c::cs) (n-1))
-         in
-            lp [] n
-         end
+         val satN = count o sat
          fun chars cs =
              E#"\\" >>= (fn _ => escape cs)
          <|> E#"\"" >>= (fn _ => return (implode (rev cs)))

Some minor optimizations.

----------------------------------------------------------------------

U   mltonlib/trunk/org/mlton/vesak/parsec/unstable/detail/mk-parsec.fun

----------------------------------------------------------------------

Modified: mltonlib/trunk/org/mlton/vesak/parsec/unstable/detail/mk-parsec.fun
===================================================================
--- mltonlib/trunk/org/mlton/vesak/parsec/unstable/detail/mk-parsec.fun	2008-12-14 12:58:31 UTC (rev 6999)
+++ mltonlib/trunk/org/mlton/vesak/parsec/unstable/detail/mk-parsec.fun	2008-12-14 17:59:06 UTC (rev 7000)
@@ -98,15 +98,6 @@
 
    open Monad
 
-   fun map x2y xM s =
-       case xM s
-        of EMPTY (FAIL m)       => EMPTY (FAIL m)
-         | EMPTY (OK (x, s, m)) => EMPTY (OK (x2y x, s, m))
-         | TASTE th             =>
-           TASTE (fn () => case th ()
-                            of FAIL m       => FAIL m
-                             | OK (x, s, m) => OK (x2y x, s, m))
-
    fun guess p s =
        case p s
         of EMPTY r  => EMPTY r
@@ -160,37 +151,37 @@
                                     of OK (x, _, m) => taste (OK (x, s, m))
                                      | FAIL m       => taste (FAIL m)
 
-   fun foldMany f s p = let
-      fun lp s = p >>= (fn x => lp (f (x, s))) <|> (fn ? => return s ?)
+   fun foldMany g f s p = let
+      fun lp s = p >>= (fn x => lp (f (x, s))) <|> (fn ? => return (g s) ?)
    in
       lp s
    end
 
-   fun manyRev p = foldMany op :: [] p
-   fun many p = map rev (manyRev p)
+   fun manyRev p = foldMany id op :: [] p
+   fun many p = foldMany rev op :: [] p
 
-   fun oneMany p q = p >>= (fn x => map (fn xs => x::xs) (many q))
+   fun oneMany p q = p >>= (fn x => foldMany rev op :: [x] q)
 
    fun many1 p = oneMany p p
 
+   val op ->> = op >>
    fun p >>- s = p >>= (fn x => map (const x) s)
-   fun s ->> p = s >>= const p
 
-   fun between b a p = b ->> p >>- a
+   fun between b a p = b ->> (p >>- a)
 
-   fun foldCount f s p n = let
+   fun foldCount g f s p n = let
       fun lp s n =
           if 0 < n
           then p >>= (fn x => lp (f (x, s)) (n-1))
-          else return s
+          else return (g s)
    in
       if n < 0 then raise Domain else lp s n
    end
 
-   fun count p = map rev o foldCount op :: [] p
+   fun count p = foldCount rev op :: [] p
 
    fun skip p = map General.ignore p
-   fun skipCount p = foldCount General.ignore () p
+   fun skipCount p = foldCount General.ignore General.ignore () p
    fun skipMany p = skipMany1 p <|> return ()
    and skipMany1 p = p >>= (fn _ => skipMany p)
 

Added a number of combinators and some ad hoc tests.

----------------------------------------------------------------------

U   mltonlib/trunk/org/mlton/vesak/parsec/unstable/detail/mk-parsec.fun
U   mltonlib/trunk/org/mlton/vesak/parsec/unstable/public/parsec.sig
A   mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/
A   mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/app/
A   mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/app/generic.mlb
A   mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/parsec.sml
A   mltonlib/trunk/org/mlton/vesak/parsec/unstable/test.mlb

----------------------------------------------------------------------

Modified: mltonlib/trunk/org/mlton/vesak/parsec/unstable/detail/mk-parsec.fun
===================================================================
--- mltonlib/trunk/org/mlton/vesak/parsec/unstable/detail/mk-parsec.fun	2008-12-09 18:07:41 UTC (rev 6998)
+++ mltonlib/trunk/org/mlton/vesak/parsec/unstable/detail/mk-parsec.fun	2008-12-14 12:58:31 UTC (rev 6999)
@@ -20,7 +20,7 @@
    infixr 4 </ />
    infix  2 >| andAlso
    infixr 2 |<
-   infix  1 orElse >>=
+   infix  1 orElse >>= ->> >>-
    infix  0 & <|>
    infixr 0 -->
    (* SML/NJ workaround --> *)
@@ -79,7 +79,7 @@
          | EMPTY (OK (x, s, m)) => replyNone m (x2yM x s)
          | TASTE th             =>
            TASTE (fn () => case th ()
-                            of FAIL e       => FAIL e
+                            of FAIL m       => FAIL m
                              | OK (x, s, m) => bindSome m (x2yM x s))
 
    fun zero s = EMPTY (FAIL (pos s))
@@ -89,6 +89,24 @@
         of EMPTY (FAIL m) => replyNone m (q s)
          | other          => other
 
+   structure Monad = MkMonadP
+     (type 'a monad = 'a t
+      val return = return
+      val op >>= = op >>=
+      val zero = zero
+      val op <|> = op <|>)
+
+   open Monad
+
+   fun map x2y xM s =
+       case xM s
+        of EMPTY (FAIL m)       => EMPTY (FAIL m)
+         | EMPTY (OK (x, s, m)) => EMPTY (OK (x2y x, s, m))
+         | TASTE th             =>
+           TASTE (fn () => case th ()
+                            of FAIL m       => FAIL m
+                             | OK (x, s, m) => OK (x2y x, s, m))
+
    fun guess p s =
        case p s
         of EMPTY r  => EMPTY r
@@ -142,27 +160,58 @@
                                     of OK (x, _, m) => taste (OK (x, s, m))
                                      | FAIL m       => taste (FAIL m)
 
-   fun many p = many1 p <|> return []
-   and many1 p = p >>= (fn x => many p >>= (fn xs => return (x::xs)))
+   fun foldMany f s p = let
+      fun lp s = p >>= (fn x => lp (f (x, s))) <|> (fn ? => return s ?)
+   in
+      lp s
+   end
 
-   fun between b a p = b >>= (fn _ => p >>= (fn r => a >>= (fn _ => return r)))
+   fun manyRev p = foldMany op :: [] p
+   fun many p = map rev (manyRev p)
 
-   fun option alt p = p <|> return alt
+   fun oneMany p q = p >>= (fn x => map (fn xs => x::xs) (many q))
 
-   fun sepBy1 p s =
-       p >>= (fn x => many (s >>= (fn _ => p)) >>= (fn xs => return (x::xs)))
-   fun sepBy p s = sepBy1 p s <|> return []
+   fun many1 p = oneMany p p
 
-   fun skip p = p >>= return o ignore
+   fun p >>- s = p >>= (fn x => map (const x) s)
+   fun s ->> p = s >>= const p
+
+   fun between b a p = b ->> p >>- a
+
+   fun foldCount f s p n = let
+      fun lp s n =
+          if 0 < n
+          then p >>= (fn x => lp (f (x, s)) (n-1))
+          else return s
+   in
+      if n < 0 then raise Domain else lp s n
+   end
+
+   fun count p = map rev o foldCount op :: [] p
+
+   fun skip p = map General.ignore p
+   fun skipCount p = foldCount General.ignore () p
    fun skipMany p = skipMany1 p <|> return ()
    and skipMany1 p = p >>= (fn _ => skipMany p)
 
-   structure Monad = MkMonadP
-     (type 'a monad = 'a t
-      val return = return
-      val op >>= = op >>=
-      val zero = zero
-      val op <|> = op <|>)
+   fun option alt p = p <|> return alt
+   fun opt p = option NONE (map SOME p)
+   fun optional p = skip p <|> return ()
 
-   open Monad
+   fun endBy p = many o p <\ op >>-
+   fun endBy1 p = many1 o p <\ op >>-
+
+   fun sepBy1 p s = oneMany p (s ->> p)
+   fun sepBy p s = sepBy1 p s <|> return []
+
+   fun sepEndBy p s = let
+      fun done xs ? = return (rev xs) ?
+      fun pee xs = p >>= (fn x => ess (x::xs)) <|> done xs
+      and ess xs = s >>= (fn _ => pee xs) <|> done xs
+   in
+      pee []
+   end
+
+   fun sepEndBy1 p s =
+       p >>= (fn x => s >>= (fn _ => map (fn xs => x::xs) (sepEndBy p s)))
 end

Modified: mltonlib/trunk/org/mlton/vesak/parsec/unstable/public/parsec.sig
===================================================================
--- mltonlib/trunk/org/mlton/vesak/parsec/unstable/public/parsec.sig	2008-12-09 18:07:41 UTC (rev 6998)
+++ mltonlib/trunk/org/mlton/vesak/parsec/unstable/public/parsec.sig	2008-12-14 12:58:31 UTC (rev 6999)
@@ -34,19 +34,34 @@
    val sat : Sequence.Elem.t UnPr.t -> Sequence.Elem.t t
    val take : Sequence.Elem.t UnPr.t -> Sequence.Elem.t List.t t
 
-   val peek : 'a t UnOp.t
+   val ->> : 'a t * 'b t -> 'b t
+   val >>- : 'a t * 'b t -> 'a t
 
+   val between : 'a t -> 'b t -> 'c t UnOp.t
+
+   val count : 'a t -> Int.t -> 'a List.t t
+
+   val endBy : 'a t -> 'end t -> 'a List.t t
+   val endBy1 : 'a t -> 'end t -> 'a List.t t
+
    val many : 'a t -> 'a List.t t
+   val manyRev : 'a t -> 'a List.t t
    val many1 : 'a t -> 'a List.t t
 
+   val opt : 'a t -> 'a Option.t t
    val option : 'a -> 'a t UnOp.t
+   val optional : 'a t -> Unit.t t
 
-   val between : 'a t -> 'b t -> 'c t UnOp.t
+   val peek : 'a t UnOp.t
 
-   val sepBy : 'a t -> 'b t -> 'a List.t t
-   val sepBy1 : 'a t -> 'b t -> 'a List.t t
+   val sepBy : 'a t -> 'sep t -> 'a List.t t
+   val sepBy1 : 'a t -> 'sep t -> 'a List.t t
 
+   val sepEndBy : 'a t -> 'sep t -> 'a List.t t
+   val sepEndBy1 : 'a t -> 'sep t -> 'a List.t t
+
    val skip : 'a t -> Unit.t t
+   val skipCount : 'a t -> Int.t -> Unit.t t
    val skipMany : 'a t -> Unit.t t
    val skipMany1 : 'a t -> Unit.t t
 end

Added: mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/app/generic.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/app/generic.mlb	2008-12-09 18:07:41 UTC (rev 6998)
+++ mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/app/generic.mlb	2008-12-14 12:58:31 UTC (rev 6999)
@@ -0,0 +1,27 @@
+(* Copyright (C) 2008 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
+   $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+   $(MLTON_LIB)/com/ssh/random/unstable/lib.mlb
+
+   $(MLTON_LIB)/com/ssh/generic/unstable/lib.mlb
+in
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/generic.sml
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/type-info.sml
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/type-hash.sml
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/hash.sml
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/pretty.sml
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/eq.sml
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/arbitrary.sml
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/size.sml
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/ord.sml
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/shrink.sml
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/close-pretty-with-extra.sml
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/reg-basis-exns.sml
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/types.sml
+   $(MLTON_LIB)/com/ssh/generic/unstable/with/types-$(SML_COMPILER).sml
+end

Added: mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/parsec.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/parsec.sml	2008-12-09 18:07:41 UTC (rev 6998)
+++ mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/parsec.sml	2008-12-14 12:58:31 UTC (rev 6999)
@@ -0,0 +1,88 @@
+(* Copyright (C) 2008 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.
+ *)
+
+structure Parsec =
+   MkParsec (structure Sequence = StringSequence
+             structure State = Unit)
+
+val () = let
+   open UnitTest Parsec
+
+   infix |>>
+   fun p |>> f = map f p
+
+   fun parse p s =
+       Parsec.parse p (StringSequence.full s, ())
+
+   datatype 'a test =
+      SUCCESS of String.t * 'a * String.t
+    | FAILURE of String.t * Int.t
+
+   fun remaining s =
+       Substring.extract (StringSequence.vector s, StringSequence.pos s, NONE)
+    >| Substring.string
+
+   fun chk p t cs =
+       test (fn () =>
+       List.app
+        (fn SUCCESS (s, v, r) =>
+            (case parse p s
+              of INL p => fails ["Parse failed at ", Int.toString p]
+               | INR (v', (r', ())) =>
+                 (thatEq t {actual = v', expect = v}
+                ; thatEq String.t {actual = remaining r', expect = r}))
+          | FAILURE (s, c) =>
+            (case parse p s
+              of INL p => thatEq Int.t {actual = p, expect = c}
+               | INR (v, (r, ())) =>
+                 fails ["Parse succeed with ", Generic.show t v,
+                        " at pos ", Int.toString (StringSequence.pos r),
+                        " and remaining input ",
+                        Generic.show String.t (remaining r)]))
+        cs)
+
+   fun S s v r = SUCCESS (s, v, r)
+   fun F s p = FAILURE (s, p)
+
+   val d = sat Char.isDigit
+   val l = sat Char.isLower
+   val u = sat Char.isUpper
+in
+   unitTests
+    (title "Parsec")
+
+    (chk (l <|> u) Char.t [F "0" 0, S "ab" #"a" "b", S "Ba" #"B" "a"])
+
+    (chk (l >>* u) (Sq.t Char.t) [F "Ul" 0, S "lU-" (#"l", #"U") "-"])
+
+    (chk (between l u d) Char.t [S "b9X-" #"9" "-", F "bX" 1])
+
+    (chk (count l 3 |>> implode) String.t [S "abcdE" "abc" "dE", F "abC" 2])
+
+    (chk (endBy l u |>> implode) String.t
+         [S "-" "" "-", S "aXbY-" "ab" "-", F "aXbYc-" 5])
+    (chk (endBy1 l u |>> implode) String.t
+         [F "-" 0, F "o-" 1, S "aXbY-" "ab" "-", F "aXbYc-" 5])
+
+    (chk (many (l >>* u |>> op ^ o Sq.map str) |>> concat) String.t
+         [S "-" "" "-", S "aBcD-" "aBcD" "-", F "abC" 1])
+    (chk (manyRev (l >>* u |>> op ^ o Sq.map str) |>> concat) String.t
+         [S "-" "" "-", S "aBcD-" "cDaB" "-", F "abC" 1])
+    (chk (many1 (l >>* u |>> op ^ o Sq.map str) |>> concat) String.t
+         [F "-" 0, S "aBcD-" "aBcD" "-", F "abC" 1])
+
+    (chk (opt (count l 2 |>> implode)) (Option.t String.t)
+         [S "xy-" (SOME "xy") "-", S "-" NONE "-", F "bA" 1])
+
+    (chk (l >>* peek u) (Sq.t Char.t) [S "lU-" (#"l", #"U") "U-", F "ab" 1])
+
+    (chk (sepBy l u |>> implode) String.t
+         [S "-" "" "-", S "aXb-" "ab" "-", F "aXbY" 4])
+    (chk (sepBy1 l u |>> implode) String.t
+         [F "-" 0, S "aXb-" "ab" "-", F "aXbY" 4])
+
+    $
+end


Property changes on: mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/parsec.sml
___________________________________________________________________
Name: svn:eol-style
   + native

Added: mltonlib/trunk/org/mlton/vesak/parsec/unstable/test.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/parsec/unstable/test.mlb	2008-12-09 18:07:41 UTC (rev 6998)
+++ mltonlib/trunk/org/mlton/vesak/parsec/unstable/test.mlb	2008-12-14 12:58:31 UTC (rev 6999)
@@ -0,0 +1,19 @@
+(* Copyright (C) 2008 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.
+ *)
+
+$(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+$(MLTON_LIB)/com/ssh/unit-test/unstable/lib.mlb
+lib.mlb
+
+$(APPLICATION)/generic.mlb
+
+ann
+   "nonexhaustiveExnMatch ignore"
+   "sequenceNonUnit warn"
+   "warnUnused true"
+in
+   test/parsec.sml
+end

Changed cenv.h so that it includes export.h near the end, and removed
some now obsolete occurrences of #include export.h.

Why?  On Solaris 10, the <sys/mman.h> header #defines PRIVATE.
Including export.h after platform.h now redefines the macro so that
the runtime compiles again.

----------------------------------------------------------------------

U   mlton/trunk/runtime/cenv.h
U   mlton/trunk/runtime/gdtoa-patch.internal
U   mlton/trunk/runtime/gen/gen-types.c
U   mlton/trunk/runtime/platform.h
U   mlton/trunk/runtime/util/to-string.c
U   mlton/trunk/runtime/util.c

----------------------------------------------------------------------

Modified: mlton/trunk/runtime/cenv.h
===================================================================
--- mlton/trunk/runtime/cenv.h	2008-12-09 17:42:16 UTC (rev 6997)
+++ mlton/trunk/runtime/cenv.h	2008-12-09 18:07:41 UTC (rev 6998)
@@ -131,12 +131,13 @@
 #endif
 
 #include "gmp.h"
+#include "export.h"
 
-COMPILE_TIME_ASSERT(sizeof_uintptr_t__is__sizeof_voidStar, 
+COMPILE_TIME_ASSERT(sizeof_uintptr_t__is__sizeof_voidStar,
                     sizeof(uintptr_t) == sizeof(void*));
-COMPILE_TIME_ASSERT(sizeof_uintptr_t__is__sizeof_size_t, 
+COMPILE_TIME_ASSERT(sizeof_uintptr_t__is__sizeof_size_t,
                     sizeof(uintptr_t) == sizeof(size_t));
-COMPILE_TIME_ASSERT(sizeof_uintptr_t__is__sizeof_ptrdiff_t, 
+COMPILE_TIME_ASSERT(sizeof_uintptr_t__is__sizeof_ptrdiff_t,
                     sizeof(uintptr_t) == sizeof(ptrdiff_t));
 COMPILE_TIME_ASSERT(sizeof_voidStar__is__pointer_bits,
                     sizeof(void*)*CHAR_BIT == POINTER_BITS);

Modified: mlton/trunk/runtime/gdtoa-patch.internal
===================================================================
--- mlton/trunk/runtime/gdtoa-patch.internal	2008-12-09 17:42:16 UTC (rev 6997)
+++ mlton/trunk/runtime/gdtoa-patch.internal	2008-12-09 18:07:41 UTC (rev 6998)
@@ -1,17 +1,9 @@
 --- gdtoa/gdtoaimp.h.orig	2008-10-04 02:27:47 +0000
 +++ gdtoa/gdtoaimp.h	2008-10-04 02:32:34 +0000
-@@ -176,6 +176,7 @@
- #ifndef GDTOAIMP_H_INCLUDED
- #define GDTOAIMP_H_INCLUDED
- #include "gdtoa.h"
-+#include "../export.h"
- 
- #ifdef DEBUG
- #include "stdio.h"
 @@ -529,53 +530,53 @@
  #define trailz trailz_D2A
  #define ulp ulp_D2A
- 
+
 - extern char *dtoa_result;
 - extern CONST double bigtens[], tens[], tinytens[];
 - extern unsigned char hexdig[];
@@ -105,6 +97,6 @@
 +PRIVATE extern Bigint *sum ANSI((Bigint*, Bigint*));
 +PRIVATE extern int trailz ANSI((Bigint*));
 +PRIVATE extern double ulp ANSI((double));
- 
+
  #ifdef __cplusplus
  }

Modified: mlton/trunk/runtime/gen/gen-types.c
===================================================================
--- mlton/trunk/runtime/gen/gen-types.c	2008-12-09 17:42:16 UTC (rev 6997)
+++ mlton/trunk/runtime/gen/gen-types.c	2008-12-09 18:07:41 UTC (rev 6998)
@@ -1,4 +1,4 @@
-/* Copyright (C) 2004-2007 Henry Cejtin, Matthew Fluet, Suresh
+/* Copyright (C) 2004-2008 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  *
  * MLton is released under a BSD-style license.
@@ -6,7 +6,6 @@
  */
 
 #include "cenv.h"
-#include "export.h"
 #include "util.h"
 
 static const char* mlTypesHPrefix[] = {
@@ -306,7 +305,7 @@
   NULL
 };
 
-int main (__attribute__ ((unused)) int argc, 
+int main (__attribute__ ((unused)) int argc,
           __attribute__ ((unused)) char* argv[]) {
   FILE *mlTypesHFd;
   FILE *cTypesHFd;
@@ -323,9 +322,9 @@
   cTypesHFd = fopen_safe ("c-types.h", "w");
   cTypesSMLFd = fopen_safe ("c-types.sml", "w");
 
-  for (int i = 0; cTypesHPrefix[i] != NULL; i++) 
+  for (int i = 0; cTypesHPrefix[i] != NULL; i++)
     writeStringWithNewline (cTypesHFd, cTypesHPrefix[i]);
-  for (int i = 0; cTypesSMLPrefix[i] != NULL; i++) 
+  for (int i = 0; cTypesSMLPrefix[i] != NULL; i++)
     writeStringWithNewline (cTypesSMLFd, cTypesSMLPrefix[i]);
 
   writeNewline (cTypesHFd);writeNewline (cTypesSMLFd);
@@ -429,9 +428,9 @@
   chksystype(mp_limb_t, "MPLimb");
 
   writeNewline (cTypesHFd);writeNewline (cTypesSMLFd);
-  for (int i = 0; cTypesHSuffix[i] != NULL; i++) 
+  for (int i = 0; cTypesHSuffix[i] != NULL; i++)
     writeStringWithNewline (cTypesHFd, cTypesHSuffix[i]);
-  for (int i = 0; cTypesSMLSuffix[i] != NULL; i++) 
+  for (int i = 0; cTypesSMLSuffix[i] != NULL; i++)
     writeStringWithNewline (cTypesSMLFd, cTypesSMLSuffix[i]);
 
   fclose_safe(mlTypesHFd);

Modified: mlton/trunk/runtime/platform.h
===================================================================
--- mlton/trunk/runtime/platform.h	2008-12-09 17:42:16 UTC (rev 6997)
+++ mlton/trunk/runtime/platform.h	2008-12-09 18:07:41 UTC (rev 6998)
@@ -10,7 +10,6 @@
 #define _MLTON_PLATFORM_H_
 
 #include "cenv.h"
-#include "export.h"
 #include "util.h"
 #include "ml-types.h"
 #include "c-types.h"
@@ -124,7 +123,7 @@
 #define MLTON_CODEGEN_STATIC_INLINE PRIVATE
 #endif
 #ifndef MLTON_CODEGEN_MATHFN
-#define MLTON_CODEGEN_MATHFN(decl) 
+#define MLTON_CODEGEN_MATHFN(decl)
 #endif
 #ifndef MLTON_CODEGEN_WORDSQUOTREM
 #define MLTON_CODEGEN_WORDSQUOTREM(func) func
@@ -158,14 +157,14 @@
 /*                Virtual Memory                     */
 /* ------------------------------------------------- */
 
-/* GC_displayMem displays the virtual memory mapping to stdout.  
- * It is used to diagnose memory problems. 
+/* GC_displayMem displays the virtual memory mapping to stdout.
+ * It is used to diagnose memory problems.
  */
 PRIVATE void GC_displayMem (void);
 
 PRIVATE void *GC_mmapAnon (void *start, size_t length);
 PRIVATE void *GC_mmapAnon_safe (void *start, size_t length);
-PRIVATE void *GC_mmapAnon_safe_protect (void *start, size_t length, 
+PRIVATE void *GC_mmapAnon_safe_protect (void *start, size_t length,
                                          size_t dead_low, size_t dead_high);
 PRIVATE void *GC_mremap (void *start, size_t oldLength, size_t newLength);
 PRIVATE void GC_release (void *base, size_t length);

Modified: mlton/trunk/runtime/util/to-string.c
===================================================================
--- mlton/trunk/runtime/util/to-string.c	2008-12-09 17:42:16 UTC (rev 6997)
+++ mlton/trunk/runtime/util/to-string.c	2008-12-09 18:07:41 UTC (rev 6998)
@@ -5,7 +5,6 @@
  * See the file MLton-LICENSE for details.
  */
 
-#include "export.h"
 #include "util.h"
 
 const char* boolToString (bool b) {

Modified: mlton/trunk/runtime/util.c
===================================================================
--- mlton/trunk/runtime/util.c	2008-12-09 17:42:16 UTC (rev 6997)
+++ mlton/trunk/runtime/util.c	2008-12-09 18:07:41 UTC (rev 6998)
@@ -1,10 +1,9 @@
-/* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
+/* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  *
  * MLton is released under a BSD-style license.
  * See the file MLton-LICENSE for details.
  */
 
-#include "export.h"
 #include "util/die.c"
 #include "util/to-string.c"

Unused variable.

----------------------------------------------------------------------

U   mlton/trunk/mlton/main/main.fun

----------------------------------------------------------------------

Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun	2008-12-09 11:31:28 UTC (rev 6996)
+++ mlton/trunk/mlton/main/main.fun	2008-12-09 17:42:16 UTC (rev 6997)
@@ -1264,7 +1264,7 @@
                         in
                            ()
                         end
-                  fun mkOutputO (c: Counter.t, input: File.t): File.t =
+                  fun mkOutputO (c: Counter.t, _): File.t =
                      if stop = Place.O orelse !keepO
                         then
                            if !keepGenerated

Fix to compile on old systems.

----------------------------------------------------------------------

U   mlton/trunk/runtime/platform/linux.h

----------------------------------------------------------------------

Modified: mlton/trunk/runtime/platform/linux.h
===================================================================
--- mlton/trunk/runtime/platform/linux.h	2008-12-03 07:29:08 UTC (rev 6995)
+++ mlton/trunk/runtime/platform/linux.h	2008-12-09 11:31:28 UTC (rev 6996)
@@ -54,6 +54,7 @@
    versions. */
 
 #ifndef __suseconds_t_defined
+#include <linux/types.h>
 typedef __kernel_suseconds_t suseconds_t;
 #define __suseconds_t_defined
 #endif

Fixed a typo (thanks, Wesley).

----------------------------------------------------------------------

U   mlton/trunk/package/mingw/mlton.bat

----------------------------------------------------------------------

Modified: mlton/trunk/package/mingw/mlton.bat
===================================================================
--- mlton/trunk/package/mingw/mlton.bat	2008-11-27 13:20:45 UTC (rev 6994)
+++ mlton/trunk/package/mingw/mlton.bat	2008-12-03 07:29:08 UTC (rev 6995)
@@ -73,4 +73,4 @@
 set retval=%errorlevel%
 
 if "%pause%" == "yes" pause
-exit /b %_retval%
+exit /b %retval%