[MLton-commit] r4392
Stephen Weeks
MLton@mlton.org
Fri, 31 Mar 2006 10:18:23 -0800
Caught up with basis changes.
----------------------------------------------------------------------
U mlton/trunk/lib/mlton/basic/vector.fun
U mlton/trunk/lib/mlton/basic/vector.sig
U mlton/trunk/lib/mlton-stubs/array.sig
U mlton/trunk/lib/mlton-stubs/bin-io.sig
U mlton/trunk/lib/mlton-stubs/mlton.sml
U mlton/trunk/lib/mlton-stubs/pointer.sig
U mlton/trunk/lib/mlton-stubs/proc-env.sig
U mlton/trunk/lib/mlton-stubs/text-io.sig
U mlton/trunk/lib/mlton-stubs/vector.sig
----------------------------------------------------------------------
Modified: mlton/trunk/lib/mlton/basic/vector.fun
===================================================================
--- mlton/trunk/lib/mlton/basic/vector.fun 2006-03-31 18:17:59 UTC (rev 4391)
+++ mlton/trunk/lib/mlton/basic/vector.fun 2006-03-31 18:18:22 UTC (rev 4392)
@@ -17,7 +17,7 @@
fun unfold (n, a, f) = unfoldi (n, a, f o #2)
-fun tabulate (n, f) = unfoldi (n, (), fn (i, ()) => (f i, ()))
+fun tabulate (n, f) = #1 (unfoldi (n, (), fn (i, ()) => (f i, ())))
fun fromArray a =
tabulate (Pervasive.Array.length a, fn i => Pervasive.Array.sub (a, i))
@@ -457,36 +457,37 @@
let
val n = List.fold (vs, 0, fn (v, s) => s + length v)
in
- unfold (n, (0, v, vs'),
- let
- fun loop (i, v, vs) =
- if i < length v
- then (sub (v, i), (i + 1, v, vs))
- else
- case vs of
- [] => Error.bug "Vector.concat"
- | v :: vs => loop (0, v, vs)
- in loop
- end)
+ #1 (unfold (n, (0, v, vs'),
+ let
+ fun loop (i, v, vs) =
+ if i < length v
+ then (sub (v, i), (i + 1, v, vs))
+ else
+ case vs of
+ [] => Error.bug "Vector.concat"
+ | v :: vs => loop (0, v, vs)
+ in loop
+ end))
end
fun concatV vs =
- if 0 = length vs
- then new0 ()
+ if 0 = length vs then
+ new0 ()
else
let
val n = fold (vs, 0, fn (v, s) => s + length v)
fun state i = (i, sub (vs, i), 0)
in
- unfold (n, state 0,
- let
- fun loop (i, v, j) =
- if j < length v
- then (sub (v, j), (i, v, j + 1))
- else loop (state (i + 1))
- in loop
- end)
- end
+ #1 (unfold (n, state 0,
+ let
+ fun loop (i, v, j) =
+ if j < length v then
+ (sub (v, j), (i, v, j + 1))
+ else
+ loop (state (i + 1))
+ in loop
+ end))
+ end
fun splitLast v =
let
Modified: mlton/trunk/lib/mlton/basic/vector.sig
===================================================================
--- mlton/trunk/lib/mlton/basic/vector.sig 2006-03-31 18:17:59 UTC (rev 4391)
+++ mlton/trunk/lib/mlton/basic/vector.sig 2006-03-31 18:18:22 UTC (rev 4392)
@@ -14,7 +14,7 @@
val length: 'a t -> int
val sub: 'a t * int -> 'a
- val unfoldi: int * 'a * (int * 'a -> 'b * 'a) -> 'b t
+ val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a t * 'b
end
signature VECTOR =
Modified: mlton/trunk/lib/mlton-stubs/array.sig
===================================================================
--- mlton/trunk/lib/mlton-stubs/array.sig 2006-03-31 18:17:59 UTC (rev 4391)
+++ mlton/trunk/lib/mlton-stubs/array.sig 2006-03-31 18:18:22 UTC (rev 4392)
@@ -1,5 +1,6 @@
-(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
*
* MLton is released under a BSD-style license.
* See the file MLton-LICENSE for details.
@@ -9,5 +10,5 @@
signature MLTON_ARRAY =
sig
- val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array
+ val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array * 'b
end
Modified: mlton/trunk/lib/mlton-stubs/bin-io.sig
===================================================================
--- mlton/trunk/lib/mlton-stubs/bin-io.sig 2006-03-31 18:17:59 UTC (rev 4391)
+++ mlton/trunk/lib/mlton-stubs/bin-io.sig 2006-03-31 18:18:22 UTC (rev 4392)
@@ -5,7 +5,5 @@
* See the file MLton-LICENSE for details.
*)
-signature MLTON_BIN_IO =
- MLTON_IO
- where type instream = BinIO.instream
- where type outstream = BinIO.outstream
+signature MLTON_BIN_IO = MLTON_IO
+
Modified: mlton/trunk/lib/mlton-stubs/mlton.sml
===================================================================
--- mlton/trunk/lib/mlton-stubs/mlton.sml 2006-03-31 18:17:59 UTC (rev 4391)
+++ mlton/trunk/lib/mlton-stubs/mlton.sml 2006-03-31 18:18:22 UTC (rev 4392)
@@ -59,14 +59,16 @@
fun unfoldi (n, a, f) =
let
val r = ref a
+ val a =
+ tabulate (n, fn i =>
+ let
+ val (b, a') = f (i, !r)
+ val _ = r := a'
+ in
+ b
+ end)
in
- tabulate (n, fn i =>
- let
- val (b, a') = f (i, !r)
- val _ = r := a'
- in
- b
- end)
+ (a, !r)
end
end
@@ -277,6 +279,8 @@
structure ProcEnv =
struct
+ type gid = Posix.ProcEnv.gid
+
fun setenv _ = raise Fail "setenv"
fun setgroups _ = raise Fail "setgroups"
end
@@ -568,17 +572,55 @@
struct
open Vector
+ fun create (n, f) =
+ let
+ val r = ref (Array.fromList [])
+ val lim = ref 0
+ fun check i =
+ if 0 <= i andalso i < !lim then () else raise Subscript
+ val sub = fn i => (check i; Array.sub (!r, i))
+ val update = fn (i, x) => (check i; Array.update (!r, i, x))
+ val (tab, finish) = f {sub = sub, update = update}
+ in
+ if 0 = n then
+ (finish (); Vector.fromList [])
+ else
+ let
+ val init = tab 0
+ val a = Array.array (n, init)
+ val () = r := a
+ val () =
+ Array.modifyi (fn (i, _) =>
+ let
+ val res =
+ if i = 0 then
+ init
+ else
+ tab i
+ val () = lim := i + 1
+ in
+ res
+ end)
+ a
+ val () = finish ()
+ in
+ Array.vector a
+ end
+ end
+
fun unfoldi (n, a, f) =
let
val r = ref a
+ val v =
+ tabulate (n, fn i =>
+ let
+ val (b, a') = f (i, !r)
+ val _ = r := a'
+ in
+ b
+ end)
in
- tabulate (n, fn i =>
- let
- val (b, a') = f (i, !r)
- val _ = r := a'
- in
- b
- end)
+ (v, !r)
end
end
Modified: mlton/trunk/lib/mlton-stubs/pointer.sig
===================================================================
--- mlton/trunk/lib/mlton-stubs/pointer.sig 2006-03-31 18:17:59 UTC (rev 4391)
+++ mlton/trunk/lib/mlton-stubs/pointer.sig 2006-03-31 18:18:22 UTC (rev 4392)
@@ -5,8 +5,8 @@
* See the file MLton-LICENSE for details.
*)
+type int = Int.int
type word = Word.word
-type int = Int.int
signature MLTON_POINTER =
sig
@@ -15,7 +15,7 @@
val add: t * word -> t
val compare: t * t -> order
val diff: t * t -> word
- val free: t -> unit
+(* val free: t -> unit *)
val getInt8: t * int -> Int8.int
val getInt16: t * int -> Int16.int
val getInt32: t * int -> Int32.int
Modified: mlton/trunk/lib/mlton-stubs/proc-env.sig
===================================================================
--- mlton/trunk/lib/mlton-stubs/proc-env.sig 2006-03-31 18:17:59 UTC (rev 4391)
+++ mlton/trunk/lib/mlton-stubs/proc-env.sig 2006-03-31 18:18:22 UTC (rev 4392)
@@ -1,5 +1,6 @@
-(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
*
* MLton is released under a BSD-style license.
* See the file MLton-LICENSE for details.
@@ -7,5 +8,8 @@
signature MLTON_PROC_ENV =
sig
+ type gid
+
val setenv: {name: string, value: string} -> unit
+ val setgroups: gid list -> unit
end
Modified: mlton/trunk/lib/mlton-stubs/text-io.sig
===================================================================
--- mlton/trunk/lib/mlton-stubs/text-io.sig 2006-03-31 18:17:59 UTC (rev 4391)
+++ mlton/trunk/lib/mlton-stubs/text-io.sig 2006-03-31 18:18:22 UTC (rev 4392)
@@ -1,11 +1,9 @@
-(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
*
* MLton is released under a BSD-style license.
* See the file MLton-LICENSE for details.
*)
-signature MLTON_TEXT_IO =
- MLTON_IO
- where type instream = TextIO.instream
- where type outstream = TextIO.outstream
+signature MLTON_TEXT_IO = MLTON_IO
Modified: mlton/trunk/lib/mlton-stubs/vector.sig
===================================================================
--- mlton/trunk/lib/mlton-stubs/vector.sig 2006-03-31 18:17:59 UTC (rev 4391)
+++ mlton/trunk/lib/mlton-stubs/vector.sig 2006-03-31 18:18:22 UTC (rev 4392)
@@ -1,5 +1,6 @@
-(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
*
* MLton is released under a BSD-style license.
* See the file MLton-LICENSE for details.
@@ -9,6 +10,10 @@
signature MLTON_VECTOR =
sig
- val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector
+ val create:
+ int * ({sub: int -> 'a, update: int * 'a -> unit}
+ -> (int -> 'a) * (unit -> unit))
+ -> 'a vector
+ val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector * 'b
end