[MLton-devel] cvs commit: marge of basis-2002 branch
Matthew Fluet
fluet@users.sourceforge.net
Sat, 23 Nov 2002 17:19:46 -0800
fluet 02/11/23 17:19:45
Modified: basis-library/arrays-and-vectors array.sig array.sml
array2.sig mono-array.sig mono-array.sml
mono-array2.sig mono-array2.sml mono-vector.sig
mono-vector.sml sequence.fun sequence.sig
vector.sig vector.sml
basis-library/general bool.sig bool.sml general.sig
general.sml option.sig option.sml
basis-library/integer int-inf.sig int-inf.sml int32.sml
integer.sig pack32.sml word.sig
basis-library/io bin-io.sig bin-io.sml bin-or-text-io.fun
bin-stream-io.sig io.sig stream-io.sig text-io.sig
text-io.sml text-stream-io.sig
basis-library/list list-pair.sig list-pair.sml list.sig
list.sml
basis-library/misc cleaner.sml primitive.sml
basis-library/mlton exn.sml signal.sml
basis-library/posix error.sig error.sml file-sys.sig
file-sys.sml flags.sig flags.sml io.sig io.sml
posix.sig posix.sml primitive.sml proc-env.sig
proc-env.sml process.sig process.sml signal.sig
tty.sig tty.sml
basis-library/real IEEE-real.sig IEEE-real.sml math.sig
pack-real.sig pack-real.sml real.sig real.sml
basis-library/sml-nj unsafe.sml
basis-library/system date.sig date.sml file-sys.sig
file-sys.sml io.sig io.sml os.sig os.sml path.sig
path.sml process.sig process.sml time.sig time.sml
timer.sig timer.sml unix.sig unix.sml
basis-library/text char.sig char.sml string-cvt.sig
string-cvt.sml string.sig string.sml string0.sml
substring.sig substring.sml
basis-library/top-level infixes.sml overloads.sml
benchmark Makefile benchmark-stubs.cm
benchmark/tests md5.sml tensor.sml
bin check-basis
doc changelog
doc/user-guide basis.tex extensions.tex man-page.tex
include ccodegen.h
lib/mlton/basic dir.sml init-script.sml process.sig
string0.sml
lib/mlton/pervasive pervasive.sml
lib/mlton-stubs sources.cm
lib/mlton-stubs-in-smlnj import.cm os.sml pervasive.sml
mllex Makefile mllex-stubs.cm
mlprof Makefile mlprof-stubs.cm
mlton Makefile mlton-stubs.cm
mlton/ast ast.fun ast.sig prim-tycons.fun prim-tycons.sig
mlton/atoms const.fun const.sig hash-type.fun prim.fun
prim.sig type-ops.fun type-ops.sig
mlton/backend backend.fun c-function.fun c-function.sig
representation.fun rssa.fun ssa-to-rssa.fun
mlton/codegen/x86-codegen x86-mlton.fun
mlton/control control.sig control.sml
mlton/core-ml lookup-constant.fun
mlton/elaborate elaborate-env.fun elaborate-env.sig
mlton/main compile.sml main.sml
mlton/ssa common-subexp.fun constant-propagation.fun
poly-equal.fun ssa-tree.fun ssa-tree.sig
mlton/type-inference infer.fun
mlyacc Makefile mlyacc-stubs.cm
regression array.ok array.sml array6.sml bytechar.sml
filesys.sml parse.sml prodcons.sml real6.ok
real6.sml size.ok vector.sml word.sml
word8array.sml word8vector.sml
runtime IntInf.h Makefile posix-constants.h
runtime/basis IntInf.c
Added: basis-library notes.txt
basis-library/arrays-and-vectors array-slice.sig
mono-array-slice.sig mono-array.fun mono-array2.fun
mono-vector-slice.sig mono-vector.fun slice.sig
vector-slice.sig
basis-library/io bin-prim-io.sml buffer-i.fun buffer-i.sig
fast-imperative-io.fun fast-imperative-io.sig
imperative-io.fun imperative-io.sig prim-io.fun
prim-io.sig stream-io.fun text-prim-io.sml
basis-library/libs build
basis-library/libs/basis-1997 bind prefix suffix
basis-library/libs/basis-1997/arrays-and-vectors array.sig
mono-array.sig mono-array2.sig
mono-vector-array-array2-convert.fun
mono-vector.sig vector-array-convert.fun vector.sig
basis-library/libs/basis-1997/io bin-io-convert.fun
bin-io.sig bin-stream-io.sig io-convert.fun io.sig
stream-io.sig text-io-convert.fun text-io.sig
text-stream-io.sig
basis-library/libs/basis-1997/posix file-sys-convert.fun
file-sys.sig flags-convert.fun flags.sig
io-convert.fun io.sig posix-convert.fun posix.sig
process-convert.fun process.sig tty-convert.fun
tty.sig
basis-library/libs/basis-1997/real IEEE-real-convert.fun
IEEE-real.sig real-convert.fun real.sig
basis-library/libs/basis-1997/system file-sys-convert.fun
file-sys.sig os-convert.fun os.sig
process-convert.fun process.sig timer-convert.fun
timer.sig unix-convert.fun unix.sig
basis-library/libs/basis-1997/text string.sig substring.sig
text-convert.fun
basis-library/libs/basis-1997/top-level basis-funs.sml
basis-sigs.sml basis.sig basis.sml infixes.sml
overloads.sml top-level.sml
basis-library/libs/basis-2002 bind prefix suffix
basis-library/libs/basis-2002/top-level basis-funs.sml
basis-sigs.sml basis.sig basis.sml infixes.sml
overloads.sml top-level.sml
basis-library/libs/basis-2002-strict bind prefix suffix
basis-library/libs/basis-2002-strict/top-level top-level.sml
basis-library/libs/none bind prefix suffix
basis-library/libs/none/top-level infixes.sml
basis-library/system pre-os.sml
basis-library/text text.sig text.sml
lib/basis-stubs Makefile basis-2002.sml os.sml sources.cm
lib/mlton-stubs int-inf.sml
regression 1.ok 2.ok command-line.ok conv.ok conv2.ok
fast.ok fast2.ok hello-world.ok int-inf.bitops.ok
int-inf.bitops.sml slow.ok slow2.ok slower.ok
substring.ok testdyn2.ok thread-switch.ok
runtime/basis/OS/IO poll.c
Removed: basis-library bind-basis
regression conv.sml.ok conv2.sml.ok fast.sml.ok fast2.sml.ok
format.sml.ok slow.sml.ok slow2.sml.ok
slower.sml.ok
runtime/basis/String equal.c
Log:
This merges in the basis-2002 branch.
Added -basis option to choose a basis library. Currently supported
basis libraries are basis-2002, basis-2002-strict, basis-1997, none.
See the user guide for caveats on basis-1997. Removed
-use-basis-library option, as -basis none subsumes it.
I'm still not quite happy with the "new" IO, so I went ahead and used
the bin-or-text-io.fun functor to build up TextIO and BinIO. All the
code for the new IO is there, and you can switch to the new IO by
editting /basis-library/io/{bin,text}{-stream-io.sig,-io.{sig,sml}}.
Should be self-evident how to switch the commented out code.
Comparing the IO code just before and after the merge, I get:
MLton0 -- mlton.cvs.HEAD
MLton1 -- mlton.cvs.HEAD.basis-2002
run time ratio
benchmark MLton1
wc-input1 0.90
wc-scanStream 0.99
So, something in the basis is speeding up wc-input1. Too bad I can't
get it in the new IO.
(The IMPERATIVE_IO, STREAM_IO signatures match the basis spec, but the
TextIO and BinIO structures respectively match TEXT_IO and BIN_IO.
So, you get type errors with
structure S : IMPERATIVE_IO = TextIO
because TextIO is missing some functionality. This isn't any
different than what was there before.)
Bootstrapping is a little tricky. Luckily /lib/mlton doesn't depend
that much on the aspects of the basis library that have changed. I've
set things up so that we assume that SML/NJ is using basis1997, while
MLton is using basis2002. This means that you can compile
mlton,mlyacc,mllex,mlprof, benchmark with any reasonably recent
version of SML/NJ without any changes.
However, no existing MLton executable will compile the code right out
of the box. The problem is OS.FileSys.readDir (which has changed
types) and is used in /lib/mlton/basic/dir.sml. In order to compile
with an existing mlton executable, first edit this file, switching the
commented code in the fold function. Then you should be able to
compile a new mlton-compile and build the world. Then switch the
/lib/mlton/basic/dir.sml code back before trying to bootstrap with
this new mlton. So, the procedure should be as follows:
G0 == mlton-20020923 (for example)
edit /lib/mlton/basic/dir.sml
make (yielding G1)
edit /lib/mlton/basic/dir.sml
make (yielding G2)
make (yielding G3)
G2 == G3 and fixed-point reached.
I can't see any way to hack mlton-stubs in order to patch
OS.FileSys.readDir in a mlton with basis1997 and a mlton with
basis2002. (In order to distinguish them, we need to run them and
check the type for OS.FileSys.readDir.) Anyways, I needed to choose
one of these two options, so I went with the latter since it was
easier.
Revision Changes Path
1.2 +449 -0 mlton/basis-library/notes.txt
1.4 +35 -25 mlton/basis-library/arrays-and-vectors/array.sig
Index: array.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/arrays-and-vectors/array.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- array.sig 1 Aug 2001 20:04:01 -0000 1.3
+++ array.sig 24 Nov 2002 01:19:35 -0000 1.4
@@ -8,42 +8,52 @@
include ARRAY_GLOBAL
type 'a vector
-
- val app: ('a -> unit) -> 'a array -> unit
- val appi: (int * 'a -> unit) -> 'a array * int * int option -> unit
+ val maxLen: int
val array: int * 'a -> 'a array
- val copy:
- {src: 'a array, si: int, len: int option, dst: 'a array, di: int}
- -> unit
- val copyVec:
- {src: 'a vector, si: int, len: int option, dst: 'a array, di: int}
- -> unit
- val extract: 'a array * int * int option -> 'a vector
- val foldl: ('a * 'b -> 'b) -> 'b -> 'a array -> 'b
- val foldli:
- (int * 'a * 'b -> 'b) -> 'b -> 'a array * int * int option -> 'b
- val foldr: ('a * 'b -> 'b) -> 'b -> 'a array -> 'b
- val foldri:
- (int * 'a * 'b -> 'b) -> 'b -> 'a array * int * int option -> 'b
val fromList: 'a list -> 'a array
+ val tabulate: int * (int -> 'a) -> 'a array
val length: 'a array -> int
- val maxLen: int
- val modify: ('a -> 'a) -> 'a array -> unit
- val modifyi: (int * 'a -> 'a) -> 'a array * int * int option -> unit
val sub: 'a array * int -> 'a
- val tabulate: int * (int -> 'a) -> 'a array
val update: 'a array * int * 'a -> unit
+ val vector: 'a array -> 'a vector
+ val copy: {src: 'a array, dst: 'a array, di: int} -> unit
+ val copyVec: {src: 'a vector, dst: 'a array, di: int} -> unit
+ val appi: (int * 'a -> unit) -> 'a array -> unit
+ val app: ('a -> unit) -> 'a array -> unit
+ val modifyi: (int * 'a -> 'a) -> 'a array -> unit
+ val modify: ('a -> 'a) -> 'a array -> unit
+ val foldli: (int * 'a * 'b -> 'b) -> 'b -> 'a array -> 'b
+ val foldri: (int * 'a * 'b -> 'b) -> 'b -> 'a array -> 'b
+ val foldl: ('a * 'b -> 'b) -> 'b -> 'a array -> 'b
+ val foldr: ('a * 'b -> 'b) -> 'b -> 'a array -> 'b
+ val findi: (int * 'a -> bool) -> 'a array -> (int * 'a) option
+ val find: ('a -> bool) -> 'a array -> 'a option
+ val exists: ('a -> bool) -> 'a array -> bool
+ val all: ('a -> bool) -> 'a array -> bool
+ val collate: ('a * 'a -> order) -> 'a array * 'a array -> order
end
signature ARRAY_EXTRA =
sig
include ARRAY
+ type 'a vector_slice
+ structure ArraySlice: ARRAY_SLICE_EXTRA
+ where type 'a array = 'a array
+ and type 'a vector = 'a vector
+ and type 'a vector_slice = 'a vector_slice
- val checkSlice: 'a array * int * int option -> int
- val checkSliceMax: int * int option * int -> int
- val prefixToList: 'a array * int -> 'a list
- val toList: 'a array -> 'a list
- val unfoldi: int * 'a * (int * 'a -> 'b * 'a) -> 'b array
val unsafeSub: 'a array * int -> 'a
val unsafeUpdate: 'a array * int * 'a -> unit
+
+ val concat: 'a array list -> 'a array
+ val duplicate: 'a array -> 'a array
+ val toList: 'a array -> 'a list
+ val unfoldi: int * 'a * (int * 'a -> 'b * 'a) -> 'b array
+
+ (* Deprecated *)
+ val checkSlice: 'a array * int * int option -> int
+ (* Deprecated *)
+ val checkSliceMax: int * int option * int -> int
+ (* Deprecated *)
+ val extract: 'a array * int * int option -> 'a vector
end
1.4 +57 -38 mlton/basis-library/arrays-and-vectors/array.sml
Index: array.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/arrays-and-vectors/array.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- array.sml 10 Apr 2002 07:02:15 -0000 1.3
+++ array.sml 24 Nov 2002 01:19:35 -0000 1.4
@@ -11,57 +11,76 @@
type 'a elt = 'a
val fromArray = fn a => a
val isMutable = true
- open Primitive.Array)
+ val length = Primitive.Array.length
+ val sub = Primitive.Array.sub)
open A
open Primitive.Int
- local open Primitive.Array
- in val unsafeSub = sub
- val unsafeUpdate = update
- end
-
type 'a array = 'a array
- type 'a vector = 'a vector
+ type 'a vector = 'a Vector.vector
+ type 'a vector_slice = 'a Vector.VectorSlice.slice
- val array = new
+ structure ArraySlice =
+ struct
+ open Slice
+ type 'a array = 'a array
+ type 'a vector = 'a Vector.vector
+ type 'a vector_slice = 'a Vector.VectorSlice.slice
+ fun update (arr, i, x) =
+ update' Primitive.Array.update (arr, i, x)
+ fun unsafeUpdate (arr, i, x) =
+ unsafeUpdate' Primitive.Array.update (arr, i, x)
+ fun vector sl = create Vector.tabulate (fn x => x) sl
+ fun modifyi f sl =
+ appi (fn (i, x) => unsafeUpdate (sl, i, f (i, unsafeSub (sl, i)))) sl
+ fun modify f sl = modifyi (f o #2) sl
+ local
+ fun make (length, sub) {src, dst, di} =
+ modifyi (fn (i, _) => sub (src, i))
+ (slice (dst, di, SOME (length src)))
+ in
+ fun copy (arg as {src, dst, di}) =
+ let val (src', si', len') = base src
+ in
+ if src' = dst andalso si' < di andalso si' +? len' >= di
+ then let val sl = slice (dst, di, SOME (length src))
+ in
+ foldri (fn (i, _, _) =>
+ unsafeUpdate (sl, i, unsafeSub (src, i)))
+ () sl
+ end
+ else make (length, unsafeSub) arg
+ end
- (* can't use o because of value restriction *)
- val extract = fn arg => Primitive.Vector.fromArray (extract arg)
+ fun copyVec arg =
+ make (Vector.VectorSlice.length, Vector.VectorSlice.unsafeSub) arg
+ end
- fun modifyi f (slice as (a, _, _)) =
- appi (fn (i, x) => unsafeUpdate (a, i, f (i, x))) slice
+ val array = sequence
+ end
- fun modify f a = modifyi (f o #2) (wholeSlice a)
+ val array = new
local
- fun make (checkSlice, sub) {src, si, len, dst, di} =
- let
- val sm = checkSlice (src, si, len)
- val diff = si -? di
- in modifyi
- (fn (i, _) => sub (src, i +? diff))
- (dst, di, SOME (sm -? si))
- end
+ fun make f arr = f (ArraySlice.full arr)
in
- fun copy (arg as {src, si, len, dst, di}) =
- if src = dst andalso si < di
- then
- (* Must go right-to-left *)
- let
- val sm = checkSlice (src, si, len)
- val dm = checkSlice (dst, di, SOME (sm -? si))
- fun loop i =
- if i < si then ()
- else (unsafeUpdate (dst, di +? i, unsafeSub (src, i))
- ; loop (i -? 1))
- in loop (sm -? 1)
- end
- else make (checkSlice, unsafeSub) arg
-
- fun copyVec arg =
- make (Vector.checkSlice, Primitive.Vector.sub) arg
+ fun vector arr = make (ArraySlice.vector) arr
+ fun modifyi f = make (ArraySlice.modifyi f)
+ fun modify f = make (ArraySlice.modify f)
+ fun copy {src, dst, di} = ArraySlice.copy {src = ArraySlice.full src,
+ dst = dst, di = di}
+ fun copyVec {src, dst, di} = ArraySlice.copyVec {src = VectorSlice.full src,
+ dst = dst, di = di}
end
+
+ val unsafeSub = Primitive.Array.sub
+ fun update (arr, i, x) = update' Primitive.Array.update (arr, i, x)
+ val unsafeUpdate = Primitive.Array.update
+
+ (* Deprecated *)
+ fun extract args = ArraySlice.vector (ArraySlice.slice args)
end
+structure ArraySlice: ARRAY_SLICE_EXTRA = Array.ArraySlice
structure ArrayGlobal: ARRAY_GLOBAL = Array
open ArrayGlobal
1.2 +13 -14 mlton/basis-library/arrays-and-vectors/array2.sig
Index: array2.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/arrays-and-vectors/array2.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- array2.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ array2.sig 24 Nov 2002 01:19:35 -0000 1.2
@@ -10,25 +10,24 @@
datatype traversal = RowMajor | ColMajor
- val app: traversal -> ('a -> unit) -> 'a array -> unit
- val appi: traversal -> (int * int * 'a -> unit) -> 'a region -> unit
val array: int * int * 'a -> 'a array
- val column: ('a array * int) -> 'a vector
+ val fromList: 'a list list -> 'a array
+ val tabulate: traversal -> (int * int * (int * int -> 'a)) -> 'a array
+ val sub: 'a array * int * int -> 'a
+ val update: 'a array * int * int * 'a -> unit
+ val dimensions: 'a array -> int * int
+ val nRows: 'a array -> int
+ val nCols: 'a array -> int
+ val row: 'a array * int -> 'a vector
+ val column: 'a array * int -> 'a vector
val copy: {src: 'a region,
dst: 'a array,
dst_row: int,
dst_col: int} -> unit
- val dimensions: 'a array -> (int * int)
+ val appi: traversal -> (int * int * 'a -> unit) -> 'a region -> unit
+ val app: traversal -> ('a -> unit) -> 'a array -> unit
+ val foldi: traversal -> (int * int * 'a * 'b -> 'b) -> 'b -> 'a region -> 'b
val fold: traversal -> ('a * 'b -> 'b) -> 'b -> 'a array -> 'b
- val foldi:
- traversal -> (int * int * 'a * 'b -> 'b) -> 'b -> 'a region -> 'b
- val fromList: 'a list list -> 'a array
- val modify: traversal -> ('a -> 'a) -> 'a array -> unit
val modifyi: traversal -> (int * int * 'a -> 'a) -> 'a region -> unit
- val nCols: 'a array -> int
- val nRows: 'a array -> int
- val row: ('a array * int) -> 'a vector
- val sub: 'a array * int * int -> 'a
- val tabulate: traversal -> (int * int * (int * int -> 'a)) -> 'a array
- val update: 'a array * int * int * 'a -> unit
+ val modify: traversal -> ('a -> 'a) -> 'a array -> unit
end
1.2 +44 -29 mlton/basis-library/arrays-and-vectors/mono-array.sig
Index: mono-array.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/arrays-and-vectors/mono-array.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- mono-array.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ mono-array.sig 24 Nov 2002 01:19:35 -0000 1.2
@@ -2,35 +2,50 @@
sig
eqtype array
type elem
-
- structure Vector: MONO_VECTOR
-
- val app: (elem -> unit) -> array -> unit
- val appi: ((int * elem) -> unit) -> (array * int * int option) -> unit
- val array: (int * elem) -> array
- val copy: {src: array,
- si: int,
- len: int option,
- dst: array,
- di: int} -> unit
- val copyVec: {src: Vector.vector,
- si: int,
- len: int option,
- dst: array,
- di: int} -> unit
- val extract: (array * int * int option) -> Vector.vector
- val foldl: ((elem * 'b) -> 'b) -> 'b -> array -> 'b
- val foldli:
- ((int * elem * 'b) -> 'b) -> 'b -> (array * int * int option) -> 'b
- val foldr: ((elem * 'b) -> 'b) -> 'b -> array -> 'b
- val foldri:
- ((int * elem * 'b) -> 'b) -> 'b -> (array * int * int option) -> 'b
- val fromList: elem list -> array
- val length: array -> int
+ type vector
val maxLen: int
+ val array: int * elem -> array
+ val fromList: elem list -> array
+ val tabulate: int * (int -> elem) -> array
+ val length: array -> int
+ val sub: array * int -> elem
+ val update: array * int * elem -> unit
+ val vector: array -> vector
+ val copy: {src: array, dst: array, di: int} -> unit
+ val copyVec: {src: vector, dst: array, di: int} -> unit
+ val appi: (int * elem -> unit) -> array -> unit
+ val app: (elem -> unit) -> array -> unit
+ val modifyi: (int * elem -> elem) -> array -> unit
val modify: (elem -> elem) -> array -> unit
- val modifyi: ((int * elem) -> elem) -> (array * int * int option) -> unit
- val sub: (array * int) -> elem
- val tabulate: (int * (int -> elem)) -> array
- val update: (array * int * elem) -> unit
+ val foldli: (int * elem * 'b -> 'b) -> 'b -> array -> 'b
+ val foldri: (int * elem * 'b -> 'b) -> 'b -> array -> 'b
+ val foldl: (elem * 'b -> 'b) -> 'b -> array -> 'b
+ val foldr: (elem * 'b -> 'b) -> 'b -> array -> 'b
+ val findi: (int * elem -> bool) -> array -> (int * elem) option
+ val find: (elem -> bool) -> array -> elem option
+ val exists: (elem -> bool) -> array -> bool
+ val all: (elem -> bool) -> array -> bool
+ val collate: (elem * elem -> order) -> array * array -> order
+ end
+
+signature MONO_ARRAY_EXTRA =
+ sig
+ include MONO_ARRAY
+ type vector_slice
+ structure MonoArraySlice: MONO_ARRAY_SLICE_EXTRA
+ where type elem = elem
+ and type array = array
+ and type vector = vector
+ and type vector_slice = vector_slice
+
+ val unsafeSub: array * int -> elem
+ val unsafeUpdate: array * int * elem -> unit
+
+ val concat: array list -> array
+ val duplicate: array -> array
+ val toList: array -> elem list
+ val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> array
+
+ (* Deprecated *)
+ val extract: array * int * int option -> vector
end
1.3 +23 -25 mlton/basis-library/arrays-and-vectors/mono-array.sml
Index: mono-array.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/arrays-and-vectors/mono-array.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- mono-array.sml 10 Apr 2002 07:02:15 -0000 1.2
+++ mono-array.sml 24 Nov 2002 01:19:35 -0000 1.3
@@ -5,30 +5,28 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-functor MonoArray (V: CONCRETE_MONO_VECTOR): MONO_ARRAY =
- struct
- structure Vector = V
- type elem = V.elem
- open Array
- type array = elem array
- end
+structure Word8Array = MonoArray (type elem = Word8.word
+ structure V = Word8Vector)
+structure Word8ArraySlice = Word8Array.MonoArraySlice
+structure CharArray = MonoArray(type elem = char
+ structure V = CharVector)
+structure CharArraySlice = CharArray.MonoArraySlice
-structure Word8Array = MonoArray (Word8Vector)
-(* Can't use MonoArray to create CharArray because Basis Library spec requires
- * type CharVector.vector = string, not char vector.
- *)
-structure CharArray: MONO_ARRAY =
- struct
- structure Vector = CharVector
- type elem = char
- open Array
- type array = elem array
- val extract = Primitive.String.fromCharVector o extract
- fun copyVec {src, dst, si, len, di} =
- Array.copyVec {src = Primitive.String.toCharVector src,
- dst = dst, si = si, len = len, di = di}
- end
-structure BoolArray = MonoArray (BoolVector)
-structure IntArray = MonoArray (IntVector)
-structure RealArray = MonoArray (RealVector)
+structure BoolArray = MonoArray (type elem = bool
+ structure V = BoolVector)
+structure BoolArraySlice = BoolArray.MonoArraySlice
+structure IntArray = MonoArray (type elem = int
+ structure V = IntVector)
+structure IntArraySlice = IntArray.MonoArraySlice
+structure Int32Array = IntArray
+structure Int32ArraySlice = Int32Array.MonoArraySlice
+structure RealArray = MonoArray (type elem = real
+ structure V = RealVector)
+structure RealArraySlice = RealArray.MonoArraySlice
structure Real64Array = RealArray
+structure Real64ArraySlice = Real64Array.MonoArraySlice
+structure WordArray = MonoArray (type elem = word
+ structure V = WordVector)
+structure WordArraySlice = WordArray.MonoArraySlice
+structure Word32Array = WordArray
+structure Word32ArraySlice = Word32Array.MonoArraySlice
1.2 +10 -15 mlton/basis-library/arrays-and-vectors/mono-array2.sig
Index: mono-array2.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/arrays-and-vectors/mono-array2.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- mono-array2.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ mono-array2.sig 24 Nov 2002 01:19:35 -0000 1.2
@@ -3,6 +3,7 @@
eqtype array
type elem
+ type vector
type region = {base: array,
row: int,
@@ -12,8 +13,6 @@
datatype traversal = datatype Array2.traversal
- structure Vector: MONO_VECTOR
-
val array: int * int * elem -> array
val fromList: elem list list -> array
val tabulate: traversal -> int * int * (int * int -> elem) -> array
@@ -22,17 +21,13 @@
val dimensions: array -> int * int
val nCols: array -> int
val nRows: array -> int
- val row: array * int -> Vector.vector
- val column: array * int -> Vector.vector
-(* val copy:
- {src: region, dst: array, dst_row: int, dst_col: int} -> unit *)
- val appi :
- Array2.traversal -> (int * int * elem -> unit) -> region -> unit
- val app: Array2.traversal -> (elem -> unit) -> array -> unit
- val modifyi :
- Array2.traversal -> (int * int * elem -> elem) -> region -> unit
- val modify: Array2.traversal -> (elem -> elem) -> array -> unit
- val foldi :
- Array2.traversal -> (int * int * elem * 'b -> 'b) -> 'b -> region -> 'b
- val fold: Array2.traversal -> (elem * 'b -> 'b) -> 'b -> array -> 'b
+ val row: array * int -> vector
+ val column: array * int -> vector
+ val copy: {src: region, dst: array, dst_row: int, dst_col: int} -> unit
+ val appi: traversal -> (int * int * elem -> unit) -> region -> unit
+ val app: traversal -> (elem -> unit) -> array -> unit
+ val foldi: traversal -> (int * int * elem * 'b -> 'b) -> 'b -> region -> 'b
+ val fold: traversal -> (elem * 'b -> 'b) -> 'b -> array -> 'b
+ val modifyi: traversal -> (int * int * elem -> elem) -> region -> unit
+ val modify: traversal -> (elem -> elem) -> array -> unit
end
1.3 +15 -32 mlton/basis-library/arrays-and-vectors/mono-array2.sml
Index: mono-array2.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/arrays-and-vectors/mono-array2.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- mono-array2.sml 10 Apr 2002 07:02:15 -0000 1.2
+++ mono-array2.sml 24 Nov 2002 01:19:35 -0000 1.3
@@ -5,35 +5,18 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-functor MonoArray2 (V: CONCRETE_MONO_VECTOR): MONO_ARRAY2 =
- struct
- structure Vector = V
- type elem = V.elem
- open Array2
- type array = elem array
- type region = {base: array,
- row: int,
- col: int,
- nrows: int option,
- ncols: int option}
- end
-
-structure Word8Array2 = MonoArray2 (Word8Vector)
-structure CharArray2: MONO_ARRAY2 =
- struct
- structure Vector = CharVector
- type elem = char
- open Array2
- type array = elem array
- type region = {base: array,
- row: int,
- col: int,
- nrows: int option,
- ncols: int option}
- val row = Primitive.String.fromCharVector o row
- val column = Primitive.String.fromCharVector o column
- end
-structure BoolArray2 = MonoArray2 (BoolVector)
-structure IntArray2 = MonoArray2 (IntVector)
-structure RealArray2 = MonoArray2 (RealVector)
-
+structure BoolArray2 = MonoArray2 (type elem = bool
+ structure V = BoolVector)
+structure CharArray2 = MonoArray2 (type elem = char
+ structure V = CharVector)
+structure IntArray2 = MonoArray2 (type elem = int
+ structure V = IntVector)
+structure Int32Array2 = IntArray2
+structure RealArray2 = MonoArray2 (type elem = real
+ structure V = RealVector)
+structure Real64Array2 = RealArray2
+structure WordArray2 = MonoArray2 (type elem = word
+ structure V = WordVector)
+structure Word8Array2 = MonoArray2 (type elem = Word8.word
+ structure V = Word8Vector)
+structure Word32Array2 = WordArray2
1.2 +46 -52 mlton/basis-library/arrays-and-vectors/mono-vector.sig
Index: mono-vector.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/arrays-and-vectors/mono-vector.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- mono-vector.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ mono-vector.sig 24 Nov 2002 01:19:35 -0000 1.2
@@ -7,66 +7,60 @@
val tabulate: int * (int -> elem) -> vector
val length: vector -> int
val sub: vector * int -> elem
- val extract: vector * int * int option -> vector
+ val update: vector * int * elem -> vector
val concat: vector list -> vector
- val mapi: (int * elem -> elem) -> vector * int * int option -> vector
- val map: (elem -> elem) -> vector -> vector
- val appi: (int * elem -> unit) -> vector * int * int option -> unit
+ val appi: (int * elem -> unit) -> vector -> unit
val app: (elem -> unit) -> vector -> unit
- val foldli:
- (int * elem * 'a -> 'a) -> 'a -> vector * int * int option -> 'a
- val foldri:
- (int * elem * 'a -> 'a) -> 'a -> vector * int * int option -> 'a
+ val mapi: (int * elem -> elem) -> vector -> vector
+ val map: (elem -> elem) -> vector -> vector
+ val foldli: (int * elem * 'a -> 'a) -> 'a -> vector -> 'a
+ val foldri: (int * elem * 'a -> 'a) -> 'a -> vector -> 'a
val foldl: (elem * 'a -> 'a) -> 'a -> vector -> 'a
val foldr: (elem * 'a -> 'a) -> 'a -> vector -> 'a
+ val findi: (int * elem -> bool) -> vector -> (int * elem) option
+ val exists: (elem -> bool) -> vector -> bool
+ val all: (elem -> bool) -> vector -> bool
+ val collate: (elem * elem -> order) -> vector * vector -> order
end
-(* The only difference between CONCRETE_MONO_VECTOR and MONO_VECTOR is that
- * the former specifies the type of vector. I couldn't figure out a way to do
- * this in SML using sharing/with, so I had to duplicate the signature.
- *)
-signature CONCRETE_MONO_VECTOR =
+signature MONO_VECTOR_EXTRA_PRE =
sig
- type elem
- type vector = elem Vector.vector
- val maxLen: int
- val fromList: elem list -> vector
- val tabulate: int * (int -> elem) -> vector
- val length: vector -> int
- val sub: vector * int -> elem
- val extract: vector * int * int option -> vector
- val concat: vector list -> vector
- val mapi: (int * elem -> elem) -> vector * int * int option -> vector
- val map: (elem -> elem) -> vector -> vector
- val appi: (int * elem -> unit) -> vector * int * int option -> unit
- val app: (elem -> unit) -> vector -> unit
- val foldli:
- (int * elem * 'a -> 'a) -> 'a -> vector * int * int option -> 'a
- val foldri:
- (int * elem * 'a -> 'a) -> 'a -> vector * int * int option -> 'a
- val foldl: (elem * 'a -> 'a) -> 'a -> vector -> 'a
- val foldr: (elem * 'a -> 'a) -> 'a -> vector -> 'a
+ include MONO_VECTOR
+
+ val unsafeSub: vector * int -> elem
+
+ (* Used to implement Substring/String functions *)
+ val append: vector * vector -> vector
+ val concatWith: vector -> vector list -> vector
+ val isPrefix: (elem * elem -> bool) -> vector -> vector -> bool
+ val isSubvector: (elem * elem -> bool) -> vector -> vector -> bool
+ val isSuffix: (elem * elem -> bool) -> vector -> vector -> bool
+ val translate: (elem -> vector) -> vector -> vector
+ val tokens: (elem -> bool) -> vector -> vector list
+ val fields: (elem -> bool) -> vector -> vector list
+
+ val duplicate: vector -> vector
+ val fromArray: elem array -> vector
+ val toList: vector -> elem list
+ val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> vector
+ val vector: int * elem -> vector
+
+ (* Deprecated *)
+ val extract: vector * int * int option -> vector
end
-signature EQTYPE_MONO_VECTOR =
+signature MONO_VECTOR_EXTRA =
sig
- type elem
- type vector = elem Vector.vector
- val maxLen: int
- val fromList: elem list -> vector
- val tabulate: int * (int -> elem) -> vector
- val length: vector -> int
- val sub: vector * int -> elem
- val extract: vector * int * int option -> vector
- val concat: vector list -> vector
- val mapi: (int * elem -> elem) -> vector * int * int option -> vector
- val map: (elem -> elem) -> vector -> vector
- val appi: (int * elem -> unit) -> vector * int * int option -> unit
- val app: (elem -> unit) -> vector -> unit
- val foldli:
- (int * elem * 'a -> 'a) -> 'a -> vector * int * int option -> 'a
- val foldri:
- (int * elem * 'a -> 'a) -> 'a -> vector * int * int option -> 'a
- val foldl: (elem * 'a -> 'a) -> 'a -> vector -> 'a
- val foldr: (elem * 'a -> 'a) -> 'a -> vector -> 'a
+ include MONO_VECTOR_EXTRA_PRE
+ structure MonoVectorSlice: MONO_VECTOR_SLICE_EXTRA
+ where type elem = elem
+ and type vector = vector
+ end
+
+signature EQTYPE_MONO_VECTOR_EXTRA =
+ sig
+ include MONO_VECTOR_EXTRA_PRE
+ structure MonoVectorSlice: EQTYPE_MONO_VECTOR_SLICE_EXTRA
+ where type elem = elem
+ and type vector = vector
end
1.3 +19 -18 mlton/basis-library/arrays-and-vectors/mono-vector.sml
Index: mono-vector.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/arrays-and-vectors/mono-vector.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- mono-vector.sml 10 Apr 2002 07:02:15 -0000 1.2
+++ mono-vector.sml 24 Nov 2002 01:19:35 -0000 1.3
@@ -5,24 +5,25 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-functor MonoVector(type elem): MONO_VECTOR =
- struct
- open Vector
- type elem = elem
- type vector = elem vector
- end
+structure Word8Vector = EqtypeMonoVector(type elem = Word8.word)
+structure Word8VectorSlice = Word8Vector.MonoVectorSlice
-structure Word8Vector = MonoVector(type elem = Word8.word)
+(* Moved to text/string0.sml
+structure CharVector = MonoVector(type elem = char)
+structure CharVectorSlice = CharVector.MonoVectorSlice
+*)
-(* Basis Library spec requires type CharVector.vector = string *)
-structure CharVector =
- struct
- open String0
- type vector = string
- type elem = char
- end
-
-structure BoolVector = MonoVector(type elem = bool)
-structure IntVector = MonoVector(type elem = int)
+structure BoolVector = EqtypeMonoVector(type elem = bool)
+structure BoolVectorSlice = BoolVector.MonoVectorSlice
+structure IntVector = EqtypeMonoVector(type elem = int)
+structure IntVectorSlice = IntVector.MonoVectorSlice
+structure Int32Vector = IntVector
+structure Int32VectorSlice = Int32Vector.MonoVectorSlice
structure RealVector = MonoVector(type elem = real)
-
+structure RealVectorSlice = RealVector.MonoVectorSlice
+structure Real64Vector = RealVector
+structure Real64VectorSlice = Real64Vector.MonoVectorSlice
+structure WordVector = EqtypeMonoVector(type elem = word)
+structure WordVectorSlice = WordVector.MonoVectorSlice
+structure Word32Vector = WordVector
+structure Word32VectorSlice = Word32Vector.MonoVectorSlice
1.12 +399 -122 mlton/basis-library/arrays-and-vectors/sequence.fun
Index: sequence.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/arrays-and-vectors/sequence.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- sequence.fun 14 Nov 2002 22:27:03 -0000 1.11
+++ sequence.fun 24 Nov 2002 01:19:35 -0000 1.12
@@ -28,16 +28,7 @@
if not isMutable andalso n = 0
then Array.array0Const ()
else Array.array n
-
- fun sub (s, i) =
- if Primitive.safe andalso Primitive.Int.geu (i, length s)
- then raise Subscript
- else S.sub (s, i)
-
- fun update (a, i, x) =
- if Primitive.safe andalso Primitive.Int.geu (i, Array.length a)
- then raise Subscript
- else Array.update (a, i, x)
+ val seq0 = fn () => fromArray (array 0)
fun unfoldi (n, b, f) =
let
@@ -50,7 +41,7 @@
val (x, b') = f (i, b)
val _ = Array.update (a, i, x)
in
- loop (i + 1, b')
+ loop (i +? 1, b')
end
val _ = loop (0, b)
in
@@ -61,6 +52,7 @@
* with reasonable bogus values.
*)
fun tabulate (n, f) =
+(*
if !Primitive.usesCallcc
then
(* This code is careful to use a list to accumulate the
@@ -85,30 +77,406 @@
; fromArray a
end
else
+*)
unfoldi (n, (), fn (i, ()) => (f i, ()))
fun new (n, x) = tabulate (n, fn _ => x)
- fun fromListOfLength (l, n) =
- let
- val a = array n
- fun loop (l, i) =
- if i < n
- then (case l of
- [] => raise Fail "fromListOfLength bug"
- | x :: l => (Array.update (a, i, x)
- ; loop (l, i + 1)))
- else ()
- in loop (l, 0)
- ; fromArray a
+ fun fromList l =
+ let val a = array (List.length l)
+ in List.foldl (fn (c, i) => (Array.update (a, i, c) ; i +? 1)) 0 l ;
+ fromArray a
end
- fun fromList l = fromListOfLength (l, List.length l)
-
- type 'a slice = 'a sequence * int * int option
-
- fun 'a wholeSlice (a: 'a sequence): 'a slice = (a, 0, NONE)
+ structure Slice =
+ struct
+ type 'a sequence = 'a sequence
+ type 'a elt = 'a elt
+ type 'a slice = {seq: 'a sequence, start: int, len: int}
+
+ fun length (sl: 'a slice as {len, ...}) = len
+ fun sub (sl: 'a slice as {seq, start, len}, i) =
+ if Primitive.safe andalso Primitive.Int.geu (i, len)
+ then raise Subscript
+ else S.sub (seq, start +? i)
+ fun unsafeSub (sl: 'a slice as {seq, start, ...}, i) =
+ S.sub (seq, start +? i)
+ fun update' update (sl: 'a slice as {seq, start, len}, i, x) =
+ if Primitive.safe andalso Primitive.Int.geu (i, len)
+ then raise Subscript
+ else update (seq, start +? i, x)
+ fun unsafeUpdate' update (sl: 'a slice as {seq, start, ...}, i, x) =
+ update (seq, start +? i, x)
+ fun full (seq: 'a sequence) : 'a slice =
+ {seq = seq, start = 0, len = S.length seq}
+ fun subslice (sl: 'a slice as {seq, start, len}, start', len') =
+ case len' of
+ NONE => if Primitive.safe andalso
+ (start' < 0 orelse start' > len)
+ then raise Subscript
+ else {seq = seq,
+ start = start +? start',
+ len = len -? start'}
+ | SOME len' => if Primitive.safe andalso
+ (start' < 0 orelse start' > len orelse
+ len' < 0 orelse len' > len -? start')
+ then raise Subscript
+ else {seq = seq,
+ start = start +? start',
+ len = len'}
+ fun unsafeSubslice (sl: 'a slice as {seq, start, len}, start', len') =
+ {seq = seq,
+ start = start +? start',
+ len = case len' of
+ NONE => len -? start'
+ | SOME len' => len'}
+ fun slice (seq: 'a sequence, start, len) =
+ subslice (full seq, start, len)
+ fun unsafeSlice (seq: 'a sequence, start, len) =
+ unsafeSubslice (full seq, start, len)
+ fun base (sl: 'a slice as {seq, start, len}) = (seq, start, len)
+ fun isEmpty sl = length sl = 0
+ fun getItem (sl: 'a slice as {seq, start, len}) =
+ if isEmpty sl
+ then NONE
+ else SOME (S.sub (seq, start),
+ {seq = seq,
+ start = start +? 1,
+ len = len -? 1})
+ fun foldli f b (sl: 'a slice as {seq, start, len}) =
+ let
+ val min = start
+ val max = start +? len
+ fun loop (i, b) =
+ if i >= max then b
+ else loop (i +? 1, f (i -? min, S.sub (seq, i), b))
+ in loop (min, b)
+ end
+ fun foldri f b (sl: 'a slice as {seq, start, len}) =
+ let
+ val min = start
+ val max = start +? len
+ fun loop (i, b) =
+ if i < min then b
+ else loop (i -? 1, f (i -? min, S.sub (seq, i), b))
+ in loop (max -? 1, b)
+ end
+ local
+ fun make foldi f b sl = foldi (fn (_, x, b) => f (x, b)) b sl
+ in
+ fun foldl f = make foldli f
+ fun foldr f = make foldri f
+ end
+ fun appi f sl = foldli (fn (i, x, ()) => f (i, x)) () sl
+ fun app f sl = appi (f o #2) sl
+ fun createi tabulate f (sl: 'a slice as {seq, start, len}) =
+ tabulate (len, fn i => f (i, S.sub (seq, start +? i)))
+ fun create tabulate f sl = createi tabulate (f o #2) sl
+ fun mapi f sl = createi tabulate f sl
+ fun map f sl = mapi (f o #2) sl
+ fun findi p (sl: 'a slice as {seq, start, len}) =
+ let
+ val min = start
+ val max = start +? len
+ fun loop i =
+ if i >= max
+ then NONE
+ else let val z = (i -? min, S.sub (seq, i))
+ in if p z
+ then SOME z
+ else loop (i +? 1)
+ end
+ in loop min
+ end
+ fun find p sl = Option.map #2 (findi (p o #2) sl)
+ fun existsi p sl = Option.isSome (findi p sl)
+ fun exists p sl = existsi (p o #2) sl
+ fun alli p sl = not (existsi (not o p) sl)
+ fun all p sl = alli (p o #2) sl
+ fun collate cmp (sl1 as {seq = seq1, start = start1, len = len1},
+ sl2 as {seq = seq2, start = start2, len = len2}) =
+ let
+ val min1 = start1
+ val min2 = start2
+ val max1 = start1 +? len1
+ val max2 = start2 +? len2
+ fun loop (i, j) =
+ case (i >= max1, j >= max2) of
+ (true, true) => EQUAL
+ | (true, false) => LESS
+ | (false, true) => GREATER
+ | (false, false) =>
+ (case cmp (S.sub (seq1, i), S.sub (seq2, j)) of
+ EQUAL => loop (i +? 1, j +? 1)
+ | ans => ans)
+ in loop (min1, min2)
+ end
+ fun sequence (sl: 'a slice as {seq, start, len}): 'a sequence =
+ if isMutable orelse (start <> 0 orelse len <> S.length seq)
+ then map (fn x => x) sl
+ else seq
+ fun append (sl1: 'a slice, sl2: 'a slice): 'a sequence =
+ if length sl1 = 0
+ then sequence sl2
+ else if length sl2 = 0
+ then sequence sl1
+ else
+ let
+ val l1 = length sl1
+ val l2 = length sl2
+ val n = l1 + l2 handle Overflow => raise Size
+ in
+ unfoldi (n, (0, sl1),
+ fn (_, (i, sl)) =>
+ if i < length sl
+ then (unsafeSub (sl, i), (i +? 1, sl))
+ else (unsafeSub (sl2, 0), (1, sl2)))
+ end
+ fun concat (sls: 'a slice list): 'a sequence =
+ case sls of
+ [] => seq0 ()
+ | [sl] => sequence sl
+ | sls' as sl::sls =>
+ let
+ val n = List.foldl (fn (sl, s) => s + length sl) 0 sls'
+ handle Overflow => raise Size
+ in
+ unfoldi (n, (0, sl, sls),
+ fn (_, ac) =>
+ let
+ fun loop (i, sl, sls) =
+ if i < length sl
+ then (unsafeSub (sl, i), (i +? 1, sl, sls))
+ else case sls of
+ [] => raise Fail "concat bug"
+ | sl :: sls => loop (0, sl, sls)
+ in loop ac
+ end)
+ end
+ fun concatWith (sep: 'a sequence) (sls: 'a slice list): 'a sequence =
+ let val sep = full sep
+ in case sls of
+ [] => seq0 ()
+ | [sl] => sequence sl
+ | sl::sls =>
+ List.foldl (fn (sl,seq) =>
+ concat [full seq, sep, full (sequence sl)])
+ (sequence sl) sls
+ end
+ fun triml k =
+ if Primitive.safe andalso k < 0
+ then raise Subscript
+ else
+ (fn (sl as {seq, start, len}) =>
+ if k > len
+ then unsafeSlice (seq, start +? len, SOME 0)
+ else unsafeSlice (seq, start +? k, SOME (len -? k)))
+ fun trimr k =
+ if Primitive.safe andalso k < 0
+ then raise Subscript
+ else
+ (fn (sl as {seq, start, len}) =>
+ unsafeSlice (seq, start, SOME (if k > len then 0 else len -? k)))
+ fun isSubsequence (eq: 'a elt * 'a elt -> bool)
+ (seq: 'a sequence)
+ (sl: 'a slice) =
+ let
+ val n = S.length seq
+ val n' = length sl
+ in
+ if n <= n'
+ then let
+ val n'' = n' -? n
+ fun loop (i, j) =
+ if i > n''
+ then false
+ else if j >= n
+ then true
+ else if eq (S.sub (seq, j), unsafeSub (sl, i +? j))
+ then loop (i, j +? 1)
+ else loop (i +? 1, 0)
+ in
+ loop (0, 0)
+ end
+ else false
+ end
+ fun isPrefix (eq: 'a elt * 'a elt -> bool)
+ (seq: 'a sequence)
+ (sl: 'a slice) =
+ let
+ val n = S.length seq
+ val n' = length sl
+ in
+ if n <= n'
+ then let
+ fun loop (j) =
+ if j >= n
+ then true
+ else if eq (S.sub (seq, j), unsafeSub (sl, j))
+ then loop (j +? 1)
+ else false
+ in
+ loop (0)
+ end
+ else false
+ end
+ fun isSuffix (eq: 'a elt * 'a elt -> bool)
+ (seq: 'a sequence)
+ (sl: 'a slice) =
+ let
+ val n = S.length seq
+ val n' = length sl
+ in
+ if n <= n'
+ then let
+ val n'' = n' -? n
+ fun loop (j) =
+ if j >= n
+ then true
+ else if eq (S.sub (seq, j), unsafeSub (sl, n'' +? j))
+ then loop (j +? 1)
+ else false
+ in
+ loop (0)
+ end
+ else false
+ end
+ fun split (sl: 'a slice as {seq, start, len}, i) =
+ (unsafeSlice (seq, start, SOME (i -? start)),
+ unsafeSlice (seq, i, SOME (len -? (i -? start))))
+ fun splitl f (sl: 'a slice as {seq, start, len}) =
+ let
+ val stop = start +? len
+ fun loop i =
+ if i >= stop
+ then i
+ else if f (S.sub (seq, i))
+ then loop (i +? 1)
+ else i
+ in split (sl, loop start)
+ end
+ fun splitr f (sl: 'a slice as {seq, start, len}) =
+ let
+ fun loop i =
+ if i < start
+ then start
+ else if f (S.sub (seq, i))
+ then loop (i -? 1)
+ else i +? 1
+ in split (sl, loop (start +? len -? 1))
+ end
+ fun splitAt (sl: 'a slice as {seq, start, len}, i) =
+ if Primitive.safe andalso Primitive.Int.gtu (i, len)
+ then raise Subscript
+ else (unsafeSlice (seq, start, SOME i),
+ unsafeSlice (seq, start +? i, SOME (len -? i)))
+ fun dropl p s = #2 (splitl p s)
+ fun dropr p s = #1 (splitr p s)
+ fun takel p s = #1 (splitl p s)
+ fun taker p s = #2 (splitr p s)
+ fun position (eq: 'a elt * 'a elt -> bool)
+ (seq': 'a sequence)
+ (sl: 'a slice as {seq, start, len}) =
+ let
+ val len' = S.length seq'
+ val max = start +? len -? len' +? 1
+ (* loop returns the index of the front of the suffix. *)
+ fun loop i =
+ if i >= max
+ then start +? len
+ else let
+ fun loop' j =
+ if j >= len'
+ then i
+ else if eq (S.sub (seq, i +? j),
+ S.sub (seq', j))
+ then loop' (j +? 1)
+ else loop (i +? 1)
+ in loop' 0
+ end
+ in split (sl, loop start)
+ end
+ fun span (eq: 'a sequence * 'a sequence -> bool)
+ (sl: 'a slice as {seq, start, len},
+ sl': 'a slice as {seq = seq', start = start', len = len'}) =
+ if Primitive.safe andalso
+ (not (eq (seq, seq')) orelse start' +? len' < start)
+ then raise Span
+ else unsafeSlice (seq, start, SOME ((start' +? len') -? start))
+ fun translate f (sl: 'a slice) =
+ concat (List.rev (foldl (fn (c, l) => (full (f c)) :: l) [] sl))
+ local
+ fun make finish p (sl: 'a slice as {seq, start, len}) =
+ let
+ val max = start +? len
+ fun loop (i, start, sls) =
+ if i >= max
+ then List.rev (finish (seq, start, i, sls))
+ else
+ if p (S.sub (seq, i))
+ then loop (i +? 1, i +? 1, finish (seq, start, i, sls))
+ else loop (i +? 1, start, sls)
+ in loop (start, start, [])
+ end
+ in
+ fun tokens p sl =
+ make (fn (seq, start, stop, sls) =>
+ if start = stop
+ then sls
+ else
+ (unsafeSlice (seq, start, SOME (stop -? start)))
+ :: sls)
+ p sl
+ fun fields p sl =
+ make (fn (seq, start, stop, sls) =>
+ (unsafeSlice (seq, start, SOME (stop -? start)))
+ :: sls)
+ p sl
+ end
+ fun toList (sl: 'a slice) = foldr (fn (a,l) => a::l) [] sl
+ end
+ local
+ fun make f seq = f (Slice.full seq)
+ fun make2 f (seq1, seq2) = f (Slice.full seq1, Slice.full seq2)
+ in
+ fun sub (seq, i) = Slice.sub (Slice.full seq, i)
+ fun unsafeSub (seq, i) = Slice.unsafeSub (Slice.full seq, i)
+ fun update' update (seq, i, x) =
+ Slice.update' update (Slice.full seq, i, x)
+ fun unsafeUpdate' update (seq, i, x) =
+ Slice.unsafeUpdate' update (Slice.full seq, i, x)
+ fun append seqs = make2 Slice.append seqs
+ fun concat seqs = Slice.concat (List.map Slice.full seqs)
+ fun appi f = make (Slice.appi f)
+ fun app f = make (Slice.app f)
+ fun mapi f = make (Slice.mapi f)
+ fun map f = make (Slice.map f)
+ fun foldli f b = make (Slice.foldli f b)
+ fun foldri f b = make (Slice.foldri f b)
+ fun foldl f b = make (Slice.foldl f b)
+ fun foldr f b = make (Slice.foldr f b)
+ fun findi p = make (Slice.findi p)
+ fun find p = make (Slice.find p)
+ fun existsi p = make (Slice.existsi p)
+ fun exists p = make (Slice.exists p)
+ fun alli p = make (Slice.alli p)
+ fun all p = make (Slice.all p)
+ fun collate cmp = make2 (Slice.collate cmp)
+ fun concatWith sep seqs = Slice.concatWith sep (List.map Slice.full seqs)
+ fun isPrefix eq seq = make (Slice.isPrefix eq seq)
+ fun isSubsequence eq seq = make (Slice.isSubsequence eq seq)
+ fun isSuffix eq seq = make (Slice.isSuffix eq seq)
+ fun translate f = make (Slice.translate f)
+ fun tokens f seq = List.map Slice.sequence (make (Slice.tokens f) seq)
+ fun fields f seq = List.map Slice.sequence (make (Slice.fields f) seq)
+ fun createi tabulate f seq = make (Slice.createi tabulate f) seq
+ fun create tabulate f seq = make (Slice.create tabulate f) seq
+ fun duplicate seq = make (Slice.sequence) seq
+ fun toList seq = make (Slice.toList) seq
+ end
+
+ (* Deprecated *)
fun checkSliceMax (start: int, num: int option, max: int): int =
case num of
NONE => if Primitive.safe andalso (start < 0 orelse start > max)
@@ -119,99 +487,8 @@
andalso (start < 0 orelse num < 0 orelse start > max -? num)
then raise Subscript
else start +? num
-
+ (* Deprecated *)
fun checkSlice (s, i, opt) = checkSliceMax (i, opt, length s)
-
- fun foldli f b (slice as (s, min, _)) =
- let
- val max = checkSlice slice
- fun loop (i, b) =
- if i >= max then b
- else loop (i + 1, f (i, S.sub (s, i), b))
- in loop (min, b)
- end
-
- fun appi f slice = foldli (fn (i, x, ()) => f (i, x)) () slice
-
- fun app f s = appi (f o #2) (wholeSlice s)
-
- fun foldri f b (slice as (s, min, _)) =
- let
- val max = checkSlice slice
- fun loop (i, b) =
- if i < min
- then b
- else loop (i -? 1, f (i, S.sub (s, i), b))
- in loop (max -? 1, b)
- end
-
- local
- fun make foldi f b s = foldi (fn (_, x, b) => f (x, b)) b (wholeSlice s)
- in
- fun foldl f = make foldli f
- fun foldr f = make foldri f
- end
-
- fun mapi f (slice as (s, min, _)) =
- let val max = checkSlice slice
- in tabulate (max -? min, fn i => let val j = i +? min
- in f (j, S.sub (s, j))
- end)
- end
-
- fun map f s = mapi (f o #2) (wholeSlice s)
-
- val extract =
- fn (s, 0, NONE) => s
- | slice => mapi #2 slice
-
- fun copy s = map (fn x => x) s
-
- fun 'a concat (vs: 'a sequence list): 'a sequence =
- case vs of
- [] => fromArray (array 0)
- | [v] => if isMutable then copy v else v
- | v :: vs' =>
- let
- val n = List.foldl (fn (v, s) => s + length v) 0 vs
- in
- unfoldi (n, (0, v, vs'),
- fn (_, ac) =>
- let
- fun loop (i, v, vs) =
- if i < length v
- then (sub (v, i), (i + 1, v, vs))
- else
- case vs of
- [] => raise Fail "concat bug"
- | v :: vs => loop (0, v, vs)
- in loop ac
- end)
- end
-
- fun prefixToList (s, n) =
- let
- fun loop (i, l) =
- if i < 0
- then l
- else loop (i - 1, S.sub (s, i) :: l)
- in loop (n - 1, [])
- end
-
- fun toList a = prefixToList (a, length a)
-
- fun find (s, p) =
- let
- val max = length s
- fun loop i =
- if i >= max
- then NONE
- else let
- val x = S.sub (s, i)
- in if p x
- then SOME x
- else loop (i + 1)
- end
- in loop 0
- end
+ (* Deprecated *)
+ fun extract args = Slice.sequence (Slice.slice args)
end
1.5 +56 -25 mlton/basis-library/arrays-and-vectors/sequence.sig
Index: sequence.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/arrays-and-vectors/sequence.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- sequence.sig 10 Apr 2002 07:02:15 -0000 1.4
+++ sequence.sig 24 Nov 2002 01:19:35 -0000 1.5
@@ -5,40 +5,71 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
+
signature SEQUENCE =
sig
type 'a sequence
type 'a elt
- val app: ('a elt -> unit) -> 'a sequence -> unit
- val appi: (int * 'a elt -> unit) -> 'a sequence * int * int option -> unit
- (* checkSlice returns max where the slice is from min (inclusive)
- * to max (exclusive). Raises Subscript if invalid slice.
+ structure Slice : SLICE where type 'a sequence = 'a sequence
+ and type 'a elt = 'a elt
+
+ val maxLen: int
+ val fromList: 'a elt list -> 'a sequence
+ val tabulate: int * (int -> 'a elt) -> 'a sequence
+ val length: 'a sequence -> int
+ val sub: 'a sequence * int -> 'a elt
+ val unsafeSub: 'a sequence * int -> 'a elt
+ (* ('a sequence * int * 'a elt -> unit should be an unsafe update.
*)
- val checkSlice: 'a sequence * int * int option -> int
- val checkSliceMax: int * int option * int -> int
- val concat: 'a sequence list -> 'a sequence
- val extract: 'a sequence * int * int option -> 'a sequence
- val find: 'a sequence * ('a elt -> bool) -> 'a elt option
+ val update': ('a sequence * int * 'a elt -> unit) ->
+ ('a sequence * int * 'a elt) -> unit
+ val unsafeUpdate': ('a sequence * int * 'a elt -> unit) ->
+ ('a sequence * int * 'a elt) -> unit
+ val concat: 'a sequence list -> 'a sequence
+ val appi: (int * 'a elt -> unit) -> 'a sequence -> unit
+ val app: ('a elt -> unit) -> 'a sequence -> unit
+ val mapi : (int * 'a elt -> 'b elt) -> 'a sequence -> 'b sequence
+ val map: ('a elt -> 'b elt) -> 'a sequence -> 'b sequence
+ val foldli: (int * 'a elt * 'b -> 'b) -> 'b -> 'a sequence -> 'b
+ val foldri: (int * 'a elt * 'b -> 'b) -> 'b -> 'a sequence -> 'b
val foldl: ('a elt * 'b -> 'b) -> 'b -> 'a sequence -> 'b
- val foldli:
- (int * 'a elt * 'b -> 'b) -> 'b -> 'a sequence * int * int option -> 'b
val foldr: ('a elt * 'b -> 'b) -> 'b -> 'a sequence -> 'b
- val foldri:
- (int * 'a elt * 'b -> 'b) -> 'b -> 'a sequence * int * int option -> 'b
- val fromList: 'a elt list -> 'a sequence
- val length: 'a sequence -> int
- val map: ('a elt -> 'b elt) -> 'a sequence -> 'b sequence
- val mapi:
- (int * 'a elt -> 'b elt)
- -> 'a sequence * int * int option -> 'b sequence
- val maxLen: int
+ val findi: (int * 'a elt -> bool) -> 'a sequence -> (int * 'a elt) option
+ val find: ('a elt -> bool) -> 'a sequence -> 'a elt option
+ val existsi: (int * 'a elt -> bool) -> 'a sequence -> bool
+ val exists: ('a elt -> bool) -> 'a sequence -> bool
+ val alli: (int * 'a elt -> bool) -> 'a sequence -> bool
+ val all: ('a elt -> bool) -> 'a sequence -> bool
+ val collate: ('a elt * 'a elt -> order) -> 'a sequence * 'a sequence -> order
+
+ (* Used to implement Substring/String functions *)
+ val concatWith: 'a sequence -> 'a sequence list -> 'a sequence
+ val isPrefix: ('a elt * 'a elt -> bool) -> 'a sequence -> 'a sequence -> bool
+ val isSubsequence: ('a elt * 'a elt -> bool) -> 'a sequence -> 'a sequence -> bool
+ val isSuffix: ('a elt * 'a elt -> bool) -> 'a sequence -> 'a sequence -> bool
+ val translate: ('a elt -> 'a sequence) -> 'a sequence -> 'a sequence
+ val tokens: ('a elt -> bool) -> 'a sequence -> 'a sequence list
+ val fields: ('a elt -> bool) -> 'a sequence -> 'a sequence list
+
+ (* Extra *)
+ val append: 'a sequence * 'a sequence -> 'a sequence
+ (* createi,create:
+ * (int * (int -> 'b elt) -> 'c should be a tabulate function.
+ *)
+ val createi: (int * (int -> 'b elt) -> 'c) ->
+ (int * 'a elt -> 'b elt) -> 'a sequence -> 'c
+ val create: (int * (int -> 'b elt) -> 'c) ->
+ ('a elt -> 'b elt) -> 'a sequence -> 'c
+ val duplicate: 'a sequence -> 'a sequence
val new: int * 'a elt -> 'a sequence
- val prefixToList: 'a sequence * int -> 'a elt list
- val sub: 'a sequence * int -> 'a elt
- val tabulate: int * (int -> 'a elt) -> 'a sequence
val toList: 'a sequence -> 'a elt list
val unfoldi: int * 'a * (int * 'a -> 'b elt * 'a) -> 'b sequence
- val update: 'a elt array * int * 'a elt -> unit
- val wholeSlice: 'a sequence -> 'a sequence * int * int option
+
+ (* Deprecated *)
+ val checkSlice: 'a sequence * int * int option -> int
+ (* Deprecated *)
+ val checkSliceMax: int * int option * int -> int
+ (* Deprecated *)
+ val extract: 'a sequence * int * int option -> 'a sequence
end
1.4 +33 -10 mlton/basis-library/arrays-and-vectors/vector.sig
Index: vector.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/arrays-and-vectors/vector.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- vector.sig 1 Aug 2001 20:04:01 -0000 1.3
+++ vector.sig 24 Nov 2002 01:19:35 -0000 1.4
@@ -12,26 +12,49 @@
val tabulate: int * (int -> 'a) -> 'a vector
val length: 'a vector -> int
val sub: 'a vector * int -> 'a
- val extract: 'a vector * int * int option -> 'a vector
+ val update: 'a vector * int * 'a -> 'a vector
val concat: 'a vector list -> 'a vector
- val mapi : (int * 'a -> 'b) -> 'a vector * int * int option -> 'b vector
- val map: ('a -> 'b) -> 'a vector -> 'b vector
- val appi: (int * 'a -> unit) -> 'a vector * int * int option -> unit
+ val appi: (int * 'a -> unit) -> 'a vector -> unit
val app: ('a -> unit) -> 'a vector -> unit
- val foldli :
- (int * 'a * 'b -> 'b) -> 'b -> 'a vector * int * int option -> 'b
- val foldri :
- (int * 'a * 'b -> 'b) -> 'b -> 'a vector * int * int option -> 'b
+ val mapi : (int * 'a -> 'b) -> 'a vector -> 'b vector
+ val map: ('a -> 'b) -> 'a vector -> 'b vector
+ val foldli: (int * 'a * 'b -> 'b) -> 'b -> 'a vector -> 'b
+ val foldri: (int * 'a * 'b -> 'b) -> 'b -> 'a vector -> 'b
val foldl: ('a * 'b -> 'b) -> 'b -> 'a vector -> 'b
val foldr: ('a * 'b -> 'b) -> 'b -> 'a vector -> 'b
+ val findi: (int * 'a -> bool) -> 'a vector -> (int * 'a) option
+ val find: ('a -> bool) -> 'a vector -> 'a option
+ val exists: ('a -> bool) -> 'a vector -> bool
+ val all: ('a -> bool) -> 'a vector -> bool
+ val collate: ('a * 'a -> order) -> 'a vector * 'a vector -> order
end
signature VECTOR_EXTRA =
sig
include VECTOR
+ structure VectorSlice: VECTOR_SLICE_EXTRA
+ where type 'a vector = 'a vector
- val checkSlice: 'a vector * int * int option -> int
+ val unsafeSub: 'a vector * int -> 'a
+
+ (* Used to implement Substring/String functions *)
+ val concatWith: 'a vector -> 'a vector list -> 'a vector
+ val isPrefix: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool
+ val isSubvector: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool
+ val isSuffix: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool
+ val translate: ('a -> 'a vector) -> 'a vector -> 'a vector
+ val tokens: ('a -> bool) -> 'a vector -> 'a vector list
+ val fields: ('a -> bool) -> 'a vector -> 'a vector list
+
+ val append: 'a vector * 'a vector -> 'a vector
+ val duplicate: 'a vector -> 'a vector
val fromArray: 'a array -> 'a vector
+ val toList: 'a vector -> 'a list
val unfoldi: int * 'a * (int * 'a -> 'b * 'a) -> 'b vector
- val unsafeSub: 'a vector * int -> 'a
+ val vector: int * 'a -> 'a vector
+
+ (* Deprecated *)
+ val checkSlice: 'a vector * int * int option -> int
+ (* Deprecated *)
+ val extract: 'a vector * int * int option -> 'a vector
end
1.4 +25 -2 mlton/basis-library/arrays-and-vectors/vector.sml
Index: vector.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/arrays-and-vectors/vector.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- vector.sml 10 Apr 2002 07:02:15 -0000 1.3
+++ vector.sml 24 Nov 2002 01:19:35 -0000 1.4
@@ -11,14 +11,37 @@
type 'a elt = 'a
val fromArray = Primitive.Vector.fromArray
val isMutable = false
- open Primitive.Vector)
+ val length = Primitive.Vector.length
+ val sub = Primitive.Vector.sub)
open V
type 'a vector = 'a vector
- val fromArray = Primitive.Vector.fromArray
+ structure VectorSlice =
+ struct
+ open Slice
+ type 'a vector = 'a vector
+ val vector = sequence
+
+ val isSubvector = isSubsequence
+ val span = fn (sl, sl') =>
+ span (op = : ''a vector * ''a vector -> bool) (sl, sl')
+ end
+
+ fun update (v, i, x) =
+ tabulate (length v,
+ fn j => if i = j
+ then x
+ else unsafeSub (v, j))
+
val unsafeSub = Primitive.Vector.sub
+
+ val isSubvector = isSubsequence
+
+ val fromArray = Primitive.Vector.fromArray
+ val vector = new
end
+structure VectorSlice: VECTOR_SLICE_EXTRA = Vector.VectorSlice
structure VectorGlobal: VECTOR_GLOBAL = Vector
open VectorGlobal
1.2 +54 -0 mlton/basis-library/arrays-and-vectors/array-slice.sig
1.2 +48 -0 mlton/basis-library/arrays-and-vectors/mono-array-slice.sig
1.2 +27 -0 mlton/basis-library/arrays-and-vectors/mono-array.fun
1.2 +22 -0 mlton/basis-library/arrays-and-vectors/mono-array2.fun
1.2 +66 -0 mlton/basis-library/arrays-and-vectors/mono-vector-slice.sig
1.2 +36 -0 mlton/basis-library/arrays-and-vectors/mono-vector.fun
1.2 +83 -0 mlton/basis-library/arrays-and-vectors/slice.sig
1.2 +67 -0 mlton/basis-library/arrays-and-vectors/vector-slice.sig
1.4 +2 -2 mlton/basis-library/general/bool.sig
Index: bool.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/general/bool.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- bool.sig 20 Jul 2002 23:14:01 -0000 1.3
+++ bool.sig 24 Nov 2002 01:19:35 -0000 1.4
@@ -1,6 +1,6 @@
signature BOOL_GLOBAL =
sig
- datatype bool = false | true
+ datatype bool = datatype bool
val not: bool -> bool
end
@@ -9,7 +9,7 @@
sig
include BOOL_GLOBAL
- val toString: bool -> string
val fromString: string -> bool option
val scan: (char, 'a) StringCvt.reader -> (bool, 'a) StringCvt.reader
+ val toString: bool -> string
end
1.5 +4 -4 mlton/basis-library/general/bool.sml
Index: bool.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/general/bool.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- bool.sml 20 Jul 2002 23:14:01 -0000 1.4
+++ bool.sml 24 Nov 2002 01:19:35 -0000 1.5
@@ -11,10 +11,6 @@
val not = not
- val toString =
- fn true => "true"
- | false => "false"
-
fun scan reader state =
case reader state of
NONE => NONE
@@ -31,6 +27,10 @@
| _ => NONE
val fromString = StringCvt.scanString scan
+
+ val toString =
+ fn true => "true"
+ | false => "false"
end
structure BoolGlobal: BOOL_GLOBAL = Bool
1.4 +3 -1 mlton/basis-library/general/general.sig
Index: general.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/general/general.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- general.sig 20 Jul 2002 23:14:01 -0000 1.3
+++ general.sig 24 Nov 2002 01:19:35 -0000 1.4
@@ -4,18 +4,20 @@
type exn
exception Bind
+ exception Match
exception Chr
exception Div
exception Domain
exception Fail of string
- exception Match
exception Overflow
exception Size
exception Span
exception Subscript
val exnName: exn -> string
val exnMessage: exn -> string
+
datatype order = LESS | EQUAL | GREATER
+
val ! : 'a ref -> 'a
val := : ('a ref * 'a) -> unit
val o : (('b -> 'c) * ('a -> 'b)) -> 'a -> 'c
1.6 +6 -7 mlton/basis-library/general/general.sml
Index: general.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/general/general.sml,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- general.sml 20 Jul 2002 23:14:01 -0000 1.5
+++ general.sml 24 Nov 2002 01:19:35 -0000 1.6
@@ -8,29 +8,28 @@
structure General: GENERAL =
struct
type unit = unit
+
type exn = exn
-
exception Bind = Bind
+ exception Match = Match
exception Chr
exception Div
exception Domain
exception Fail = Fail
- exception Match = Match
exception Overflow = Overflow
exception Size = Size
exception Span
exception Subscript
-
- datatype order = LESS | EQUAL | GREATER
-
val exnName = Primitive.Exn.name
val exnMessage = exnName
+ datatype order = LESS | EQUAL | GREATER
+
+ val ! = Primitive.Ref.deref
+ val op := = Primitive.Ref.assign
fun (f o g) x = f (g x)
fun x before () = x
fun ignore _ = ()
- val op := = Primitive.Ref.assign
- val ! = Primitive.Ref.deref
end
structure GeneralGlobal: GENERAL_GLOBAL = General
1.4 +1 -0 mlton/basis-library/general/option.sig
Index: option.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/general/option.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- option.sig 20 Jul 2002 23:14:01 -0000 1.3
+++ option.sig 24 Nov 2002 01:19:35 -0000 1.4
@@ -13,6 +13,7 @@
val filter: ('a -> bool) -> 'a -> 'a option
val join: 'a option option -> 'a option
+ val app: ('a -> unit) -> 'a option -> unit
val map: ('a -> 'b) -> 'a option -> 'b option
val mapPartial: ('a -> 'b option) -> 'a option -> 'b option
val compose: ('a -> 'b) * ('c -> 'a option) -> 'c -> 'b option
1.4 +6 -1 mlton/basis-library/general/option.sml
Index: option.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/general/option.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- option.sml 20 Jul 2002 23:14:01 -0000 1.3
+++ option.sml 24 Nov 2002 01:19:35 -0000 1.4
@@ -1,4 +1,5 @@
(* Modified from SML/NJ sources by sweeks@research.nj.nec.com on 4/18/98. *)
+(* Modified by fluet@cs.cornell.edu on 7/19/02. *)
(* option.sml
*
@@ -29,8 +30,12 @@
fn SOME opt => opt
| NONE => NONE
+ fun app f =
+ fn SOME x => f x
+ | NONE => ()
+
fun map f =
- fn SOME x => SOME(f x)
+ fn SOME x => SOME (f x)
| NONE => NONE
fun mapPartial f =
1.7 +9 -42 mlton/basis-library/integer/int-inf.sig
Index: int-inf.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/integer/int-inf.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- int-inf.sig 20 Jul 2002 23:14:01 -0000 1.6
+++ int-inf.sig 24 Nov 2002 01:19:35 -0000 1.7
@@ -1,50 +1,17 @@
signature INT_INF =
sig
- eqtype int
+ include INTEGER
- val * : int * int -> int
- val + : int * int -> int
- val - : int * int -> int
- val < : int * int -> bool
- val <= : int * int -> bool
- val > : int * int -> bool
- val >= : int * int -> bool
- val abs: int -> int
- val compare: int * int -> order
- val div: int * int -> int
val divMod: int * int -> int * int
- val fmt: StringCvt.radix -> int -> string
- val fromInt: Int.int -> int
- val fromLarge: LargeInt.int -> int
- val fromString: string -> int option
- val log2: int -> Int.int
- val max: int * int -> int
- val maxInt: int option
- val min: int * int -> int
- val minInt: int option
- val mod: int * int -> int
- val pow: int * Int.int -> int
- val precision: Int.int option
- val quot: int * int -> int
val quotRem: int * int -> int * int
- val rem: int * int -> int
- val sameSign: int * int -> bool
- val scan:
- StringCvt.radix
- -> (char, 'a) StringCvt.reader
- -> (int, 'a) StringCvt.reader
- val sign: int -> Int.int
- val toInt: int -> Int.int
- val toLarge: int -> LargeInt.int
- val toString: int -> string
- val ~ : int -> int
-(* val orb: int * int -> int
- * val xorb: int * int -> int
- * val andb: int * int -> int
- * val notb: int -> int
- * val << : int * Word.word -> int
- * val ~>> : int * Word.word -> int
- *)
+ val pow: int * Int.int -> int
+ val log2: int -> Int.int
+ val orb: int * int -> int
+ val xorb: int * int -> int
+ val andb: int * int -> int
+ val notb: int -> int
+ val << : int * Word.word -> int
+ val ~>> : int * Word.word -> int
end
signature INT_INF_EXTRA =
1.10 +69 -7 mlton/basis-library/integer/int-inf.sml
Index: int-inf.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/integer/int-inf.sml,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- int-inf.sml 14 Nov 2002 22:27:04 -0000 1.9
+++ int-inf.sml 24 Nov 2002 01:19:35 -0000 1.10
@@ -43,15 +43,9 @@
val one = bigIntConstant 1
val negOne = bigIntConstant ~1
- (*
- * Return the number of `limbs' in a bignum bigInt.
- *)
- fun bigSize (arg: bigInt): smallInt =
- Vector.length (Prim.toVector arg) -? 1
-
(* Check if an IntInf.int is small (i.e., a fixnum). *)
fun isSmall (i: bigInt): bool =
- 0w0 <> Word.andb (0w1, Prim.toWord i)
+ 0w0 <> Word.andb (Prim.toWord i, 0w1)
(* Check if two IntInf.int's are both small (i.e., fixnums).
* This is a gross hack, but uses only one test.
@@ -65,6 +59,8 @@
* where x is size arg. If arg is small, then it is in
* [ - 2^30, 2^30 ).
*)
+ fun bigSize (arg: bigInt): smallInt =
+ Vector.length (Prim.toVector arg) -? 1
fun size (arg: bigInt): smallInt =
if isSmall arg
then 1
@@ -845,6 +841,66 @@
Word.log2 (Vector.sub (v, Int.- (Vector.length v, 1))))
| Small w => Word.log2 w
end
+
+ (*
+ * bigInt bit operations.
+ *)
+ local fun make (wordOp, bigIntOp): bigInt * bigInt -> bigInt =
+ let fun expensive (lhs: bigInt, rhs: bigInt): bigInt =
+ let val tsize = Int.max (size lhs, size rhs)
+ in bigIntOp (lhs, rhs, reserve tsize)
+ end
+ in fn (lhs: bigInt, rhs: bigInt) =>
+ if areSmall (lhs, rhs)
+ then let val ansv = wordOp (stripTag lhs, stripTag rhs)
+ val ans = addTag ansv
+ in Prim.fromWord ans
+ end
+ else expensive (lhs, rhs)
+ end
+ in
+ val bigAndb = make (Word.andb, Prim.andb)
+ val bigOrb = make (Word.orb, Prim.orb)
+ val bigXorb = make (Word.xorb, Prim.xorb)
+ end
+
+ local fun expensive (arg: bigInt): bigInt =
+ let val tsize = size arg
+ in Prim.notb (arg, reserve tsize)
+ end
+ in fun bigNotb (arg: bigInt): bigInt =
+ if isSmall arg
+ then let val ansv = Word.notb (stripTag arg)
+ val ans = addTag ansv
+ in Prim.fromWord ans
+ end
+ else expensive arg
+ end
+
+ local
+ val bitsPerLimb : Word.word = 0w32
+ fun shiftSize shift = Word.toIntX (Word.div (shift, bitsPerLimb))
+ in
+ local fun expensive (arg: bigInt, shift: word): bigInt =
+ let val tsize = Int.max (1, (size arg) -? (shiftSize shift))
+ in Prim.~>> (arg, shift, reserve tsize)
+ end
+ in fun bigArshift (arg: bigInt, shift: word): bigInt =
+ if shift = 0wx0
+ then arg
+ else expensive (arg, shift)
+ end
+
+ local fun expensive (arg: bigInt, shift: word): bigInt =
+ let val tsize = (size arg) +? (shiftSize shift) +? 1
+ in Prim.<< (arg, shift, reserve tsize)
+ end
+ in fun bigLshift (arg: bigInt, shift: word): bigInt =
+ if shift = 0wx0
+ then arg
+ else expensive (arg, shift)
+ end
+ end
type int = bigInt
val abs = bigAbs
@@ -883,6 +939,12 @@
val toLarge = fn x => x
val toString = bigToString
val ~ = bigNegate
+ val andb = bigAndb
+ val notb = bigNotb
+ val orb = bigOrb
+ val xorb = bigXorb
+ val ~>> = bigArshift
+ val << = bigLshift
end
structure LargeInt = IntInf
1.3 +1 -0 mlton/basis-library/integer/int32.sml
Index: int32.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/integer/int32.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- int32.sml 10 Apr 2002 07:02:17 -0000 1.2
+++ int32.sml 24 Nov 2002 01:19:35 -0000 1.3
@@ -176,3 +176,4 @@
structure IntGlobal: INTEGER_GLOBAL = Int
open IntGlobal
structure Position = Int
+structure FixedInt = Int
\ No newline at end of file
1.4 +28 -23 mlton/basis-library/integer/integer.sig
Index: integer.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/integer/integer.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- integer.sig 20 Jul 2002 23:14:01 -0000 1.3
+++ integer.sig 24 Nov 2002 01:19:35 -0000 1.4
@@ -17,37 +17,37 @@
sig
include INTEGER_GLOBAL
- val * : int * int -> int
+ val toLarge: int -> LargeInt.int
+ val fromLarge: LargeInt.int -> int
+ val toInt: int -> Int.int
+ val fromInt: Int.int -> int
+ val precision: Int.int option
+ val minInt: int option
+ val maxInt: int option
val + : int * int -> int
val - : int * int -> int
- val < : int * int -> bool
- val <= : int * int -> bool
- val > : int * int -> bool
- val >= : int * int -> bool
- val abs: int -> int
- val compare: int * int -> order
+ val * : int * int -> int
val div: int * int -> int
- val fmt: StringCvt.radix -> int -> string
- val fromInt: Int.int -> int
- val fromLarge: LargeInt.int -> int
- val fromString: string -> int option
- val max: int * int -> int
- val maxInt: int option
- val min: int * int -> int
- val minInt: int option
val mod: int * int -> int
- val precision: Int.int option
val quot: int * int -> int
val rem: int * int -> int
- val sameSign: int * int -> bool
- val scan: StringCvt.radix
- -> (char, 'a) StringCvt.reader
- -> (int, 'a) StringCvt.reader
+ val compare: int * int -> order
+ val > : int * int -> bool
+ val >= : int * int -> bool
+ val < : int * int -> bool
+ val <= : int * int -> bool
+ val ~ : int -> int
+ val abs: int -> int
+ val min: int * int -> int
+ val max: int * int -> int
val sign: int -> Int.int
- val toInt: int -> Int.int
- val toLarge: int -> LargeInt.int
+ val sameSign: int * int -> bool
+ val fmt: StringCvt.radix -> int -> string
val toString: int -> string
- val ~ : int -> int
+ val scan: StringCvt.radix
+ -> (char, 'a) StringCvt.reader
+ -> (int, 'a) StringCvt.reader
+ val fromString: string -> int option
end
signature INTEGER_EXTRA =
@@ -59,4 +59,9 @@
val maxInt': int
val minInt': int
val power: {base: int, exp: int} -> int
+ end
+
+signature INTEGER32_EXTRA =
+ sig
+ include INTEGER_EXTRA
end
1.5 +1 -1 mlton/basis-library/integer/pack32.sml
Index: pack32.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/integer/pack32.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- pack32.sml 20 Jul 2002 23:14:01 -0000 1.4
+++ pack32.sml 24 Nov 2002 01:19:35 -0000 1.5
@@ -76,7 +76,7 @@
*)
(* Depends on being on a little-endian machine. *)
-structure Pack32Little: PACK_WORD =
+structure Pack32Little: PACK_WORD_EXTRA =
struct
val start = Pack32Big.start
val _ = if Primitive.isLittleEndian
1.4 +32 -30 mlton/basis-library/integer/word.sig
Index: word.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/integer/word.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- word.sig 20 Jul 2002 23:14:01 -0000 1.3
+++ word.sig 24 Nov 2002 01:19:35 -0000 1.4
@@ -1,10 +1,12 @@
-structure Word32 =
+structure Word =
struct
type word = word
end
-structure Word = Word32
-structure LargeWord = Word32
+structure LargeWord =
+ struct
+ type word = word
+ end
signature WORD_GLOBAL =
sig
@@ -15,48 +17,48 @@
sig
include WORD_GLOBAL
- val * : word * word -> word
+ val wordSize: int
+ val toLargeWord: word -> LargeWord.word
+ val toLargeWordX: word -> LargeWord.word
+ val fromLargeWord: LargeWord.word -> word
+ val toInt: word -> Int.int
+ val toIntX: word -> Int.int
+ val fromInt: Int.int -> word
+ val orb: word * word -> word
+ val xorb: word * word -> word
+ val andb: word * word -> word
+ val notb: word -> word
+ val << : word * Word.word -> word
+ val >> : word * Word.word -> word
+ val ~>> : word * Word.word -> word
val + : word * word -> word
val - : word * word -> word
+ val * : word * word -> word
+ val div: word * word -> word
+ val mod: word * word -> word
+ val ~ : word -> word
+ val compare: word * word -> order
val < : word * word -> bool
- val << : word * Word.word -> word
- val <= : word * word -> bool
val > : word * word -> bool
val >= : word * word -> bool
- val >> : word * Word.word -> word
- val andb: word * word -> word
- val compare: word * word -> order
- val div: word * word -> word
- val fromInt: Int.int -> word
- val fromLargeWord: LargeWord.word -> word
- val max: word * word -> word
+ val <= : word * word -> bool
val min: word * word -> word
- val mod: word * word -> word
- val notb: word -> word
- val orb: word * word -> word
- val toInt: word -> Int.int
- val toIntX: word -> Int.int
- val toLargeWord: word -> LargeWord.word
- val toLargeWordX: word -> LargeWord.word
- val wordSize: int
- val xorb: word * word -> word
- val ~>> : word * Word.word -> word
+ val max: word * word -> word
end
signature WORD =
sig
include PRE_WORD
- val fmt: StringCvt.radix -> word -> string
- val fromLargeInt: LargeInt.int -> word
- val fromString: string -> word option
- val scan:
- StringCvt.radix
- -> (char, 'a) StringCvt.reader
- -> (word, 'a) StringCvt.reader
val toLargeInt: word -> LargeInt.int
val toLargeIntX: word -> LargeInt.int
+ val fromLargeInt: LargeInt.int -> word
+ val fmt: StringCvt.radix -> word -> string
val toString: word -> string
+ val scan: StringCvt.radix
+ -> (char, 'a) StringCvt.reader
+ -> (word, 'a) StringCvt.reader
+ val fromString: string -> word option
end
signature WORD_EXTRA =
1.4 +51 -11 mlton/basis-library/io/bin-io.sig
Index: bin-io.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/io/bin-io.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- bin-io.sig 17 Jun 2002 06:28:56 -0000 1.3
+++ bin-io.sig 24 Nov 2002 01:19:35 -0000 1.4
@@ -1,3 +1,40 @@
+(*
+signature BIN_IO =
+ sig
+ structure StreamIO: BIN_STREAM_IO
+
+ (* IMPERATIVE_IO *)
+ type vector = StreamIO.vector
+ type elem = StreamIO.elem
+ type instream
+ type outstream
+ val input: instream -> vector
+ val input1: instream -> elem option
+ val inputN: instream * int -> vector
+ val inputAll: instream -> vector
+ val canInput: instream * int -> int option
+ val lookahead: instream -> elem option
+ val closeIn: instream -> unit
+ val endOfStream: instream -> bool
+ val output: outstream * vector -> unit
+ val output1: outstream * elem -> unit
+ val flushOut: outstream -> unit
+ val closeOut: outstream -> unit
+ val mkInstream: StreamIO.instream -> instream
+ val getInstream: instream -> StreamIO.instream
+ val setInstream: instream * StreamIO.instream -> unit
+ val mkOutstream: StreamIO.outstream -> outstream
+ val getOutstream: outstream -> StreamIO.outstream
+ val setOutstream: outstream * StreamIO.outstream -> unit
+ val getPosOut: outstream -> StreamIO.out_pos
+ val setPosOut: outstream * StreamIO.out_pos -> unit
+
+ val openIn: string -> instream
+ val openOut: string -> outstream
+ val openAppend: string -> outstream
+ end
+*)
+
signature BIN_IO =
sig
structure StreamIO: BIN_STREAM_IO
@@ -17,15 +54,17 @@
val lookahead: instream -> elem option
val mkInstream: StreamIO.instream -> instream
val openIn: string -> instream
- (*
+(*
val scanStream:
((Char.char, StreamIO.instream) StringCvt.reader
-> ('a, StreamIO.instream) StringCvt.reader)
- -> instream -> 'a option *)
+ -> instream -> 'a option
+*)
val setInstream: (instream * StreamIO.instream) -> unit
-(* val getPosIn: instream -> StreamIO.in_pos
- * val setPosIn: (instream * StreamIO.in_pos) -> unit
- *)
+(*
+ val getPosIn: instream -> StreamIO.in_pos
+ val setPosIn: (instream * StreamIO.in_pos) -> unit
+*)
type outstream
val closeOut: outstream -> unit
@@ -38,22 +77,23 @@
val output1: outstream * elem -> unit
val output: outstream * vector -> unit
val setOutstream: outstream * StreamIO.outstream -> unit
-(* val setPosOut: outstream * StreamIO.out_pos -> unit *)
+(*
+ val setPosOut: outstream * StreamIO.out_pos -> unit
+*)
end
signature BIN_IO_EXTRA =
sig
include BIN_IO
-(* val equalsIn: instream * instream -> bool *)
-(* val equalsOut: outstream * outstream -> bool *)
- val inFd: instream -> Posix.IO.file_desc
+ val equalsIn: instream * instream -> bool
+ val equalsOut: outstream * outstream -> bool
val newIn: Posix.IO.file_desc -> instream
val newOut: Posix.IO.file_desc -> outstream
+ val inFd: instream -> Posix.IO.file_desc
val outFd: outstream -> Posix.IO.file_desc
-(* val setIn: instream * instream -> unit *)
+
val stdIn: instream
val stdErr: outstream
val stdOut: outstream
end
-
1.5 +35 -1 mlton/basis-library/io/bin-io.sml
Index: bin-io.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/io/bin-io.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- bin-io.sml 17 Jun 2002 06:28:56 -0000 1.4
+++ bin-io.sml 24 Nov 2002 01:19:36 -0000 1.5
@@ -1,3 +1,38 @@
+(*
+structure BinIO: BIN_IO_EXTRA =
+ struct
+ structure S = struct
+ structure PrimIO = BinPrimIO
+ structure Array = Word8Array
+ structure Vector = Word8Vector
+ val someElem = (0wx0: Word8.word)
+ val lineElem = (0wx0: Word8.word)
+ fun isLine _ = false
+ fun hasLine _ = false
+ structure Cleaner = Cleaner
+ end
+ structure StreamIO = StreamIOExtraFile(open S)
+ structure SIO = StreamIO
+ structure S = struct
+ open S
+ structure StreamIO = StreamIO
+ end
+ structure BufferI = BufferIExtraFile(open S)
+ structure BI = BufferI
+ structure S = struct
+ open S
+ structure BufferI = BufferI
+ val chunkSize = Primitive.TextIO.bufSize
+ val fileTypeFlags = [PosixPrimitive.FileSys.O.binary]
+ val mkReader = Posix.IO.mkBinReader
+ val mkWriter = Posix.IO.mkBinWriter
+ end
+ structure ImperativeIO = ImperativeIOExtraFile(open S)
+ structure FastImperativeIO = FastImperativeIOExtraFile(open S)
+ open FastImperativeIO
+ end
+*)
+
structure BinIO: BIN_IO_EXTRA =
BinOrTextIO
(val fileTypeFlags = [PosixPrimitive.FileSys.O.binary]
@@ -23,4 +58,3 @@
end
structure Primitive = Primitive
structure String = String)
-
1.3 +10 -8 mlton/basis-library/io/bin-or-text-io.fun
Index: bin-or-text-io.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/io/bin-or-text-io.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- bin-or-text-io.fun 17 Jun 2002 06:28:56 -0000 1.2
+++ bin-or-text-io.fun 24 Nov 2002 01:19:36 -0000 1.3
@@ -117,6 +117,8 @@
bufStyle: bufStyle}
type outstream = outstream' ref
+fun equalsOut (os1, os2) = os1 = os2
+
fun outFd (ref (Out {fd, ...})) = fd
val mkOutstream = ref
@@ -240,8 +242,7 @@
if newSize >= Array.length array orelse maybe ()
then (flush (fd, b); put ())
else
- (Array.copyVec {src = v, si = 0, len = NONE,
- dst = array, di = curSize}
+ (Array.copyVec {src = v, dst = array, di = curSize}
; size := newSize)
end
in
@@ -435,8 +436,9 @@
let
val dst = Primitive.Array.array bytesToRead
val _ =
- (Array.copy {src = buf, si = !first,
- len = SOME size, dst = dst, di = 0}
+ (ArraySlice.copy
+ {src = ArraySlice.slice (buf, !first, SOME size),
+ dst = dst, di = 0}
; first := !last)
fun loop (bytesRead: int): int =
if bytesRead = bytesToRead
@@ -651,7 +653,7 @@
else NONE
end
- fun inputAll' (s: t): vector * t =
+ fun inputAll (s: t): vector * t =
let
fun loop (s, ac) =
let val (v, s) = input s
@@ -661,8 +663,6 @@
end
in loop (s, [])
end
-
- val inputAll = #1 o inputAll'
end
datatype t' =
@@ -671,6 +671,8 @@
datatype t = T of t' ref
type instream = t
+fun equalsIn (T is1, T is2) = is1 = is2
+
fun inFd (T r) =
case !r of
Buf b => Buf.fd b
@@ -729,7 +731,7 @@
fun inputAll (T r) =
case !r of
Buf b => Buf.inputAll b
- | Stream s => let val (res, s) = StreamIO.inputAll' s
+ | Stream s => let val (res, s) = StreamIO.inputAll s
in r := Stream s; res
end
1.2 +44 -2 mlton/basis-library/io/bin-stream-io.sig
Index: bin-stream-io.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/io/bin-stream-io.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- bin-stream-io.sig 29 Mar 2002 00:08:31 -0000 1.1
+++ bin-stream-io.sig 24 Nov 2002 01:19:36 -0000 1.2
@@ -1,6 +1,48 @@
+(*
signature BIN_STREAM_IO =
sig
include STREAM_IO
- where type vector = Word8Vector.vector
- where type elem = Word8Vector.elem
+ where type vector = Word8Vector.vector
+ where type elem = Word8Vector.elem
+ end
+*)
+
+signature BIN_STREAM_IO =
+ sig
+ (* STREAM_IO *)
+ type elem = Word8Vector.elem
+ type vector = Word8Vector.vector
+(*
+ type reader
+ type writer
+*)
+
+ type instream
+ type outstream
+
+ type out_pos
+ type pos = int
+
+ val canInput: instream * int -> int option
+ val closeIn: instream -> unit
+ val endOfStream: instream -> bool
+ val filePosOut: out_pos -> pos
+ val input1: instream -> (elem * instream) option
+ val input: instream -> vector * instream
+ val inputAll: instream -> vector * instream
+ val inputN: instream * int -> vector * instream
+(*
+ val mkInstream: reader * vector -> instream (* need to update this *)
+ val getReader: instream -> reader * vector
+ val output: outstream * vector -> unit
+ val output1: outstream * elem -> unit
+ val flushOut: outstream -> unit
+ val closeOut: outstream -> unit
+ val setBufferMode: outstream * IO.buffer_mode -> unit
+ val getBufferMode: outstream -> IO.buffer_mode
+ val mkOutstream: writer * IO.buffer_mode -> outstream
+ val getWriter: outstream -> writer * IO.buffer_mode
+ val getPosOut: outstream -> out_pos
+ val setPosOut: out_pos -> outstream
+*)
end
1.2 +3 -4 mlton/basis-library/io/io.sig
Index: io.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/io/io.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- io.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ io.sig 24 Nov 2002 01:19:36 -0000 1.2
@@ -1,12 +1,11 @@
signature IO =
sig
- exception Io of {cause: exn,
- function: string,
- name: string}
+ exception Io of {name : string,
+ function : string,
+ cause : exn}
exception BlockingNotSupported
exception NonblockingNotSupported
exception RandomAccessNotSupported
- exception TerminatedStream
exception ClosedStream
datatype buffer_mode = NO_BUF | LINE_BUF | BLOCK_BUF
end
1.3 +59 -25 mlton/basis-library/io/stream-io.sig
Index: stream-io.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/io/stream-io.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- stream-io.sig 3 Feb 2002 18:57:17 -0000 1.2
+++ stream-io.sig 24 Nov 2002 01:19:36 -0000 1.3
@@ -2,35 +2,69 @@
sig
type elem
type vector
-(* type reader
- * type writer
- *)
-
type instream
type outstream
-
type out_pos
- type pos = int
-
+ type reader
+ type writer
+ type pos
+ val input: instream -> vector * instream
+ val input1: instream -> (elem * instream) option
+ val inputN: instream * int -> vector * instream
+ val inputAll: instream -> vector * instream
val canInput: instream * int -> int option
val closeIn: instream -> unit
- val endOfStream: instream -> bool
+ val endOfStream: instream -> bool
+ val output: outstream * vector -> unit
+ val output1: outstream * elem -> unit
+ val flushOut: outstream -> unit
+ val closeOut: outstream -> unit
+ val mkInstream: reader * vector -> instream
+ val getReader: instream -> reader * vector
+ val filePosIn: instream -> pos
+ val setBufferMode: outstream * IO.buffer_mode -> unit
+ val getBufferMode: outstream -> IO.buffer_mode
+ val mkOutstream: writer * IO.buffer_mode -> outstream
+ val getWriter: outstream -> writer * IO.buffer_mode
+ val getPosOut: outstream -> out_pos
+ val setPosOut: out_pos -> outstream
val filePosOut: out_pos -> pos
- val input1: instream -> (elem * instream) option
- val input: instream -> vector * instream
- val inputAll: instream -> vector
- val inputN: instream * int -> vector * instream
-(* val mkInstream: reader * vector -> instream (* need to update this *)
- * val getReader: instream -> reader * vector
- * val output: outstream * vector -> unit
- * val output1: outstream * elem -> unit
- * val flushOut: outstream -> unit
- * val closeOut: outstream -> unit
- * val setBufferMode: outstream * IO.buffer_mode -> unit
- * val getBufferMode: outstream -> IO.buffer_mode
- * val mkOutstream: writer * IO.buffer_mode -> outstream
- * val getWriter: outstream -> writer * IO.buffer_mode
- * val getPosOut: outstream -> out_pos
- * val setPosOut: out_pos -> outstream
- *)
end
+
+signature STREAM_IO_EXTRA =
+ sig
+ include STREAM_IO
+
+ val equalsIn: instream * instream -> bool
+ val instreamReader: instream -> reader
+ val mkInstream': {reader: reader,
+ closed: bool,
+ buffer_contents: vector option} -> instream
+
+ val equalsOut: outstream * outstream -> bool
+ val outstreamWriter: outstream -> writer
+ val mkOutstream': {writer: writer,
+ closed: bool,
+ buffer_mode: IO.buffer_mode} -> outstream
+
+ val openVector: vector -> instream
+ val inputLine: instream -> (vector * instream)
+ val outputSlice: outstream * (vector * int * int option) -> unit
+ end
+
+signature STREAM_IO_EXTRA_FILE =
+ sig
+ include STREAM_IO_EXTRA
+
+ val mkInstream'': {reader: reader,
+ closed: bool,
+ buffer_contents: vector option,
+ atExit: {close: bool}} -> instream
+ val mkOutstream'': {writer: writer,
+ closed: bool,
+ buffer_mode: IO.buffer_mode,
+ atExit: {close: bool}} -> outstream
+
+ val inFd: instream -> Posix.IO.file_desc
+ val outFd: outstream -> Posix.IO.file_desc
+ end
1.3 +61 -9 mlton/basis-library/io/text-io.sig
Index: text-io.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/io/text-io.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- text-io.sig 3 Feb 2002 18:57:17 -0000 1.2
+++ text-io.sig 24 Nov 2002 01:19:36 -0000 1.3
@@ -3,6 +3,57 @@
val print: string -> unit
end
+(*
+signature TEXT_IO =
+ sig
+ include TEXT_IO_GLOBAL
+
+ structure StreamIO : TEXT_STREAM_IO
+ where type reader = TextPrimIO.reader
+ where type writer = TextPrimIO.writer
+ where type pos = TextPrimIO.pos
+
+ (* IMPERATIVE_IO *)
+ type vector = StreamIO.vector
+ type elem = StreamIO.elem
+ type instream
+ type outstream
+ val input: instream -> vector
+ val input1: instream -> elem option
+ val inputN: instream * int -> vector
+ val inputAll: instream -> vector
+ val canInput: instream * int -> int option
+ val lookahead: instream -> elem option
+ val closeIn: instream -> unit
+ val endOfStream: instream -> bool
+ val output: outstream * vector -> unit
+ val output1: outstream * elem -> unit
+ val flushOut: outstream -> unit
+ val closeOut: outstream -> unit
+ val mkInstream: StreamIO.instream -> instream
+ val getInstream: instream -> StreamIO.instream
+ val setInstream: instream * StreamIO.instream -> unit
+ val mkOutstream: StreamIO.outstream -> outstream
+ val getOutstream: outstream -> StreamIO.outstream
+ val setOutstream: outstream * StreamIO.outstream -> unit
+ val getPosOut: outstream -> StreamIO.out_pos
+ val setPosOut: outstream * StreamIO.out_pos -> unit
+
+ val inputLine: instream -> string
+ val outputSubstr: outstream * substring -> unit
+ val openIn: string -> instream
+ val openOut: string -> outstream
+ val openAppend: string -> outstream
+ val openString: string -> instream
+ val stdIn: instream
+ val stdOut: outstream
+ val stdErr: outstream
+ val scanStream: ((Char.char, StreamIO.instream) StringCvt.reader ->
+ ('a, StreamIO.instream) StringCvt.reader) ->
+ instream -> 'a option
+ end
+*)
+
signature TEXT_IO =
sig
include TEXT_IO_GLOBAL
@@ -31,10 +82,11 @@
-> instream -> 'a option
val setInstream: (instream * StreamIO.instream) -> unit
val stdIn: instream
-(* val openString: string -> instream
- * val getPosIn: instream -> StreamIO.in_pos
- * val setPosIn: (instream * StreamIO.in_pos) -> unit
- *)
+(*
+ val openString: string -> instream
+ val getPosIn: instream -> StreamIO.in_pos
+ val setPosIn: (instream * StreamIO.in_pos) -> unit
+*)
type outstream
val closeOut: outstream -> unit
@@ -50,19 +102,19 @@
val setOutstream: outstream * StreamIO.outstream -> unit
val stdErr: outstream
val stdOut: outstream
-(* val setPosOut: outstream * StreamIO.out_pos -> unit *)
+(*
+ val setPosOut: outstream * StreamIO.out_pos -> unit
+*)
end
signature TEXT_IO_EXTRA =
sig
include TEXT_IO
-(* val equalsIn: instream * instream -> bool *)
-(* val equalsOut: outstream * outstream -> bool *)
+ val equalsIn: instream * instream -> bool
+ val equalsOut: outstream * outstream -> bool
val inFd: instream -> Posix.IO.file_desc
val newIn: Posix.IO.file_desc -> instream
val newOut: Posix.IO.file_desc -> outstream
val outFd: outstream -> Posix.IO.file_desc
-(* val setIn: instream * instream -> unit *)
end
-
1.10 +54 -7 mlton/basis-library/io/text-io.sml
Index: text-io.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/io/text-io.sml,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- text-io.sml 17 Jun 2002 06:28:56 -0000 1.9
+++ text-io.sml 24 Nov 2002 01:19:36 -0000 1.10
@@ -1,10 +1,57 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- * Copyright (C) 1997-1999 NEC Research Institute.
- *
- * MLton is released under the GNU General Public License (GPL).
- * Please see the file MLton-LICENSE for license information.
- *)
+(*
+structure TextIO: TEXT_IO_EXTRA =
+ struct
+ structure S = struct
+ structure PrimIO = TextPrimIO
+ structure Array = CharArray
+ structure Vector = CharVector
+ val someElem = (#"\000": Char.char)
+ val lineElem = (#"\n": Char.char)
+ fun isLine c = c = lineElem
+ val hasLine = CharVector.exists isLine
+ structure Cleaner = Cleaner
+ end
+ structure StreamIO = StreamIOExtraFile(open S)
+ structure SIO = StreamIO
+ structure S = struct
+ open S
+ structure StreamIO = StreamIO
+ end
+ structure BufferI = BufferIExtraFile(open S)
+ structure BI = BufferI
+ structure S = struct
+ open S
+ structure BufferI = BufferI
+ val chunkSize = Primitive.TextIO.bufSize
+ val fileTypeFlags = [PosixPrimitive.FileSys.O.text]
+ val mkReader = Posix.IO.mkTextReader
+ val mkWriter = Posix.IO.mkTextWriter
+ end
+ structure ImperativeIO = ImperativeIOExtraFile(open S)
+ structure FastImperativeIO = FastImperativeIOExtraFile(open S)
+ open FastImperativeIO
+
+ structure StreamIO =
+ struct
+ open SIO
+ val outputSubstr = fn (os, ss) =>
+ let
+ val (s, i, sz) = Substring.base ss
+ in
+ outputSlice (os, (s, i, SOME sz))
+ end
+ end
+
+ val outputSubstr = fn (os, ss) =>
+ let
+ val (s, i, sz) = Substring.base ss
+ in
+ outputSlice (os, (s, i, SOME sz))
+ end
+ val openString = openVector
+ fun print (s: string) = (output (stdOut, s); flushOut stdOut)
+ end
+*)
structure TextIO : TEXT_IO_EXTRA =
struct
1.2 +50 -4 mlton/basis-library/io/text-stream-io.sig
Index: text-stream-io.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/io/text-stream-io.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- text-stream-io.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ text-stream-io.sig 24 Nov 2002 01:19:36 -0000 1.2
@@ -1,10 +1,56 @@
+(*
signature TEXT_STREAM_IO =
sig
include STREAM_IO
- where type vector = CharVector.vector
- where type elem = Char.char
+ where type vector = CharVector.vector
+ where type elem = Char.char
val inputLine: instream -> string * instream
-(* val outputSubstr: outstream * substring -> unit
- *)
+ val outputSubstr: outstream * substring -> unit
+ end
+*)
+
+signature TEXT_STREAM_IO =
+ sig
+ (* STREAM_IO *)
+ type elem = Char.char
+ type vector = CharVector.vector
+(*
+ type reader
+ type writer
+*)
+
+ type instream
+ type outstream
+
+ type out_pos
+ type pos (* = int *)
+
+ val canInput: instream * int -> int option
+ val closeIn: instream -> unit
+ val endOfStream: instream -> bool
+ val filePosOut: out_pos -> pos
+ val input1: instream -> (elem * instream) option
+ val input: instream -> vector * instream
+ val inputAll: instream -> vector * instream
+ val inputN: instream * int -> vector * instream
+(*
+ val mkInstream: reader * vector -> instream (* need to update this *)
+ val getReader: instream -> reader * vector
+ val output: outstream * vector -> unit
+ val output1: outstream * elem -> unit
+ val flushOut: outstream -> unit
+ val closeOut: outstream -> unit
+ val setBufferMode: outstream * IO.buffer_mode -> unit
+ val getBufferMode: outstream -> IO.buffer_mode
+ val mkOutstream: writer * IO.buffer_mode -> outstream
+ val getWriter: outstream -> writer * IO.buffer_mode
+ val getPosOut: outstream -> out_pos
+ val setPosOut: out_pos -> outstream
+*)
+
+ val inputLine: instream -> string * instream
+(*
+ val outputSubstr: outstream * substring -> unit
+*)
end
1.2 +11 -0 mlton/basis-library/io/bin-prim-io.sml
1.2 +580 -0 mlton/basis-library/io/buffer-i.fun
1.2 +55 -0 mlton/basis-library/io/buffer-i.sig
1.2 +282 -0 mlton/basis-library/io/fast-imperative-io.fun
1.2 +41 -0 mlton/basis-library/io/fast-imperative-io.sig
1.2 +250 -0 mlton/basis-library/io/imperative-io.fun
1.2 +61 -0 mlton/basis-library/io/imperative-io.sig
1.2 +353 -0 mlton/basis-library/io/prim-io.fun
1.2 +59 -0 mlton/basis-library/io/prim-io.sig
1.2 +762 -0 mlton/basis-library/io/stream-io.fun
1.2 +10 -0 mlton/basis-library/io/text-prim-io.sml
1.2 +272 -0 mlton/basis-library/libs/build
1.2 +5 -0 mlton/basis-library/libs/basis-1997/bind
1.2 +0 -0 mlton/basis-library/libs/basis-1997/prefix
<<Binary file>>
1.2 +1 -0 mlton/basis-library/libs/basis-1997/suffix
1.2 +26 -0 mlton/basis-library/libs/basis-1997/arrays-and-vectors/array.sig
1.2 +26 -0 mlton/basis-library/libs/basis-1997/arrays-and-vectors/mono-array.sig
1.2 +27 -0 mlton/basis-library/libs/basis-1997/arrays-and-vectors/mono-array2.sig
1.2 +60 -0 mlton/basis-library/libs/basis-1997/arrays-and-vectors/mono-vector-array-array2-convert.fun
1.2 +20 -0 mlton/basis-library/libs/basis-1997/arrays-and-vectors/mono-vector.sig
1.2 +45 -0 mlton/basis-library/libs/basis-1997/arrays-and-vectors/vector-array-convert.fun
1.2 +19 -0 mlton/basis-library/libs/basis-1997/arrays-and-vectors/vector.sig
1.2 +12 -0 mlton/basis-library/libs/basis-1997/io/bin-io-convert.fun
1.2 +46 -0 mlton/basis-library/libs/basis-1997/io/bin-io.sig
1.2 +6 -0 mlton/basis-library/libs/basis-1997/io/bin-stream-io.sig
1.2 +7 -0 mlton/basis-library/libs/basis-1997/io/io-convert.fun
1.2 +12 -0 mlton/basis-library/libs/basis-1997/io/io.sig
1.2 +38 -0 mlton/basis-library/libs/basis-1997/io/stream-io.sig
1.2 +12 -0 mlton/basis-library/libs/basis-1997/io/text-io-convert.fun
1.2 +51 -0 mlton/basis-library/libs/basis-1997/io/text-io.sig
1.2 +11 -0 mlton/basis-library/libs/basis-1997/io/text-stream-io.sig
1.2 +22 -0 mlton/basis-library/libs/basis-1997/posix/file-sys-convert.fun
1.2 +124 -0 mlton/basis-library/libs/basis-1997/posix/file-sys.sig
1.2 +7 -0 mlton/basis-library/libs/basis-1997/posix/flags-convert.fun
1.2 +10 -0 mlton/basis-library/libs/basis-1997/posix/flags.sig
1.2 +19 -0 mlton/basis-library/libs/basis-1997/posix/io-convert.fun
1.2 +75 -0 mlton/basis-library/libs/basis-1997/posix/io.sig
1.2 +10 -0 mlton/basis-library/libs/basis-1997/posix/posix-convert.fun
1.2 +11 -0 mlton/basis-library/libs/basis-1997/posix/posix.sig
1.2 +12 -0 mlton/basis-library/libs/basis-1997/posix/process-convert.fun
1.2 +45 -0 mlton/basis-library/libs/basis-1997/posix/process.sig
1.2 +31 -0 mlton/basis-library/libs/basis-1997/posix/tty-convert.fun
1.2 +165 -0 mlton/basis-library/libs/basis-1997/posix/tty.sig
1.2 +48 -0 mlton/basis-library/libs/basis-1997/real/IEEE-real-convert.fun
1.2 +23 -0 mlton/basis-library/libs/basis-1997/real/IEEE-real.sig
1.2 +10 -0 mlton/basis-library/libs/basis-1997/real/real-convert.fun
1.2 +68 -0 mlton/basis-library/libs/basis-1997/real/real.sig
1.2 +10 -0 mlton/basis-library/libs/basis-1997/system/file-sys-convert.fun
1.2 +37 -0 mlton/basis-library/libs/basis-1997/system/file-sys.sig
1.2 +8 -0 mlton/basis-library/libs/basis-1997/system/os-convert.fun
1.2 +15 -0 mlton/basis-library/libs/basis-1997/system/os.sig
1.2 +6 -0 mlton/basis-library/libs/basis-1997/system/process-convert.fun
1.2 +16 -0 mlton/basis-library/libs/basis-1997/system/process.sig
1.2 +14 -0 mlton/basis-library/libs/basis-1997/system/timer-convert.fun
1.2 +11 -0 mlton/basis-library/libs/basis-1997/system/timer.sig
1.2 +7 -0 mlton/basis-library/libs/basis-1997/system/unix-convert.fun
1.2 +11 -0 mlton/basis-library/libs/basis-1997/system/unix.sig
1.2 +30 -0 mlton/basis-library/libs/basis-1997/text/string.sig
1.2 +39 -0 mlton/basis-library/libs/basis-1997/text/substring.sig
1.2 +28 -0 mlton/basis-library/libs/basis-1997/text/text-convert.fun
1.2 +8 -0 mlton/basis-library/libs/basis-1997/top-level/basis-funs.sml
1.2 +62 -0 mlton/basis-library/libs/basis-1997/top-level/basis-sigs.sml
1.2 +195 -0 mlton/basis-library/libs/basis-1997/top-level/basis.sig
1.2 +95 -0 mlton/basis-library/libs/basis-1997/top-level/basis.sml
1.2 +13 -0 mlton/basis-library/libs/basis-1997/top-level/infixes.sml
1.2 +103 -0 mlton/basis-library/libs/basis-1997/top-level/overloads.sml
1.2 +13 -0 mlton/basis-library/libs/basis-1997/top-level/top-level.sml
1.2 +5 -0 mlton/basis-library/libs/basis-2002/bind
1.2 +0 -0 mlton/basis-library/libs/basis-2002/prefix
<<Binary file>>
1.2 +1 -0 mlton/basis-library/libs/basis-2002/suffix
1.2 +6 -0 mlton/basis-library/libs/basis-2002/top-level/basis-funs.sml
1.2 +76 -0 mlton/basis-library/libs/basis-2002/top-level/basis-sigs.sml
1.2 +413 -0 mlton/basis-library/libs/basis-2002/top-level/basis.sig
1.2 +149 -0 mlton/basis-library/libs/basis-2002/top-level/basis.sml
1.2 +13 -0 mlton/basis-library/libs/basis-2002/top-level/infixes.sml
1.2 +104 -0 mlton/basis-library/libs/basis-2002/top-level/overloads.sml
1.2 +23 -0 mlton/basis-library/libs/basis-2002/top-level/top-level.sml
1.2 +5 -0 mlton/basis-library/libs/basis-2002-strict/bind
1.2 +0 -0 mlton/basis-library/libs/basis-2002-strict/prefix
<<Binary file>>
1.2 +1 -0 mlton/basis-library/libs/basis-2002-strict/suffix
1.2 +10 -0 mlton/basis-library/libs/basis-2002-strict/top-level/top-level.sml
1.2 +1 -0 mlton/basis-library/libs/none/bind
1.2 +0 -0 mlton/basis-library/libs/none/prefix
<<Binary file>>
1.2 +0 -0 mlton/basis-library/libs/none/suffix
<<Binary file>>
1.1 mlton/basis-library/libs/none/top-level/infixes.sml
Index: infixes.sml
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
infix 4 =
1.4 +12 -5 mlton/basis-library/list/list-pair.sig
Index: list-pair.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/list/list-pair.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- list-pair.sig 20 Jul 2002 23:14:01 -0000 1.3
+++ list-pair.sig 24 Nov 2002 01:19:39 -0000 1.4
@@ -1,11 +1,18 @@
signature LIST_PAIR =
sig
- val all: ('a * 'b -> bool) -> 'a list * 'b list -> bool
+ exception UnequalLengths
+ val zip: 'a list * 'b list -> ('a * 'b) list
+ val zipEq: 'a list * 'b list -> ('a * 'b) list
+ val unzip: ('a * 'b) list -> 'a list * 'b list
val app: ('a * 'b -> unit) -> 'a list * 'b list -> unit
- val exists: ('a * 'b -> bool) -> 'a list * 'b list -> bool
+ val appEq: ('a * 'b -> unit) -> 'a list * 'b list -> unit
+ val map: ('a * 'b -> 'c) -> 'a list * 'b list -> 'c list
+ val mapEq: ('a * 'b -> 'c) -> 'a list * 'b list -> 'c list
val foldl: ('a * 'b * 'c -> 'c) -> 'c -> 'a list * 'b list -> 'c
val foldr: ('a * 'b * 'c -> 'c) -> 'c -> 'a list * 'b list -> 'c
- val map: ('a * 'b -> 'c) -> 'a list * 'b list -> 'c list
- val unzip: ('a * 'b) list -> 'a list * 'b list
- val zip: 'a list * 'b list -> ('a * 'b) list
+ val foldlEq: ('a * 'b * 'c -> 'c) -> 'c -> 'a list * 'b list -> 'c
+ val foldrEq: ('a * 'b * 'c -> 'c) -> 'c -> 'a list * 'b list -> 'c
+ val all: ('a * 'b -> bool) -> 'a list * 'b list -> bool
+ val exists: ('a * 'b -> bool) -> 'a list * 'b list -> bool
+ val allEq: ('a * 'b -> bool) -> 'a list * 'b list -> bool
end
1.5 +32 -8 mlton/basis-library/list/list-pair.sml
Index: list-pair.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/list/list-pair.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- list-pair.sml 20 Jul 2002 23:14:01 -0000 1.4
+++ list-pair.sml 24 Nov 2002 01:19:39 -0000 1.5
@@ -7,32 +7,46 @@
*)
structure ListPair: LIST_PAIR =
struct
+ exception UnequalLengths
+ fun id x = x
+ fun ul _ = raise UnequalLengths
+
fun unzip l =
List.foldr (fn ((x, y), (xs, ys)) => (x :: xs, y :: ys)) ([], []) l
- fun foldl f b (l1, l2) =
+ fun foldl' w f b (l1, l2) =
let
fun loop(l1, l2, b) =
case (l1, l2) of
(x1 :: l1, x2 :: l2) => loop(l1, l2, f(x1, x2, b))
- | _ => b
+ | _ => w b
in loop(l1, l2, b)
end
+ fun foldl f = foldl' id f
+ fun foldlEq f = foldl' ul f
- fun foldr f b (l1, l2) =
+ fun foldr' w f b (l1, l2) =
let
fun loop(l1, l2) =
case (l1, l2) of
(x1 :: l1, x2 :: l2) => f(x1, x2, loop(l1, l2))
- | _ => b
+ | _ => w b
in loop(l1, l2)
end
+ fun foldr f = foldr' id f
+ fun foldrEq f = foldr' ul f
- fun zip(l1, l2) = rev(foldl (fn (x, x', l) => (x, x') :: l) [] (l1, l2))
+ fun zip' w (l1, l2) = rev(foldl' w (fn (x, x', l) => (x, x') :: l) [] (l1, l2))
+ fun zip(l1, l2) = zip' id (l1, l2)
+ fun zipEq(l1, l2) = zip' ul (l1, l2)
- fun map f = rev o (foldl (fn (x1, x2, l) => f(x1, x2) :: l) [])
+ fun map' w f = rev o (foldl' w (fn (x1, x2, l) => f(x1, x2) :: l) [])
+ fun map f = map' id f
+ fun mapEq f = map' ul f
- fun app f = foldl (fn (x1, x2, ()) => f(x1, x2)) ()
+ fun app' w f = foldl' w (fn (x1, x2, ()) => f(x1, x2)) ()
+ fun app f = app' id f
+ fun appEq f = app' ul f
fun exists p (l1, l2) =
let
@@ -42,6 +56,16 @@
| _ => false
in loop(l1, l2)
end
-
+
fun all p ls = not(exists (not o p) ls)
+
+ fun allEq p =
+ let
+ fun loop(l1, l2) =
+ case (l1, l2) of
+ ([], []) => true
+ | (x1 :: l1, x2 :: l2) => p(x1, x2) andalso loop(l1, l2)
+ | _ => false
+ in loop
+ end
end
1.4 +18 -17 mlton/basis-library/list/list.sig
Index: list.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/list/list.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- list.sig 20 Jul 2002 23:14:01 -0000 1.3
+++ list.sig 24 Nov 2002 01:19:39 -0000 1.4
@@ -1,37 +1,38 @@
signature LIST_GLOBAL =
sig
- datatype 'a list = nil | :: of 'a * 'a list
+ datatype list = datatype list
exception Empty
+ val null: 'a list -> bool
+ val length: 'a list -> int
val @ : 'a list * 'a list -> 'a list
+ val hd: 'a list -> 'a
+ val tl: 'a list -> 'a list
+ val rev: 'a list -> 'a list
val app: ('a -> unit) -> 'a list -> unit
+ val map: ('a -> 'b) -> 'a list -> 'b list
val foldl: ('a * 'b -> 'b) -> 'b -> 'a list -> 'b
val foldr: ('a * 'b -> 'b) -> 'b -> 'a list -> 'b
- val hd: 'a list -> 'a
- val length: 'a list -> int
- val map: ('a -> 'b) -> 'a list -> 'b list
- val null: 'a list -> bool
- val rev: 'a list -> 'a list
- val tl: 'a list -> 'a list
end
signature LIST =
sig
include LIST_GLOBAL
- val all: ('a -> bool) -> 'a list -> bool
- val concat: 'a list list -> 'a list
- val drop: 'a list * int -> 'a list
- val exists: ('a -> bool) -> 'a list -> bool
- val filter: ('a -> bool) -> 'a list -> 'a list
- val find: ('a -> bool) -> 'a list -> 'a option
- val getItem: 'a list -> ('a * 'a list) option
val last: 'a list -> 'a
- val mapPartial: ('a -> 'b option) -> 'a list -> 'b list
+ val getItem: 'a list -> ('a * 'a list) option
val nth: 'a list * int -> 'a
- val partition: ('a -> bool) -> 'a list -> 'a list * 'a list
+ val take: 'a list * int -> 'a list
+ val drop: 'a list * int -> 'a list
+ val concat: 'a list list -> 'a list
val revAppend: 'a list * 'a list -> 'a list
+ val mapPartial: ('a -> 'b option) -> 'a list -> 'b list
+ val find: ('a -> bool) -> 'a list -> 'a option
+ val filter: ('a -> bool) -> 'a list -> 'a list
+ val partition: ('a -> bool) -> 'a list -> 'a list * 'a list
+ val exists: ('a -> bool) -> 'a list -> bool
+ val all: ('a -> bool) -> 'a list -> bool
val tabulate: int * (int -> 'a) -> 'a list
- val take: 'a list * int -> 'a list
+ val collate: ('a * 'a -> order) -> 'a list * 'a list -> order
end
1.7 +12 -0 mlton/basis-library/list/list.sml
Index: list.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/list/list.sml,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- list.sml 14 Nov 2002 22:27:04 -0000 1.6
+++ list.sml 24 Nov 2002 01:19:39 -0000 1.7
@@ -152,6 +152,18 @@
then raise Subscript
else loop (l, n)
end
+
+ fun collate cmp =
+ let
+ val rec loop =
+ fn ([], []) => EQUAL
+ | ([], _) => LESS
+ | (_, []) => GREATER
+ | (x1::l1,x2::l2) => (case cmp (x1, x2) of
+ EQUAL => loop (l1, l2)
+ | ans => ans)
+ in loop
+ end
end
structure ListGlobal: LIST_GLOBAL = List
1.4 +21 -1 mlton/basis-library/misc/cleaner.sml
Index: cleaner.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/cleaner.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- cleaner.sml 10 Apr 2002 07:02:17 -0000 1.3
+++ cleaner.sml 24 Nov 2002 01:19:39 -0000 1.4
@@ -28,5 +28,25 @@
val atExit = new ()
val atLoadWorld = new ()
-
+
end
+
+structure EmptyCleaner: CLEANER =
+struct
+
+structure UniqueId = UniqueId()
+structure Id = UniqueId
+
+type t = unit
+
+fun new (): t = ()
+
+fun add _ = ()
+fun addNew _ = ()
+fun remove _ = ()
+fun clean _ = ()
+
+val atExit = new ()
+val atLoadWorld = new ()
+
+end
\ No newline at end of file
1.39 +13 -8 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- primitive.sml 2 Nov 2002 03:37:34 -0000 1.38
+++ primitive.sml 24 Nov 2002 01:19:39 -0000 1.39
@@ -20,17 +20,17 @@
type int = int
type intInf = intInf
datatype list = datatype list
-type nullString = string
type pointer = pointer (* C integer, not SML heap pointer *)
type real = real
datatype ref = datatype ref
-type string = string
type preThread = preThread
type thread = thread
type word = word
type word8 = word8
type word32 = word
type 'a vector = 'a vector
+type string = char vector
+type nullString = string
exception Bind = Bind
exception Fail of string
@@ -255,12 +255,17 @@
type int = intInf
val + = _prim "IntInf_add": int * int * word -> int;
+ val andb = _prim "IntInf_andb": int * int * word -> int;
+ val ~>> = _prim "IntInf_arshift": int * word * word -> int;
val compare = _prim "IntInf_compare": int * int -> Int.int;
val fromVector = _prim "IntInf_fromVector": word vector -> int;
val fromWord = _prim "IntInf_fromWord": word -> int;
val gcd = _prim "IntInf_gcd": int * int * word -> int;
+ val << = _prim "IntInf_lshift": int * word * word -> int;
val * = _prim "IntInf_mul": int * int * word -> int;
val ~ = _prim "IntInf_neg": int * word -> int;
+ val notb = _prim "IntInf_notb": int * word -> int;
+ val orb = _prim "IntInf_orb": int * int * word -> int;
val quot = _prim "IntInf_quot": int * int * word -> int;
val rem = _prim "IntInf_rem": int * int * word -> int;
val smallMul =
@@ -270,6 +275,7 @@
= _prim "IntInf_toString": int * Int.int * word -> string;
val toVector = _prim "IntInf_toVector": int -> word vector;
val toWord = _prim "IntInf_toWord": int -> word;
+ val xorb = _prim "IntInf_xorb": int * int * word -> int;
end
structure Itimer =
@@ -418,6 +424,11 @@
struct
val tmpnam = _ffi "OS_FileSys_tmpnam": unit -> cstring;
end
+ structure IO =
+ struct
+ val poll = _ffi "OS_IO_poll": int vector * word vector *
+ int * int * word array -> int;
+ end
end
structure PackReal =
@@ -562,16 +573,10 @@
structure String =
struct
- val fromCharVector =
- _prim "String_fromCharVector": char vector -> string;
val fromWord8Vector =
_prim "String_fromWord8Vector": word8 vector -> string;
- val size = _prim "String_size": string -> int;
- val toCharVector =
- _prim "String_toCharVector": string -> char vector;
val toWord8Vector =
_prim "String_toWord8Vector": string -> word8 vector;
- val sub = _prim "String_sub": string * int -> char;
end
structure TextIO =
1.4 +9 -5 mlton/basis-library/mlton/exn.sml
Index: exn.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/exn.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- exn.sml 25 Aug 2002 22:23:58 -0000 1.3
+++ exn.sml 24 Nov 2002 01:19:39 -0000 1.4
@@ -19,11 +19,15 @@
; let
fun loop e =
case e of
- Fail s => (message "Fail "; message s)
- | IO.Io {cause, function, ...} => (message "IO "
- ; message function
- ; message ": "
- ; loop cause)
+ Fail s =>
+ (message "Fail "; message s)
+ | IO.Io {name, function, cause, ...} =>
+ (message "IO "
+ ; message function
+ ; message " on "
+ ; message name
+ ; message ": "
+ ; loop cause)
| PosixError.SysErr (s, _) =>
(message "SysErr "; message s)
| _ => message (exnName e)
1.15 +2 -2 mlton/basis-library/mlton/signal.sml
Index: signal.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/signal.sml,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- signal.sml 2 Nov 2002 03:37:34 -0000 1.14
+++ signal.sml 24 Nov 2002 01:19:39 -0000 1.15
@@ -86,7 +86,7 @@
val _ =
Cleaner.addNew
(Cleaner.atLoadWorld, fn () =>
- Array.modifyi (defaultOrIgnore o #1) (handlers, 0, NONE))
+ Array.modifyi (defaultOrIgnore o #1) handlers)
in
(fn s => Array.sub (handlers, s),
fn (s, h) => if Primitive.MLton.ProfileTime.isOn andalso s = prof
@@ -147,7 +147,7 @@
Handler f => if Prim.isPending s then f t else t
| _ => t)
t
- (handlers, 0, NONE))
+ handlers)
in
Handler
end
1.2 +46 -45 mlton/basis-library/posix/error.sig
Index: error.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/error.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- error.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ error.sig 24 Nov 2002 01:19:39 -0000 1.2
@@ -2,56 +2,57 @@
sig
eqtype syserror
- val toWord: syserror -> SysWord.word
- val fromWord: SysWord.word -> syserror
+ val toWord: syserror -> SysWord.word
+ val fromWord: SysWord.word -> syserror
val errorMsg: syserror -> string
- val errorName: syserror -> string
- val syserror: string -> syserror option
+ val errorName: syserror -> string
+ val syserror: string -> syserror option
- val toobig: syserror
- val acces: syserror
- val again: syserror
- val badf: syserror
- val badmsg: syserror
- val busy: syserror
+ val acces: syserror
+ val again: syserror
+ val badf: syserror
+ val badmsg: syserror
+ val busy: syserror
val canceled: syserror
- val child: syserror
- val deadlk: syserror
- val dom: syserror
- val exist: syserror
- val fault: syserror
- val fbig: syserror
- val inprogress: syserror
- val intr: syserror
- val inval: syserror
- val io: syserror
- val isdir: syserror
- val loop: syserror
- val mfile: syserror
- val mlink: syserror
- val msgsize: syserror
- val nametoolong: syserror
- val nfile: syserror
- val nodev: syserror
- val noent: syserror
- val noexec: syserror
- val nolck: syserror
- val nomem: syserror
- val nospc: syserror
- val nosys: syserror
- val notdir: syserror
- val notempty: syserror
- val notsup: syserror
- val notty: syserror
- val nxio: syserror
- val perm: syserror
- val pipe: syserror
- val range: syserror
- val rofs: syserror
- val spipe: syserror
- val srch: syserror
+ val child: syserror
+ val deadlk: syserror
+ val dom: syserror
+ val exist: syserror
+ val fault: syserror
+ val fbig: syserror
+ val inprogress: syserror
+ val intr: syserror
+ val inval: syserror
+ val io: syserror
+ val isdir: syserror
+ val loop: syserror
+ val mfile: syserror
+ val mlink: syserror
+ val msgsize: syserror
+ val nametoolong: syserror
+ val nfile: syserror
+ val nodev: syserror
+ val noent: syserror
+ val noexec: syserror
+ val nolck: syserror
+ val nomem: syserror
+ val nospc: syserror
+ val nosys: syserror
+ val notdir: syserror
+ val notempty: syserror
+ val notsup: syserror
+ val notty: syserror
+ val nxio: syserror
+ val perm: syserror
+ val pipe: syserror
+ val range: syserror
+ val rofs: syserror
+ val spipe: syserror
+ val srch: syserror
+ val toobig: syserror
val xdev: syserror
+
end
signature POSIX_ERROR_EXTRA =
1.3 +2 -17 mlton/basis-library/posix/error.sml
Index: error.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/error.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- error.sml 10 Apr 2002 07:02:17 -0000 1.2
+++ error.sml 24 Nov 2002 01:19:39 -0000 1.3
@@ -12,8 +12,8 @@
exception SysErr of string * syserror option
- val toWord = Word.fromInt
- val fromWord = Word.toInt
+ val toWord = SysWord.fromInt
+ val fromWord = SysWord.toInt
fun errorName n =
case List.find (fn (m, _) => n = m) errorNames of
@@ -33,22 +33,7 @@
end
fun raiseSys n = raise SysErr (errorMsg n, SOME n)
-
- fun restart (f: 'a -> int) (a: 'a): int =
- let
- fun loop () =
- case f a of
- ~1 => let val errno = getErrno ()
- in if errno = intr
- then loop ()
- else raiseSys errno
- end
- | n => n
- in loop ()
- end
-
fun error () = raiseSys (getErrno ())
-
fun checkReturnResult (n: int) = if n = ~1 then error () else n
fun checkResult n = (checkReturnResult n; ())
end
1.2 +100 -104 mlton/basis-library/posix/file-sys.sig
Index: file-sys.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/file-sys.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- file-sys.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ file-sys.sig 24 Nov 2002 01:19:39 -0000 1.2
@@ -1,132 +1,128 @@
-signature POSIX_FILESYS =
+signature POSIX_FILE_SYS =
sig
eqtype uid
eqtype gid
- eqtype file_desc
- val fdToWord: file_desc -> SysWord.word
- val wordToFD: SysWord.word -> file_desc
+ eqtype file_desc
+ val fdToWord: file_desc -> SysWord.word
+ val wordToFD: SysWord.word -> file_desc
(* identity functions *)
- val fdToIOD: file_desc -> file_desc (* OS.IO.iodesc *)
- val iodToFD: file_desc (* OS.IO.iodesc *) -> file_desc option
-
+ val fdToIOD: file_desc -> OS.IO.iodesc
+ val iodToFD: OS.IO.iodesc -> file_desc option
+
type dirstream
val opendir: string -> dirstream
- val readdir: dirstream -> string
+ val readdir: dirstream -> string option
val rewinddir: dirstream -> unit
val closedir: dirstream -> unit
val chdir: string -> unit
val getcwd: unit -> string
-
- val stdin: file_desc
- val stdout: file_desc
+
+ val stdin: file_desc
+ val stdout: file_desc
val stderr: file_desc
-
- structure S:
+
+ structure S:
sig
- type mode
- include POSIX_FLAGS where type flags = mode
+ eqtype mode
+ include BIT_FLAGS where type flags = mode
- val irwxu: mode
- val irusr: mode
- val iwusr: mode
- val ixusr: mode
- val irwxg: mode
- val irgrp: mode
- val iwgrp: mode
- val ixgrp: mode
- val irwxo: mode
- val iroth: mode
- val iwoth: mode
- val ixoth: mode
- val isuid: mode
- val isgid: mode
+ val irwxu: mode
+ val irusr: mode
+ val iwusr: mode
+ val ixusr: mode
+ val irwxg: mode
+ val irgrp: mode
+ val iwgrp: mode
+ val ixgrp: mode
+ val irwxo: mode
+ val iroth: mode
+ val iwoth: mode
+ val ixoth: mode
+ val isuid: mode
+ val isgid: mode
end
- structure O:
+ structure O:
sig
- include POSIX_FLAGS
+ include BIT_FLAGS
- val append: flags
- val excl: flags
- val noctty: flags
- val nonblock: flags
- val sync: flags
- val trunc: flags
+ val append: flags
+ val excl: flags
+ val noctty: flags
+ val nonblock: flags
+ val sync: flags
+ val trunc: flags
end
-
- datatype open_mode = O_RDONLY | O_WRONLY | O_RDWR
- val openf: string * open_mode * O.flags -> file_desc
- val createf: string * open_mode * O.flags * S.mode -> file_desc
- val creat: string * S.mode -> file_desc
- val umask: S.mode -> S.mode
- val link: {old: string, new: string} -> unit
- val mkdir: string * S.mode -> unit
- val mkfifo: string * S.mode -> unit
- val unlink: string -> unit
- val rmdir: string -> unit
- val rename: {old: string, new: string} -> unit
- val symlink: {old: string, new: string} -> unit
- val readlink: string -> string
-
- eqtype dev
- val wordToDev: SysWord.word -> dev
- val devToWord: dev -> SysWord.word
-
- eqtype ino
- val wordToIno: SysWord.word -> ino
- val inoToWord: ino -> SysWord.word
-
- structure ST:
- sig
- type stat
-
- val isDir: stat -> bool
- val isChr: stat -> bool
- val isBlk: stat -> bool
- val isReg: stat -> bool
- val isFIFO: stat -> bool
- val isLink: stat -> bool
- val isSock: stat -> bool
- val mode: stat -> S.mode
- val ino: stat -> ino
- val dev: stat -> dev
- val nlink: stat -> int
- val uid: stat -> uid
- val gid: stat -> gid
- val size: stat -> Position.int
- val atime: stat -> Time.time
- val mtime: stat -> Time.time
- val ctime: stat -> Time.time
- end
-
- val stat: string -> ST.stat
- val lstat: string -> ST.stat
- val fstat: file_desc -> ST.stat
-
- datatype access_mode =
- A_READ
- | A_WRITE
- | A_EXEC
-
- val access: string * access_mode list -> bool
- val chmod: string * S.mode -> unit
- val fchmod: file_desc * S.mode -> unit
- val chown: string * uid * gid -> unit
- val fchown: file_desc * uid * gid -> unit
- val utime: string * {actime: Time.time, modtime: Time.time} option -> unit
- val ftruncate: file_desc * Position.int -> unit
- val pathconf: string * string -> SysWord.word option
- val fpathconf: file_desc * string -> SysWord.word option
- end
+ datatype open_mode = O_RDONLY | O_WRONLY | O_RDWR
+ val openf: string * open_mode * O.flags -> file_desc
+ val createf: string * open_mode * O.flags * S.mode -> file_desc
+ val creat: string * S.mode -> file_desc
+ val umask: S.mode -> S.mode
+ val link: {old: string, new: string} -> unit
+ val mkdir: string * S.mode -> unit
+ val mkfifo: string * S.mode -> unit
+ val unlink: string -> unit
+ val rmdir: string -> unit
+ val rename: {old: string, new: string} -> unit
+ val symlink: {old: string, new: string} -> unit
+ val readlink: string -> string
+
+ eqtype dev
+ val wordToDev: SysWord.word -> dev
+ val devToWord: dev -> SysWord.word
+
+ eqtype ino
+ val wordToIno: SysWord.word -> ino
+ val inoToWord: ino -> SysWord.word
+
+ structure ST:
+ sig
+ type stat
+
+ val isDir: stat -> bool
+ val isChr: stat -> bool
+ val isBlk: stat -> bool
+ val isReg: stat -> bool
+ val isFIFO: stat -> bool
+ val isLink: stat -> bool
+ val isSock: stat -> bool
+ val mode: stat -> S.mode
+ val ino: stat -> ino
+ val dev: stat -> dev
+ val nlink: stat -> int
+ val uid: stat -> uid
+ val gid: stat -> gid
+ val size: stat -> Position.int
+ val atime: stat -> Time.time
+ val mtime: stat -> Time.time
+ val ctime: stat -> Time.time
+ end
+
+ val stat: string -> ST.stat
+ val lstat: string -> ST.stat
+ val fstat: file_desc -> ST.stat
+
+ datatype access_mode = A_READ | A_WRITE | A_EXEC
+
+ val access: string * access_mode list -> bool
+ val chmod: string * S.mode -> unit
+ val fchmod: file_desc * S.mode -> unit
+ val chown: string * uid * gid -> unit
+ val fchown: file_desc * uid * gid -> unit
+ val utime: string * {actime: Time.time, modtime: Time.time} option -> unit
+ val ftruncate: file_desc * Position.int -> unit
+ val pathconf: string * string -> SysWord.word option
+ val fpathconf: file_desc * string -> SysWord.word option
+ end
-signature POSIX_FILESYS_EXTRA =
+signature POSIX_FILE_SYS_EXTRA =
sig
- include POSIX_FILESYS
+ include POSIX_FILE_SYS
val wordToOpenMode: SysWord.word -> open_mode
end
1.4 +19 -16 mlton/basis-library/posix/file-sys.sml
Index: file-sys.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/file-sys.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- file-sys.sml 10 Apr 2002 07:02:17 -0000 1.3
+++ file-sys.sml 24 Nov 2002 01:19:39 -0000 1.4
@@ -5,7 +5,7 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-structure PosixFileSys: POSIX_FILESYS_EXTRA =
+structure PosixFileSys: POSIX_FILE_SYS_EXTRA =
struct
(* Patch to make Time look like it deals with Int.int
* instead of LargeInt.int.
@@ -21,7 +21,7 @@
structure Prim = PosixPrimitive.FileSys
open Prim
structure Stat = Prim.Stat
- structure Flags = PosixFlags
+ structure Flags = BitFlags
val checkResult = Error.checkResult
@@ -66,12 +66,16 @@
val cs = Prim.readdir d
in if Primitive.Cpointer.isNull cs
then if Error.getErrno () = 0
- then ""
+ then NONE
else Error.error ()
- else (case C.CS.toString cs of
- "." => loop ()
- | ".." => loop ()
- | s => s)
+ else
+ let
+ val s = C.CS.toString cs
+ in
+ if s = "." orelse s = ".."
+ then loop ()
+ else SOME s
+ end
end
in loop ()
end
@@ -117,7 +121,7 @@
then (size := 2 * !size
; buffer := make ()
; getcwd ())
- else Primitive.String.fromCharVector (extract (!buffer))
+ else extract (!buffer)
end
val stdin = FD 0
@@ -153,8 +157,8 @@
let
val fd =
Prim.openn (String.nullTerm pathname,
- Flags.flags [openModeToWord openMode, flags, O.creat],
- mode)
+ Flags.flags [openModeToWord openMode, flags, O.creat],
+ mode)
in if fd = ~1
then error ()
else FD fd
@@ -162,8 +166,8 @@
fun openf (pathname, openMode, flags) =
let val fd = Prim.openn (String.nullTerm pathname,
- Flags.flags [openModeToWord openMode, flags],
- Flags.empty)
+ Flags.flags [openModeToWord openMode, flags],
+ Flags.empty)
in if fd = ~1
then error ()
else FD fd
@@ -293,7 +297,7 @@
structure U = Prim.Utimbuf
in
fun utime (f: string, opt: {actime: Time.time,
- modtime: Time.time} option): unit =
+ modtime: Time.time} option): unit =
let
val (a, m) =
case opt of
@@ -315,13 +319,12 @@
NONE => Error.raiseSys Error.inval
| SOME (n, _) => n
+ (* QUESTION: is this o.k.? *)
fun make prim (f, s) =
let val n = prim (f, convertProperty s)
in if n < 0
then Error.error ()
- else if n = 0
- then NONE
- else SOME (SysWord.fromInt n)
+ else SOME (SysWord.fromInt n)
end
in
1.2 +7 -4 mlton/basis-library/posix/flags.sig
Index: flags.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/flags.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- flags.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ flags.sig 24 Nov 2002 01:19:39 -0000 1.2
@@ -1,16 +1,19 @@
-signature POSIX_FLAGS =
+signature BIT_FLAGS =
sig
eqtype flags
val toWord: flags -> SysWord.word
- val wordTo: SysWord.word -> flags
+ val fromWord: SysWord.word -> flags
+ val all: flags
val flags: flags list -> flags
+ val intersect: flags list -> flags
+ val clear: flags * flags -> flags
val allSet: flags * flags -> bool
val anySet: flags * flags -> bool
end
-signature POSIX_FLAGS_EXTRA =
+signature BIT_FLAGS_EXTRA =
sig
- include POSIX_FLAGS
+ include BIT_FLAGS
val empty: flags
end
1.3 +16 -9 mlton/basis-library/posix/flags.sml
Index: flags.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/flags.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- flags.sml 10 Apr 2002 07:02:17 -0000 1.2
+++ flags.sml 24 Nov 2002 01:19:39 -0000 1.3
@@ -5,18 +5,25 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-structure PosixFlags: POSIX_FLAGS_EXTRA =
+functor BitFlags(val all: SysWord.word): BIT_FLAGS_EXTRA =
struct
- type flags = word
+ type flags = SysWord.word
+ val all: flags = all
+ val empty: flags = 0w0
+
fun toWord f = f
- fun wordTo f = f
-
- val flags: flags list -> flags = List.foldl Word.orb 0w0
-
- fun anySet(f, f') = Word.andb(f, f') <> 0w0
+ fun fromWord f = SysWord.andb(f, all)
- fun allSet(f, f') = Word.andb(f, f') = f
+ val flags: flags list -> flags = List.foldl SysWord.orb empty
+
+ val intersect: flags list -> flags = List.foldl SysWord.andb all
+
+ fun clear(f, f') = SysWord.andb(SysWord.notb f, f')
+
+ fun allSet(f, f') = SysWord.andb(f, f') = f
+
+ fun anySet(f, f') = SysWord.andb(f, f') <> 0w0
- val empty: flags = 0w0
end
+structure BitFlags = BitFlags(val all = 0wxFFFF: SysWord.word)
1.2 +22 -10 mlton/basis-library/posix/io.sig
Index: io.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/io.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- io.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ io.sig 24 Nov 2002 01:19:39 -0000 1.2
@@ -23,14 +23,14 @@
structure FD:
sig
- include POSIX_FLAGS
+ include BIT_FLAGS
val cloexec: flags
end
structure O:
sig
- include POSIX_FLAGS
+ include BIT_FLAGS
val append: flags
val nonblock: flags
@@ -47,21 +47,16 @@
val lseek: file_desc * Position.int * whence -> Position.int
val fsync: file_desc -> unit
- datatype lock_type =
- F_RDLCK
- | F_WRLCK
- | F_UNLCK
+ datatype lock_type = F_RDLCK | F_WRLCK | F_UNLCK
structure FLock:
sig
type flock
- val flock: {
- ltype: lock_type,
+ val flock: {ltype: lock_type,
whence: whence,
start: Position.int,
len: Position.int,
- pid: pid option
- } -> flock
+ pid: pid option} -> flock
val ltype: flock -> lock_type
val whence: flock -> whence
val start: flock -> Position.int
@@ -72,4 +67,21 @@
val getlk: file_desc * FLock.flock -> FLock.flock
val setlk: file_desc * FLock.flock -> FLock.flock
val setlkw: file_desc * FLock.flock -> FLock.flock
+
+ val mkBinReader: {fd: file_desc,
+ name: string,
+ initBlkMode: bool} -> BinPrimIO.reader
+ val mkTextReader: {fd: file_desc,
+ name: string,
+ initBlkMode: bool} -> TextPrimIO.reader
+ val mkBinWriter: {fd: file_desc,
+ name: string,
+ appendMode: bool,
+ initBlkMode: bool,
+ chunkSize: int} -> BinPrimIO.writer
+ val mkTextWriter: {fd: file_desc,
+ name: string,
+ appendMode: bool,
+ initBlkMode: bool,
+ chunkSize: int} -> TextPrimIO.writer
end
1.4 +196 -27 mlton/basis-library/posix/io.sml
Index: io.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/io.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- io.sml 10 Apr 2002 07:02:17 -0000 1.3
+++ io.sml 24 Nov 2002 01:19:39 -0000 1.4
@@ -33,36 +33,48 @@
fun close (FD fd) = checkResult (Prim.close fd)
- fun readArr (FD fd, {buf, i, sz}): int =
- let
- val max = Array.checkSlice (buf, i, sz)
- in
- checkReturnResult (Prim.read (fd, buf, i, max -? i))
- end
-
- fun readVec (fd, n): Word8Vector.vector =
- let
- val a = Primitive.Array.array n
- val bytesRead = readArr (fd, {buf = a, i = 0, sz = SOME n})
- in
- if n = bytesRead
- then Vector.fromArray a
- else Array.extract (a, 0, SOME bytesRead)
- end
-
- fun writeVec (FD fd, {buf, i, sz}) =
- let
- val max = Vector.checkSlice (buf, i, sz)
- in
- checkReturnResult (Prim.write (fd, buf, i, max -? i))
- end
-
- fun writeArr (fd, {buf, i, sz}) =
- writeVec (fd, {buf = Vector.fromArray buf, i = i, sz = sz})
+ local
+ fun make {read, write} =
+ let
+ fun readArr (FD fd, {buf, i, sz}): int =
+ let
+ val max = Array.checkSlice (buf, i, sz)
+ in
+ checkReturnResult (read (fd, buf, i, max -? i))
+ end
+
+ fun readVec (fd, n) =
+ let
+ val a = Primitive.Array.array n
+ val bytesRead = readArr (fd, {buf = a, i = 0, sz = SOME n})
+ in
+ if n = bytesRead
+ then Vector.fromArray a
+ else Array.extract (a, 0, SOME bytesRead)
+ end
+
+ fun writeVec (FD fd, {buf, i, sz}) =
+ let
+ val max = Vector.checkSlice (buf, i, sz)
+ in
+ checkReturnResult (write (fd, buf, i, max -? i))
+ end
+
+ fun writeArr (fd, {buf, i, sz}) =
+ writeVec (fd, {buf = Vector.fromArray buf, i = i, sz = sz})
+ in
+ {readArr = readArr, readVec = readVec,
+ writeVec = writeVec, writeArr = writeArr}
+ end
+ in
+ val rwChar = make {read = readChar, write = writeChar}
+ val rwWord8 = make {read = readWord8, write = writeWord8}
+ end
+ val {readArr, readVec, writeVec, writeArr} = rwWord8
structure FD =
struct
- open FD PosixFlags
+ open FD BitFlags
end
structure O = PosixFileSys.O
@@ -168,5 +180,162 @@
val getlk = make (F_GETLK, true)
val setlk = make (F_SETLK, false)
val setlkw = make (F_SETLKW, false)
+ end
+
+ (* Adapted from SML/NJ sources. *)
+ (* posix-bin-prim-io.sml
+ *
+ * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
+ *
+ * This implements the UNIX version of the OS specific binary primitive
+ * IO structure. The Text IO version is implemented by a trivial translation
+ * of these operations (see posix-text-prim-io.sml).
+ *
+ *)
+ local
+ val pos0 = Position.fromInt 0
+ fun isReg fd = FS.ST.isReg(FS.fstat fd)
+ fun posFns (closed, fd) =
+ if (isReg fd)
+ then let
+ val pos = ref pos0
+ fun getPos () = !pos
+ fun setPos p = (if !closed
+ then raise IO.ClosedStream
+ else ();
+ pos := lseek(fd,p,SEEK_SET))
+ fun endPos () = (if !closed
+ then raise IO.ClosedStream
+ else ();
+ FS.ST.size(FS.fstat fd))
+ fun verifyPos () = let
+ val curPos = lseek(fd, pos0, SEEK_CUR)
+ in
+ pos := curPos; curPos
+ end
+ in
+ verifyPos ();
+ {pos = pos,
+ getPos = SOME getPos,
+ setPos = SOME setPos,
+ endPos = SOME endPos,
+ verifyPos = SOME verifyPos}
+ end
+ else {pos = ref pos0,
+ getPos = NONE,
+ setPos = NONE,
+ endPos = NONE,
+ verifyPos = NONE}
+
+ fun make {readArr, readVec, writeVec, writeArr} (RD, WR) =
+ let
+ fun mkReader {fd, name, initBlkMode} =
+ let
+ val closed = ref false
+ val {pos, getPos, setPos, endPos, verifyPos} = posFns (closed, fd)
+ val blocking = ref initBlkMode
+ fun blockingOn () =
+ (setfl(fd, O.flags[]); blocking := true)
+ fun blockingOff () =
+ (setfl(fd, O.nonblock); blocking := false)
+ fun ensureOpen () =
+ if !closed then raise IO.ClosedStream else ()
+ fun incPos k = pos := Position.+ (!pos, Position.fromInt k)
+ val readVec = fn n =>
+ let val v = readVec (fd, n)
+ in incPos (Vector.length v); v
+ end
+ val readArr = fn x =>
+ let val k = readArr (fd, x)
+ in incPos k; k
+ end
+ fun blockWrap f x =
+ (ensureOpen ();
+ if !blocking then () else blockingOn ();
+ f x)
+ fun noBlockWrap f x =
+ (ensureOpen ();
+ if !blocking then blockingOff () else ();
+ (SOME (f x)
+ handle (e as PosixError.SysErr (_, SOME cause)) =>
+ if cause = PosixError.again then NONE else raise e))
+ val close =
+ fn () => if !closed then () else (closed := true; close fd)
+ val avail =
+ if isReg fd
+ then fn () => if !closed
+ then SOME 0
+ else SOME(Position.-(FS.ST.size(FS.fstat fd), !pos))
+ else fn () => if !closed then SOME 0 else NONE
+ in
+ RD {name = name,
+ chunkSize = Primitive.TextIO.bufSize,
+ readVec = SOME (blockWrap readVec),
+ readArr = SOME (blockWrap readArr),
+ readVecNB = SOME (noBlockWrap readVec),
+ readArrNB = SOME (noBlockWrap readArr),
+ block = NONE,
+ canInput = NONE,
+ avail = avail,
+ getPos = getPos,
+ setPos = setPos,
+ endPos = endPos,
+ verifyPos = verifyPos,
+ close = close,
+ ioDesc = SOME (FS.fdToIOD fd)}
+ end
+ fun mkWriter {fd, name, initBlkMode, appendMode, chunkSize} =
+ let
+ val closed = ref false
+ val {pos, getPos, setPos, endPos, verifyPos} = posFns (closed, fd)
+ fun incPos k = (pos := Position.+ (!pos, Position.fromInt k); k)
+ val blocking = ref initBlkMode
+ val appendFlgs = O.flags(if appendMode then [O.append] else [])
+ fun updateStatus () =
+ let
+ val flgs = if !blocking
+ then appendFlgs
+ else O.flags [O.nonblock, appendFlgs]
+ in
+ setfl(fd, flgs)
+ end
+ fun ensureOpen () =
+ if !closed then raise IO.ClosedStream else ()
+ fun ensureBlock x =
+ if !blocking then () else (blocking := x; updateStatus ())
+ fun putV x = incPos(writeVec x)
+ fun putA x = incPos(writeArr x)
+ fun write (put, block) arg =
+ (ensureOpen (); ensureBlock block; put (fd, arg))
+ fun handleBlock writer arg =
+ SOME(writer arg)
+ handle (e as PosixError.SysErr (_, SOME cause)) =>
+ if cause = PosixError.again then NONE else raise e
+ val close =
+ fn () => if !closed then () else (closed := true; close fd)
+ in
+ WR {name = name,
+ chunkSize = chunkSize,
+ writeVec = SOME (write (putV, true)),
+ writeArr = SOME (write (putA, true)),
+ writeVecNB = SOME (handleBlock (write (putV, false))),
+ writeArrNB = SOME (handleBlock (write (putA, false))),
+ block = NONE,
+ canOutput = NONE,
+ getPos = getPos,
+ setPos = setPos,
+ endPos = endPos,
+ verifyPos = verifyPos,
+ close = close,
+ ioDesc = SOME (FS.fdToIOD fd)}
+ end
+ in
+ {mkReader = mkReader, mkWriter = mkWriter}
+ end
+ in
+ val {mkReader = mkBinReader, mkWriter = mkBinWriter} =
+ make rwWord8 (BinPrimIO.RD, BinPrimIO.WR)
+ val {mkReader = mkTextReader, mkWriter = mkTextWriter} =
+ make rwChar (TextPrimIO.RD, TextPrimIO.WR)
end
end
1.2 +33 -1 mlton/basis-library/posix/posix.sig
Index: posix.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/posix.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- posix.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ posix.sig 24 Nov 2002 01:19:39 -0000 1.2
@@ -3,9 +3,41 @@
structure Error: POSIX_ERROR
structure Signal: POSIX_SIGNAL
structure Process: POSIX_PROCESS
+ where type signal = Signal.signal
structure ProcEnv: POSIX_PROC_ENV
- structure FileSys: POSIX_FILESYS
+ where type pid = Process.pid
+ structure FileSys: POSIX_FILE_SYS
+ where type file_desc = ProcEnv.file_desc
+ where type uid = ProcEnv.uid
+ where type gid = ProcEnv.gid
structure IO: POSIX_IO
+ where type open_mode = FileSys.open_mode
structure SysDB: POSIX_SYS_DB
+ where type uid = ProcEnv.uid
+ where type gid = ProcEnv.gid
structure TTY: POSIX_TTY
+ where type pid = Process.pid
+ where type file_desc = ProcEnv.file_desc
+ end
+
+signature POSIX_EXTRA =
+ sig
+ structure Error: POSIX_ERROR_EXTRA
+ structure Signal: POSIX_SIGNAL
+ structure Process: POSIX_PROCESS_EXTRA
+ where type signal = Signal.signal
+ structure ProcEnv: POSIX_PROC_ENV
+ where type pid = Process.pid
+ structure FileSys: POSIX_FILE_SYS_EXTRA
+ where type file_desc = ProcEnv.file_desc
+ where type uid = ProcEnv.uid
+ where type gid = ProcEnv.gid
+ structure IO: POSIX_IO
+ where type open_mode = FileSys.open_mode
+ structure SysDB: POSIX_SYS_DB
+ where type uid = ProcEnv.uid
+ where type gid = ProcEnv.gid
+ structure TTY: POSIX_TTY
+ where type pid = Process.pid
+ where type file_desc = ProcEnv.file_desc
end
1.3 +1 -1 mlton/basis-library/posix/posix.sml
Index: posix.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/posix.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- posix.sml 10 Apr 2002 07:02:17 -0000 1.2
+++ posix.sml 24 Nov 2002 01:19:39 -0000 1.3
@@ -5,7 +5,7 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-structure Posix =
+structure Posix : POSIX_EXTRA =
struct
structure Error = PosixError
1.9 +178 -171 mlton/basis-library/posix/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/primitive.sml,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- primitive.sml 10 Sep 2002 16:08:04 -0000 1.8
+++ primitive.sml 24 Nov 2002 01:19:39 -0000 1.9
@@ -122,6 +122,171 @@
]
end
+ structure Signal =
+ struct
+ type signal = signal
+ type how = int
+
+ val abrt = _const "Posix_Signal_abrt": signal;
+ val alrm = _const "Posix_Signal_alrm": signal;
+ val bus = _const "Posix_Signal_bus": signal;
+ val chld = _const "Posix_Signal_chld": signal;
+ val cont = _const "Posix_Signal_cont": signal;
+ val fpe = _const "Posix_Signal_fpe": signal;
+ val hup = _const "Posix_Signal_hup": signal;
+ val ill = _const "Posix_Signal_ill": signal;
+ val int = _const "Posix_Signal_int": signal;
+ val kill = _const "Posix_Signal_kill": signal;
+ val pipe = _const "Posix_Signal_pipe": signal;
+ val prof = _const "Posix_Signal_prof": signal;
+ val quit = _const "Posix_Signal_quit": signal;
+ val segv = _const "Posix_Signal_segv": signal;
+ val stop = _const "Posix_Signal_stop": signal;
+ val term = _const "Posix_Signal_term": signal;
+ val tstp = _const "Posix_Signal_tstp": signal;
+ val ttin = _const "Posix_Signal_ttin": signal;
+ val ttou = _const "Posix_Signal_ttou": signal;
+ val usr1 = _const "Posix_Signal_usr1": signal;
+ val usr2 = _const "Posix_Signal_usr2": signal;
+ val vtalrm = _const "Posix_Signal_vtalrm": signal;
+
+ val block = _const "Posix_Signal_block": how;
+ val default = _ffi "Posix_Signal_default": signal -> int;
+ val handlee = _ffi "Posix_Signal_handle": signal -> int;
+ val ignore = _ffi "Posix_Signal_ignore": signal -> int;
+ val isDefault = _ffi "Posix_Signal_isDefault": signal * bool ref -> int;
+ val isPending = _ffi "Posix_Signal_isPending": signal -> bool;
+ val numSignals = _const "Posix_Signal_numSignals": int;
+ val setmask = _const "Posix_Signal_setmask": how;
+ val sigaddset = _ffi "Posix_Signal_sigaddset": signal -> int;
+ val sigdelset = _ffi "Posix_Signal_sigdelset": signal -> int;
+ val sigemptyset = _ffi "Posix_Signal_sigemptyset": unit -> int;
+ val sigfillset = _ffi "Posix_Signal_sigfillset": unit -> int;
+ val sigprocmask = _ffi "Posix_Signal_sigprocmask": how -> int;
+ val suspend = _ffi "Posix_Signal_suspend": unit -> int;
+ val unblock = _const "Posix_Signal_unblock": how;
+ end
+
+ structure Process =
+ struct
+ val wnohang = _const "Posix_Process_wnohang": word;
+ structure W =
+ struct
+ type flags = word
+ val untraced = _const "Posix_Process_W_untraced": flags;
+ end
+
+ type pid = pid
+ type status = int
+
+ val alarm = _ffi "Posix_Process_alarm": int -> int;
+ val exece =
+ _ffi "Posix_Process_exece"
+ : nullString * nullString array * nullString array -> int;
+ val execp =
+ _ffi "Posix_Process_execp": nullString * nullString array -> int;
+ val exit = _ffi "Posix_Process_exit": int -> unit;
+ val exitStatus = _ffi "Posix_Process_exitStatus": status -> int;
+ val fork = _ffi "Posix_Process_fork": unit -> pid;
+ val ifExited = _ffi "Posix_Process_ifExited": status -> bool;
+ val ifSignaled = _ffi "Posix_Process_ifSignaled": status -> bool;
+ val ifStopped = _ffi "Posix_Process_ifStopped": status -> bool;
+ val kill = _ffi "Posix_Process_kill": pid * signal -> int;
+ val pause = _ffi "Posix_Process_pause": unit -> int;
+ val sleep = _ffi "Posix_Process_sleep": int -> int;
+ val stopSig = _ffi "Posix_Process_stopSig": status -> signal;
+ val termSig = _ffi "Posix_Process_termSig": status -> signal;
+ val waitpid =
+ _ffi "Posix_Process_waitpid": pid * status ref * int -> pid;
+ end
+
+ structure ProcEnv =
+ struct
+ val numgroups = _const "Posix_ProcEnv_numgroups": int;
+ val sysconfNames =
+ [
+ (* Required *)
+ (_const "Posix_ProcEnv_ARG_MAX": int;, "ARG_MAX"),
+ (_const "Posix_ProcEnv_CHILD_MAX": int;, "CHILD_MAX"),
+ (_const "Posix_ProcEnv_CLK_TCK": int;, "CLK_TCK"),
+ (_const "Posix_ProcEnv_NGROUPS_MAX": int;, "NGROUPS_MAX"),
+ (_const "Posix_ProcEnv_OPEN_MAX": int;, "OPEN_MAX"),
+ (_const "Posix_ProcEnv_STREAM_MAX": int;, "STREAM_MAX"),
+ (_const "Posix_ProcEnv_TZNAME_MAX": int;, "TZNAME_MAX"),
+ (_const "Posix_ProcEnv_JOB_CONTROL": int;, "JOB_CONTROL"),
+ (_const "Posix_ProcEnv_SAVED_IDS": int;, "SAVED_IDS"),
+ (_const "Posix_ProcEnv_VERSION": int;, "VERSION"),
+ (* Optional *)
+ (_const "Posix_ProcEnv_BC_BASE_MAX": int;, "BC_BASE_MAX"),
+ (_const "Posix_ProcEnv_BC_DIM_MAX": int;, "BC_DIM_MAX"),
+ (_const "Posix_ProcEnv_BC_SCALE_MAX": int;, "BC_SCALE_MAX"),
+ (_const "Posix_ProcEnv_BC_STRING_MAX": int;, "BC_STRING_MAX"),
+ (_const "Posix_ProcEnv_COLL_WEIGHTS_MAX": int;, "COLL_WEIGHTS_MAX"),
+ (_const "Posix_ProcEnv_EXPR_NEST_MAX": int;, "EXPR_NEST_MAX"),
+ (_const "Posix_ProcEnv_LINE_MAX": int;, "LINE_MAX"),
+ (_const "Posix_ProcEnv_RE_DUP_MAX": int;, "RE_DUP_MAX"),
+ (_const "Posix_ProcEnv_2_VERSION": int;, "2_VERSION"),
+ (_const "Posix_ProcEnv_2_FORT_DEV": int;, "2_FORT_DEV"),
+ (_const "Posix_ProcEnv_2_FORT_RUN": int;, "2_FORT_RUN"),
+ (_const "Posix_ProcEnv_2_SW_DEV": int;, "2_SW_DEV")
+ ]
+
+ type pid = pid
+ type gid = gid
+ type uid = uid
+ datatype file_desc = datatype file_desc
+
+ val getegid = _ffi "Posix_ProcEnv_getegid": unit -> gid;
+ val geteuid = _ffi "Posix_ProcEnv_geteuid": unit -> uid;
+ val getgid = _ffi "Posix_ProcEnv_getgid": unit -> gid;
+ val getgroups = _ffi "Posix_ProcEnv_getgroups": gid array -> int;
+ val getlogin = _ffi "Posix_ProcEnv_getlogin": unit -> cstring;
+ val getpgrp = _ffi "Posix_ProcEnv_getpgrp": unit -> pid;
+ val getpid = _ffi "Posix_ProcEnv_getpid": unit -> pid;
+ val getppid = _ffi "Posix_ProcEnv_getppid": unit -> pid;
+ val getuid = _ffi "Posix_ProcEnv_getuid": unit -> uid;
+ val setenv = _ffi "Posix_ProcEnv_setenv": nullString * nullString -> int;
+ val setgid = _ffi "Posix_ProcEnv_setgid": gid -> int;
+ val setpgid = _ffi "Posix_ProcEnv_setpgid": pid * pid -> int;
+ val setsid = _ffi "Posix_ProcEnv_setsid": unit -> pid;
+ val setuid = _ffi "Posix_ProcEnv_setuid": uid -> int;
+
+ structure Uname =
+ struct
+ type uname = pointer
+
+ val uname = _ffi "Posix_ProcEnv_Uname_uname": unit -> int;
+ val sysname =
+ _ffi "Posix_ProcEnv_Uname_sysname": unit -> cstring;
+ val nodename =
+ _ffi "Posix_ProcEnv_Uname_nodename": unit -> cstring;
+ val release =
+ _ffi "Posix_ProcEnv_Uname_release": unit -> cstring;
+ val version =
+ _ffi "Posix_ProcEnv_Uname_version": unit -> cstring;
+ val machine =
+ _ffi "Posix_ProcEnv_Uname_machine": unit -> cstring;
+ end
+
+ type clock_t = word
+
+ structure Tms =
+ struct
+ val utime = _ffi "Posix_ProcEnv_Tms_utime": unit -> clock_t;
+ val stime = _ffi "Posix_ProcEnv_Tms_stime": unit -> clock_t;
+ val cutime = _ffi "Posix_ProcEnv_Tms_cutime": unit -> clock_t;
+ val cstime = _ffi "Posix_ProcEnv_Tms_cstime": unit -> clock_t;
+ end
+
+ val ctermid = _ffi "Posix_ProcEnv_ctermid" : unit -> cstring;
+ val environ = _ffi "Posix_ProcEnv_environ" : cstringArray;
+ val getenv = _ffi "Posix_ProcEnv_getenv" : nullString -> cstring;
+ val isatty = _ffi "Posix_ProcEnv_isatty" : fd -> bool;
+ val sysconf = _ffi "Posix_ProcEnv_sysconf" : int -> int;
+ val times = _ffi "Posix_ProcEnv_times" : unit -> clock_t;
+ val ttyname = _ffi "Posix_ProcEnv_ttyname" : fd -> cstring;
+ end
+
structure FileSys =
struct
datatype file_desc = datatype file_desc
@@ -181,16 +346,19 @@
val properties =
[
+ (_const "Posix_FileSys_CHOWN_RESTRICTED": int;,
+ "CHOWN_RESTRICTED"),
(_const "Posix_FileSys_LINK_MAX": int;, "LINK_MAX"),
(_const "Posix_FileSys_MAX_CANON": int;, "MAX_CANON"),
(_const "Posix_FileSys_MAX_INPUT": int;, "MAX_INPUT"),
(_const "Posix_FileSys_NAME_MAX": int;, "NAME_MAX"),
+ (_const "Posix_FileSys_NO_TRUNC": int;, "NO_TRUNC"),
(_const "Posix_FileSys_PATH_MAX": int;, "PATH_MAX"),
(_const "Posix_FileSys_PIPE_BUF": int;, "PIPE_BUF"),
- (_const "Posix_FileSys_CHOWN_RESTRICTED": int;,
- "CHOWN_RESTRICTED"),
- (_const "Posix_FileSys_NO_TRUNC": int;, "NO_TRUNC"),
- (_const "Posix_FileSys_VDISABLE": int;, "VDISABLE")
+ (_const "Posix_FileSys_VDISABLE": int;, "VDISABLE"),
+ (_const "Posix_FileSys_ASYNC_IO": int;, "ASYNC_IO"),
+ (_const "Posix_FileSys_SYNC_IO": int;, "SYNC_IO"),
+ (_const "Posix_FileSys_PRIO_IO": int;, "PRIO_IO")
]
structure Dirstream =
@@ -350,177 +518,16 @@
val fsync = _ffi "Posix_IO_fsync": fd -> int;
val lseek = _ffi "Posix_IO_lseek": fd * int * int -> int;
val pipe = _ffi "Posix_IO_pipe": fd array -> int;
- val read = _ffi "Posix_IO_read":
+ val readChar = _ffi "Posix_IO_read":
+ fd * char array * int * size -> ssize;
+ val writeChar = _ffi "Posix_IO_write":
+ fd * char vector * int * size -> ssize;
+ val readWord8 = _ffi "Posix_IO_read":
fd * word8 array * int * size -> ssize;
- val write = _ffi "Posix_IO_write":
+ val writeWord8 = _ffi "Posix_IO_write":
fd * word8 vector * int * size -> ssize;
end
- structure ProcEnv =
- struct
- val numgroups = _const "Posix_ProcEnv_numgroups": int;
- val sysconfNames =
- [
- (_const "Posix_ProcEnv_ARG_MAX": int;, "ARG_MAX"),
- (_const "Posix_ProcEnv_CHILD_MAX": int;, "CHILD_MAX"),
- (_const "Posix_ProcEnv_CLK_TCK": int;, "CLK_TCK"),
- (_const "Posix_ProcEnv_STREAM_MAX": int;, "STREAM_MAX"),
- (_const "Posix_ProcEnv_TZNAME_MAX": int;, "TZNAME_MAX"),
- (_const "Posix_ProcEnv_OPEN_MAX": int;, "OPEN_MAX"),
- (_const "Posix_ProcEnv_JOB_CONTROL": int;, "JOB_CONTROL"),
- (_const "Posix_ProcEnv_SAVED_IDS": int;, "SAVED_IDS"),
- (_const "Posix_ProcEnv_VERSION": int;, "VERSION"),
- (_const "Posix_ProcEnv_BC_BASE_MAX": int;, "BC_BASE_MAX"),
- (_const "Posix_ProcEnv_BC_DIM_MAX": int;, "BC_DIM_MAX"),
- (_const "Posix_ProcEnv_BC_SCALE_MAX": int;, "BC_SCALE_MAX"),
- (_const "Posix_ProcEnv_BC_STRING_MAX": int;, "BC_STRING_MAX"),
- (_const "Posix_ProcEnv_COLL_WEIGHTS_MAX": int;,
- "COLL_WEIGHTS_MAX"),
- (_const "Posix_ProcEnv_EXPR_NEST_MAX": int;, "EXPR_NEST_MAX"),
- (_const "Posix_ProcEnv_LINE_MAX": int;, "LINE_MAX"),
- (_const "Posix_ProcEnv_RE_DUP_MAX": int;, "RE_DUP_MAX"),
- (_const "Posix_ProcEnv_2_VERSION": int;, "2_VERSION"),
- (_const "Posix_ProcEnv_2_FORT_DEV": int;, "2_FORT_DEV"),
- (_const "Posix_ProcEnv_2_FORT_RUN": int;, "2_FORT_RUN"),
- (_const "Posix_ProcEnv_2_SW_DEV": int;, "2_SW_DEV")
- ]
-
- type pid = pid
- type gid = gid
- type uid = uid
- datatype file_desc = datatype file_desc
-
- val getegid = _ffi "Posix_ProcEnv_getegid": unit -> gid;
- val geteuid = _ffi "Posix_ProcEnv_geteuid": unit -> uid;
- val getgid = _ffi "Posix_ProcEnv_getgid": unit -> gid;
- val getgroups = _ffi "Posix_ProcEnv_getgroups": gid array -> int;
- val getlogin = _ffi "Posix_ProcEnv_getlogin": unit -> cstring;
- val getpgrp = _ffi "Posix_ProcEnv_getpgrp": unit -> pid;
- val getpid = _ffi "Posix_ProcEnv_getpid": unit -> pid;
- val getppid = _ffi "Posix_ProcEnv_getppid": unit -> pid;
- val getuid = _ffi "Posix_ProcEnv_getuid": unit -> uid;
- val setenv =
- _ffi "Posix_ProcEnv_setenv": nullString * nullString -> int;
- val setgid = _ffi "Posix_ProcEnv_setgid": gid -> int;
- val setpgid = _ffi "Posix_ProcEnv_setpgid": pid * pid -> int;
- val setsid = _ffi "Posix_ProcEnv_setsid": unit -> pid;
- val setuid = _ffi "Posix_ProcEnv_setuid": uid -> int;
-
- structure Uname =
- struct
- type uname = pointer
-
- val uname = _ffi "Posix_ProcEnv_Uname_uname": unit -> int;
- val sysname =
- _ffi "Posix_ProcEnv_Uname_sysname": unit -> cstring;
- val nodename =
- _ffi "Posix_ProcEnv_Uname_nodename": unit -> cstring;
- val release =
- _ffi "Posix_ProcEnv_Uname_release": unit -> cstring;
- val version =
- _ffi "Posix_ProcEnv_Uname_version": unit -> cstring;
- val machine =
- _ffi "Posix_ProcEnv_Uname_machine": unit -> cstring;
- end
-
- type clock_t = word
-
- structure Tms =
- struct
- val utime = _ffi "Posix_ProcEnv_Tms_utime": unit -> clock_t;
- val stime = _ffi "Posix_ProcEnv_Tms_stime": unit -> clock_t;
- val cutime = _ffi "Posix_ProcEnv_Tms_cutime": unit -> clock_t;
- val cstime = _ffi "Posix_ProcEnv_Tms_cstime": unit -> clock_t;
- end
-
- val ctermid = _ffi "Posix_ProcEnv_ctermid" : unit -> cstring;
- val environ = _ffi "Posix_ProcEnv_environ" : cstringArray;
- val getenv = _ffi "Posix_ProcEnv_getenv" : nullString -> cstring;
- val isatty = _ffi "Posix_ProcEnv_isatty" : fd -> bool;
- val sysconf = _ffi "Posix_ProcEnv_sysconf" : int -> int;
- val times = _ffi "Posix_ProcEnv_times" : unit -> clock_t;
- val ttyname = _ffi "Posix_ProcEnv_ttyname" : fd -> cstring;
- end
-
- structure Process =
- struct
- val wnohang = _const "Posix_Process_wnohang": word;
- structure W =
- struct
- type flags = word
- val untraced = _const "Posix_Process_W_untraced": flags;
- end
-
- type pid = pid
- type status = int
-
- val alarm = _ffi "Posix_Process_alarm": int -> int;
- val exece =
- _ffi "Posix_Process_exece"
- : nullString * nullString array * nullString array -> int;
- val execp =
- _ffi "Posix_Process_execp": nullString * nullString array -> int;
- val exit = _ffi "Posix_Process_exit": int -> unit;
- val exitStatus = _ffi "Posix_Process_exitStatus": status -> int;
- val fork = _ffi "Posix_Process_fork": unit -> pid;
- val ifExited = _ffi "Posix_Process_ifExited": status -> bool;
- val ifSignaled = _ffi "Posix_Process_ifSignaled": status -> bool;
- val ifStopped = _ffi "Posix_Process_ifStopped": status -> bool;
- val kill = _ffi "Posix_Process_kill": pid * signal -> int;
- val pause = _ffi "Posix_Process_pause": unit -> int;
- val sleep = _ffi "Posix_Process_sleep": int -> int;
- val stopSig = _ffi "Posix_Process_stopSig": status -> signal;
- val termSig = _ffi "Posix_Process_termSig": status -> signal;
- val waitpid =
- _ffi "Posix_Process_waitpid": pid * status ref * int -> pid;
- end
-
- structure Signal =
- struct
- type signal = signal
- type how = int
-
- val abrt = _const "Posix_Signal_abrt": signal;
- val alrm = _const "Posix_Signal_alrm": signal;
- val bus = _const "Posix_Signal_bus": signal;
- val chld = _const "Posix_Signal_chld": signal;
- val cont = _const "Posix_Signal_cont": signal;
- val fpe = _const "Posix_Signal_fpe": signal;
- val hup = _const "Posix_Signal_hup": signal;
- val ill = _const "Posix_Signal_ill": signal;
- val int = _const "Posix_Signal_int": signal;
- val kill = _const "Posix_Signal_kill": signal;
- val pipe = _const "Posix_Signal_pipe": signal;
- val prof = _const "Posix_Signal_prof": signal;
- val quit = _const "Posix_Signal_quit": signal;
- val segv = _const "Posix_Signal_segv": signal;
- val stop = _const "Posix_Signal_stop": signal;
- val term = _const "Posix_Signal_term": signal;
- val tstp = _const "Posix_Signal_tstp": signal;
- val ttin = _const "Posix_Signal_ttin": signal;
- val ttou = _const "Posix_Signal_ttou": signal;
- val usr1 = _const "Posix_Signal_usr1": signal;
- val usr2 = _const "Posix_Signal_usr2": signal;
- val vtalrm = _const "Posix_Signal_vtalrm": signal;
-
- val block = _const "Posix_Signal_block": how;
- val default = _ffi "Posix_Signal_default": signal -> int;
- val handlee = _ffi "Posix_Signal_handle": signal -> int;
- val ignore = _ffi "Posix_Signal_ignore": signal -> int;
- val isDefault =
- _ffi "Posix_Signal_isDefault": signal * bool ref -> int;
- val isPending = _ffi "Posix_Signal_isPending": signal -> bool;
- val numSignals = _const "Posix_Signal_numSignals": int;
- val setmask = _const "Posix_Signal_setmask": how;
- val sigaddset = _ffi "Posix_Signal_sigaddset": signal -> int;
- val sigdelset = _ffi "Posix_Signal_sigdelset": signal -> int;
- val sigemptyset = _ffi "Posix_Signal_sigemptyset": unit -> int;
- val sigfillset = _ffi "Posix_Signal_sigfillset": unit -> int;
- val sigprocmask = _ffi "Posix_Signal_sigprocmask": how -> int;
- val suspend = _ffi "Posix_Signal_suspend": unit -> unit;
- val unblock = _const "Posix_Signal_unblock": how;
- end
-
structure SysDB =
struct
type gid = gid
1.2 +22 -22 mlton/basis-library/posix/proc-env.sig
Index: proc-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/proc-env.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- proc-env.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ proc-env.sig 24 Nov 2002 01:19:39 -0000 1.2
@@ -1,38 +1,38 @@
signature POSIX_PROC_ENV =
sig
- eqtype file_desc
- eqtype gid
eqtype pid
eqtype uid
+ eqtype gid
+ eqtype file_desc
- val ctermid: unit -> string
- val environ: unit -> string list
- val getegid: unit -> gid
- val getenv: string -> string option
- val geteuid: unit -> uid
- val getgid: unit -> gid
+ val uidToWord: uid -> SysWord.word
+ val wordToUid: SysWord.word -> uid
+ val gidToWord: gid -> SysWord.word
+ val wordToGid: SysWord.word -> gid
+ val getpid : unit -> pid
+ val getppid: unit -> pid
+ val getuid : unit -> uid
+ val geteuid: unit -> uid
+ val getgid : unit -> gid
+ val getegid: unit -> gid
+ val setuid: uid -> unit
+ val setgid: gid -> unit
val getgroups: unit -> gid list
val getlogin: unit -> string
- val getpgrp: unit -> pid
- val getpid: unit -> pid
- val getppid: unit -> pid
- val getuid: unit -> uid
- val gidToWord: gid -> SysWord.word
- val isatty: file_desc -> bool
- val setgid: gid -> unit
- val setpgid: {pid: pid option, pgid: pid option} -> unit
+ val getpgrp: unit -> pid
val setsid: unit -> pid
- val setuid: uid -> unit
- val sysconf: string -> SysWord.word
+ val setpgid: {pid: pid option, pgid: pid option} -> unit
+ val uname: unit -> (string * string) list
val time: unit -> Time.time
val times: unit -> {elapsed: Time.time,
utime: Time.time,
stime: Time.time,
cutime: Time.time,
cstime: Time.time}
+ val getenv: string -> string option
+ val environ: unit -> string list
+ val ctermid: unit -> string
val ttyname: file_desc -> string
- val uidToWord: uid -> SysWord.word
- val uname: unit -> (string * string) list
- val wordToGid: SysWord.word -> gid
- val wordToUid: SysWord.word -> uid
+ val isatty: file_desc -> bool
+ val sysconf: string -> SysWord.word
end
1.4 +7 -19 mlton/basis-library/posix/proc-env.sml
Index: proc-env.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/proc-env.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- proc-env.sml 10 Apr 2002 07:02:17 -0000 1.3
+++ proc-env.sml 24 Nov 2002 01:19:39 -0000 1.4
@@ -29,22 +29,22 @@
val setuid = Error.checkResult o setuid
end
+ fun id x = x
+ val uidToWord = id
+ val wordToUid = id
+ val gidToWord = id
+ val wordToGid = id
+
local
val a: word array = Primitive.Array.array Prim.numgroups
in
fun getgroups () =
let val n = Prim.getgroups a
in Error.checkResult n
- ; Array.prefixToList (a, n)
+ ; ArraySlice.toList (ArraySlice.slice (a, 0, SOME n))
end
end
- fun id x = x
- val uidToWord = id
- val wordToUid = id
- val gidToWord = id
- val wordToGid = id
-
fun getlogin () =
let val cs = Prim.getlogin ()
in if Primitive.Cpointer.isNull cs
@@ -86,18 +86,6 @@
local
structure Tms = Prim.Tms
-(*
- val ticksPerSecond: LargeInt.int =
- SysWord.toLargeInt (sysconf "CLK_TCK")
-
- val millisecondsPerSecond: LargeInt.int = 1000
-
- fun cvt (ticks: int): Time.time =
- Time.fromMilliseconds
- (LargeInt.div
- (LargeInt.fromInt ticks * millisecondsPerSecond,
- ticksPerSecond))
-*)
val ticksPerSec = Real.fromInt (SysWord.toIntX (sysconf "CLK_TCK"))
fun cvt (ticks: word) =
1.2 +9 -1 mlton/basis-library/posix/process.sig
Index: process.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/process.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- process.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ process.sig 24 Nov 2002 01:19:39 -0000 1.2
@@ -22,9 +22,11 @@
| W_SIGNALED of signal
| W_STOPPED of signal
+ val fromStatus: OS.Process.status -> exit_status
+
structure W :
sig
- include POSIX_FLAGS
+ include BIT_FLAGS
val untraced: flags
end
@@ -43,3 +45,9 @@
val pause: unit -> unit
val sleep: Time.time -> Time.time
end
+
+signature POSIX_PROCESS_EXTRA =
+ sig
+ include POSIX_PROCESS
+ type status
+ end
\ No newline at end of file
1.10 +23 -20 mlton/basis-library/posix/process.sml
Index: process.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/process.sml,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- process.sml 10 Apr 2002 07:02:18 -0000 1.9
+++ process.sml 24 Nov 2002 01:19:39 -0000 1.10
@@ -5,7 +5,7 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-structure PosixProcess: POSIX_PROCESS =
+structure PosixProcess: POSIX_PROCESS_EXTRA =
struct
structure Prim = PosixPrimitive.Process
open Prim
@@ -93,15 +93,27 @@
| W_SAME_GROUP
| W_GROUP of pid
+ type status = status
datatype exit_status =
W_EXITED
| W_EXITSTATUS of Word8.word
| W_SIGNALED of signal
| W_STOPPED of signal
+ fun fromStatus status =
+ if Prim.ifExited status
+ then (case Prim.exitStatus status of
+ 0 => W_EXITED
+ | n => W_EXITSTATUS (Word8.fromInt n))
+ else if Prim.ifSignaled status
+ then W_SIGNALED (Prim.termSig status)
+ else if Prim.ifStopped status
+ then W_STOPPED (Prim.stopSig status)
+ else raise Fail "Posix.Process.fromStatus"
+
structure W =
struct
- open W PosixFlags
+ open W BitFlags
end
local
@@ -113,31 +125,21 @@
val status: status ref = ref 0
- fun getStatus () =
- let val status = !status
- in if Prim.ifExited status
- then (case Prim.exitStatus status of
- 0 => W_EXITED
- | n => W_EXITSTATUS (Word8.fromInt n))
- else if Prim.ifSignaled status
- then W_SIGNALED (Prim.termSig status)
- else if Prim.ifStopped status
- then W_STOPPED (Prim.stopSig status)
- else raise Fail "Posix.Process.waitpid"
- end
+ fun getStatus () = fromStatus (!status)
in
fun waitpid (wa, flags) =
let val pid = Prim.waitpid (convertwa wa, status,
- SysWord.toInt (W.flags flags))
+ SysWord.toInt
+ (W.flags flags))
in Error.checkResult pid
; (pid, getStatus ())
end
fun waitpid_nh (wa, flags) =
let
- val pid =
- Prim.waitpid (convertwa wa, status,
- SysWord.toInt (W.flags (wnohang :: flags)))
+ val pid = Prim.waitpid (convertwa wa, status,
+ SysWord.toInt
+ (W.flags (wnohang :: flags)))
in Error.checkResult pid
; if pid = 0
then NONE
@@ -169,8 +171,9 @@
local
fun wrap prim (t: Time.time): Time.time =
- Time.fromSeconds
- (LargeInt.fromInt (prim (LargeInt.toInt (Time.toSeconds t))))
+ (Time.fromSeconds (LargeInt.fromInt
+ (prim
+ (LargeInt.toInt (Time.toSeconds t)))))
in
val alarm = wrap Prim.alarm
val sleep = wrap Prim.sleep
1.2 +22 -21 mlton/basis-library/posix/signal.sig
Index: signal.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/signal.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- signal.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ signal.sig 24 Nov 2002 01:19:39 -0000 1.2
@@ -2,26 +2,27 @@
sig
eqtype signal
- val toWord: signal -> SysWord.word
- val fromWord: SysWord.word -> signal
- val abrt: signal
- val alrm: signal
- val bus: signal
- val chld: signal
- val cont: signal
- val fpe: signal
- val hup: signal
- val ill: signal
- val int: signal
- val kill: signal
- val pipe: signal
- val quit: signal
- val segv: signal
- val term: signal
- val usr1: signal
- val usr2: signal
- val stop: signal
- val tstp: signal
- val ttin: signal
+ val toWord: signal -> SysWord.word
+ val fromWord: SysWord.word -> signal
+
+ val abrt: signal
+ val alrm: signal
+ val bus: signal
+ val fpe: signal
+ val hup: signal
+ val ill: signal
+ val int: signal
+ val kill: signal
+ val pipe: signal
+ val quit: signal
+ val segv: signal
+ val term: signal
+ val usr1: signal
+ val usr2: signal
+ val chld: signal
+ val cont: signal
+ val stop: signal
+ val tstp: signal
+ val ttin: signal
val ttou: signal
end
1.2 +15 -15 mlton/basis-library/posix/tty.sig
Index: tty.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/tty.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- tty.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ tty.sig 24 Nov 2002 01:19:39 -0000 1.2
@@ -26,7 +26,7 @@
structure I:
sig
- include POSIX_FLAGS
+ include BIT_FLAGS
val brkint: flags
val icrnl: flags
val ignbrk: flags
@@ -42,13 +42,13 @@
structure O:
sig
- include POSIX_FLAGS
+ include BIT_FLAGS
val opost: flags
end
structure C:
sig
- include POSIX_FLAGS
+ include BIT_FLAGS
val clocal: flags
val cread: flags
val cs5: flags
@@ -64,7 +64,7 @@
structure L:
sig
- include POSIX_FLAGS
+ include BIT_FLAGS
val echo: flags
val echoe: flags
val echok: flags
@@ -150,16 +150,16 @@
val iflush: queue_sel
val oflush: queue_sel
val ioflush: queue_sel
- end
- val getattr: file_desc -> termios
- val setattr: file_desc * TC.set_action * termios -> unit
-
- val sendbreak: file_desc * int -> unit
- val drain: file_desc -> unit
- val flush: file_desc * TC.queue_sel -> unit
- val flow: file_desc * TC.flow_action -> unit
-
- val getpgrp: file_desc -> pid
- val setpgrp: file_desc * pid -> unit
+ val getattr: file_desc -> termios
+ val setattr: file_desc * set_action * termios -> unit
+
+ val sendbreak: file_desc * int -> unit
+ val drain: file_desc -> unit
+ val flush: file_desc * queue_sel -> unit
+ val flow: file_desc * flow_action -> unit
+
+ val getpgrp: file_desc -> pid
+ val setpgrp: file_desc * pid -> unit
+ end
end
1.4 +44 -40 mlton/basis-library/posix/tty.sml
Index: tty.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/tty.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- tty.sml 10 Apr 2002 07:02:18 -0000 1.3
+++ tty.sml 24 Nov 2002 01:19:39 -0000 1.4
@@ -33,8 +33,7 @@
fun update (a, l) =
let val a' = new ()
- in Array.copy {src = a, si = 0, len = NONE,
- dst = a', di = 0}
+ in Array.copy {src = a, dst = a', di = 0}
; updates (a', l)
; a'
end
@@ -44,22 +43,22 @@
structure I =
struct
- open I PosixFlags
+ open I BitFlags
end
structure O =
struct
- open O PosixFlags
+ open O BitFlags
end
structure C =
struct
- open C PosixFlags
+ open C BitFlags
end
structure L =
struct
- open L PosixFlags
+ open L BitFlags
end
type speed = Prim.speed
@@ -114,39 +113,44 @@
structure Termios = Prim.Termios
- fun getattr (FD fd) =
- (Error.checkResult (Prim.getattr (fd))
- ; {iflag = Termios.iflag (),
- oflag = Termios.oflag (),
- cflag = Termios.cflag (),
- lflag = Termios.lflag (),
- cc = Cstring.toCharArrayOfLength (Termios.cc (), V.nccs),
- ispeed = Termios.ispeed (),
- ospeed = Termios.ospeed ()})
-
- fun setattr (FD fd, a, {iflag, oflag, cflag, lflag, cc, ispeed, ospeed}) =
- (Termios.setiflag iflag
- ; Termios.setoflag oflag
- ; Termios.setcflag cflag
- ; Termios.setlflag lflag
- ; Termios.setospeed ospeed
- ; Termios.setispeed ispeed
- ; let val cs = Termios.cc ()
- in Util.naturalForeach
- (V.nccs, fn i => Cstring.update (cs, i, V.sub (cc, i)))
- end
- ; Error.checkResult (Prim.setattr (fd, a)))
-
- fun sendbreak (FD fd, n) =
- Error.checkResult (Prim.sendbreak (fd, n))
+ structure TC =
+ struct
+ open Prim.TC
- fun drain (FD fd) = Error.checkResult (Prim.drain fd)
-
- fun flush (FD fd, n) = Error.checkResult (Prim.flush (fd, n))
-
- fun flow (FD fd, n) = Error.checkResult (Prim.flow (fd, n))
-
- fun getpgrp (FD fd) = Error.checkReturnResult (Prim.getpgrp fd)
-
- fun setpgrp (FD fd, pid) = Error.checkResult (Prim.setpgrp (fd, pid))
+ fun getattr (FD fd) =
+ (Error.checkResult (Prim.getattr (fd))
+ ; {iflag = Termios.iflag (),
+ oflag = Termios.oflag (),
+ cflag = Termios.cflag (),
+ lflag = Termios.lflag (),
+ cc = Cstring.toCharArrayOfLength (Termios.cc (), V.nccs),
+ ispeed = Termios.ispeed (),
+ ospeed = Termios.ospeed ()})
+
+ fun setattr (FD fd, a, {iflag, oflag, cflag, lflag, cc, ispeed, ospeed}) =
+ (Termios.setiflag iflag
+ ; Termios.setoflag oflag
+ ; Termios.setcflag cflag
+ ; Termios.setlflag lflag
+ ; Termios.setospeed ospeed
+ ; Termios.setispeed ispeed
+ ; let val cs = Termios.cc ()
+ in Util.naturalForeach
+ (V.nccs, fn i => Cstring.update (cs, i, V.sub (cc, i)))
+ end
+ ; Error.checkResult (Prim.setattr (fd, a)))
+
+ fun sendbreak (FD fd, n) =
+ Error.checkResult (Prim.sendbreak (fd, n))
+
+ fun drain (FD fd) = Error.checkResult (Prim.drain fd)
+
+ fun flush (FD fd, n) = Error.checkResult (Prim.flush (fd, n))
+
+ fun flow (FD fd, n) = Error.checkResult (Prim.flow (fd, n))
+
+ fun getpgrp (FD fd) = Error.checkReturnResult (Prim.getpgrp fd)
+
+ fun setpgrp (FD fd, pid) = Error.checkResult (Prim.setpgrp (fd, pid))
+ end
end
1.4 +5 -5 mlton/basis-library/real/IEEE-real.sig
Index: IEEE-real.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/IEEE-real.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- IEEE-real.sig 20 Jul 2002 23:14:01 -0000 1.3
+++ IEEE-real.sig 24 Nov 2002 01:19:39 -0000 1.4
@@ -4,10 +4,8 @@
datatype real_order = LESS | EQUAL | GREATER | UNORDERED
- datatype nan_mode = QUIET | SIGNALLING
-
datatype float_class =
- NAN of nan_mode
+ NAN
| INF
| ZERO
| NORMAL
@@ -22,12 +20,14 @@
val setRoundingMode: rounding_mode -> unit
val getRoundingMode: unit -> rounding_mode
- type decimal_approx = {kind: float_class,
+ type decimal_approx = {class: float_class,
sign: bool,
digits: int list,
exp: int}
val toString: decimal_approx -> string
-(* val fromString: string -> decimal_approx option*)
+ val scan: (char, 'a) StringCvt.reader
+ -> (decimal_approx, 'a) StringCvt.reader
+ val fromString: string -> decimal_approx option
end
1.5 +8 -6 mlton/basis-library/real/IEEE-real.sml
Index: IEEE-real.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/IEEE-real.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- IEEE-real.sml 20 Jul 2002 23:14:01 -0000 1.4
+++ IEEE-real.sml 24 Nov 2002 01:19:39 -0000 1.5
@@ -9,10 +9,9 @@
struct
exception Unordered
datatype real_order = LESS | EQUAL | GREATER | UNORDERED
- datatype nan_mode = QUIET | SIGNALLING
datatype float_class =
- NAN of nan_mode
+ NAN
| INF
| ZERO
| NORMAL
@@ -42,12 +41,12 @@
val setRoundingMode = Prim.setRoundingMode o rounding_modeToInt
val getRoundingMode = intToRounding_mode o Prim.getRoundingMode
- type decimal_approx = {kind: float_class,
+ type decimal_approx = {class: float_class,
sign: bool,
digits: int list,
exp: int}
- fun toString{kind, sign, digits, exp}: string =
+ fun toString {class, sign, digits, exp}: string =
let
fun digitStr() = implode(map StringCvt.digitToChar digits)
fun norm() =
@@ -57,15 +56,18 @@
else concat[num, "E", Int.toString exp]
end
val num =
- case kind of
+ case class of
ZERO => "0.0"
| NORMAL => norm()
| SUBNORMAL => norm()
| INF => "inf"
- | NAN _ => concat["nan(", digitStr(), ")"]
+ | NAN => "nan"
in if sign
then "~" ^ num
else num
end
+
+ val scan = fn _ => raise (Fail "<IEEEReal.scan not implemented>")
+ fun fromString s = StringCvt.scanString scan s
end
1.5 +10 -10 mlton/basis-library/real/math.sig
Index: math.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/math.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- math.sig 20 Jul 2002 23:14:01 -0000 1.4
+++ math.sig 24 Nov 2002 01:19:39 -0000 1.5
@@ -2,21 +2,21 @@
sig
type real
- val acos: real -> real
+ val pi: real
+ val e: real
+ val sqrt: real -> real
+ val sin: real -> real
+ val cos: real -> real
+ val tan: real -> real
val asin: real -> real
- val atan2: real * real -> real
+ val acos: real -> real
val atan: real -> real
- val cos: real -> real
- val cosh: real -> real
- val e: real
+ val atan2: real * real -> real
val exp: real -> real
+ val pow: real * real -> real
val ln: real -> real
val log10: real -> real
- val pi: real
- val pow: real * real -> real
- val sin: real -> real
val sinh: real -> real
- val sqrt: real -> real
- val tan: real -> real
+ val cosh: real -> real
val tanh: real -> real
end
1.4 +3 -3 mlton/basis-library/real/pack-real.sig
Index: pack-real.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/pack-real.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- pack-real.sig 20 Jul 2002 23:14:01 -0000 1.3
+++ pack-real.sig 24 Nov 2002 01:19:39 -0000 1.4
@@ -3,10 +3,10 @@
type real
val bytesPerElem: int
- val fromBytes: Word8Vector.vector -> real
val isBigEndian: bool
- val subArr: Word8Array.array * int -> real
- val subVec: Word8Vector.vector * int -> real
val toBytes: real -> Word8Vector.vector
+ val fromBytes: Word8Vector.vector -> real
+ val subVec: Word8Vector.vector * int -> real
+ val subArr: Word8Array.array * int -> real
val update: Word8Array.array * int * real -> unit
end
1.4 +2 -0 mlton/basis-library/real/pack-real.sml
Index: pack-real.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/pack-real.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- pack-real.sml 20 Jul 2002 23:14:01 -0000 1.3
+++ pack-real.sml 24 Nov 2002 01:19:39 -0000 1.4
@@ -29,3 +29,5 @@
fun subArr (a, i) = subVec (Primitive.Vector.fromArray a, i)
end
+
+structure PackRealLittle = PackReal64Little
1.5 +62 -57 mlton/basis-library/real/real.sig
Index: real.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/real.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- real.sig 2 Nov 2002 03:37:35 -0000 1.4
+++ real.sig 24 Nov 2002 01:19:39 -0000 1.5
@@ -1,3 +1,8 @@
+structure Real =
+ struct
+ type real = real
+ end
+
structure LargeReal =
struct
type real = real
@@ -5,74 +10,74 @@
signature REAL_GLOBAL =
sig
- structure Math: MATH
type real
+ structure Math: MATH where type real = real
- val ceil: real -> Int.int
- val floor: real -> Int.int
val round: real -> Int.int
val trunc: real -> Int.int
+ val ceil: real -> Int.int
+ val floor: real -> Int.int
end
signature REAL =
sig
include REAL_GLOBAL
- val != : real * real -> bool
- val * : real * real -> real
- val *+ : real * real * real -> real
- val *- : real * real * real -> real
- val + : real * real -> real
- val - : real * real -> real
- val / : real * real -> real
- val < : real * real -> bool
- val <= : real * real -> bool
- val == : real * real -> bool
- val > : real * real -> bool
- val >= : real * real -> bool
- val ?= : real * real -> bool
- val abs: real -> real
- val checkFloat: real -> real
- val class: real -> IEEEReal.float_class
- val compare: real * real -> order
- val compareReal: real * real -> IEEEReal.real_order
- val copySign: real * real -> real
- val fmt: StringCvt.realfmt -> real -> string
- val fromInt: int -> real
- val fromLarge: IEEEReal.rounding_mode -> LargeReal.real -> real
- val fromLargeInt: LargeInt.int -> real
- val fromManExp: {man: real, exp: int} -> real
- val fromString: string -> real option
- val isFinite: real -> bool
- val isNan: real -> bool
- val isNormal: real -> bool
- val max: real * real -> real
- val maxFinite: real
- val min: real * real -> real
- val minNormalPos: real
- val minPos: real
+ val radix: int
+ val precision: int
+ val maxFinite: real
+ val minPos: real
+ val minNormalPos: real
+ val posInf: real
val negInf: real
- val posInf: real
- val precision: int
- val radix: int
- val realCeil: real -> real
- val realFloor: real -> real
- val realMod: real -> real
- val realTrunc: real -> real
- val rem: real * real -> real
- val sameSign: real * real -> bool
+ val + : real * real -> real
+ val - : real * real -> real
+ val * : real * real -> real
+ val / : real * real -> real
+ val rem: real * real -> real
+ val *+ : real * real * real -> real
+ val *- : real * real * real -> real
+ val ~ : real -> real
+ val abs: real -> real
+ val min: real * real -> real
+ val max: real * real -> real
+ val sign: real -> int
+ val signBit: real -> bool
+ val sameSign: real * real -> bool
+ val copySign: real * real -> real
+ val compare: real * real -> order
+ val compareReal: real * real -> IEEEReal.real_order
+ val < : real * real -> bool
+ val <= : real * real -> bool
+ val > : real * real -> bool
+ val >= : real * real -> bool
+ val == : real * real -> bool
+ val != : real * real -> bool
+ val ?= : real * real -> bool
+ val unordered: real * real -> bool
+ val isFinite: real -> bool
+ val isNan: real -> bool
+ val isNormal: real -> bool
+ val class: real -> IEEEReal.float_class
+ val fmt: StringCvt.realfmt -> real -> string
+ val toString: real -> string
val scan: (char, 'a) StringCvt.reader -> (real, 'a) StringCvt.reader
- val sign: real -> int
- val signBit: real -> bool
- val split: real -> {whole: real, frac: real}
- val toInt: IEEEReal.rounding_mode -> real -> int
- val toLarge: real -> LargeReal.real
+ val fromString: string -> real option
+ val toManExp: real -> {man: real, exp: int}
+ val fromManExp: {man: real, exp: int} -> real
+ val split: real -> {whole: real, frac: real}
+ val realMod: real -> real
+ val nextAfter: real * real -> real
+ val checkFloat: real -> real
+ val realFloor: real -> real
+ val realCeil: real -> real
+ val realTrunc: real -> real
+ val toInt: IEEEReal.rounding_mode -> real -> int
val toLargeInt: IEEEReal.rounding_mode -> real -> LargeInt.int
- val toManExp: real -> {man: real, exp: int}
- val toString: real -> string
- val unordered: real * real -> bool
- val ~ : real -> real
-(* val nextAfter: real * real -> real *)
-(* val toDecimal: real -> IEEEReal.decimal_approx *)
-(* val fromDecimal: IEEEReal.decimal_approx -> real *)
+ val fromInt: int -> real
+ val fromLargeInt: LargeInt.int -> real
+ val toLarge: real -> LargeReal.real
+ val fromLarge: IEEEReal.rounding_mode -> LargeReal.real -> real
+ val toDecimal: real -> IEEEReal.decimal_approx
+ val fromDecimal: IEEEReal.decimal_approx -> real option
end
1.15 +34 -12 mlton/basis-library/real/real.sml
Index: real.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/real.sml,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- real.sml 2 Nov 2002 03:37:35 -0000 1.14
+++ real.sml 24 Nov 2002 01:19:39 -0000 1.15
@@ -7,7 +7,7 @@
*
*)
-structure Real: REAL =
+structure Real64: REAL =
struct
structure Real = Primitive.Real
open Real IEEEReal
@@ -81,8 +81,8 @@
(* See runtime/basis/Real.c for the integers returned by class. *)
fun class x =
case Real.class x of
- 0 => NAN QUIET
- | 1 => NAN SIGNALLING
+ 0 => NAN (* QUIET *)
+ | 1 => NAN (* SIGNALLING *)
| 2 => INF
| 3 => ZERO
| 4 => NORMAL
@@ -145,7 +145,7 @@
Real.toInt (Real.round x))
in
case class x of
- NAN _ => raise Domain
+ NAN => raise Domain
| INF => raise Overflow
| ZERO => 0
| NORMAL =>
@@ -188,7 +188,7 @@
local
fun round mode x =
case class x of
- NAN _ => x
+ NAN => x
| INF => x
| _ => withRoundingMode (mode, fn () => Real.round x)
in
@@ -251,7 +251,7 @@
| EXACT => raise Fail "Real.fmt EXACT unimplemented"
in fn x =>
case class x of
- NAN _ => "nan" (* this is wrong *)
+ NAN => "nan"
| INF => if x > 0.0 then "inf" else "~inf"
| ZERO => "0.0"
| _ =>
@@ -266,8 +266,7 @@
val res =
String.translate
(fn #"-" => "~" | c => str c)
- (Primitive.String.fromCharVector
- (Array.extract (buffer, 0, SOME len)))
+ (Array.extract (buffer, 0, SOME len))
in res
end
end
@@ -330,6 +329,23 @@
| SOME (#"~", rest) => (false, rest)
| _ => (true, src )
+ fun sym src =
+ case getc src of
+ SOME (#"i", restA) =>
+ (case Reader.reader2 getc restA of
+ SOME ((#"n", #"f"), restB) =>
+ SOME (posInf,
+ case Reader.readerN (getc, 5) restB of
+ SOME ([#"i", #"n", #"i", #"t", #"y"], restC) => restC
+ | _ => restB)
+ | _ => NONE)
+ | SOME (#"n", restA) =>
+ (case Reader.reader2 getc restA of
+ SOME ((#"a", #"n"), restB) =>
+ SOME (nan, restB)
+ | _ => NONE)
+ | _ => NONE
+
val src = StringCvt.dropl Char.isSpace getc source
val (manpos, src1) = sign src
val (intg, src2) = getint src1
@@ -358,7 +374,9 @@
| (SOME ival, true, NONE ) => mkres ival src2
| (SOME ival, false, NONE ) => expopt ival src2
| (SOME ival, _ , SOME fval) => expopt (ival+fval) src4
- | _ => NONE
+ | _ => (case sym src1 of
+ SOME (v, rest) => mkres v rest
+ | NONE => NONE)
end
fun fromString s = StringCvt.scanString scan s
@@ -481,10 +499,14 @@
else IntInf.~ (pos (~ x, negateMode mode))
end)
end
- end
+ val toDecimal = fn _ => raise (Fail "<Real.toDecimal not implemented>")
+ val fromDecimal = fn _ => raise (Fail "<Real.fromDecimal not implemented>")
+ val nextAfter = fn _ => raise (Fail "<Real.nextAfter not implemented>")
+ end
+
+structure Real = Real64
+structure LargeReal = Real64
structure RealGlobal: REAL_GLOBAL = Real
open RealGlobal
val real = Real.fromInt
-
-structure LargeReal: REAL = Real
1.3 +1 -6 mlton/basis-library/sml-nj/unsafe.sml
Index: unsafe.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/sml-nj/unsafe.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- unsafe.sml 10 Apr 2002 07:02:18 -0000 1.2
+++ unsafe.sml 24 Nov 2002 01:19:40 -0000 1.3
@@ -18,12 +18,7 @@
val update = Primitive.Array.update
val create = Array.array
end
- structure CharVector =
- struct
- type vector = string
- type elem = char
- val sub = Primitive.String.sub
- end
+ structure CharVector = UnsafeMonoVector(type elem = char)
structure Word8Vector = UnsafeMonoVector(type elem = word8)
structure CharArray = UnsafeMonoArray(type elem = char)
structure Word8Array = UnsafeMonoArray(type elem = word8)
1.2 +1 -1 mlton/basis-library/system/date.sig
Index: date.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/date.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- date.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ date.sig 24 Nov 2002 01:19:40 -0000 1.2
@@ -35,6 +35,6 @@
val toString: date -> string
val fmt: string -> date -> string
val fromString: string -> date option
- val scan: (char, 'a) StringCvt.reader -> 'a -> (date * 'a) option
+ val scan: (char, 'a) StringCvt.reader -> (date, 'a) StringCvt.reader
val compare: date * date -> order
end
1.6 +62 -14 mlton/basis-library/system/date.sml
Index: date.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/date.sml,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- date.sml 16 Oct 2001 20:13:35 -0000 1.5
+++ date.sml 24 Nov 2002 01:19:40 -0000 1.6
@@ -34,8 +34,8 @@
wday : weekday,
yday : int, (* 0-365 *)
isDst : bool option, (* daylight savings time in force *)
- offset : int option (* signed seconds East of UTC: this
- zone = UTC+t; ~43200 < t <= 43200 *)
+ offset : int option (* signed seconds East of UTC:
+ this zone = UTC+t; ~82800 < t <= 82800 *)
}
exception Date
@@ -307,8 +307,7 @@
concat ["%", str fmtChar, "\000"])
in if len = 0
then raise Fail "Date.fmt"
- else Primitive.String.fromCharVector (Array.extract
- (buf, 0, SOME len))
+ else Array.extract (buf, 0, SOME len)
end
val max = size fmtStr
fun loop (i, start, accum) =
@@ -358,15 +357,64 @@
fun drop p = StringCvt.dropl p getc
fun isColon c = (c = #":")
- val getMonth = fn "Jan" => Jan | "Feb" => Feb | "Mar" => Mar
- | "Apr" => Apr | "May" => May | "Jun" => Jun
- | "Jul" => Jul | "Aug" => Aug | "Sep" => Sep
- | "Oct" => Oct | "Nov" => Nov | "Dec" => Dec
- | _ => raise BadFormat
- val getWday = fn "Sun" => Sun | "Mon" => Mon | "Tue" => Tue
- | "Wed" => Wed | "Thu" => Thu | "Fri" => Fri
- | "Sat" => Sat
- | _ => raise BadFormat
+ local
+ fun err () = raise BadFormat
+ fun check1 (s, c1, r) = if String.sub(s,1) = c1
+ then r
+ else err ()
+ fun check2 (s, c2, r) = if String.sub(s,2) = c2
+ then r
+ else err ()
+ fun check12 (s, c1, c2, r) = if String.sub(s,1) = c1
+ andalso
+ String.sub(s,2) = c2
+ then r
+ else err ()
+ in
+ val getMonth = fn m =>
+ if String.size m <> 3
+ then err ()
+ else
+ (case String.sub (m, 0) of
+ #"J" => (case String.sub (m, 1) of
+ #"a" => check2 (m, #"n", Jan)
+ | #"u" => (case String.sub (m, 2) of
+ #"n" => Jun
+ | #"l" => Jul
+ | _ => err ())
+ | _ => err ())
+ | #"F" => check12 (m, #"e", #"b", Feb)
+ | #"M" => check1 (m, #"a", case String.sub (m, 2) of
+ #"r" => Mar
+ | #"y" => May
+ | _ => err ())
+ | #"A" => (case String.sub (m, 1) of
+ #"p" => check2 (m, #"r", Apr)
+ | #"u" => check2 (m, #"g", Aug)
+ | _ => err ())
+ | #"S" => check12 (m, #"e", #"p", Sep)
+ | #"O" => check12 (m, #"c", #"t", Oct)
+ | #"N" => check12 (m, #"o", #"v", Nov)
+ | #"D" => check12 (m, #"e", #"c", Dec)
+ | _ => err ())
+ val getWday = fn w =>
+ if String.size w <> 3
+ then err ()
+ else
+ (case String.sub (w, 0) of
+ #"S" => (case String.sub (w,1) of
+ #"u" => check2 (w, #"n", Sun)
+ | #"a" => check2 (w, #"t", Sat)
+ | _ => err ())
+ | #"M" => check12 (w, #"o", #"n", Mon)
+ | #"T" => (case String.sub (w,1) of
+ #"u" => check2 (w, #"e", Tue)
+ | #"h" => check2 (w, #"u", Thu)
+ | _ => err ())
+ | #"W" => check12 (w, #"e", #"d", Wed)
+ | #"F" => check12 (w, #"r", #"i", Fri)
+ | _ => err ())
+ end
val (wday, src1) = getstring src
val (month, src2) = getstring (drop Char.isSpace src1)
@@ -414,7 +462,7 @@
| SOME time =>
let val secs = Time.toSeconds time
val secoffset =
- if secs <= 43200 then ~secs else 86400 - secs
+ if secs <= 82800 then ~secs else 86400 - secs
in (Int.quot (secs, 86400), SOME secoffset) end
val day' = day + dayoffset
in
1.2 +24 -26 mlton/basis-library/system/file-sys.sig
Index: file-sys.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/file-sys.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- file-sys.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ file-sys.sig 24 Nov 2002 01:19:40 -0000 1.2
@@ -2,36 +2,34 @@
sig
type dirstream
- val openDir: string -> dirstream
- val readDir: dirstream -> string
- val rewindDir: dirstream -> unit
- val closeDir: dirstream -> unit
+ val openDir: string -> dirstream
+ val readDir: dirstream -> string option
+ val rewindDir: dirstream -> unit
+ val closeDir: dirstream -> unit
val chDir: string -> unit
- val getDir: unit -> string
- val mkDir: string -> unit
- val rmDir: string -> unit
- val isDir: string -> bool
- val isLink: string -> bool
- val readLink: string -> string
- val fullPath: string -> string
- val realPath: string -> string
- val modTime: string -> Time.time
- val fileSize: string -> Position.int
- val setTime: string * Time.time option -> unit
- val remove: string -> unit
+ val getDir: unit -> string
+ val mkDir: string -> unit
+ val rmDir: string -> unit
+ val isDir: string -> bool
+ val isLink: string -> bool
+ val readLink: string -> string
+ val fullPath: string -> string
+ val realPath: string -> string
+ val modTime: string -> Time.time
+ val fileSize: string -> Position.int
+ val setTime: string * Time.time option -> unit
+ val remove: string -> unit
val rename: {old: string, new: string} -> unit
-
- datatype access_mode =
- A_READ
- | A_WRITE
- | A_EXEC
-
- val access: string * access_mode list -> bool
- val tmpName: unit -> string
+
+ datatype access_mode = A_READ | A_WRITE | A_EXEC
+
+ val access: string * access_mode list -> bool
+ val tmpName: unit -> string
eqtype file_id
- val fileId: string -> file_id
- val hash: file_id -> word
+ val fileId: string -> file_id
+ val hash: file_id -> word
val compare: file_id * file_id -> order
end
+
1.2 +25 -22 mlton/basis-library/system/file-sys.sml
Index: file-sys.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/file-sys.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- file-sys.sml 18 Jul 2001 05:51:02 -0000 1.1
+++ file-sys.sml 24 Nov 2002 01:19:40 -0000 1.2
@@ -46,26 +46,30 @@
val oldCWD = getDir()
fun mkPath pathFromRoot =
P.toString{isAbs=true, vol="", arcs=List.rev pathFromRoot}
- fun walkPath (0, _, _) =
- raise PosixError.SysErr("too many links", NONE)
- | walkPath (n, pathFromRoot, []) =
- mkPath pathFromRoot
- | walkPath (n, pathFromRoot, "" :: al) =
- walkPath (n, pathFromRoot, al)
- | walkPath (n, pathFromRoot, "." :: al) =
- walkPath (n, pathFromRoot, al)
- | walkPath (n, [], ".." :: al) =
- walkPath (n, [], al)
- | walkPath (n, _ :: r, ".." :: al) =
- (chDir ".."; walkPath (n, r, al))
- | walkPath (n, pathFromRoot, [arc]) =
- if (isLink arc)
- then expandLink (n, pathFromRoot, arc, [])
- else mkPath (arc :: pathFromRoot)
- | walkPath (n, pathFromRoot, arc :: al) =
- if (isLink arc)
- then expandLink (n, pathFromRoot, arc, al)
- else (chDir arc; walkPath (n, arc :: pathFromRoot, al))
+ fun walkPath (n, pathFromRoot, arcs) =
+ if n = 0
+ then raise PosixError.SysErr ("too many links", NONE)
+ else
+ case arcs of
+ [] => mkPath pathFromRoot
+ | arc :: al =>
+ if arc = "" orelse arc = "."
+ then walkPath (n, pathFromRoot, al)
+ else if arc = ".."
+ then
+ (case pathFromRoot of
+ [] => walkPath (n, [], al)
+ | _ :: r =>
+ (chDir ".."; walkPath (n, r, al)))
+ else
+ if isLink arc
+ then expandLink (n, pathFromRoot, arc, [])
+ else
+ case al of
+ [] => mkPath (arc :: pathFromRoot)
+ | _ =>
+ (chDir arc
+ ; walkPath (n, arc :: pathFromRoot, al))
and expandLink (n, pathFromRoot, link, rest) =
(
case (P.fromString(readLink link))
@@ -133,8 +137,7 @@
}
end
- fun hash (FID{dev, ino}) = sysWordToWord(
- SysWord.+(SysWord.<<(dev, 0w16), ino))
+ fun hash (FID{dev, ino}) = sysWordToWord(SysWord.+(SysWord.<<(dev, 0w16), ino))
fun compare (FID{dev=d1, ino=i1}, FID{dev=d2, ino=i2}) =
if (SysWord.<(d1, d2))
1.2 +22 -30 mlton/basis-library/system/io.sig
Index: io.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/io.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- io.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ io.sig 24 Nov 2002 01:19:40 -0000 1.2
@@ -1,40 +1,32 @@
signature OS_IO =
sig
eqtype iodesc
-
- val hash: iodesc -> word
- val compare: (iodesc * iodesc) -> order
-
+ val hash: iodesc -> word
+ val compare: iodesc * iodesc -> order
eqtype iodesc_kind
-
- val kind: iodesc -> iodesc_kind
-
- structure Kind:
+ val kind: iodesc -> iodesc_kind
+ structure Kind:
sig
- val file: iodesc_kind
- val dir: iodesc_kind
- val symlink: iodesc_kind
- val tty: iodesc_kind
- val pipe: iodesc_kind
- val socket: iodesc_kind
- val device: iodesc_kind
+ val file: iodesc_kind
+ val dir: iodesc_kind
+ val symlink: iodesc_kind
+ val tty: iodesc_kind
+ val pipe: iodesc_kind
+ val socket: iodesc_kind
+ val device: iodesc_kind
end
-(*
- type poll_desc
- type poll_info
-
- val pollDesc: iodesc -> poll_desc option
- val pollToIODesc: poll_desc -> iodesc
+ eqtype poll_desc
+ type poll_info
+ val pollDesc: iodesc -> poll_desc option
+ val pollToIODesc: poll_desc -> iodesc
exception Poll
-
- val pollIn: poll_desc -> poll_desc
- val pollOut: poll_desc -> poll_desc
- val pollPri: poll_desc -> poll_desc
- val poll: poll_desc list * Time.time option -> poll_info list
- val isIn: poll_info -> bool
- val isOut: poll_info -> bool
- val isPri: poll_info -> bool
+ val pollIn: poll_desc -> poll_desc
+ val pollOut: poll_desc -> poll_desc
+ val pollPri: poll_desc -> poll_desc
+ val poll: poll_desc list * Time.time option -> poll_info list
+ val isIn: poll_info -> bool
+ val isOut: poll_info -> bool
+ val isPri: poll_info -> bool
val infoToPollDesc: poll_info -> poll_desc
-*)
end
1.2 +36 -21 mlton/basis-library/system/io.sml
Index: io.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/io.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- io.sml 18 Jul 2001 05:51:02 -0000 1.1
+++ io.sml 24 Nov 2002 01:19:40 -0000 1.2
@@ -1,4 +1,6 @@
(* modified from SML/NJ sources by Stephen Weeks 1998-6-25 *)
+(* modified by Matthew Fluet 2002-10-11 *)
+(* modified by Matthew Fluet 2002-11-21 *)
(* os-io.sml
*
@@ -15,15 +17,15 @@
(* an iodesc is an abstract descriptor for an OS object that
* supports I/O (e.g., file, tty device, socket, ...).
*)
- type iodesc = int (* sweeks OS.IO.iodesc *)
+ datatype iodesc = datatype PreOS.IO.iodesc
datatype iodesc_kind = K of string
(* return a hash value for the I/O descriptor. *)
- fun hash (fd) = Word.fromInt fd
+ fun hash (FD fd) = Word.fromInt fd
(* compare two I/O descriptors *)
- fun compare (fd1, fd2) = Int.compare(fd1, fd2)
+ fun compare (FD fd1, FD fd2) = Int.compare(fd1, fd2)
structure Kind =
struct
@@ -38,7 +40,6 @@
(* return the kind of I/O descriptor *)
fun kind (fd) = let
- val fd = Posix.FileSys.wordToFD(SysWord.fromInt fd)
val stat = Posix.FileSys.fstat fd
in
if (Posix.FileSys.ST.isReg stat) then Kind.file
@@ -50,7 +51,7 @@
else if (Posix.FileSys.ST.isSock stat) then Kind.socket
else K "UNKNOWN"
end
-(*
+
type poll_flags = {rd: bool, wr: bool, pri: bool}
datatype poll_desc = PollDesc of (iodesc * poll_flags)
datatype poll_info = PollInfo of (iodesc * poll_flags)
@@ -78,30 +79,45 @@
(* polling function *)
local
- val poll': ((int * word) list * (Int32.int * int) option) -> (int * word) list =
- CInterface.c_function "POSIX-OS" "poll"
+ structure Prim = Primitive.OS.IO
fun join (false, _, w) = w
| join (true, b, w) = Word.orb(w, b)
fun test (w, b) = (Word.andb(w, b) <> 0w0)
- val rdBit = 0w1 and wrBit = 0w2 and priBit = 0w4
- fun fromPollDesc (PollDesc(fd, {rd, wr, pri})) =
+ val rdBit : Word.word = 0w1
+ and wrBit : Word.word = 0w2
+ and priBit : Word.word = 0w4
+ fun fromPollDesc (PollDesc(FD fd, {rd, wr, pri})) =
( fd,
- join (rd, rdBit, join (wr, wrBit, join (pri, priBit, 0w0)))
+ join (rd, rdBit,
+ join (wr, wrBit,
+ join (pri, priBit, 0w0)))
)
- fun toPollInfo (fd, w) = PollInfo(fd, {
- rd = test(w, rdBit), wr = test(w, wrBit), pri = test(w, priBit)
+ fun toPollInfo (fd, w) = PollInfo(FD fd, {
+ rd = test(w, rdBit),
+ wr = test(w, wrBit),
+ pri = test(w, priBit)
})
in
fun poll (pds, timeOut) = let
- val timeOut =
+ val (fds, eventss) = ListPair.unzip (List.map fromPollDesc pds)
+ val fds = Vector.fromList fds
+ val n = Vector.length fds
+ val eventss = Vector.fromList eventss
+ val timeOut =
case timeOut of
- (* sweeks *)
- SOME(Time.T{sec, usec}) => SOME(sec, Int.fromLarge usec)
- | NONE => NONE
- (* end case *))
- val info = poll' (List.map fromPollDesc pds, timeOut)
+ SOME t => Int.fromLarge (Time.toMilliseconds t)
+ | NONE => ~1
+ val reventss = Array.array (n, 0w0)
+ val _ = Posix.Error.checkResult
+ (Prim.poll (fds, eventss, n, timeOut, reventss))
in
- List.map toPollInfo info
+ Array.foldri
+ (fn (i, w, l) =>
+ if w <> 0w0
+ then (toPollInfo (Vector.sub (fds, i), w))::l
+ else l)
+ []
+ reventss
end
end (* local *)
@@ -109,8 +125,7 @@
fun isIn (PollInfo(_, flgs)) = #rd flgs
fun isOut (PollInfo(_, flgs)) = #wr flgs
fun isPri (PollInfo(_, flgs)) = #pri flgs
- fun infoToPollDesc (PollInfo arg) = PollDesc arg
-*)
+ fun infoToPollDesc (PollInfo arg) = PollDesc arg
end (* OS_IO *)
1.2 +5 -8 mlton/basis-library/system/os.sig
Index: os.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/os.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- os.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ os.sig 24 Nov 2002 01:19:40 -0000 1.2
@@ -1,15 +1,12 @@
signature OS =
sig
- eqtype syserror
-
- exception SysErr of string * syserror option
-
- val errorMsg: syserror -> string
- val errorName: syserror -> string
- val syserror: string -> syserror option
-
structure FileSys: OS_FILE_SYS
structure Path: OS_PATH
structure Process: OS_PROCESS
structure IO: OS_IO
+ eqtype syserror
+ exception SysErr of string * syserror option
+ val errorMsg: syserror -> string
+ val errorName: syserror -> string
+ val syserror: string -> syserror option
end
1.3 +1 -2 mlton/basis-library/system/os.sml
Index: os.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/os.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- os.sml 10 Apr 2002 07:02:18 -0000 1.2
+++ os.sml 24 Nov 2002 01:19:40 -0000 1.3
@@ -7,10 +7,9 @@
*)
structure OS: OS =
struct
- open PosixError
-
structure FileSys = OS_FileSys
structure Path = OS_Path
structure Process = OS_Process
structure IO = OS_IO
+ open PosixError
end
1.4 +26 -30 mlton/basis-library/system/path.sig
Index: path.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/path.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- path.sig 4 Jun 2002 21:21:19 -0000 1.3
+++ path.sig 24 Nov 2002 01:19:40 -0000 1.4
@@ -1,35 +1,31 @@
signature OS_PATH =
sig
exception Path
-(* exception InvalidArc *)
+ exception InvalidArc
+ val parentArc: string
+ val currentArc: string
+ val validVolume: {isAbs: bool, vol: string} -> bool
+ val fromString: string -> {isAbs: bool, vol: string, arcs: string list}
+ val toString: {isAbs: bool, vol: string, arcs: string list} -> string
+ val getVolume: string -> string
+ val getParent: string -> string
+ val splitDirFile: string -> {dir: string, file: string}
+ val joinDirFile: {dir: string, file: string} -> string
+ val dir: string -> string
+ val file: string -> string
+ val splitBaseExt: string -> {base: string, ext: string option}
+ val joinBaseExt: {base: string, ext: string option} -> string
+ val base: string -> string
+ val ext: string -> string option
+ val mkCanonical: string -> string
+ val isCanonical: string -> bool
+ val mkAbsolute: {path: string, relativeTo: string} -> string
+ val mkRelative: {path: string, relativeTo: string} -> string
+ val isAbsolute: string -> bool
+ val isRelative: string -> bool
+ val isRoot: string -> bool
+ val concat: string * string -> string
- val parentArc: string
- val currentArc: string
- val validVolume: {isAbs: bool, vol: string} -> bool
- val fromString: string -> {isAbs: bool,
- vol: string,
- arcs: string list}
- val toString: {isAbs: bool, vol: string, arcs: string list} -> string
- val getVolume: string -> string
- val getParent: string -> string
- val splitDirFile: string -> {dir: string, file: string}
- val joinDirFile: {dir: string, file: string} -> string
- val dir: string -> string
- val file: string -> string
- val splitBaseExt: string -> {base: string, ext: string option}
- val joinBaseExt: {base: string, ext: string option} -> string
- val base: string -> string
- val ext: string -> string option
- val mkCanonical: string -> string
- val isCanonical: string -> bool
- val mkAbsolute: {path:string, relativeTo:string} -> string
- val mkRelative: {path:string, relativeTo:string} -> string
-
- val isAbsolute: string -> bool
- val isRelative: string -> bool
- val isRoot: string -> bool
- val concat: (string * string) -> string
-(* val toUnixPath: string -> string
- * val fromUnixPath: string -> string
- *)
+ val fromUnixPath: string -> string
+ val toUnixPath: string -> string
end
1.4 +83 -41 mlton/basis-library/system/path.sml
Index: path.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/path.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- path.sml 4 Jun 2002 21:21:19 -0000 1.3
+++ path.sml 24 Nov 2002 01:19:40 -0000 1.4
@@ -6,6 +6,7 @@
structure OS_Path : OS_PATH = struct
exception Path
+ exception InvalidArc
(* It would make sense to use substrings for internal versions of
* fromString and toString, and to allocate new strings only when
@@ -50,15 +51,22 @@
fun isRelative p = not (isAbsolute p);
fun fromString p =
- case splitabsvolrest p of
- (false, v, "") => {isAbs=false, vol = v, arcs = []}
- | (isAbs, v, rest) => {isAbs=isAbs, vol = v,
- arcs = String.fields isslash rest};
+ let
+ val (isAbs, v, rest) = splitabsvolrest p
+ in
+ if not isAbs andalso rest = ""
+ then {isAbs = false, vol = v, arcs = []}
+ else {arcs = String.fields isslash rest,
+ isAbs = isAbs,
+ vol = v}
+ end
fun isRoot p =
- case splitabsvolrest p of
- (true, _, "") => true
- | _ => false;
+ let
+ val (isAbs, _, rest) = splitabsvolrest p
+ in
+ isAbs andalso rest = ""
+ end
fun getVolume p = #2 (splitabsvolrest p);
fun validVolume{isAbs, vol} = validVol vol;
@@ -67,16 +75,22 @@
let fun h [] res = res
| h (a :: ar) res = h ar (a :: slash :: res)
in
- if validVolume{isAbs=isAbs, vol=vol} then
- case (isAbs, arcs) of
- (false, [] ) => vol
- | (false, "" :: _ ) => raise Path
- | (false, a1 :: arest) =>
- String.concat (vol :: List.rev (h arest [a1]))
-
- | (true, [] ) => vol ^ volslash
- | (true, a1 :: arest ) =>
- String.concat (List.rev (h arest [a1, volslash, vol]))
+ if validVolume {isAbs = isAbs, vol = vol}
+ then
+ if isAbs
+ then
+ (case arcs of
+ [] => vol ^ volslash
+ | a1 :: arest =>
+ String.concat
+ (List.rev (h arest [a1, volslash, vol])))
+ else
+ case arcs of
+ [] => vol
+ | a1 :: arest =>
+ if a1 = ""
+ then raise Path
+ else String.concat (vol :: List.rev (h arest [a1]))
else
raise Path
end;
@@ -89,11 +103,18 @@
in
if isAbsolute p2 then raise Path
else
- case splitabsvolrest p1 of
- (false, "", "") => p2
- | (false, v, path) => v ^ stripslash path ^ slash ^ p2
- | (true, v, "" ) => v ^ volslash ^ p2
- | (true, v, path) => v ^ volslash ^ stripslash path ^ slash ^ p2
+ let
+ val (isAbs, v, path) = splitabsvolrest p1
+ in
+ if isAbs
+ then if path = ""
+ then v ^ volslash ^ p2
+ else String.concat [v, volslash, stripslash path,
+ slash, p2]
+ else if v = "" andalso path = ""
+ then p2
+ else String.concat [v, stripslash path, slash, p2]
+ end
end
fun getParent p =
@@ -101,12 +122,16 @@
val {isAbs, vol, arcs} = fromString p
fun getpar xs =
rev (case rev xs of
- [] => [parentArc]
- | [""] => if isAbs then [] else [parentArc]
- | "" :: revrest => parentArc :: revrest
- | "." :: revrest => parentArc :: revrest
- | ".." :: revrest => parentArc :: parentArc :: revrest
- | last :: revrest => revrest)
+ [] => [parentArc]
+ | last :: revrest =>
+ if last = ""
+ andalso (case revrest of [] => true | _ => false)
+ then if isAbs then [] else [parentArc]
+ else if last = "" orelse last = "."
+ then parentArc :: revrest
+ else if last = ".."
+ then parentArc :: parentArc :: revrest
+ else revrest)
in
case getpar arcs of
[] =>
@@ -117,16 +142,26 @@
fun mkCanonical p =
let val {isAbs, vol, arcs} = fromString p
- fun backup [] = if isAbs then [] else [parentArc]
- | backup (".."::res) = parentArc :: parentArc :: res
- | backup ( _ :: res) = res
+ fun backup l =
+ case l of
+ [] => if isAbs then [] else [parentArc]
+ | first :: res =>
+ if first = ".."
+ then parentArc :: parentArc :: res
+ else res
fun reduce arcs =
- let fun h [] [] = if isAbs then [""] else [currentArc]
- | h [] res = res
- | h (""::ar) res = h ar res
- | h ("."::ar) res = h ar res
- | h (".."::ar) res = h ar (backup res)
- | h (a1::ar) res = h ar (a1 :: res)
+ let
+ fun h l res =
+ case l of
+ [] => (case res of
+ [] => if isAbs then [""] else [currentArc]
+ | _ => res)
+ | a1 :: ar =>
+ if a1 = "" orelse a1 = "."
+ then h ar res
+ else if a1 = ".."
+ then h ar (backup res)
+ else h ar (a1 :: res)
in h arcs [] end
in
toString {isAbs=isAbs, vol=vol, arcs=List.rev (reduce arcs)}
@@ -176,9 +211,13 @@
fun dir s = #dir (splitDirFile s);
fun file s = #file(splitDirFile s);
- fun joinBaseExt {base, ext = NONE} = base
- | joinBaseExt {base, ext = SOME ""} = base
- | joinBaseExt {base, ext = SOME ex} = base ^ "." ^ ex;
+ fun joinBaseExt {base, ext} =
+ case ext of
+ NONE => base
+ | SOME ex =>
+ if ex = ""
+ then base
+ else String.concat [base, ".", ex]
fun splitBaseExt s =
let val {dir, file} = splitDirFile s
@@ -200,9 +239,12 @@
fun isRoot path =
case fromString path of
- {isAbs = true, arcs= [""], ...} => true
+ {isAbs = true, arcs= [a], ...} => a = ""
| _ => false
end
+
+ fun fromUnixPath _ = raise (Fail "<Path.fromUnixPath not implemented>")
+ fun toUnixPath _ = raise (Fail "<Path.toUnixPath not implemented>")
end (*structure Path*)
1.2 +9 -8 mlton/basis-library/system/process.sig
Index: process.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/process.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- process.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ process.sig 24 Nov 2002 01:19:40 -0000 1.2
@@ -1,14 +1,15 @@
signature OS_PROCESS =
sig
- eqtype status
-
- val atExit: (unit -> unit) -> unit
- val exit: status -> 'a
- val failure: status
+ type status
+ val success: status
+ val failure: status
+ val isSuccess: status -> bool
+ val system: string -> status
+ val atExit: (unit -> unit) -> unit
+ val exit: status -> 'a
+ val terminate: status -> 'a
val getEnv: string -> string option
- val success: status
- val system: string -> status
- val terminate: status -> 'a
+ val sleep: Time.time -> unit
end
signature OS_PROCESS_EXTRA =
1.7 +10 -4 mlton/basis-library/system/process.sml
Index: process.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/process.sml,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- process.sml 10 Apr 2002 07:44:18 -0000 1.6
+++ process.sml 24 Nov 2002 01:19:40 -0000 1.7
@@ -16,11 +16,13 @@
open Posix.Process
structure Signal = MLton.Signal
- type status = int
+ type status = PreOS.Process.status
val success: status = 0
val failure: status = 1
+ fun isSuccess st = st = success
+
fun wait pid =
case #2 (waitpid (W_CHILD pid, [])) of
W_EXITED => success
@@ -47,10 +49,14 @@
end
fun atExit f = Cleaner.addNew (Cleaner.atExit, f)
-
- fun terminate x = exit (Word8.fromInt x)
-
+
val exit = MLton.Process.exit
+ fun terminate x = Posix.Process.exit (Word8.fromInt x)
+
val getEnv = Posix.ProcEnv.getenv
+
+ fun sleep t = if Time.<=(t, Time.zeroTime)
+ then ()
+ else (Posix.Process.sleep t; ())
end
1.2 +1 -2 mlton/basis-library/system/time.sig
Index: time.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/time.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- time.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ time.sig 24 Nov 2002 01:19:40 -0000 1.2
@@ -1,7 +1,6 @@
signature TIME =
sig
eqtype time
-
exception Time
val zeroTime: time
@@ -24,7 +23,7 @@
val fmt: int -> time -> string
val toString: time -> string
val fromString: string -> time option
- val scan: (char, 'a) StringCvt.reader -> 'a -> (time * 'a) option
+ val scan: (char, 'a) StringCvt.reader -> (time, 'a) StringCvt.reader
end
signature TIME_EXTRA =
1.5 +106 -99 mlton/basis-library/system/time.sml
Index: time.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/time.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- time.sml 19 Sep 2002 16:58:42 -0000 1.4
+++ time.sml 24 Nov 2002 01:19:40 -0000 1.5
@@ -8,28 +8,30 @@
structure Time: TIME_EXTRA =
struct
structure Prim = Primitive.Time
-
- (* Inv: sec >= 0 and 0 <= usec < 1000000 *)
+
+ (* Inv: 0 <= usec < 1000000 *)
datatype time = T of {sec: Int.int,
- usec: Int.int}
+ usec: Int.int}
datatype time' = datatype time
exception Time
+ val thousand'': IntInf.int = 1000
+ val thousand': LargeInt.int = 1000
val thousand: int = 1000
+ val million'': IntInf.int = 1000000
+ val million': LargeInt.int = 1000000
val million: int = 1000000
val zeroTime = T {sec = 0,
usec = 0}
-
- fun fromReal (r: LargeReal.real): time =
- if r < 0.0
- then raise Time
- else let
- val sec = LargeReal.floor r
- val usec = LargeReal.floor (1E6 * (r - (LargeReal.fromInt sec)))
- in T {sec = sec, usec = usec}
- end handle Overflow => raise Time
-
+
+ fun fromReal (r: LargeReal.real): time =
+ let
+ val sec = LargeReal.floor r
+ val usec = LargeReal.floor (1E6 * (r - (LargeReal.fromInt sec)))
+ in T {sec = sec, usec = usec}
+ end handle Overflow => raise Time
+
fun toReal (T {sec, usec}): LargeReal.real =
LargeReal.fromInt sec + (LargeReal.fromInt usec / 1E6)
@@ -37,41 +39,37 @@
LargeInt.fromInt sec
fun toMilliseconds (T {sec, usec}): LargeInt.int =
- 1000 * LargeInt.fromInt sec
+ thousand' * LargeInt.fromInt sec
+ LargeInt.fromInt (Int.quot (usec, thousand))
fun toMicroseconds (T {sec, usec}): LargeInt.int =
- 1000000 * LargeInt.fromInt sec + LargeInt.fromInt usec
+ million' * LargeInt.fromInt sec + LargeInt.fromInt usec
fun convert (s: LargeInt.int): int =
LargeInt.toInt s handle Overflow => raise Time
fun fromSeconds (s: LargeInt.int): time =
- if Primitive.safe andalso s < 0
- then raise Time
- else T {sec = convert s, usec = 0}
-
- fun fromMilliseconds (ms: LargeInt.int): time =
- if Primitive.safe andalso ms < 0
- then raise Time
- else
- let
- val (sec, ms) = IntInf.quotRem (ms, 1000)
- in
- T {sec = convert sec,
- usec = LargeInt.toInt ms * 1000}
- end
-
+ T {sec = convert s, usec = 0}
+
+ fun fromMilliseconds (msec: LargeInt.int): time =
+ let
+ val msec = IntInf.fromLarge msec
+ val (sec, msec) = IntInf.divMod (msec, thousand'')
+ val (sec, msec) = (IntInf.toLarge sec, IntInf.toLarge msec)
+ in
+ T {sec = convert sec,
+ usec = (LargeInt.toInt msec) * thousand}
+ end
+
fun fromMicroseconds (usec: LargeInt.int): time =
- if Primitive.safe andalso usec < 0
- then raise Time
- else
- let
- val (sec, usec) = IntInf.quotRem (usec, 1000000)
- in
- T {sec = convert sec,
- usec = LargeInt.toInt usec}
- end
+ let
+ val usec = IntInf.fromLarge usec
+ val (sec, usec) = IntInf.divMod (usec, million'')
+ val (sec, usec) = (IntInf.toLarge sec, IntInf.toLarge usec)
+ in
+ T {sec = convert sec,
+ usec = LargeInt.toInt usec}
+ end
val add =
fn (T {sec = s, usec = u}, T {sec = s', usec = u'}) =>
@@ -87,22 +85,21 @@
end
(* Basis spec says Overflow, not Time, should be raised. *)
(* handle Overflow => raise Time *)
-
+
val sub =
- fn (t1 as T {sec = s, usec = u}, t2 as T {sec = s', usec = u'}) =>
- if s < s' orelse (s = s' andalso u < u')
- then raise Time
- else
- let
- val s'' = s -? s'
- val u'' = u -? u'
- in
+ fn (T {sec = s, usec = u}, T {sec = s', usec = u'}) =>
+ let
+ val s'' = s - s' (* overflow possible *)
+ val u'' = u -? u'
+ val (s'', u'') =
if u'' < 0
- then T {sec = s'' -? 1,
- usec = u'' +? million}
- else T {sec = s'',
- usec = u''}
- end
+ then (s'' - 1, (* overflow possible *)
+ u'' +? million)
+ else (s'', u'')
+ in T {sec = s'', usec = u''}
+ end
+ (* Basis spec says Overflow, not Time, should be raised. *)
+ (* handle Overflow => raise Time *)
fun compare (T {sec = s, usec = u}, T {sec = s', usec = u'}) =
if s > s'
@@ -140,54 +137,64 @@
val toString = fmt 3
- (* Copied from MLKitV3 basislib/Time.sml*)
- fun scan getc source =
+ (* Adapted from MLKitV3 basislib/Time.sml*)
+ fun scan getc src =
let
- fun skipWSget getc source =
- getc (StringCvt.dropl Char.isSpace getc source)
- fun decval c = Char.ord c -? 48;
- fun pow10 0 = 1
- | pow10 n = 10 * pow10 (n-1)
- fun mktime intgv decs fracv =
- let val usecs = (pow10 (7-decs) * fracv + 5) div 10
- in
- T {sec = floor (intgv + 0.5) + usecs div 1000000,
- usec = usecs mod 1000000}
- end
- fun skipdigs src =
- case getc src of
- NONE => src
- | SOME (c, rest) => if Char.isDigit c then skipdigs rest
- else src
- fun frac intgv decs fracv src =
- if decs >= 7 then SOME (mktime intgv decs fracv, skipdigs src)
- else case getc src of
- NONE => SOME (mktime intgv decs fracv, src)
- | SOME (c, rest) =>
- if Char.isDigit c then
- frac intgv (decs+1) (10 * fracv + decval c) rest
- else
- SOME (mktime intgv decs fracv, src)
- fun intg intgv src =
- case getc src of
- NONE => SOME (mktime intgv 6 0, src)
- | SOME (#".", rest) => frac intgv 0 0 rest
- | SOME (c, rest) =>
- if Char.isDigit c then
- intg (10.0 * intgv + real (decval c)) rest
- else SOME (mktime intgv 6 0, src)
- in case skipWSget getc source of
- NONE => NONE
- | SOME (#".", rest) =>
- (case getc rest of
- NONE => NONE
- | SOME (c, rest) =>
- if Char.isDigit c then frac 0.0 1 (decval c) rest
- else NONE)
- | SOME (c, rest) =>
- if Char.isDigit c then intg (real (decval c)) rest else NONE
+ val charToDigit = StringCvt.charToDigit StringCvt.DEC
+ fun pow10 0 = 1
+ | pow10 n = 10 * pow10 (n-1)
+ fun mkTime sign intv fracv decs =
+ let
+ val sec = intv
+ val usec = (pow10 (7-decs) * fracv + 5) div 10
+ val t = T {sec = intv, usec = usec}
+ in
+ if sign then t else sub (zeroTime, t)
+ end
+ fun frac' sign intv fracv decs src =
+ if decs >= 7
+ then SOME (mkTime sign intv fracv decs,
+ StringCvt.dropl Char.isDigit getc src)
+ else case getc src of
+ NONE => SOME (mkTime sign intv fracv decs, src)
+ | SOME (c, rest) =>
+ (case charToDigit c of
+ NONE => SOME (mkTime sign intv fracv decs, src)
+ | SOME d => frac' sign intv (10 * fracv + d) (decs + 1) rest)
+ fun frac sign intv src =
+ case getc src of
+ NONE => NONE
+ | SOME (c, rest) =>
+ (case charToDigit c of
+ NONE => NONE
+ | SOME d => frac' sign intv d 1 rest)
+ fun int' sign intv src =
+ case getc src of
+ NONE => SOME (mkTime sign intv 0 7, src)
+ | SOME (#".", rest) => frac sign intv rest
+ | SOME (c, rest) =>
+ (case charToDigit c of
+ NONE => SOME (mkTime sign intv 0 7, src)
+ | SOME d => int' sign (10 * intv + d) rest)
+ fun int sign src =
+ case getc src of
+ NONE => NONE
+ | SOME (c, rest) =>
+ (case charToDigit c of
+ NONE => NONE
+ | SOME d => int' sign d rest)
+ in
+ case getc (StringCvt.skipWS getc src) of
+ NONE => NONE
+ | SOME (#"+", rest) => int true rest
+ | SOME (#"~", rest) => int false rest
+ | SOME (#"-", rest) => int false rest
+ | SOME (#".", rest) => frac true 0 rest
+ | SOME (c, rest) =>
+ (case charToDigit c of
+ NONE => NONE
+ | SOME d => int' true d rest)
end
-
val fromString = StringCvt.scanString scan
val op + = add
1.2 +7 -9 mlton/basis-library/system/timer.sig
Index: timer.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/timer.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- timer.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ timer.sig 24 Nov 2002 01:19:40 -0000 1.2
@@ -2,13 +2,11 @@
sig
type cpu_timer
type real_timer
-
- val checkCPUTimer: cpu_timer -> {gc: Time.time,
- sys: Time.time,
- usr: Time.time}
- val checkRealTimer: real_timer -> Time.time
- val startCPUTimer: unit -> cpu_timer
- val startRealTimer: unit -> real_timer
- val totalCPUTimer: unit -> cpu_timer
- val totalRealTimer: unit -> real_timer
+ val startCPUTimer: unit -> cpu_timer
+ val checkCPUTimer: cpu_timer -> {usr: Time.time, sys: Time.time}
+ val checkGCTime: cpu_timer -> Time.time
+ val totalCPUTimer: unit -> cpu_timer
+ val startRealTimer: unit -> real_timer
+ val checkRealTimer: real_timer -> Time.time
+ val totalRealTimer: unit -> real_timer
end
1.2 +14 -10 mlton/basis-library/system/timer.sml
Index: timer.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/timer.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- timer.sml 18 Jul 2001 05:51:02 -0000 1.1
+++ timer.sml 24 Nov 2002 01:19:40 -0000 1.2
@@ -15,9 +15,9 @@
usr = selfu}
end
- fun checkCPUTimer ({gc, sys, usr}: cpu_timer) =
+ fun checkCPUTimer ({gc, sys, usr, ...}: cpu_timer) =
let
- val {gc = g, sys = s, usr = u} = startCPUTimer ()
+ val {gc = g, sys = s, usr = u, ...} = startCPUTimer ()
val op - = Time.-
in
{gc = g - gc,
@@ -26,22 +26,26 @@
end
val totalCPUTimer =
- let
- val t = startCPUTimer ()
+ let val t = startCPUTimer ()
in fn () => checkCPUTimer t
end
+ val checkGCTime = fn t => let val {gc, ...} = checkCPUTimer t
+ in gc
+ end
+ val checkCPUTimer = fn t => let val {usr, sys, ...} = checkCPUTimer t
+ in {usr = usr, sys = sys}
+ end
+
type real_timer = Time.time
- fun startRealTimer (): real_timer = Posix.ProcEnv.time ()
+ fun startRealTimer (): real_timer = Time.now ()
fun checkRealTimer (t: real_timer): Time.time =
- Time.- (Posix.ProcEnv.time (), t)
+ Time.- (startRealTimer (), t)
val totalRealTimer =
- let
- val t = startRealTimer ()
- in
- fn () => checkRealTimer t
+ let val t = startRealTimer ()
+ in fn () => checkRealTimer t
end
end
1.2 +18 -7 mlton/basis-library/system/unix.sig
Index: unix.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/unix.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- unix.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ unix.sig 24 Nov 2002 01:19:40 -0000 1.2
@@ -1,11 +1,22 @@
signature UNIX =
sig
- type proc
+ type ('a, 'b) proc
type signal
-
- val executeInEnv: string * string list * string list -> proc
- val execute: string * string list -> proc
- val streamsOf: proc -> TextIO.instream * TextIO.outstream
- val reap: proc -> OS.Process.status
- val kill: proc * signal -> unit
+ datatype exit_status =
+ W_EXITED
+ | W_EXITSTATUS of Word8.word
+ | W_SIGNALED of signal
+ | W_STOPPED of signal
+ val fromStatus: OS.Process.status -> exit_status
+ val executeInEnv: string * string list * string list -> ('a, 'b) proc
+ val execute: string * string list -> ('a, 'b) proc
+ val textInstreamOf: (TextIO.instream, 'a) proc -> TextIO.instream
+ val binInstreamOf: (BinIO.instream, 'a) proc -> BinIO.instream
+ val textOutstreamOf: ('a, TextIO.outstream) proc -> TextIO.outstream
+ val binOutstreamOf: ('a, BinIO.outstream) proc -> BinIO.outstream
+ val streamsOf: (TextIO.instream, TextIO.outstream) proc ->
+ TextIO.instream * TextIO.outstream
+ val reap: ('a, 'b) proc -> OS.Process.status
+ val kill: ('a, 'b) proc * signal -> unit
+ val exit: Word8.word -> 'a
end
1.2 +66 -30 mlton/basis-library/system/unix.sml
Index: unix.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/unix.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- unix.sml 18 Jul 2001 05:51:02 -0000 1.1
+++ unix.sml 24 Nov 2002 01:19:40 -0000 1.2
@@ -3,6 +3,8 @@
* 2. IO
* Further modified by sweeks@acm.org on 1999-12-10.
* 1. Put back support for Signals
+ * Further modified by fluet@cs.cornell.edu on 2002-10-15.
+ * 1. Adapted for new Basis Library specification.
*)
(* unix.sml
@@ -14,13 +16,16 @@
structure Unix: UNIX =
struct
- structure P = Posix.Process
- structure PE = Posix.ProcEnv
- structure PF = Posix.FileSys
+ structure OSP = OS_Process
+ structure PP = Posix.Process
+ structure PPE = Posix.ProcEnv
+ structure PFS = Posix.FileSys
structure PIO = Posix.IO
structure SS = Substring
type signal = Posix.Signal.signal
+ datatype exit_status = datatype Posix.Process.exit_status
+ val fromStatus = Posix.Process.fromStatus
structure Mask = MLton.Signal.Mask
@@ -28,15 +33,20 @@
let val _ = Mask.block Mask.all
in DynamicWind.wind(fn () => f x, fn () => Mask.unblock Mask.all)
end
-
- datatype proc = PROC of {
- pid: P.pid,
- ins: TextIO.instream,
- outs: TextIO.outstream
- }
+
+ datatype 'a str = FD of PFS.file_desc | STR of 'a * ('a -> unit)
+ fun close str =
+ case str of
+ FD file_desc => PIO.close file_desc
+ | STR (str, close) => close str
+
+ datatype ('a, 'b) proc = PROC of {pid: PP.pid,
+ status: OSP.status option ref,
+ ins: 'a str ref,
+ outs: 'b str ref}
fun executeInEnv (cmd, argv, env) =
- if not(PF.access(cmd, [PF.A_EXEC]))
+ if not(PFS.access(cmd, [PFS.A_EXEC]))
then PosixError.raiseSys PosixError.noent
else
let
@@ -48,13 +58,13 @@
PIO.close (#infd p2))
val base = SS.string(SS.taker (fn c => c <> #"/") (SS.all cmd))
fun startChild () =
- case protect P.fork () of
- SOME pid => pid (* parent *)
+ case protect PP.fork () of
+ SOME pid => pid (* parent *)
| NONE => let
val oldin = #infd p1
- val newin = PF.stdin
val oldout = #outfd p2
- val newout = PF.stdout
+ val newin = PFS.stdin
+ val newout = PFS.stdout
in
PIO.close (#outfd p1);
PIO.close (#infd p2);
@@ -64,13 +74,11 @@
if (oldout = newout) then ()
else (PIO.dup2{old = oldout, new = newout};
PIO.close oldout);
- P.exece (cmd, base :: argv, env)
+ PP.exece (cmd, base :: argv, env)
end
(* end case *)
val _ = TextIO.flushOut TextIO.stdOut
val pid = (startChild ()) handle ex => (closep(); raise ex)
- val ins = TextIO.newIn(#infd p2)
- val outs = TextIO.newOut(#outfd p1)
in
(* close the child-side fds *)
PIO.close (#outfd p2);
@@ -80,23 +88,51 @@
PIO.setfd (#outfd p1, PIO.FD.flags [PIO.FD.cloexec]);
PROC {
pid = pid,
- ins = ins,
- outs = outs
+ status = ref NONE,
+ ins = ref (FD (#infd p2)),
+ outs = ref (FD (#outfd p1))
}
end
- fun execute (cmd, argv) = executeInEnv (cmd, argv, PE.environ())
-
- fun streamsOf (PROC{ins, outs, ...}) = (ins, outs)
+ fun execute (cmd, argv) = executeInEnv (cmd, argv, PPE.environ())
- fun kill (PROC{pid, ...}, signal) = P.kill (P.K_PROC pid, signal)
+ local
+ fun mkInstreamOf (newIn, closeIn) (PROC {ins, ...}) =
+ case !ins of
+ FD file_desc => let val str' = newIn file_desc
+ in ins := STR (str', closeIn); str'
+ end
+ | STR (str, _) => str
+ fun mkOutstreamOf (newOut, closeOut) (PROC {outs, ...}) =
+ case !outs of
+ FD file_desc => let val str' = newOut file_desc
+ in outs := STR (str', closeOut); str'
+ end
+ | STR (str, _) => str
+ in
+ fun textInstreamOf proc = mkInstreamOf (TextIO.newIn, TextIO.closeIn) proc
+ fun textOutstreamOf proc = mkOutstreamOf (TextIO.newOut, TextIO.closeOut) proc
+ fun binInstreamOf proc = mkInstreamOf (BinIO.newIn, BinIO.closeIn) proc
+ fun binOutstreamOf proc = mkOutstreamOf (BinIO.newOut, BinIO.closeOut) proc
+ end
+ fun streamsOf pr = (textInstreamOf pr, textOutstreamOf pr)
+
+ fun reap (PROC{pid, status, ins, outs}) =
+ case !status of
+ SOME status => status
+ | NONE => let
+ val _ = close (!ins)
+ val _ = close (!outs)
+ (* protect is probably too much; typically, one
+ * would only mask SIGINT, SIGQUIT and SIGHUP
+ *)
+ val st = protect OSP.wait pid
+ val _ = status := SOME st
+ in
+ st
+ end
- fun reap (PROC{pid, ins, outs}) =
- (TextIO.closeIn ins
- ; TextIO.closeOut outs
- ; (* protect is probably too much; typically, one
- * would only mask SIGINT, SIGQUIT and SIGHUP
- *)
- protect OS_Process.wait pid)
+ fun kill (PROC{pid, ...}, signal) = PP.kill (PP.K_PROC pid, signal)
+ fun exit st = OSP.exit (Word8.toInt st)
end (* structure Unix *)
1.2 +15 -0 mlton/basis-library/system/pre-os.sml
1.2 +13 -13 mlton/basis-library/text/char.sig
Index: char.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/text/char.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- char.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ char.sig 24 Nov 2002 01:19:40 -0000 1.2
@@ -12,37 +12,37 @@
eqtype string
+ val minChar: char
+ val maxChar: char
+ val maxOrd: int
+ val succ: char -> char
+ val pred: char -> char
val < : char * char -> bool
val <= : char * char -> bool
val > : char * char -> bool
val >= : char * char -> bool
val compare: char * char -> order
val contains: string -> char -> bool
- val fromCString: string -> char option
- val fromString: string -> char option
+ val notContains: string -> char -> bool
+ val toLower: char -> char
+ val toUpper: char -> char
+ val isAscii: char -> bool
val isAlpha: char -> bool
val isAlphaNum: char -> bool
- val isAscii: char -> bool
val isCntrl: char -> bool
val isDigit: char -> bool
val isGraph: char -> bool
val isHexDigit: char -> bool
val isLower: char -> bool
+ val isUpper: char -> bool
val isPrint: char -> bool
val isPunct: char -> bool
val isSpace: char -> bool
- val isUpper: char -> bool
- val maxChar: char
- val maxOrd: int
- val minChar: char
- val notContains: string -> char -> bool
- val pred: char -> char
+ val fromString: string -> char option
val scan: (char, 'a) StringCvt.reader -> (char, 'a) StringCvt.reader
- val succ: char -> char
- val toCString: char -> string
- val toLower: char -> char
val toString: char -> string
- val toUpper: char -> char
+ val fromCString: string -> char option
+ val toCString: char -> string
end
signature CHAR_EXTRA =
1.3 +3 -6 mlton/basis-library/text/char.sml
Index: char.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/text/char.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- char.sml 10 Apr 2002 07:02:18 -0000 1.2
+++ char.sml 24 Nov 2002 01:19:40 -0000 1.3
@@ -86,19 +86,15 @@
| #"v" => yes #"\v"
| #"f" => yes #"\f"
| #"r" => yes #"\r"
+ | #"?" => yes #"?"
| #"\\" => yes #"\\"
| #"\"" => yes #"\""
- | #"?" => yes #"?"
| #"'" => yes #"'"
| #"^" => control reader state'
| #"x" =>
Reader.mapOpt chrOpt
(StringCvt.digits StringCvt.HEX reader)
state'
- | #"u" =>
- Reader.mapOpt chrOpt
- (StringCvt.digitsExact (StringCvt.HEX, 4) reader)
- state'
| _ =>
Reader.mapOpt chrOpt
(StringCvt.digitsPlus (StringCvt.OCT, 3) reader)
@@ -151,7 +147,8 @@
if c < #" "
then (String.concat
["\\^", String0.str (chr (ord c +? ord #"@"))])
- else String.concat ["\\", padLeft (Int.toString (ord c), 3)])
+ else String.concat
+ ["\\", padLeft (Int.fmt StringCvt.DEC (ord c), 3)])
val toCString =
memoize
1.2 +3 -4 mlton/basis-library/text/string-cvt.sig
Index: string-cvt.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/text/string-cvt.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- string-cvt.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ string-cvt.sig 24 Nov 2002 01:19:40 -0000 1.2
@@ -15,13 +15,12 @@
val splitl: (char -> bool) -> (char, 'a) reader -> 'a -> string * 'a
- val takel: (char -> bool) -> (char, 'a) reader ->'a -> string
- val dropl: (char -> bool) -> (char, 'a) reader ->'a -> 'a
+ val takel: (char -> bool) -> (char, 'a) reader -> 'a -> string
+ val dropl: (char -> bool) -> (char, 'a) reader -> 'a -> 'a
val skipWS: (char, 'a) reader -> 'a -> 'a
type cs
- val scanString :
- ((char, cs) reader -> ('a, cs) reader) -> string -> 'a option
+ val scanString : ((char, cs) reader -> ('a, cs) reader) -> string -> 'a option
end
signature STRING_CVT_EXTRA =
1.3 +1 -1 mlton/basis-library/text/string-cvt.sml
Index: string-cvt.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/text/string-cvt.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- string-cvt.sml 10 Apr 2002 07:02:18 -0000 1.2
+++ string-cvt.sml 24 Nov 2002 01:19:40 -0000 1.3
@@ -34,7 +34,7 @@
fun pad f c i s =
let val n = String.size s
in if n >= i then s
- else f (s, String0.new (i -? n, c))
+ else f (s, String0.vector (i -? n, c))
end
in
val padLeft = pad (fn (s, pad) => String.^ (pad, s))
1.2 +20 -17 mlton/basis-library/text/string.sig
Index: string.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/text/string.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- string.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ string.sig 24 Nov 2002 01:19:40 -0000 1.2
@@ -2,39 +2,42 @@
sig
eqtype string
+ val size: string -> int
+ val substring: string * int * int -> string
val ^ : string * string -> string
val concat: string list -> string
- val explode: string -> Char.char list
- val implode: Char.char list -> string
- val size: string -> int
val str: Char.char -> string
- val substring: string * int * int -> string
+ val implode: Char.char list -> string
+ val explode: string -> Char.char list
end
signature STRING =
sig
include STRING_GLOBAL
- structure Char: CHAR
+ eqtype char
+ val maxSize: int
+ val sub: string * int -> char
+ val extract: string * int * int option -> string
+ val concatWith: string -> string list -> string
+ val map: (Char.char -> Char.char) -> string -> string
+ val translate: (Char.char -> string) -> string -> string
+ val tokens: (Char.char -> bool) -> string -> string list
+ val fields: (Char.char -> bool) -> string -> string list
+ val isPrefix: string -> string -> bool
+ val isSubstring: string -> string -> bool
+ val isSuffix: string -> string -> bool
+ val compare: string * string -> order
+ val collate: (char * char -> order) -> string * string -> order
val < : string * string -> bool
val <= : string * string -> bool
val > : string * string -> bool
val >= : string * string -> bool
- val collate: (Char.char * Char.char -> order) -> string * string -> order
- val compare: string * string -> order
- val extract: string * int * int option -> string
- val fields: (Char.char -> bool) -> string -> string list
- val fromCString: string -> string option
val fromString: string -> string option
- val isPrefix: string -> string -> bool
- val map: (Char.char -> Char.char) -> string -> string
- val maxSize: int
- val sub: string * int -> Char.char
- val toCString: string -> string
val toString: string -> string
- val tokens: (Char.char -> bool) -> string -> string list
- val translate: (Char.char -> string) -> string -> string
+ val fromCString: string -> string option
+ val toCString: string -> string
end
signature STRING_EXTRA =
1.3 +4 -46 mlton/basis-library/text/string.sml
Index: string.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/text/string.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- string.sml 10 Apr 2002 07:02:18 -0000 1.2
+++ string.sml 24 Nov 2002 01:19:40 -0000 1.3
@@ -9,56 +9,14 @@
struct
open String0
- structure Char = Char
-
- fun explode s =
- let
- fun loop (i, l) =
- if i < 0 then l
- else loop (i - 1, sub (s, i) :: l)
- in loop (size s - 1, [])
- end
-
- fun translate f s = concat (List.map f (explode s))
-
- fun isPrefix s s' =
- let
- val n = size s
- val n' = size s'
- fun loop i =
- i >= n orelse (sub (s, i) = sub (s', i)
- andalso loop (i + 1))
- in n <= n' andalso loop 0
- end
-
local
- fun make (tokens,name) p s =
- case StringCvt.scanString (tokens p) s of
- SOME l => List.map implode l
- | NONE => raise Fail ("String." ^ name)
+ fun make f = f (op = : char * char -> bool)
in
- val tokens = make (Reader.tokens, "tokens")
- val fields = make (Reader.fields, "fields")
+ val isPrefix = make isPrefix
+ val isSubstring = make isSubvector
+ val isSuffix = make isSuffix
end
-
- fun collate comp (s, s') =
- let val n = size s
- val n' = size s'
- fun loop i =
- if i >= n
- then if i >= n'
- then EQUAL
- else LESS
- else if i >= n'
- then GREATER
- else (case comp (sub (s, i), sub (s', i)) of
- EQUAL => loop (i + 1)
- | r => r)
- in loop 0
- end
-
val compare = collate Char.compare
-
val {<, <=, >, >=} = Util.makeOrder compare
val toString = translate Char.toString
1.4 +22 -34 mlton/basis-library/text/string0.sml
Index: string0.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/text/string0.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- string0.sml 10 Apr 2002 07:02:18 -0000 1.3
+++ string0.sml 24 Nov 2002 01:19:40 -0000 1.4
@@ -5,42 +5,30 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-structure String0 =
- struct
- val fromArray =
- Primitive.String.fromCharVector o Primitive.Vector.fromArray
-
- structure S = Sequence (type 'a sequence = string
- type 'a elt = char
- val fromArray = fromArray
- val isMutable = false
- open Primitive.String
- val length = size)
- open S
-
- open Primitive.Int
-
- type string = string
- type array = string
+structure CharVector = EqtypeMonoVector(type elem = char)
+structure CharVectorSlice = CharVector.MonoVectorSlice
+structure String0 =
+ struct
+ open CharVector
+ type char = elem
+ type string = vector
+ structure Substring0 =
+ struct
+ open CharVectorSlice
+ type char = elem
+ type string = vector
+ type substring = slice
+ end
val maxSize = maxLen
-
val size = length
-
- fun substring (s, i, j) = extract (s, i, SOME j)
-
- fun copy s = tabulate (length s, fn i => sub (s, i))
-
- fun map f s =
- fromArray (Array.tabulate (size s, fn i => f (sub (s, i))))
-
- fun s ^ s' = concat [s, s']
-
- fun implode cs =
- let val a = Primitive.Array.array (List.length cs)
- in List.foldl (fn (c, i) => (Array.update (a, i, c) ; i +? 1)) 0 cs ;
- fromArray a
- end
-
+ fun extract (s, start, len) =
+ CharVectorSlice.vector (CharVectorSlice.slice (s, start, len))
+ fun substring (s, start, len) = extract (s, start, SOME len)
+ val op ^ = append
+ val new = vector
fun str c = new (1, c)
+ val implode = fromList
+ val explode = toList
end
+structure Substring0 = String0.Substring0
1.2 +37 -38 mlton/basis-library/text/substring.sig
Index: substring.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/text/substring.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- substring.sig 18 Jul 2001 05:51:02 -0000 1.1
+++ substring.sig 24 Nov 2002 01:19:41 -0000 1.2
@@ -6,45 +6,44 @@
signature SUBSTRING =
sig
include SUBSTRING_GLOBAL
-
- structure String: STRING
+ eqtype char
+ eqtype string
- val all: String.string -> substring
- val app: (String.Char.char -> unit) -> substring -> unit
- val base: substring -> String.string * int * int
- val collate:
- (String.Char.char * String.Char.char -> order)
- -> substring * substring -> order
- val compare: substring * substring -> order
- val concat: substring list -> String.string
- val dropl: (String.Char.char -> bool) -> substring -> substring
- val dropr: (String.Char.char -> bool) -> substring -> substring
- val explode: substring -> String.Char.char list
- val extract: String.string * int * int option -> substring
- val fields: (String.Char.char -> bool) -> substring -> substring list
- val first: substring -> String.Char.char option
- val foldl: (String.Char.char * 'a -> 'a) -> 'a -> substring -> 'a
- val foldr: (String.Char.char * 'a -> 'a) -> 'a -> substring -> 'a
- val getc: substring -> (String.Char.char * substring) option
- val isEmpty: substring -> bool
- val isPrefix: String.string -> substring -> bool
- val position: String.string -> substring -> substring * substring
- val size: substring -> int
+ val sub: substring * int -> char
+ val size: substring -> int
+ val base: substring -> string * int * int
+ val extract: string * int * int option -> substring
+ val substring: string * int * int -> substring
+ val full: string -> substring
+ val all: string -> substring
+ val string: substring -> string
+ val isEmpty: substring -> bool
+ val getc: substring -> (char * substring) option
+ val first: substring -> char option
+ val triml: int -> substring -> substring
+ val trimr: int -> substring -> substring
val slice: substring * int * int option -> substring
+ val concat: substring list -> string
+ val concatWith: string -> substring list -> string
+ val explode: substring -> char list
+ val isPrefix: string -> substring -> bool
+ val isSubstring: string -> substring -> bool
+ val isSuffix: string -> substring -> bool
+ val compare: substring * substring -> order
+ val collate: (char * char -> order) -> substring * substring -> order
+ val splitl: (char -> bool) -> substring -> substring * substring
+ val splitr: (char -> bool) -> substring -> substring * substring
+ val splitAt: substring * int -> substring * substring
+ val dropl: (char -> bool) -> substring -> substring
+ val dropr: (char -> bool) -> substring -> substring
+ val takel: (char -> bool) -> substring -> substring
+ val taker: (char -> bool) -> substring -> substring
+ val position: string -> substring -> substring * substring
val span: substring * substring -> substring
- val splitAt: substring * int -> substring * substring
- val splitl:
- (String.Char.char -> bool) -> substring -> substring * substring
- val splitr:
- (String.Char.char -> bool) -> substring -> substring * substring
- val string: substring -> String.string
- val sub: substring * int -> char
- val substring: String.string * int * int -> substring
- val takel: (String.Char.char -> bool) -> substring -> substring
- val taker: (String.Char.char -> bool) -> substring -> substring
- val tokens: (String.Char.char -> bool) -> substring -> substring list
- val translate:
- (String.Char.char -> String.string) -> substring -> String.string
- val triml: int -> substring -> substring
- val trimr: int -> substring -> substring
+ val translate: (char -> string) -> substring -> string
+ val tokens: (char -> bool) -> substring -> substring list
+ val fields: (char -> bool) -> substring -> substring list
+ val app: (char -> unit) -> substring -> unit
+ val foldl: (char * 'a -> 'a) -> 'a -> substring -> 'a
+ val foldr: (char * 'a -> 'a) -> 'a -> substring -> 'a
end
1.3 +20 -241 mlton/basis-library/text/substring.sml
Index: substring.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/text/substring.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- substring.sml 10 Apr 2002 07:02:18 -0000 1.2
+++ substring.sml 24 Nov 2002 01:19:41 -0000 1.3
@@ -7,210 +7,27 @@
*)
structure Substring: SUBSTRING =
struct
- open Int
-
- structure String = String
-
- datatype t = T of {str: string,
- start: int,
- size: int}
- type substring = t
-
- fun base (T {str, start, size}) = (str, start, size)
-
- val string = String.substring o base
-
- fun extract (slice as (str, start, _)): t =
- let val max = String0.checkSlice slice
- in T {str = str,
- start = start,
- size = max -? start}
- end
-
- fun substring (s, i, j) = extract (s, i, SOME j)
-
- fun all s = substring (s, 0, String.size s)
-
- fun isEmpty (T {size, ...}) = size = 0
-
- fun getc (T {str, start, size}) =
- if size = 0
- then NONE
- else SOME (String.sub (str, start),
- T {str = str,
- start = start +? 1,
- size = size -? 1})
-
- fun first ss =
- case getc ss of
- NONE => NONE
- | SOME (c, _) => SOME c
-
- fun triml k =
- if Primitive.safe andalso k < 0
- then raise Subscript
- else
- (fn T {str, start, size} =>
- if k > size
- then T {str = str, start = start +? size, size = 0}
- else T {str = str, start = start +? k, size = size -? k})
-
- fun trimr k =
- if Primitive.safe andalso k < 0
- then raise Subscript
- else
- (fn T {str, start, size} =>
- T {str = str,
- start = start,
- size = if k > size then 0 else size -? k})
-
- fun slice (T {str, start, size}, i, opt) =
- case opt of
- SOME m =>
- if Primitive.safe andalso 0 <= i
- andalso 0 <= m
- andalso i <= size -? m
- then T {str = str, start = start +? i, size = m}
- else raise Subscript
- | NONE =>
- if Primitive.safe andalso 0 <= i andalso i <= size
- then T {str = str, start = start +? i, size = size -? i}
- else raise Subscript
-
- fun sub (T {str, start, size}, i) =
- if Primitive.safe andalso Int.geu (i, size)
- then raise Subscript
- else String.sub (str, start +? i)
-
- fun size (T {size, ...}) = size
-
- fun concat substrings =
- let
- val size = List.foldl (fn (ss, n) => n +? size ss) 0 substrings
- val dst = Primitive.Array.array size
- in
- List.foldl (fn (T {str, start, size}, n) =>
- let
- fun loop i =
- if i >= size then ()
- else (Array.update (dst, n +? i,
- String.sub (str, start +? i))
- ; loop (i + 1))
- in loop 0;
- n +? size
- end)
- 0 substrings
- ; String.fromArray dst
- end
-
- val explode = String.explode o string
-
- fun explode (T {str, start, size}) =
- let
- fun loop (i, l) =
- if i < start
- then l
- else loop (i -? 1, String.sub (str, i) :: l)
- in
- loop (start +? size -? 1, [])
- end
-
- fun isPrefix str' (T {str, start, size}) =
- let
- val size' = String.size str'
- fun loop (i, i') =
- i' >= size'
- orelse (String.sub (str, i) = String.sub (str', i')
- andalso loop (i +? 1, i' + 1))
- in
- size' <= size andalso loop (start, 0)
- end
-
- fun collate comp (T {str, start, size},
- T {str=str', start=start', size=size'}) =
- let
- val max = start +? size
- val max' = start' +? size'
- fun loop (i, i') =
- if i >= max
- then if i' = max'
- then EQUAL
- else LESS
- else if i' >= max'
- then GREATER
- else (case comp (String.sub (str, i),
- String.sub (str', i')) of
- EQUAL => loop (i + 1, i' + 1)
- | r => r)
- in loop (start, start')
- end
+ open Substring0
+ val size = length
+ val extract = slice
+ fun substring (s, start, len) = extract (s, start, SOME len)
+ val all = full
+ val string = vector
+ val getc = getItem
+ fun first ss = Option.map #1 (getItem ss)
+ val slice = subslice
+ val explode = toList
+ local
+ fun make f = f (op = : char * char -> bool)
+ in
+ val isPrefix = make isPrefix
+ val isSubstring = make isSubvector
+ val isSuffix = make isSuffix
+ val position = make position
+ end
val compare = collate Char.compare
-
- fun split (T {str, start, size}, i) =
- (T {str = str, start = start, size = i -? start},
- T {str = str, start = i, size = size -? (i -? start)})
-
- fun splitl f (ss as T {str, start, size}) =
- let
- val stop = start +? size
- fun loop i =
- if i >= stop
- then i
- else if f (String.sub (str, i))
- then loop (i + 1)
- else i
- in split (ss, loop start)
- end
-
- fun splitr f (ss as T {str, start, size}) =
- let
- fun loop i =
- if i < start
- then start
- else if f (String.sub (str, i))
- then loop (i -? 1)
- else i +? 1
- in split (ss, loop (start +? size -? 1))
- end
-
- fun splitAt (T {str, start, size}, i) =
- if Primitive.safe andalso Int.gtu (i, size)
- then raise Subscript
- else (T {str = str, start = start, size = i},
- T {str = str, start = start +? i, size = size -? i})
-
- fun takel p s = #1 (splitl p s)
- fun dropl p s = #2 (splitl p s)
- fun taker p s = #2 (splitr p s)
- fun dropr p s = #1 (splitr p s)
-
- fun position s' (ss as T {str=s, start, size}) =
- let
- val size' = String.size s'
- val max = start +? size -? size' +? 1
- (* loop returns the index of the front of suffix. *)
- fun loop i =
- if i >= max
- then start +? size
- else let
- fun loop' j =
- if j >= size'
- then i
- else if String.sub (s, i +? j) = String.sub (s', j)
- then loop' (j + 1)
- else loop (i + 1)
- in loop' 0
- end
- in split (ss, loop start)
- end
-
- fun span (T {str = s, start = i, size = n},
- T {str = s', start = i', size = n'}) =
- if s = s' andalso i' +? n' >= i
- then T {str = s, start = i, size = i' +? n' -? i}
- else raise Span
-
+(*
type cs = int
fun reader (T {str, start, size}): (char, cs) Reader.reader =
@@ -224,45 +41,7 @@
case f (reader ss) 0 of
NONE => NONE
| SOME (a, _) => SOME a
-
- local
- fun make finish p (T {str, start, size}) =
- let
- val max = start +? size
- fun loop (i, start, sss) =
- if i >= max
- then rev (finish (str, start, i, sss))
- else
- if p (String.sub (str, i))
- then loop (i + 1, i + 1, finish (str, start, i, sss))
- else loop (i + 1, start, sss)
- in loop (start, start, [])
- end
- in
- val tokens = make (fn (str, start, stop, sss) =>
- if start = stop
- then sss
- else
- T {str = str, start = start, size = stop -? start}
- :: sss)
- val fields = make (fn (str, start, stop, sss) =>
- T {str = str, start = start, size = stop -? start}
- :: sss)
- end
-
- local
- fun make naturalFold f b (T {str, size, start}) =
- naturalFold (size, b, fn (i, b) =>
- f (String.sub (str, start +? i), b))
- in
- fun foldl f = make Util.naturalFold f
- fun foldr f = make Util.naturalFoldDown f
- end
-
- fun app f ss = foldl (f o #1) () ss
-
- fun translate f ss =
- String.concat (rev (foldl (fn (c, l) => f c :: l) [] ss))
+*)
end
structure SubstringGlobal: SUBSTRING_GLOBAL = Substring
1.2 +12 -0 mlton/basis-library/text/text.sig
1.2 +8 -0 mlton/basis-library/text/text.sml
1.3 +5 -5 mlton/basis-library/top-level/infixes.sml
Index: infixes.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/top-level/infixes.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- infixes.sml 10 Apr 2002 07:02:18 -0000 1.2
+++ infixes.sml 24 Nov 2002 01:19:41 -0000 1.3
@@ -5,9 +5,9 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-infix 7 * / mod div
-infix 6 ^ + -
-infix 3 := o
-infix 4 > < >= <= = <>
+infix 7 * / mod div
+infix 6 + - ^
infixr 5 :: @
-infix 0 before
+infix 4 = <> > >= < <=
+infix 3 := o
+infix 0 before
1.4 +2 -0 mlton/basis-library/top-level/overloads.sml
Index: overloads.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/top-level/overloads.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- overloads.sml 31 May 2002 16:23:35 -0000 1.3
+++ overloads.sml 24 Nov 2002 01:19:41 -0000 1.4
@@ -9,6 +9,8 @@
_overload ~ : ('a -> 'a)
as Int.~
and IntInf.~
+and Word.~
+and Word8.~
and Real.~
_overload + : ('a * 'a -> 'a)
1.38 +4 -4 mlton/benchmark/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/benchmark/Makefile,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -r1.37 -r1.38
--- Makefile 6 Nov 2002 22:00:59 -0000 1.37
+++ Makefile 24 Nov 2002 01:19:41 -0000 1.38
@@ -2,7 +2,7 @@
BUILD = $(SRC)/build
BIN = $(BUILD)/bin
LIB = $(BUILD)/lib
-MLTON = mlton
+MLTON = $(BIN)/mlton
HOST = self
FLAGS = -host $(HOST)
NAME = benchmark
@@ -27,7 +27,8 @@
$(NAME)-stubs_cm:
( \
echo 'Group is'&& \
- cmcat sources.cm | grep -v 'mlton-stubs-in-smlnj' && \
+ cmcat sources.cm | grep -v 'basis-stubs' | \
+ grep -v 'mlton-stubs-in-smlnj' && \
echo 'call-main.sml'; \
) >$(NAME)-stubs.cm
@@ -55,8 +56,7 @@
test: $(NAME)
export PATH=$(PATH):$$PATH && cd tests && ../benchmark $(BFLAGS) $(BENCH)
-QBENCH = $(BENCH)
-
+QBENCH = $(BFLAGS)
QBFLAGS = -mlton "mlton"
.PHONY: qtest
1.3 +1 -0 mlton/benchmark/benchmark-stubs.cm
Index: benchmark-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/benchmark/benchmark-stubs.cm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- benchmark-stubs.cm 7 Nov 2002 01:36:52 -0000 1.2
+++ benchmark-stubs.cm 24 Nov 2002 01:19:41 -0000 1.3
@@ -1,5 +1,6 @@
Group is
../lib/mlton-stubs/thread.sml
+../lib/mlton-stubs/int-inf.sml
../lib/mlton-stubs/random.sig
../lib/mlton-stubs/random.sml
../lib/mlton-stubs/world.sig
1.3 +6 -1 mlton/benchmark/tests/md5.sml
Index: md5.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/benchmark/tests/md5.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- md5.sml 27 Sep 2002 23:46:29 -0000 1.2
+++ md5.sml 24 Nov 2002 01:19:41 -0000 1.3
@@ -17,7 +17,12 @@
structure MD5 :> MD5 =
struct
structure W32 = Word32
- structure W8V = Word8Vector
+ structure W8V =
+ struct
+ open Word8Vector
+ fun extract (vec, s, l) =
+ Word8VectorSlice.vector (Word8VectorSlice.slice (vec, s, l))
+ end
type word64 = {hi:W32.word,lo:W32.word}
type word128 = {A:W32.word, B:W32.word, C:W32.word, D:W32.word}
type md5state = {digest:word128,
1.3 +26 -5 mlton/benchmark/tests/tensor.sml
Index: tensor.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/benchmark/tests/tensor.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- tensor.sml 27 Sep 2002 23:46:29 -0000 1.2
+++ tensor.sml 24 Nov 2002 01:19:41 -0000 1.3
@@ -1,4 +1,26 @@
(* Obtained at http://www.arrakis.es/~worm/ *)
+
+signature MONO_VECTOR =
+ sig
+ type vector
+ type elem
+ val maxLen : int
+ val fromList : elem list -> vector
+ val tabulate : (int * (int -> elem)) -> vector
+ val length : vector -> int
+ val sub : (vector * int) -> elem
+ val extract : (vector * int * int option) -> vector
+ val concat : vector list -> vector
+ val mapi : ((int * elem) -> elem) -> (vector * int * int option) -> vector
+ val map : (elem -> elem) -> vector -> vector
+ val appi : ((int * elem) -> unit) -> (vector * int * int option) -> unit
+ val app : (elem -> unit) -> vector -> unit
+ val foldli : ((int * elem * 'a) -> 'a) -> 'a -> (vector * int * int option) -> 'a
+ val foldri : ((int * elem * 'a) -> 'a) -> 'a -> (vector * int * int option) -> 'a
+ val foldl : ((elem * 'a) -> 'a) -> 'a -> vector -> 'a
+ val foldr : ((elem * 'a) -> 'a) -> 'a -> vector -> 'a
+ end
+
(*
Copyright (c) Juan Jose Garcia Ripoll.
All rights reserved.
@@ -645,7 +667,7 @@
raise Match
end
- fun appi f tensor = Array.appi f (toArray tensor, 0, NONE)
+ fun appi f tensor = Array.appi f (toArray tensor)
fun app f tensor = Array.app f (toArray tensor)
@@ -1382,7 +1404,6 @@
fun foldl f init a = foldli (fn (_, a, x) => f(a,x)) init (a,0,NONE)
fun foldr f init a = foldri (fn (_, x, a) => f(x,a)) init (a,0,NONE)
-
end
end (* BasicCNumberArray *)
@@ -1658,7 +1679,7 @@
fun print_one (i,x) =
(print(cvt x); if not(i = length) then print ", " else ())
in
- Array.appi print_one (a, 0, NONE)
+ Array.appi print_one a
end
fun boolArray a = array Bool.toString a
fun intArray a = array Int.toString a
@@ -1982,7 +2003,7 @@
else
raise Match
end
- fun appi f tensor = Array.appi f (toArray tensor, 0, NONE)
+ fun appi f tensor = Array.appi f (toArray tensor)
fun app f tensor = Array.app f (toArray tensor)
fun all f tensor =
let val a = toArray tensor
@@ -2267,7 +2288,7 @@
else
raise Match
end
- fun appi f tensor = Array.appi f (toArray tensor, 0, NONE)
+ fun appi f tensor = Array.appi f (toArray tensor)
fun app f tensor = Array.app f (toArray tensor)
fun all f tensor =
let val a = toArray tensor
1.9 +282 -24 mlton/bin/check-basis
Index: check-basis
===================================================================
RCS file: /cvsroot/mlton/mlton/bin/check-basis,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- check-basis 29 Oct 2002 06:08:23 -0000 1.8
+++ check-basis 24 Nov 2002 01:19:41 -0000 1.9
@@ -7,14 +7,62 @@
name=`basename $0`
-usage () {
- echo >&2 "usage: $name"
+function usage() {
+ echo >&2 "usage: $name lib [file.sml | file.cm]"
exit 1
}
+function rewrite() {
+ sed 's/_build_const\(.*\);/(PRIM\1)/' |
+ sed 's/_build_const/PRIM/' |
+ sed 's/_const\(.*\);/(PRIM\1)/' |
+ sed 's/_const/PRIM/' |
+ sed 's/_prim\(.*\);/(PRIM\1)/' |
+ sed 's/_prim/PRIM/' |
+ sed 's/_ffi\(.*\);/(PRIM\1)/' |
+ sed 's/_ffi/PRIM/' |
+ sed 's/fun bigIntConstant x = x/fun bigIntConstant(x:smallInt):bigInt = raise Fail "bigIntConstant"/' |
+ sed 's/#"\([^"\]*\(\\.[^"\]*\)*\)"/#ZZZ\1ZZZ/g' |
+ sed 's/\([^\]\)"\([^"\]*\(\\.[^"\]*\)*\)"/\1(STRING_CONST "\2")/g' |
+ sed 's/#ZZZ\(\(.\)\|\(..\)\|\([^Z][^Z][^Z].*\)\)ZZZ/#"\1"/g' |
+ sed 's/(\*#line 0.0 \(.*\)\*)/(*#line 0.0 "\1"*)/'
+}
+
+REWRITE_FILE=""
+function rewrite_file() {
+(
+ echo "(*#line 0.0 $REWRITE_FILE*)"
+ cat $REWRITE_FILE
+) | rewrite
+}
+
+REWRITE_FILES=""
+function rewrite_files() {
+for f in `cat $REWRITE_FILES | grep -v "^#" | grep -v overload | grep -v Group`; do
+ echo "(*#line 0.0 $f*)"
+ cat $f
+done | rewrite
+}
+
+SML_FILE=""
+CM_FILE=""
+LIB=""
case "$#" in
0)
+ usage
+ ;;
+1)
+ LIB=$1
;;
+2)
+ LIB=$1
+ if [ "$2" == "`basename $2 .sml`.sml" -a -r "$2" ]; then
+ SML_FILE=$2
+ elif [ "$2" == "`basename $2 .cm`.cm" -a -r "$2" ]; then
+ CM_FILE=$2
+ else usage
+ fi
+ ;;
*)
usage
;;
@@ -22,37 +70,247 @@
dir=`dirname $0`
root=`cd $dir/.. && pwd`
+here=`pwd`
basis="$root/basis-library/basis.sml"
-cd $root/basis-library
rm -f $basis
(
cat <<-EOF
val _ = SMLofNJ.Internals.GC.messages false;
- fun PRIM x = raise Fail "_prim"
- datatype pointer = T
- datatype preThread = T
- datatype thread = T
- type word8 = Word8.word
- type word = Word32.word
- type int = Int32.int
- type intInf = int
+ fun PRIM (x:char vector) = raise Fail "_prim"
+ fun STRING_CONST (x:string) : char vector = raise Fail "<string constant>"
+ structure Types = struct
+ type 'a array = 'a array
+ datatype bool = datatype bool
+ type char = char
+ type exn = exn
+ type int = Int32.int
+ type intInf = int
+ datatype list = datatype list
+ datatype pointer = T
+ type real = real
+ datatype ref = datatype ref
+ datatype preThread = T
+ datatype thread = T
+ type word = Word32.word
+ type word8 = Word8.word
+ type 'a vector = 'a vector
+
+ datatype 'a option = T
+ end
+ signature GENERAL = sig end
+ structure General = struct end
+ signature OPTION = sig end
+ structure Option = struct end
+ signature BOOL = sig end
+ structure Bool = struct end
+ signature SML90 = sig end
+ structure SML90 = struct end
+ signature CHAR = sig end
+ structure Char = struct end
+ structure WideChar = struct end
+ signature STRING = sig end
+ structure String = struct end
+ structure WideString = struct end
+ signature SUBSTRING = sig end
+ structure Substring = struct end
+ structure WideSubstring = struct end
+ signature STRING_CVT = sig end
+ structure StringCvt = struct end
+ signature BYTE = sig end
+ structure Byte = struct end
+ signature INTEGER = sig end
+ structure Int = struct end
+ structure Int8 = struct end
+ structure Int16 = struct end
+ structure Int32 = struct end
+ structure Int64 = struct end
+ structure FixedInt = struct end
+ structure LargeInt = struct end
+ structure Position = struct end
+ signature INT_INF = sig end
+ structure IntInf = struct end
+ signature WORD = sig end
+ structure Word = struct end
+ structure Word8 = struct end
+ structure Word16 = struct end
+ structure Word32 = struct end
+ structure Word64 = struct end
+ structure LargeWord = struct end
+ structure SysWord = struct end
+ signature PACK_WORD = sig end
+ structure Pack8Big = struct end
+ structure Pack8Little = struct end
+ structure Pack16Big = struct end
+ structure Pack16Little = struct end
+ structure Pack32Big = struct end
+ structure Pack32Little = struct end
+ structure Pack64Big = struct end
+ structure Pack64Little = struct end
+ signature REAL = sig end
+ structure Real = struct end
+ structure Real32 = struct end
+ structure Real64 = struct end
+ structure Real128 = struct end
+ structure LargeReal = struct end
+ signature MATH = sig end
+ structure Math = struct end
+ signature IEEE_REAL = sig end
+ structure IEEEReal = struct end
+ signature PACK_REAL = sig end
+ structure PackRealBig = struct end
+ structure PackRealLittle = struct end
+ structure PackReal32Big = struct end
+ structure PackReal32Little = struct end
+ structure PackReal64Big = struct end
+ structure PackReal64Little = struct end
+ structure PackReal128Big = struct end
+ structure PackReal128Little = struct end
+ signature LIST = sig end
+ structure List = struct end
+ signature LIST_PAIR = sig end
+ structure ListPair = struct end
+ signature VECTOR = sig end
+ structure Vector = struct end
+ signature MONO_VECTOR = sig end
+ structure CharVector = struct end
+ structure WideCharVector = struct end
+ structure BoolVector = struct end
+ structure IntVector = struct end
+ structure RealVector = struct end
+ structure WordVector = struct end
+ structure Int8Vector = struct end
+ structure Int16Vector = struct end
+ structure Int32Vector = struct end
+ structure Int64Vector = struct end
+ structure Real32Vector = struct end
+ structure Real64Vector = struct end
+ structure Real128Vector = struct end
+ structure Word8Vector = struct end
+ structure Word16Vector = struct end
+ structure Word32Vector = struct end
+ structure Word64Vector = struct end
+ signature ARRAY = sig end
+ structure Array = struct end
+ signature MONO_ARRAY = sig end
+ structure CharArray = struct end
+ structure WideCharArray = struct end
+ structure BoolArray = struct end
+ structure IntArray = struct end
+ structure RealArray = struct end
+ structure WordArray = struct end
+ structure Int8Array = struct end
+ structure Int16Array = struct end
+ structure Int32Array = struct end
+ structure Int64Array = struct end
+ structure Real32Array = struct end
+ structure Real64Array = struct end
+ structure Real128Array = struct end
+ structure Word8Array = struct end
+ structure Word16Array = struct end
+ structure Word32Array = struct end
+ structure Word64Array = struct end
+ signature ARRAY2 = sig end
+ structure Array2 = struct end
+ signature MONO_ARRAY2 = sig end
+ structure CharArray2 = struct end
+ structure WideCharArray2 = struct end
+ structure BoolArray2 = struct end
+ structure IntArray2 = struct end
+ structure RealArray2 = struct end
+ structure WordArray2 = struct end
+ structure Int8Array2 = struct end
+ structure Int16Array2 = struct end
+ structure Int32Array2 = struct end
+ structure Int64Array2 = struct end
+ structure Real32Array2 = struct end
+ structure Real64Array2 = struct end
+ structure Real128Array2 = struct end
+ structure Word8Array2 = struct end
+ structure Word16Array2 = struct end
+ structure Word32Array2 = struct end
+ structure Word64Array2 = struct end
+ signature IO = sig end
+ structure IO = struct end
+ signature TEXT_IO = sig end
+ structure TextIO = struct end
+ signature TEXT_STREAM_IO = sig end
+ signature BIN_IO = sig end
+ structure BinIO = struct end
+ signature IMPERATIVE_IO = sig end
+ functor ImperativeIO () = struct end
+ signature STREAM_IO = sig end
+ functor StreamIO () = struct end
+ signature PRIM_IO = sig end
+ structure BinPrimIO = struct end
+ structure TextPrimIO = struct end
+ structure WideTextPrimIO = struct end
+ functor PrimIO () = struct end
+ signature OS = sig end
+ structure OS = struct end
+ signature OS_FILE_SYS = sig end
+ signature OS_IO = sig end
+ signature OS_PATH = sig end
+ signature OS_PROCESS = sig end
+ signature COMMAND_LINE = sig end
+ structure CommandLine = struct end
+ signature UNIX = sig end
+ structure Unix = struct end
+ signature DATE = sig end
+ structure Date = struct end
+ signature TIME = sig end
+ structure Time = struct end
+ signature TIMER = sig end
+ structure Timer = struct end
+ signature POSIX = sig end
+ structure Posix = struct end
+ signature POSIX_ERROR = sig end
+ signature POSIX_FILE_SYS = sig end
+ signature POSIX_FLAGS = sig end
+ signature POSIX_IO = sig end
+ signature POSIX_PROC_ENV = sig end
+ signature POSIX_PROCESS = sig end
+ signature POSIX_SIGNAL = sig end
+ signature POSIX_SYS_DB = sig end
+ signature POSIX_TTY = sig end
nonfix * / mod div ^ + - := o > < >= <= = <> :: @ before
+
+ open Types
EOF
-for f in `(cat build-basis; cat bind-basis) | grep -v overload`; do
- echo "(*#line 1.0 \"$f\"*)"
- cat $f
-done |
- sed 's/_build_const\(.*\);/(PRIM\1)/' |
- sed 's/_build_const/PRIM/' |
- sed 's/_const\(.*\);/(PRIM\1)/' |
- sed 's/_const/PRIM/' |
- sed 's/_prim\(.*\);/(PRIM\1)/' |
- sed 's/_prim/PRIM/' |
- sed 's/_ffi\(.*\);/(PRIM\1)/' |
- sed 's/_ffi/PRIM/' |
- sed 's/fun bigIntConstant x = x/fun bigIntConstant(x:smallInt):bigInt = raise Fail "bigIntConstant"/'
cat <<-EOF
+ local
+EOF
+cd $root/basis-library
+REWRITE_FILES="libs/build"
+rewrite_files
+cat <<-EOF
+ in
+EOF
+cd $root/basis-library
+REWRITE_FILES="libs/$LIB/bind"
+rewrite_files
+cat <<-EOF
+ end
+EOF
+cd $here
+case "$SML_FILE" in
+"")
+ ;;
+*)
+ REWRITE_FILE=$SML_FILE
+ rewrite_file
+ ;;
+esac
+case "$CM_FILE" in
+"")
+ ;;
+*)
+ REWRITE_FILES=$CM_FILE
+ rewrite_files
+ ;;
+esac
+cat <<-EOF
+ (*#line 0.0 "check-basis"*)
val _ = () ()
EOF
) >$basis
1.9 +5 -0 mlton/doc/changelog
Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- changelog 22 Nov 2002 22:46:15 -0000 1.8
+++ changelog 24 Nov 2002 01:19:41 -0000 1.9
@@ -1,5 +1,10 @@
Here are the changes from version 20020923.
+* 2002-11-23
+ - Added support for the latest Basis Library specification.
+ - Added option -basis to choose Basis Library version. Currently available
+ basis libraries are basis-2002, basis-2002-strict, basis-1997, and none.
+
* 2002-11-22
- Fixed bug that caused time profiling to fail (with a segfault) when resuming
a saved world.
1.11 +71 -30 mlton/doc/user-guide/basis.tex
Index: basis.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/basis.tex,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- basis.tex 2 Nov 2002 03:37:35 -0000 1.10
+++ basis.tex 24 Nov 2002 01:19:41 -0000 1.11
@@ -2,7 +2,7 @@
This section describes the portion that {\mlton} implements of the Standard ML
Basis Library specified at
-\link{http://cm.bell-labs.com/cm/cs/what/smlnj/doc/basis/index.html}.
+\link{http://SML.sourceforge.net/Basis/index.html}.
\subsection{Top level values}
@@ -25,6 +25,7 @@
\begin{longtable}{lll}
\fullmodule{Array}{ARRAY}
+\fullmodule{ArraySlice}{ARRAY\_SLICE}
\fullmodule{Array2}{ARRAY2}
\module{BinIO}{BIN\_IO}
{Missing:
@@ -32,15 +33,35 @@
{\tt scanStream},
{\tt setPosIn},
{\tt setPosOut}.}
+\extra{Missing:
+ {\tt StreamIO.reader},
+ {\tt StreamIO.writer},
+ {\tt StreamIO.mkInstream},
+ {\tt StreamIO.getReader},
+ {\tt StreamIO.output},
+ {\tt StreamIO.output1},
+ {\tt StreamIO.flushOut},
+ {\tt StreamIO.closeOut},
+ {\tt StreamIO.setBufferMode},
+ {\tt StreamIO.getBufferMode},
+ {\tt StreamIO.mkOutstream},
+ {\tt StreamIO.getWriter},
+ {\tt StreamIO.getPosOut},
+ {\tt StreamIO.setPosOut}}
+\fullmodule{BinPrimIO}{PRIM\_IO}
\fullmodule{Bool}{BOOL}
\fullmodule{BoolArray}{MONO\_ARRAY}
-\fullmodule{BoolArray2}{MONO\_ARRAY2}
+\fullmodule{BoolArraySlice}{MONO\_ARRAY\_SLICE}
\fullmodule{BoolVector}{MONO\_VECTOR}
+\fullmodule{BoolVectorSlice}{MONO\_VECTOR\_SLICE}
+\fullmodule{BoolArray2}{MONO\_ARRAY2}
\fullmodule{Byte}{BYTE}
\fullmodule{Char}{CHAR}
\fullmodule{CharArray}{MONO\_ARRAY}
-\fullmodule{CharArray2}{MONO\_ARRAY2}
+\fullmodule{CharArraySlice}{MONO\_ARRAY\_SLICE}
\fullmodule{CharVector}{MONO\_VECTOR}
+\fullmodule{CharVectorSlice}{MONO\_VECTOR\_SLICE}
+\fullmodule{CharArray2}{MONO\_ARRAY2}
\fullmodule{CommandLine}{COMMAND\_LINE}
\fullmodule{Date}{DATE}
\fullmodule{FixedInt}{INTEGER}
@@ -48,13 +69,18 @@
\fullmodule{IEEEReal}{IEEE\_REAL}
\fullmodule{IO}{IO}
\fullmodule{Int}{INTEGER}
-\fullmodule{Int32}{INTEGER}
\fullmodule{IntArray}{MONO\_ARRAY}
-\fullmodule{IntArray2}{MONO\_ARRAY2}
-\module{IntInf}{INT\_INF}
- {Missing: {\tt orb}, {\tt xorb}, {\tt andb},
- {\tt notb}, {\tt <<}, {\tt \~{}>>}}
+\fullmodule{IntArraySlice}{MONO\_ARRAY\_SLICE}
\fullmodule{IntVector}{MONO\_VECTOR}
+\fullmodule{IntVectorSlice}{MONO\_VECTOR\_SLICE}
+\fullmodule{IntArray2}{MONO\_ARRAY2}
+\fullmodule{Int32}{INTEGER}
+\fullmodule{Int32Array}{MONO\_ARRAY}
+\fullmodule{Int32ArraySlice}{MONO\_ARRAY\_SLICE}
+\fullmodule{Int32Vector}{MONO\_VECTOR}
+\fullmodule{Int32VectorSlice}{MONO\_VECTOR\_SLICE}
+\fullmodule{Int32Array2}{MONO\_ARRAY2}
+\fullmodule{IntInf}{INT\_INF}
\fullmodule{LargeInt}{INTEGER}
\module{LargeReal}{REAL}{Same as {\tt Real}}
\fullmodule{LargeWord}{WORD}
@@ -65,25 +91,9 @@
\fullmodule{OS.FileSys}{OS\_FILE\_SYS}
\extra{Use of {\tt OS.FileSys.tmpName} causes a link-time warning.}
\extra{You can use {\tt MLton.TextIO.mkstemp} instead.}
-\module{OS.IO}
- {OS\_IO}
- {Missing: {\tt type poll\_desc},
- {\tt type poll\_info},
- {\tt exception Poll},}
-\extra{
- {\tt infoToPollDesc},
- {\tt isIn},
- {\tt isOut},
- {\tt isPri},
- {\tt pollDesc},
- {\tt pollIn},}
-\extra{
- {\tt pollOut},
- {\tt pollPri},
- {\tt pollToIODesc},
- {\tt poll}.}
+\fullmodule{OS.IO}{OS\_IO}
\module{OS.Path}{OS\_PATH}
- {Missing: {\tt exception InvalidArc}, {\tt toUnixPath},
+ {Missing: {\tt toUnixPath},
{\tt fromUnixPath}.}
\fullmodule{OS.Process}{OS\_PROCESS}
\fullmodule{Pack32Big}{PACK\_WORD}
@@ -96,29 +106,60 @@
{Missing: {\tt nextAfter}, {\tt toDecimal}, {\tt fromDecimal}.}
\extra{Do not match spec: {\tt scan}, {\tt fmt}, {\tt toString}, {\tt
fromString}.}
-\fullmodule{Real64Array}{MONO\_ARRAY}
\fullmodule{RealArray}{MONO\_ARRAY}
-\fullmodule{RealArray2}{MONO\_ARRAY2}
+\fullmodule{RealArraySlice}{MONO\_ARRAY\_SLICE}
\fullmodule{RealVector}{MONO\_VECTOR}
-\fullmodule{SML90}{SML90}
+\fullmodule{RealVectorSlice}{MONO\_VECTOR\_SLICE}
+\fullmodule{RealArray2}{MONO\_ARRAY2}
+\module{Real64}{REAL}{Same as {\tt Real}}
+\fullmodule{Real64Array}{MONO\_ARRAY}
+\fullmodule{Real64ArraySlice}{MONO\_ARRAY\_SLICE}
+\fullmodule{Real64Vector}{MONO\_VECTOR}
+\fullmodule{Real64VectorSlice}{MONO\_VECTOR\_SLICE}
+\fullmodule{Real64Array2}{MONO\_ARRAY2}
\fullmodule{String}{STRING}
\fullmodule{StringCvt}{STRING\_CVT}
\fullmodule{Substring}{SUBSTRING}
\fullmodule{SysWord}{WORD}
+\fullmodule{Text}{TEXT}
\module{TextIO}{TEXT\_IO}
{Missing:
{\tt getPosIn},
{\tt openString},
{\tt setPosIn},
{\tt setPosOut}.}
+\extra{Missing:
+ {\tt StreamIO.reader},
+ {\tt StreamIO.writer},
+ {\tt StreamIO.mkInstream},
+ {\tt StreamIO.getReader},
+ {\tt StreamIO.output},
+ {\tt StreamIO.output1},
+ {\tt StreamIO.flushOut},
+ {\tt StreamIO.closeOut},
+ {\tt StreamIO.setBufferMode},
+ {\tt StreamIO.getBufferMode},
+ {\tt StreamIO.mkOutstream},
+ {\tt StreamIO.getWriter},
+ {\tt StreamIO.getPosOut},
+ {\tt StreamIO.setPosOut}}
+\fullmodule{TextPrimIO}{PRIM\_IO}
\fullmodule{Time}{TIME}
\fullmodule{Timer}{TIMER}
\fullmodule{Unix}{UNIX}
\fullmodule{Vector}{VECTOR}
+\fullmodule{VectorSlice}{VECTOR\_SLICE}
\fullmodule{Word}{WORD}
\fullmodule{Word8}{WORD}
\fullmodule{Word8Array}{MONO\_ARRAY}
-\fullmodule{Word8Array2}{MONO\_ARRAY2}
+\fullmodule{Word8ArraySlice}{MONO\_ARRAY\_SLICE}
\fullmodule{Word8Vector}{MONO\_VECTOR}
+\fullmodule{Word8VectorSlice}{MONO\_VECTOR\_SLICE}
+\fullmodule{Word8Array2}{MONO\_ARRAY2}
\fullmodule{Word32}{WORD}
+\fullmodule{Word32Array}{MONO\_ARRAY}
+\fullmodule{Word32ArraySlice}{MONO\_ARRAY\_SLICE}
+\fullmodule{Word32Vector}{MONO\_VECTOR}
+\fullmodule{Word32VectorSlice}{MONO\_VECTOR\_SLICE}
+\fullmodule{Word32Array2}{MONO\_ARRAY2}
\end{longtable}
1.29 +19 -0 mlton/doc/user-guide/extensions.tex
Index: extensions.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/extensions.tex,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- extensions.tex 2 Nov 2002 03:37:35 -0000 1.28
+++ extensions.tex 24 Nov 2002 01:19:41 -0000 1.29
@@ -1044,3 +1044,22 @@
where type elem = Real64Array.elem
end
\end{verbatim}
+
+\subsec{{\tt Basis1997: BASIS\_1997}}{basis1997}
+
+Opening this module at the top-level will, for the most part, simulate
+the Basis Library as implemented in previous versions of {\mlton}.
+However, there are two major caveats. First, {\tt Basis1997} inherits
+much of the current Basis Library implementation. Hence, some
+functions violate the stated semantics of the previous Basis Library
+specification. For the most part, such violations are benign; the
+major exception is the {\tt Time} module which now supports negative
+time-values. Second, since Standard ML does not support declaring
+signatures within structures, opening this module will not introduce
+signatures. To recover such signatures, compile with {\tt -basis
+basis-1997}.
+
+\subsection{{\tt SML90: SML90}}
+
+This module has been removed from the latest Basis Library
+specification. It is included for backwards compatiblility.
1.23 +10 -0 mlton/doc/user-guide/man-page.tex
Index: man-page.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/man-page.tex,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- man-page.tex 2 Nov 2002 03:37:35 -0000 1.22
+++ man-page.tex 24 Nov 2002 01:19:41 -0000 1.23
@@ -35,6 +35,16 @@
\begin{description}
+\option{-basis \{basis-2002|basis-2002-strict|basis-1997|none\}}
+Selects a Basis Library to be used by the input program. {\tt
+basis-2002} and {\tt basis-2002-strict} implement the current Basis
+Library specification; {\tt basis-2002-strict} removes all extensions
+described in \secref{mlton}. {\tt basis-1997} implements a previous
+version of the Basis Library specification; see \secref{basis1997} for
+more information. {\tt none} removes all Basis Library functionality;
+the only bound identifier is {\tt =} corresponding to polymorphic
+equality.
+
\option{-detect-overflow \{true|false\}}
This flag controls whether or not overflow checking is performed on integer
arithmetic, in particular on {\tt Int.\{+,-,*,\~{},div,quot\}}.
1.41 +0 -3 mlton/include/ccodegen.h
Index: ccodegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/ccodegen.h,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -r1.40 -r1.41
--- ccodegen.h 22 Nov 2002 02:48:20 -0000 1.40
+++ ccodegen.h 24 Nov 2002 01:19:41 -0000 1.41
@@ -647,10 +647,7 @@
/* String */
/* ------------------------------------------------- */
-#define String_size GC_arrayNumElements
-#define String_fromCharVector(x) x
#define String_fromWord8Vector(x) x
-#define String_toCharVector(x) x
#define String_toWord8Vector(x) x
/* ------------------------------------------------- */
1.1 mlton/lib/basis-stubs/Makefile
Index: Makefile
===================================================================
.PHONY: clean
clean:
../../bin/clean
1.1 mlton/lib/basis-stubs/basis-2002.sml
Index: basis-2002.sml
===================================================================
structure Basis2002 =
struct
structure Array = Array
structure Array2 = Array2
structure BinIO = BinIO
structure Bool = Bool
structure Byte = Byte
structure Char = Char
structure CharArray = CharArray
structure CharVector = CharVector
structure CommandLine = CommandLine
structure Date = Date
structure General = General
structure IEEEReal = IEEEReal
structure Int = Int
structure Int32 = Int32
structure IntInf = IntInf
structure IO = IO
structure LargeInt = LargeInt
structure LargeReal = LargeReal
structure LargeWord = LargeWord
structure List = List
structure ListPair = ListPair
structure Math = Math
structure OS = OS
structure Option = Option
structure Pack32Big = Pack32Big
structure Pack32Little = Pack32Little
structure Position = Position
structure Posix = Posix
structure Real = Real
structure Real64Array = Real64Array
structure RealArray = RealArray
structure RealVector = RealVector
structure SML90 = SML90
structure SMLofNJ = SMLofNJ
structure String = String
structure StringCvt = StringCvt
structure Substring = Substring
structure SysWord = SysWord
structure TextIO = TextIO
structure Time = Time
structure Unix = Unix
structure Unsafe = Unsafe
structure Vector = Vector
structure Word = Word
structure Word32 = Word32
structure Word8 = Word8
structure Word8Array = Word8Array
structure Word8Vector = Word8Vector
end
1.1 mlton/lib/basis-stubs/os.sml
Index: os.sml
===================================================================
structure OS =
struct
open OS
structure FileSys =
struct
open FileSys
val readDir = fn d =>
case readDir d of
"" => NONE
| s => SOME s
end
end
1.1 mlton/lib/basis-stubs/sources.cm
Index: sources.cm
===================================================================
Library
structure Basis2002
is
#if (SMLNJ_VERSION == 110) && (SMLNJ_MINOR_VERSION >= 20)
$/basis.cm
$/smlnj-lib.cm
#endif
basis-2002.sml
os.sml
1.3 +2 -5 mlton/lib/mlton/basic/dir.sml
Index: dir.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/dir.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- dir.sml 10 Apr 2002 07:50:30 -0000 1.2
+++ dir.sml 24 Nov 2002 01:19:42 -0000 1.3
@@ -45,10 +45,8 @@
val stream = FS.openDir d
fun loop a =
case FS.readDir stream of
- "" => a
- | "." => raise Fail "read saw ."
- | ".." => raise Fail "read saw .."
- | s => loop (f (s, a))
+ NONE => a
+ | SOME s => loop (f (s, a))
in DynamicWind.wind (fn () => loop a, fn () => FS.closeDir stream)
end
@@ -91,5 +89,4 @@
DynamicWind.wind (fn () => inDir (d, fn _ => thunk ()),
fn () => removeR d)
end
-
end
1.5 +0 -1 mlton/lib/mlton/basic/init-script.sml
Index: init-script.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/init-script.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- init-script.sml 10 Apr 2002 07:50:31 -0000 1.4
+++ init-script.sml 24 Nov 2002 01:19:42 -0000 1.5
@@ -88,5 +88,4 @@
| "stop" => stop ()
| _ => usage "must start|status|stop"
end
-
end
1.7 +2 -1 mlton/lib/mlton/basic/process.sig
Index: process.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/process.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- process.sig 7 Nov 2002 01:36:54 -0000 1.6
+++ process.sig 24 Nov 2002 01:19:42 -0000 1.7
@@ -100,6 +100,7 @@
pid: Pid.t,
ppid: Pid.t,
state: State.t} list
+
end
functor TestProcess (S: PROCESS): sig end =
@@ -110,5 +111,5 @@
open S
val _ = ps ()
-
+
end
1.6 +1 -1 mlton/lib/mlton/basic/string0.sml
Index: string0.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/string0.sml,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- string0.sml 14 Nov 2002 22:28:12 -0000 1.5
+++ string0.sml 24 Nov 2002 01:19:42 -0000 1.6
@@ -199,7 +199,7 @@
fun alphabetize s = implode (sort (explode s, Char.<))
fun fromCharArray (a: CharArray.array): t =
- CharArray.extract (a, 0, NONE)
+ CharVector.tabulate (CharArray.length a, fn i => CharArray.sub (a, i))
fun toString s = s
1.5 +2 -0 mlton/lib/mlton/pervasive/pervasive.sml
Index: pervasive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/pervasive/pervasive.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- pervasive.sml 20 Jul 2002 23:14:01 -0000 1.4
+++ pervasive.sml 24 Nov 2002 01:19:42 -0000 1.5
@@ -33,7 +33,9 @@
structure Position = Position
structure Posix = Posix
structure Real = Real
+(*
structure SML90 = SML90
+*)
structure SMLofNJ = SMLofNJ
structure String = String
structure StringCvt = StringCvt
1.4 +1 -0 mlton/lib/mlton-stubs/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/sources.cm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- sources.cm 2 Nov 2002 03:37:37 -0000 1.3
+++ sources.cm 24 Nov 2002 01:19:42 -0000 1.4
@@ -66,6 +66,7 @@
exn.sig
gc.sig
int-inf.sig
+int-inf.sml
io.sig
itimer.sig
mlton.sig
1.1 mlton/lib/mlton-stubs/int-inf.sml
Index: int-inf.sml
===================================================================
structure IntInf =
struct
open IntInf
val orb: int * int -> int =
fn _ => raise Fail "IntInf.orb"
val xorb: int * int -> int =
fn _ => raise Fail "IntInf.xorb"
val andb: int * int -> int =
fn _ => raise Fail "IntInf.andb"
val notb: int -> int =
fn _ => raise Fail "IntInf.notb"
val << : int * Word.word -> int =
fn _ => raise Fail "IntInf.<<"
val ~>> : int * Word.word -> int =
fn _ => raise Fail "IntInf.~>>"
end
1.4 +1 -0 mlton/lib/mlton-stubs-in-smlnj/import.cm
Index: import.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs-in-smlnj/import.cm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- import.cm 3 Feb 2002 20:43:34 -0000 1.3
+++ import.cm 24 Nov 2002 01:19:42 -0000 1.4
@@ -8,4 +8,5 @@
$/basis.cm
$/smlnj-lib.cm
#endif
+../basis-stubs/sources.cm
pervasive.sml
1.3 +1 -1 mlton/lib/mlton-stubs-in-smlnj/os.sml
Index: os.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs-in-smlnj/os.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- os.sml 9 Oct 2001 00:17:49 -0000 1.2
+++ os.sml 24 Nov 2002 01:19:42 -0000 1.3
@@ -1,6 +1,6 @@
structure OS =
struct
- open OS
+ open Pervasive.OS
structure FileSys =
struct
1.3 +1 -0 mlton/lib/mlton-stubs-in-smlnj/pervasive.sml
Index: pervasive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs-in-smlnj/pervasive.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- pervasive.sml 3 Feb 2002 20:43:34 -0000 1.2
+++ pervasive.sml 24 Nov 2002 01:19:42 -0000 1.3
@@ -1,5 +1,6 @@
structure Pervasive =
struct
+ open Basis2002
structure Array = Array
structure Array2 = Array2
structure Bool = Bool
1.18 +3 -2 mlton/mllex/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/mllex/Makefile,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- Makefile 21 Nov 2002 02:49:21 -0000 1.17
+++ Makefile 24 Nov 2002 01:19:42 -0000 1.18
@@ -25,8 +25,9 @@
.PHONY: $(NAME)-stubs_cm
$(NAME)-stubs_cm:
( \
- echo 'Group is'&& \
- cmcat sources.cm | grep -v 'mlton-stubs-in-smlnj' && \
+ echo 'Group is' && \
+ cmcat sources.cm | grep -v 'basis-stubs' | \
+ grep -v 'mlton-stubs-in-smlnj' && \
echo 'call-main.sml'; \
) >$(NAME)-stubs.cm
1.3 +1 -0 mlton/mllex/mllex-stubs.cm
Index: mllex-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mllex/mllex-stubs.cm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- mllex-stubs.cm 2 Nov 2002 03:37:37 -0000 1.2
+++ mllex-stubs.cm 24 Nov 2002 01:19:42 -0000 1.3
@@ -1,4 +1,5 @@
Group is
+../lib/mlton-stubs/int-inf.sml
../lib/mlton-stubs/real.sml
../lib/mlton/pervasive/pervasive.sml
../lib/mlton/basic/error.sig
1.19 +3 -2 mlton/mlprof/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/mlprof/Makefile,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- Makefile 21 Nov 2002 02:49:21 -0000 1.18
+++ Makefile 24 Nov 2002 01:19:43 -0000 1.19
@@ -25,8 +25,9 @@
.PHONY: $(NAME)-stubs_cm
$(NAME)-stubs_cm:
( \
- echo 'Group is'&& \
- cmcat sources.cm | grep -v 'mlton-stubs-in-smlnj' && \
+ echo 'Group is' && \
+ cmcat sources.cm | grep -v 'basis-stubs' | \
+ grep -v 'mlton-stubs-in-smlnj' && \
echo 'call-main.sml'; \
) >$(NAME)-stubs.cm
1.3 +1 -0 mlton/mlprof/mlprof-stubs.cm
Index: mlprof-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlprof/mlprof-stubs.cm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- mlprof-stubs.cm 2 Nov 2002 03:37:37 -0000 1.2
+++ mlprof-stubs.cm 24 Nov 2002 01:19:43 -0000 1.3
@@ -1,4 +1,5 @@
Group is
+../lib/mlton-stubs/int-inf.sml
../lib/mlton-stubs/real.sml
../lib/mlton/pervasive/pervasive.sml
../lib/mlton/basic/dynamic-wind.sig
1.59 +5 -3 mlton/mlton/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/Makefile,v
retrieving revision 1.58
retrieving revision 1.59
diff -u -r1.58 -r1.59
--- Makefile 22 Nov 2002 20:05:47 -0000 1.58
+++ Makefile 24 Nov 2002 01:19:43 -0000 1.59
@@ -33,10 +33,12 @@
.PHONY: $(NAME)-stubs_cm
$(NAME)-stubs_cm: front-end/ml.lex.sml front-end/ml.grm.sig front-end/ml.grm.sml
( \
- echo 'Group is'&& \
- cmcat sources.cm | grep -v 'mlton-stubs-in-smlnj' | \
+ echo 'Group is' && \
+ cmcat sources.cm | grep -v 'basis-stubs' | \
+ grep -v 'mlton-stubs-in-smlnj' | \
grep mlyacc && \
- cmcat sources.cm | grep -v 'mlton-stubs-in-smlnj' | \
+ cmcat sources.cm | grep -v 'basis-stubs' | \
+ grep -v 'mlton-stubs-in-smlnj' | \
grep -v mlyacc && \
echo 'call-main.sml'; \
) >$(NAME)-stubs.cm
1.7 +1 -0 mlton/mlton/mlton-stubs.cm
Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- mlton-stubs.cm 7 Nov 2002 01:36:55 -0000 1.6
+++ mlton-stubs.cm 24 Nov 2002 01:19:43 -0000 1.7
@@ -5,6 +5,7 @@
../lib/mlyacc/parser2.sml
../lib/mlyacc/join.sml
../lib/mlton-stubs/thread.sml
+../lib/mlton-stubs/int-inf.sml
../lib/mlton-stubs/random.sig
../lib/mlton-stubs/random.sml
../lib/mlton-stubs/world.sig
1.6 +4 -0 mlton/mlton/ast/ast.fun
Index: ast.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- ast.fun 10 Apr 2002 07:02:18 -0000 1.5
+++ ast.fun 24 Nov 2002 01:19:43 -0000 1.6
@@ -342,6 +342,10 @@
struct
datatype t = T of Topdec.t list
+ val empty = T []
+
+ fun append (T ds1, T ds2) = T (ds1 @ ds2)
+
fun layout (T ds) = Layout.align (List.map (ds, Topdec.layout))
fun size (T ds): int =
1.3 +2 -0 mlton/mlton/ast/ast.sig
Index: ast.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- ast.sig 10 Apr 2002 07:02:18 -0000 1.2
+++ ast.sig 24 Nov 2002 01:19:43 -0000 1.3
@@ -171,6 +171,8 @@
sig
datatype t = T of Topdec.t list
+ val append: t * t -> t
+ val empty: t
val size: t -> int
val layout: t -> Layout.t
end
1.4 +1 -2 mlton/mlton/ast/prim-tycons.fun
Index: prim-tycons.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- prim-tycons.fun 10 Apr 2002 07:02:18 -0000 1.3
+++ prim-tycons.fun 24 Nov 2002 01:19:43 -0000 1.4
@@ -25,7 +25,6 @@
val real = fromString "real"
val reff = fromString "ref"
val thread = fromString "thread"
- val string = fromString "string"
val tuple = fromString "*"
val vector = fromString "vector"
val word = fromString "word"
@@ -33,7 +32,7 @@
val prims =
[array, arrow, bool, char, exn, int, intInf, list, pointer,
- preThread, real, reff, string, thread, tuple, vector, word, word8]
+ preThread, real, reff, thread, tuple, vector, word, word8]
val defaultInt = int
val defaultWord = word
1.4 +0 -1 mlton/mlton/ast/prim-tycons.sig
Index: prim-tycons.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- prim-tycons.sig 10 Apr 2002 07:02:18 -0000 1.3
+++ prim-tycons.sig 24 Nov 2002 01:19:43 -0000 1.4
@@ -28,7 +28,6 @@
val preThread: tycon
val real: tycon
val reff: tycon
- val string: tycon
val thread: tycon
val tuple: tycon
val vector: tycon
1.6 +46 -21 mlton/mlton/atoms/const.fun
Index: const.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/const.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- const.fun 6 Jul 2002 17:22:05 -0000 1.5
+++ const.fun 24 Nov 2002 01:19:43 -0000 1.6
@@ -14,6 +14,32 @@
in structure Aconst = Const
end
+structure Type =
+ struct
+ type t = Tycon.t * Tycon.t vector
+ fun equals ((tc1,tcs1), (tc2,tcs2)) =
+ Tycon.equals (tc1, tc2)
+ andalso
+ Vector.equals (tcs1, tcs2, Tycon.equals)
+ fun toType ((tc,tcs), con) =
+ con (tc, Vector.map (tcs, fn tc => con (tc, Vector.new0())))
+ val layout = Ast.Type.layout o (fn t =>
+ toType (t, fn (t, ts) =>
+ Ast.Type.con (Tycon.toAst t, ts)))
+ val toString = Layout.toString o layout
+ fun make (tc, tcs) : t = (tc, tcs)
+ fun unary (tc, tc') = make (tc, Vector.new1 tc')
+ fun nullary tc = make (tc, Vector.new0())
+ val bool = nullary Tycon.bool
+ val char = nullary Tycon.char
+ val int = nullary Tycon.defaultInt
+ val intInf = nullary Tycon.intInf
+ val real = nullary Tycon.real
+ val word = nullary Tycon.word
+ val word8 = nullary Tycon.word8
+ val string = unary (Tycon.vector, Tycon.char)
+ end
+
structure Node =
struct
datatype t =
@@ -40,19 +66,19 @@
datatype z = datatype Node.t
datatype t = T of {node: Node.t,
- tycon: Tycon.t}
+ ty: Type.t}
local
fun make sel (T r) = sel r
in
val node = make #node
- val tycon = make #tycon
+ val ty = make #ty
end
val layout = Node.layout o node
val toString = Layout.toString o layout
-fun make (n, t) = T {node = n, tycon = t}
+fun make (n, t) = T {node = n, ty = t}
local
val char = Random.word ()
@@ -74,12 +100,13 @@
val make = fn n => make (Ast.Const.makeRegion (n, Region.bogus))
fun maybeConstrain (defaultTycon, aconst) =
let
- val t = tycon c
+ val ty = ty c
+ val con : Tycon.t * Ast.Type.t vector -> Ast.Type.t =
+ fn (t, ts) => Ast.Type.con (Tycon.toAst t, ts)
in
- if Tycon.equals (t, defaultTycon)
+ if Type.equals (ty, Type.nullary defaultTycon)
then make aconst
- else constrain (make aconst, Ast.Type.con (Tycon.toAst t,
- Vector.new0 ()))
+ else constrain (make aconst, Type.toType (ty, con))
end
fun int s = maybeConstrain (Tycon.defaultInt, Aconst.Int s)
in
@@ -96,7 +123,7 @@
val toAstPat = toAst (Ast.Pat.const, Ast.Pat.constraint)
fun equals (c, c') =
- Tycon.equals (tycon c, tycon c')
+ Type.equals (ty c, ty c')
andalso
case (node c, node c') of
(Char c, Char c') => c = c'
@@ -109,19 +136,17 @@
val equals = Trace.trace2 ("Const.equals", layout, layout, Bool.layout) equals
-fun fromChar c = T {node = Char c, tycon = Tycon.char}
-
-fun fromInt n = T {node = Int n, tycon = Tycon.defaultInt}
-
-fun fromIntInf i = T {node = IntInf i, tycon = Tycon.intInf}
-
-fun fromString s = T {node = String s, tycon = Tycon.string}
-
-fun fromReal s = T {node = Real s, tycon = Tycon.real}
-
-fun fromWord w = T {node = Word w, tycon = Tycon.word}
-
-fun fromWord8 w = T {node = Word (Word.fromWord8 w), tycon = Tycon.word8}
+local
+ fun make c t x = T {node = c x, ty = t}
+in
+ val fromChar = make Char Type.char
+ val fromInt = make Int Type.int
+ val fromIntInf = make IntInf Type.intInf
+ val fromReal = make Real Type.real
+ val fromString = make String Type.string
+ val fromWord = make Word Type.word
+ val fromWord8 = make (fn w => Word (Word.fromWord8 w)) Type.word8
+end
structure SmallIntInf =
struct
1.5 +21 -2 mlton/mlton/atoms/const.sig
Index: const.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/const.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- const.sig 6 Jul 2002 17:22:05 -0000 1.4
+++ const.sig 24 Nov 2002 01:19:43 -0000 1.5
@@ -13,12 +13,31 @@
structure Ast: AST
structure Tycon: TYCON
sharing Tycon.AstId = Ast.Tycon
+ sharing Tycon.AstId = Ast.Tycon
end
signature CONST =
sig
include CONST_STRUCTS
+ structure Type:
+ sig
+ type t
+ val make: Tycon.t * Tycon.t vector -> t
+ val equals: t * t -> bool
+ val layout: t -> Layout.t
+ val toString: t -> string
+ val toType: t * (Tycon.t * 'a vector -> 'a) -> 'a
+ val bool: t
+ val char: t
+ val int: t
+ val intInf: t
+ val real: t
+ val string: t
+ val word: t
+ val word8: t
+ end
+
structure SmallIntInf:
sig
val isSmall: IntInf.t -> bool
@@ -51,10 +70,10 @@
val fromWord8: Word8.t -> t
val hash: t -> word
val layout: t -> Layout.t
- val make: Node.t * Tycon.t -> t
+ val make: Node.t * Type.t -> t
val node: t -> Node.t
val toAstExp: t -> Ast.Exp.t
val toAstPat: t -> Ast.Pat.t
val toString: t -> string
- val tycon: t -> Tycon.t
+ val ty: t -> Type.t
end
1.3 +1 -1 mlton/mlton/atoms/hash-type.fun
Index: hash-type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/hash-type.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- hash-type.fun 10 Apr 2002 07:02:18 -0000 1.2
+++ hash-type.fun 24 Nov 2002 01:19:43 -0000 1.3
@@ -177,7 +177,7 @@
fun optionToAst z = Option.map (z, toAst)
-fun ofConst c = con (Const.tycon c, Vector.new0 ())
+fun ofConst c = Const.Type.toType (Const.ty c, con)
fun isUnit t =
case dest t of
1.41 +28 -35 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -r1.40 -r1.41
--- prim.fun 14 Nov 2002 22:25:41 -0000 1.40
+++ prim.fun 24 Nov 2002 01:19:43 -0000 1.41
@@ -61,20 +61,6 @@
| GC_collect
| GC_pack
| GC_unpack
- | IntInf_add
- | IntInf_compare
- | IntInf_equal
- | IntInf_fromVector
- | IntInf_fromWord
- | IntInf_gcd
- | IntInf_mul
- | IntInf_neg
- | IntInf_quot
- | IntInf_rem
- | IntInf_sub
- | IntInf_toString
- | IntInf_toVector
- | IntInf_toWord
| Int_add
| Int_addCheck
| Int_ge
@@ -91,6 +77,26 @@
| Int_rem
| Int_sub
| Int_subCheck
+ | IntInf_add
+ | IntInf_andb
+ | IntInf_arshift
+ | IntInf_compare
+ | IntInf_equal
+ | IntInf_fromVector
+ | IntInf_fromWord
+ | IntInf_gcd
+ | IntInf_lshift
+ | IntInf_mul
+ | IntInf_notb
+ | IntInf_neg
+ | IntInf_orb
+ | IntInf_quot
+ | IntInf_rem
+ | IntInf_sub
+ | IntInf_toString
+ | IntInf_toVector
+ | IntInf_toWord
+ | IntInf_xorb
| MLton_bogus
| MLton_bug
| MLton_deserialize
@@ -140,12 +146,7 @@
| Ref_assign
| Ref_deref
| Ref_ref
- | String_equal
- | String_fromCharVector
| String_fromWord8Vector
- | String_size
- | String_sub
- | String_toCharVector
| String_toWord8Vector
| Thread_atomicBegin
| Thread_atomicEnd
@@ -212,17 +213,16 @@
val equals: t * t -> bool = op =
val isCommutative =
- fn IntInf_equal => true
- | Int_add => true
+ fn Int_add => true
| Int_addCheck => true
| Int_mul => true
| Int_mulCheck => true
+ | IntInf_equal => true
| MLton_eq => true
| MLton_equal => true
| Real_add => true
| Real_mul => true
| Real_qequal => true
- | String_equal => true
| Word32_add => true
| Word32_addCheck => true
| Word32_andb => true
@@ -282,19 +282,25 @@
(GC_pack, SideEffect, "GC_pack"),
(GC_unpack, SideEffect, "GC_unpack"),
(IntInf_add, Functional, "IntInf_add"),
+ (IntInf_andb, Functional, "IntInf_andb"),
+ (IntInf_arshift, Functional, "IntInf_arshift"),
(IntInf_compare, Functional, "IntInf_compare"),
(IntInf_equal, Functional, "IntInf_equal"),
(IntInf_fromVector, Functional, "IntInf_fromVector"),
(IntInf_fromWord, Functional, "IntInf_fromWord"),
(IntInf_gcd, Functional, "IntInf_gcd"),
+ (IntInf_lshift, Functional, "IntInf_lshift"),
(IntInf_mul, Functional, "IntInf_mul"),
+ (IntInf_notb, Functional, "IntInf_notb"),
(IntInf_neg, Functional, "IntInf_neg"),
+ (IntInf_orb, Functional, "IntInf_orb"),
(IntInf_quot, Functional, "IntInf_quot"),
(IntInf_rem, Functional, "IntInf_rem"),
(IntInf_sub, Functional, "IntInf_sub"),
(IntInf_toString, Functional, "IntInf_toString"),
(IntInf_toVector, Functional, "IntInf_toVector"),
(IntInf_toWord, Functional, "IntInf_toWord"),
+ (IntInf_xorb, Functional, "IntInf_xorb"),
(Int_add, Functional, "Int_add"),
(Int_addCheck, SideEffect, "Int_addCheck"),
(Int_ge, Functional, "Int_ge"),
@@ -361,12 +367,7 @@
(Ref_assign, SideEffect, "Ref_assign"),
(Ref_deref, DependsOnState, "Ref_deref"),
(Ref_ref, Moveable, "Ref_ref"),
- (String_equal, Functional, "String_equal"),
- (String_fromCharVector, Functional, "String_fromCharVector"),
(String_fromWord8Vector, Functional, "String_fromWord8Vector"),
- (String_size, Functional, "String_size"),
- (String_sub, Functional, "String_sub"),
- (String_toCharVector, Functional, "String_toCharVector"),
(String_toWord8Vector, Functional, "String_toWord8Vector"),
(Thread_atomicBegin, SideEffect, "Thread_atomicBegin"),
(Thread_atomicEnd, SideEffect, "Thread_atomicEnd"),
@@ -551,7 +552,6 @@
val intInfNeg =
new0 (Name.IntInf_neg, tuple [intInf, word] --> intInf)
val intInfEqual = new0 (Name.IntInf_equal, tuple [intInf, intInf] --> bool)
- val stringEqual = new0 (Name.String_equal, tuple [string, string] --> bool)
val word8Neg = new0 (Name.Word8_neg, word8 --> word8)
val word8Notb = new0 (Name.Word8_notb, word8 --> word8)
val word32Notb = new0 (Name.Word32_notb, word --> word)
@@ -849,10 +849,6 @@
| SOME w => word w)
| (MLton_eq, [c1, c2]) => eq (c1, c2)
| (MLton_equal, [c1, c2]) => equal (c1, c2)
- | (String_equal, [String s1, String s2]) =>
- bool (String.equals (s1, s2))
- | (String_size, [String s]) => int (String.size s)
- | (String_sub, [String s, Int i]) => char (String.sub (s, i))
| (Word8_mul, [Word w1, Word w2]) => w8o (Word8.*, w1, w2)
| (Word8_add, [Word w1, Word w2]) => w8o (Word8.+, w1, w2)
| (Word8_sub, [Word w1, Word w2]) => w8o (Word8.-, w1, w2)
@@ -1186,7 +1182,6 @@
| Real_gt => f
| Real_ge => t
| Real_qequal => t
- | String_equal => t
| Word8_andb => Var x
| Word8_div => word8 0w1
| Word8_ge => t
@@ -1280,8 +1275,6 @@
| Ref_assign => two ":="
| Ref_deref => one "!"
| Ref_ref => one "ref"
- | String_equal => two "="
- | String_size => one "size"
| Vector_length => one "length"
| Word32_add => two "+"
| Word32_addCheck => two "+c"
1.33 +22 -22 mlton/mlton/atoms/prim.sig
Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- prim.sig 14 Nov 2002 22:25:41 -0000 1.32
+++ prim.sig 24 Nov 2002 01:19:43 -0000 1.33
@@ -51,36 +51,42 @@
| GC_collect
| GC_pack
| GC_unpack
- | Int_mul
- | Int_mulCheck
- | Int_add
- | Int_addCheck
- | Int_sub
- | Int_subCheck
- | Int_lt
- | Int_le
- | Int_gt
- | Int_ge
- | Int_geu
- | Int_gtu
- | Int_quot
- | Int_rem
- | Int_neg
- | Int_negCheck
+ | Int_add
+ | Int_addCheck
+ | Int_ge
+ | Int_geu
+ | Int_gt
+ | Int_gtu
+ | Int_le
+ | Int_lt
+ | Int_mul
+ | Int_mulCheck
+ | Int_neg
+ | Int_negCheck
+ | Int_quot
+ | Int_rem
+ | Int_sub
+ | Int_subCheck
| IntInf_add
+ | IntInf_andb
+ | IntInf_arshift
| IntInf_compare
| IntInf_equal
| IntInf_fromVector
| IntInf_fromWord
| IntInf_gcd
+ | IntInf_lshift
| IntInf_mul
+ | IntInf_notb
| IntInf_neg
+ | IntInf_orb
| IntInf_quot
| IntInf_rem
| IntInf_sub
| IntInf_toString
| IntInf_toVector
| IntInf_toWord
+ | IntInf_xorb
| MLton_bogus (* of type unit -> 'a.
* implemented in backend.
* Makes a bogus value of any type.
@@ -145,12 +151,7 @@
| Ref_assign (* implemented in backend *)
| Ref_deref (* implemented in backend *)
| Ref_ref (* implemented in backend *)
- | String_equal
- | String_fromCharVector
| String_fromWord8Vector
- | String_size
- | String_sub (* implemented in backend *)
- | String_toCharVector
| String_toWord8Vector
| Thread_atomicBegin (* implemented in backend *)
| Thread_atomicEnd (* implemented in backend *)
@@ -312,7 +313,6 @@
val reff: t
val scheme: t -> Scheme.t
val serialize: t
- val stringEqual: t
val toString: t -> string
val vectorLength: t
val vectorSub: t
1.4 +18 -1 mlton/mlton/atoms/type-ops.fun
Index: type-ops.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- type-ops.fun 10 Apr 2002 07:02:19 -0000 1.3
+++ type-ops.fun 24 Nov 2002 01:19:43 -0000 1.4
@@ -22,7 +22,6 @@
val intInf = nullary Tycon.intInf
val preThread = nullary Tycon.preThread
val real = nullary Tycon.real
- val string = nullary Tycon.string
val thread = nullary Tycon.thread
val word = nullary Tycon.word
val word8 = nullary Tycon.word8
@@ -40,6 +39,8 @@
val reff = unary Tycon.reff
end
+val string = vector char
+
local
fun binary tycon (t1, t2) = con (tycon, Vector.new2 (t1, t2))
in
@@ -94,6 +95,22 @@
case deconOpt t of
SOME (c, _) => c
| NONE => Error.bug "detycon"
+
+fun deconConstOpt t =
+ case deconOpt t of
+ SOME (c, ts) => SOME (c, Vector.map (ts, fn t =>
+ case deconOpt t of
+ SOME (c, _) => c
+ | NONE => Error.bug "deconConstOpt"))
+ | NONE => NONE
+fun deconConst t =
+ case deconOpt t of
+ SOME (c, ts) => (c, Vector.map (ts, fn t =>
+ case deconOpt t of
+ SOME (c, _) => c
+ | NONE => Error.bug "deconConst"))
+ | NONE => Error.bug "deconConst"
+
fun dearrowOpt t =
case deconOpt t of
1.4 +2 -0 mlton/mlton/atoms/type-ops.sig
Index: type-ops.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- type-ops.sig 10 Apr 2002 07:02:19 -0000 1.3
+++ type-ops.sig 24 Nov 2002 01:19:43 -0000 1.4
@@ -39,6 +39,8 @@
val dearrow: t -> t * t
val dearrowOpt: t -> (t * t) option
val deconOpt: t -> (tycon * t vector) option
+ val deconConstOpt: t -> (tycon * tycon vector) option
+ val deconConst: t -> (tycon * tycon vector)
val defaultInt: t
val defaultWord: t
val deref: t -> t
1.36 +3 -3 mlton/mlton/backend/backend.fun
Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -r1.35 -r1.36
--- backend.fun 2 Nov 2002 03:37:38 -0000 1.35
+++ backend.fun 24 Nov 2002 01:19:43 -0000 1.36
@@ -292,10 +292,10 @@
else M.Operand.Float f
| String s => globalString s
| Word w =>
- let val t = Const.tycon c
- in if Tycon.equals (t, Tycon.word)
+ let val ty = Const.ty c
+ in if Const.Type.equals (ty, Const.Type.word)
then M.Operand.Uint w
- else if Tycon.equals (t, Tycon.word8)
+ else if Const.Type.equals (ty, Const.Type.word8)
then M.Operand.Char (Char.chr (Word.toInt w))
else Error.bug "strange word"
end
1.4 +0 -4 mlton/mlton/backend/c-function.fun
Index: c-function.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/c-function.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- c-function.fun 2 Nov 2002 03:37:38 -0000 1.3
+++ c-function.fun 24 Nov 2002 01:19:43 -0000 1.4
@@ -123,8 +123,4 @@
val size = vanilla {name = "MLton_size",
returnTy = SOME Type.int}
-
-val stringEqual = vanilla {name = "String_equal",
- returnTy = SOME Type.bool}
-
end
1.3 +0 -1 mlton/mlton/backend/c-function.sig
Index: c-function.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/c-function.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- c-function.sig 2 Nov 2002 03:37:38 -0000 1.2
+++ c-function.sig 24 Nov 2002 01:19:43 -0000 1.3
@@ -49,6 +49,5 @@
val needsProfileAllocIndex: t -> bool
val returnTy: t -> Type.t option
val size: t
- val stringEqual: t
val vanilla: {name: string, returnTy: Type.t option} -> t
end
1.8 +0 -2 mlton/mlton/backend/representation.fun
Index: representation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- representation.fun 10 Apr 2002 07:02:19 -0000 1.7
+++ representation.fun 24 Nov 2002 01:19:43 -0000 1.8
@@ -126,7 +126,6 @@
| PreThread => SOME Mtype.pointer
| Real => SOME Mtype.double
| Ref _ => SOME Mtype.pointer
- | String => SOME Mtype.pointer
| Thread => SOME Mtype.pointer
| Tuple ts => if Vector.isEmpty ts
then NONE
@@ -189,7 +188,6 @@
TyconRep.IndirectTag _ => true
| _ => false)
| Ref _ => true
- | String => true
| Tuple _ => true
| Vector _ => true
| _ => false
1.19 +3 -3 mlton/mlton/backend/rssa.fun
Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- rssa.fun 2 Nov 2002 03:37:38 -0000 1.18
+++ rssa.fun 24 Nov 2002 01:19:43 -0000 1.19
@@ -95,11 +95,11 @@
| String _ => Type.pointer
| Word _ =>
let
- val t = Const.tycon c
+ val ty = Const.ty c
in
- if Tycon.equals (t, Tycon.word)
+ if Const.Type.equals (ty, Const.Type.word)
then Type.uint
- else if Tycon.equals (t, Tycon.word8)
+ else if Const.Type.equals (ty, Const.Type.word8)
then Type.char
else Error.bug "strange word"
end
1.25 +12 -3 mlton/mlton/backend/ssa-to-rssa.fun
Index: ssa-to-rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.fun,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- ssa-to-rssa.fun 2 Nov 2002 03:37:39 -0000 1.24
+++ ssa-to-rssa.fun 24 Nov 2002 01:19:43 -0000 1.25
@@ -49,13 +49,19 @@
returnTy = SOME Type.pointer}
in
val intInfAdd = make ("IntInf_do_add", 2)
+ val intInfAndb = make ("IntInf_do_andb", 2)
+ val intInfArshift = make ("IntInf_do_arshift", 2)
val intInfGcd = make ("IntInf_do_gcd", 2)
+ val intInfLshift = make ("IntInf_do_lshift", 2)
val intInfMul = make ("IntInf_do_mul", 2)
val intInfNeg = make ("IntInf_do_neg", 1)
+ val intInfNotb = make ("IntInf_do_notb", 1)
+ val intInfOrb = make ("IntInf_do_orb", 2)
val intInfQuot = make ("IntInf_do_quot", 2)
val intInfRem = make ("IntInf_do_rem", 2)
val intInfSub = make ("IntInf_do_sub", 2)
val intInfToString = make ("IntInf_do_toString", 2)
+ val intInfXorb = make ("IntInf_do_xorb", 2)
end
local
@@ -1009,18 +1015,24 @@
ccall {args = Vector.new1 Operand.GCState,
func = CFunction.unpack}
| IntInf_add => simpleCCall CFunction.intInfAdd
+ | IntInf_andb => simpleCCall CFunction.intInfAndb
+ | IntInf_arshift => simpleCCall CFunction.intInfArshift
| IntInf_compare =>
simpleCCall CFunction.intInfCompare
| IntInf_equal =>
simpleCCall CFunction.intInfEqual
| IntInf_gcd => simpleCCall CFunction.intInfGcd
+ | IntInf_lshift => simpleCCall CFunction.intInfLshift
| IntInf_mul => simpleCCall CFunction.intInfMul
| IntInf_neg => simpleCCall CFunction.intInfNeg
+ | IntInf_notb => simpleCCall CFunction.intInfNotb
+ | IntInf_orb => simpleCCall CFunction.intInfOrb
| IntInf_quot => simpleCCall CFunction.intInfQuot
| IntInf_rem => simpleCCall CFunction.intInfRem
| IntInf_sub => simpleCCall CFunction.intInfSub
| IntInf_toString =>
simpleCCall CFunction.intInfToString
+ | IntInf_xorb => simpleCCall CFunction.intInfXorb
| MLton_bogus =>
(case toType ty of
NONE => none ()
@@ -1075,9 +1087,6 @@
Vector.new1 (SOME t))
in allocate (ys, sortTypes (0, ts))
end
- | String_equal =>
- simpleCCall CFunction.stringEqual
- | String_sub => sub Type.char
| Thread_atomicBegin =>
(* assert (s->canHandle >= 0);
* s->canHandle++;
1.37 +0 -3 mlton/mlton/codegen/x86-codegen/x86-mlton.fun
Index: x86-mlton.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton.fun,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -r1.36 -r1.37
--- x86-mlton.fun 7 Aug 2002 01:02:43 -0000 1.36
+++ x86-mlton.fun 24 Nov 2002 01:19:43 -0000 1.37
@@ -1303,10 +1303,7 @@
end
| Real_neg => funa Instruction.FCHS
| Real_round => funa Instruction.FRNDINT
- | String_fromCharVector => mov ()
| String_fromWord8Vector => mov ()
- | String_size => lengthArrayVectorString ()
- | String_toCharVector => mov ()
| String_toWord8Vector => mov ()
| Vector_length => lengthArrayVectorString ()
| Word8_toInt => movx Instruction.MOVZX
1.56 +3 -0 mlton/mlton/control/control.sig
Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -r1.55 -r1.56
--- control.sig 14 Nov 2002 22:25:41 -0000 1.55
+++ control.sig 24 Nov 2002 01:19:43 -0000 1.56
@@ -18,6 +18,9 @@
(* Begin Flags *)
(*------------------------------------*)
+ val basisLibs: string list
+ val basisLibrary: string ref
+
(* build identifies the machine on which this MLton was built. *)
val build: string
1.71 +5 -0 mlton/mlton/control/control.sml
Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.70
retrieving revision 1.71
diff -u -r1.70 -r1.71
--- control.sml 14 Nov 2002 22:25:41 -0000 1.70
+++ control.sml 24 Nov 2002 01:19:44 -0000 1.71
@@ -11,6 +11,11 @@
structure C = Control ()
open C
+val basisLibs = ["basis-2002", "basis-2002-strict", "basis-1997", "none"]
+val basisLibrary = control {name = "basis library",
+ default = "basis-2002",
+ toString = fn s => s}
+
val cardSizeLog2 = control {name = "log2 (card size)",
default = 8,
toString = Int.toString}
1.15 +20 -18 mlton/mlton/core-ml/lookup-constant.fun
Index: lookup-constant.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/lookup-constant.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- lookup-constant.fun 2 Nov 2002 03:37:40 -0000 1.14
+++ lookup-constant.fun 24 Nov 2002 01:19:44 -0000 1.15
@@ -74,24 +74,26 @@
Error.bug
(concat ["constant with strange type: ", c])
in case Prim.scheme p of
- Scheme.T {tyvars, ty = Type.Con (tc, ts)} =>
- if 0 = Vector.length ts
- andalso 0 = Vector.length tyvars
- then
- let
- val tycons = [(Tycon.bool, Bool),
- (Tycon.int, Int),
- (Tycon.real, Real),
- (Tycon.string, String),
- (Tycon.word, Word)]
- in case (List.peek
- (tycons, fn (tc', _) =>
- Tycon.equals (tc, tc'))) of
- NONE => strange ()
- | SOME (_, t) => (c, t) :: ac
- end
- else strange ()
- | _ => strange ()
+ Scheme.T {tyvars, ty as Type.Con (tc, ts)} =>
+ if 0 = Vector.length tyvars
+ then
+ let
+ val ty = Const.Type.make
+ (Type.deconConst ty)
+ val tys = [(Const.Type.bool, Bool),
+ (Const.Type.int, Int),
+ (Const.Type.real, Real),
+ (Const.Type.string, String),
+ (Const.Type.word, Word)]
+ in case (List.peek
+ (tys, fn (ty', _) =>
+ Const.Type.equals (ty, ty'))) of
+ NONE => strange ()
+ | SOME (_,t) => (c,t) :: ac
+
+ end
+ else strange ()
+ | _ => strange ()
end
| _ => ac)
| Record r => Record.fold (r, ac, loopExp)
1.8 +12 -8 mlton/mlton/elaborate/elaborate-env.fun
Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- elaborate-env.fun 10 Apr 2002 07:02:20 -0000 1.7
+++ elaborate-env.fun 24 Nov 2002 01:19:44 -0000 1.8
@@ -1047,8 +1047,7 @@
end
end
in
- fun localTop (T {currentScope, fcts, fixs, sigs, strs, types, vals, ...},
- f1, f2) =
+ fun localTop (T {currentScope, fcts, fixs, sigs, strs, types, vals, ...}, f) =
let
val s0 = !currentScope
val fcts = doit (fcts, s0)
@@ -1058,18 +1057,23 @@
val types = doit (types, s0)
val vals = doit (vals, s0)
val _ = currentScope := Scope.new ()
- val a1 = f1 ()
+ val a = f ()
val fcts = fcts ()
val fixs = fixs ()
val sigs = sigs ()
val strs = strs ()
val types = types ()
val vals = vals ()
- val _ = currentScope := Scope.new ()
- val a2 = f2 ()
- val _ = (fcts (); fixs (); sigs (); strs (); types (); vals ())
- val _ = currentScope := s0
- in (a1, a2)
+ fun finish g =
+ let
+ val _ = currentScope := Scope.new ()
+ val b = g ()
+ val _ = (fcts (); fixs (); sigs (); strs (); types (); vals ())
+ val _ = currentScope := s0
+ in
+ b
+ end
+ in (a, finish)
end
fun localModule (T {currentScope, fixs, strs, types, vals, ...},
1.4 +1 -1 mlton/mlton/elaborate/elaborate-env.sig
Index: elaborate-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- elaborate-env.sig 10 Apr 2002 07:02:20 -0000 1.3
+++ elaborate-env.sig 24 Nov 2002 01:19:44 -0000 1.4
@@ -109,7 +109,7 @@
val layoutUsed: t -> Layout.t
val localCore: t * (unit -> 'a) * (unit -> 'b) -> 'a * 'b
val localModule: t * (unit -> 'a) * (unit -> 'b) -> 'a * 'b
- val localTop: t * (unit -> 'a) * (unit -> 'b) -> 'a * 'b
+ val localTop: t * (unit -> 'a) -> ('a * ((unit -> 'b) -> 'b))
val lookupFctid: t * Ast.Fctid.t -> FunctorClosure.t
val lookupLongcon: t * Ast.Longcon.t -> CoreML.Con.t
val lookupLongstrid: t * Ast.Longstrid.t -> Structure.t
1.38 +118 -81 mlton/mlton/main/compile.sml
Index: compile.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sml,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -r1.37 -r1.38
--- compile.sml 2 Nov 2002 03:37:40 -0000 1.37
+++ compile.sml 24 Nov 2002 01:19:44 -0000 1.38
@@ -62,16 +62,26 @@
val (lexAndParse, lexAndParseMsg) =
Control.traceBatch (Control.Pass, "lex and parse") FrontEnd.lexAndParse
+fun lexAndParseFile (f: File.t): Ast.Program.t =
+ let
+ val ast = lexAndParse f
+ val _ = Control.checkForErrors "parse"
+ in ast
+ end
+
+fun lexAndParseFiles (fs: File.t list): Ast.Program.t =
+ List.fold
+ (fs, Ast.Program.empty, fn (f, ast) =>
+ Ast.Program.append (ast, lexAndParseFile f))
+
val (elaborate, elaborateMsg) =
Control.traceBatch (Control.Pass, "elaborate") Elaborate.elaborateProgram
-fun parseAndElaborateFile (f: File.t, E): Decs.t =
+fun elaborateProg (ast: Ast.Program.t, E: Env.t): Decs.t =
let
- val ast = lexAndParse f
- val _ = Control.checkForErrors "parse"
- val res = elaborate (ast, E)
+ val decs = elaborate (ast, E)
val _ = Control.checkForErrors "elaborate"
- in res
+ in decs
end
val displayDecs =
@@ -85,7 +95,8 @@
suffix = "core-ml",
style = Control.ML,
thunk = fn () => List.fold (fs, Decs.empty, fn (f, ds) =>
- Decs.append (ds, parseAndElaborateFile (f, E))),
+ Decs.append
+ (ds, elaborateProg (lexAndParseFile f, E))),
display = displayDecs}
(* ------------------------------------------------- *)
@@ -147,13 +158,6 @@
let
val resultType =
Type.con (tycon, Vector.map (tyvars, Type.var))
- (* val scheme =
- * Scheme.T
- * {tyvars = tyvars,
- * ty = (case arg of
- * NONE => resultType
- * | SOME t => Type.arrow (t, resultType))}
- *)
in {name = Con.toAst con,
con = con}
end)
@@ -183,7 +187,12 @@
in
fun setBasisLibraryDir (d: Dir.t): unit =
dir := SOME d
- val basisLibrary =
+ val basisLibrary : unit -> {build: Decs.t,
+ localTopFinish: (unit -> Decs.t) -> Decs.t,
+ libs: {name: string,
+ bind: Ast.Program.t,
+ prefix: Ast.Program.t,
+ suffix: Ast.Program.t} list} =
Promise.lazy
(fn () =>
let
@@ -192,27 +201,44 @@
NONE => Error.bug "basis library dir not set"
| SOME d => d
fun basisFile f = String./ (d, f)
- fun files (f, E) =
- parseAndElaborateFiles
- (rev (File.foldLines (basisFile f, [], fn (s, ac) =>
- if s <> "\n" andalso #"#" <> String.sub (s, 0)
- then basisFile (String.dropLast s) :: ac
- else ac)),
- basisEnv)
- val (d1, (d2, d3)) =
+ fun libsFile f = basisFile (String./ ("libs", f))
+ fun withFiles (f, g) =
+ let
+ val fs = File.foldLines
+ (f, [], fn (s, ac) =>
+ if s <> "\n" andalso #"#" <> String.sub (s, 0)
+ then basisFile (String.dropLast s) :: ac
+ else ac)
+ in
+ g (List.rev fs)
+ end
+
+ val (build, localTopFinish) =
Env.localTop
(basisEnv,
fn () => (Env.addPrim basisEnv
- ; files ("build-basis", basisEnv)),
- fn () =>
- (files ("bind-basis", basisEnv),
- (* Suffix is concatenated onto the end of the program for cleanup. *)
- parseAndElaborateFiles ([basisFile "misc/suffix.sml"], basisEnv)))
- val _ = Env.addEquals basisEnv
- val _ = Env.clean basisEnv
+ ; withFiles (libsFile "build",
+ fn fs => parseAndElaborateFiles (fs, basisEnv))))
+ val localTopFinish = fn g =>
+ (localTopFinish g) before (Env.addEquals basisEnv
+ ; Env.clean basisEnv)
+
+ fun doit name =
+ let
+ fun libFile f = libsFile (String./ (name, f))
+ val bind = withFiles (libFile "bind", lexAndParseFiles)
+ val prefix = withFiles (libFile "prefix", lexAndParseFiles)
+ val suffix = withFiles (libFile "suffix", lexAndParseFiles)
+ in
+ {name = name,
+ bind = bind,
+ prefix = prefix,
+ suffix = suffix}
+ end
in
- {prefix = Decs.append (d1, d2),
- suffix = d3}
+ {build = build,
+ localTopFinish = localTopFinish,
+ libs = List.map (Control.basisLibs, doit)}
end)
end
@@ -221,17 +247,37 @@
; basisLibrary ()
; ())
-fun basisDecs () =
+fun buildDecs () =
let
- val {prefix, ...} = basisLibrary ()
+ val {build, ...} = basisLibrary ()
in
- Decs.toVector prefix
+ Decs.toVector build
end
fun outputBasisConstants (out: Out.t): unit =
- LookupConstant.build (basisDecs (), out)
+ LookupConstant.build (buildDecs (), out)
+
+fun selectBasisLibrary () =
+ let
+ val {build, localTopFinish, libs} = basisLibrary ()
+ val lib = !Control.basisLibrary
+ in
+ case List.peek (libs, fn {name, ...} => name = lib) of
+ NONE => Error.bug ("Missing basis library: " ^ lib)
+ | SOME {bind, prefix, suffix, ...} =>
+ let
+ val bind = localTopFinish (fn () => elaborateProg (bind, basisEnv))
+ in
+ {basis = Decs.append (build, bind),
+ prefix = prefix,
+ suffix = suffix}
+ end
+ end
-fun layoutBasisLibrary () = Env.layoutPretty basisEnv
+fun layoutBasisLibrary () =
+ let val _ = selectBasisLibrary ()
+ in Env.layoutPretty basisEnv
+ end
(* ------------------------------------------------- *)
(* compile *)
@@ -251,50 +297,41 @@
make (Exception {con = c, arg = NONE}))]
end
val decs =
- if !Control.useBasisLibrary
- then
- let
- val {prefix, suffix} = basisLibrary ()
- val basis = Decs.toList prefix
- val decs =
- if !Control.showBasisUsed
- then
- let
- val decs =
- Elaborate.Env.scopeAll
- (basisEnv, fn () =>
- parseAndElaborateFiles (input, basisEnv))
- val _ =
- Layout.outputl
- (Elaborate.Env.layoutUsed basisEnv,
- Out.standard)
- in
- Process.succeed ()
- end
- else
- parseAndElaborateFiles (input, basisEnv)
- val user = Decs.toList (Decs.append (decs, suffix))
- val _ = parseElabMsg ()
- val basis =
- Control.pass
- {name = "dead",
- suffix = "basis",
- style = Control.ML,
- thunk = fn () => DeadCode.deadCode {basis = basis,
- user = user},
- display = Control.Layout (List.layout CoreML.Dec.layout)}
- in Vector.concat [primitiveDecs,
- Vector.fromList basis,
- Vector.fromList user]
- end
- else
- let
- val E = Env.empty ()
- val _ = Env.addPrim E
- val decs = parseAndElaborateFiles (input, E)
- val _ = parseElabMsg ()
- in Vector.concat [primitiveDecs, Decs.toVector decs]
- end
+ let
+ val {basis, prefix, suffix, ...} = selectBasisLibrary ()
+ val prefix = elaborateProg (prefix, basisEnv)
+ val input =
+ if !Control.showBasisUsed
+ then let
+ val input =
+ Elaborate.Env.scopeAll
+ (basisEnv, fn () =>
+ parseAndElaborateFiles (input, basisEnv))
+ val _ =
+ Layout.outputl
+ (Elaborate.Env.layoutUsed basisEnv,
+ Out.standard)
+ in
+ Process.succeed ()
+ end
+ else parseAndElaborateFiles (input, basisEnv)
+ val suffix = elaborateProg (suffix, basisEnv)
+ val user = Decs.appends [prefix, input, suffix]
+ val _ = parseElabMsg ()
+ val basis = Decs.toList basis
+ val user = Decs.toList user
+ val basis =
+ Control.pass
+ {name = "deadCode",
+ suffix = "basis",
+ style = Control.ML,
+ thunk = fn () => DeadCode.deadCode {basis = basis,
+ user = user},
+ display = Control.Layout (List.layout CoreML.Dec.layout)}
+ in Vector.concat [primitiveDecs,
+ Vector.fromList basis,
+ Vector.fromList user]
+ end
val coreML = CoreML.Program.T {decs = decs}
val _ = Control.message (Control.Detail, fn () =>
CoreML.Program.layoutStats coreML)
@@ -318,7 +355,7 @@
val lookupConstant =
File.withIn
(concat [!Control.libDir, "/constants"], fn ins =>
- LookupConstant.load (basisDecs (), ins))
+ LookupConstant.load (buildDecs (), ins))
(* Set GC_state offsets. *)
val _ =
let
1.99 +9 -5 mlton/mlton/main/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.98
retrieving revision 1.99
diff -u -r1.98 -r1.99
--- main.sml 23 Nov 2002 00:02:15 -0000 1.98
+++ main.sml 24 Nov 2002 01:19:44 -0000 1.99
@@ -75,6 +75,13 @@
in List.map
(
[
+ (Normal, "basis", " {basis-2002|...}",
+ "select basis library to prefix to the program",
+ SpaceString (fn s =>
+ basisLibrary :=
+ (if List.contains (Control.basisLibs, s, String.equals)
+ then s
+ else usage (concat ["invalid -basis flag: ", s])))),
(Expert, "build-constants", "",
"output C file that prints basis constants",
trueRef buildConstants),
@@ -273,9 +280,6 @@
intRef textIOBufSize),
(Expert, "type-check", " {false|true}", "type check ILs",
boolRef typeCheck),
- (Expert, "use-basis-library", " {true|false}",
- "prefix the basis library to the program",
- boolRef useBasisLibrary),
(Normal, "v", "[0123]", "how verbose to be about compiler passes",
String
(fn s =>
@@ -357,8 +361,8 @@
then Layout.outputl (Compile.layoutBasisLibrary (),
Out.standard)
else if !buildConstants
- then Compile.outputBasisConstants Out.standard
- else usage "must supply a file"
+ then Compile.outputBasisConstants Out.standard
+ else usage "must supply a file"
| Top => printVersion ()
| _ => (inputFile := ""
; outputHeader' (No, Out.standard)))
1.20 +3 -3 mlton/mlton/ssa/common-subexp.fun
Index: common-subexp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/common-subexp.fun,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- common-subexp.fun 18 Nov 2002 00:18:34 -0000 1.19
+++ common-subexp.fun 24 Nov 2002 01:19:44 -0000 1.20
@@ -80,7 +80,10 @@
else
if (case Prim.name prim of
IntInf_add => true
+ | IntInf_andb => true
| IntInf_mul => true
+ | IntInf_orb => true
+ | IntInf_xorb => true
| _ => false)
then
let
@@ -204,11 +207,8 @@
Array_array => knownLength (arg ())
| Array_length => length ()
| Vector_fromArray => conv ()
- | String_fromCharVector => conv ()
| String_fromWord8Vector => conv ()
- | String_toCharVector => conv ()
| String_toWord8Vector => conv ()
- | String_size => length ()
| Vector_length => length ()
| _ => if Prim.isFunctional prim
then doit ()
1.11 +78 -22 mlton/mlton/ssa/constant-propagation.fun
Index: constant-propagation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/constant-propagation.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- constant-propagation.fun 21 Aug 2002 04:48:31 -0000 1.10
+++ constant-propagation.fun 24 Nov 2002 01:19:44 -0000 1.11
@@ -39,6 +39,7 @@
| _ => true
end
+structure Sconst = Const
open Exp Transfer
structure Value =
@@ -391,7 +392,10 @@
fun tuple vs =
new (Tuple vs, Type.tuple (Vector.map (vs, ty)))
- fun const c = new (Const (Const.const c), Type.ofConst c)
+ fun const' (c, ty) = new (Const c, ty)
+ fun const c = let val c' = Const.const c
+ in new (Const c', Type.ofConst c)
+ end
val zero = const (S.Const.fromInt 0)
@@ -404,6 +408,28 @@
fun make (err, sel) v =
case value v of
Vector fs => sel fs
+ | Const (Const.T {const = ref (Const.Const c), coercedTo}) =>
+ let
+ val s = case Sconst.node c of
+ Sconst.Node.String s => s
+ | _ => Error.bug err
+ val n = String.length s
+ val x = if n = 0
+ then const' (Const.unknown(), Type.char)
+ else let
+ val c = String.sub (s, 0)
+ in
+ if String.forall (s, fn c' => c = c')
+ then (const o Sconst.make)
+ (Sconst.Node.Char c,
+ Sconst.Type.char)
+ else const' (Const.unknown(), Type.char)
+ end
+ val n = (const o Sconst.make)
+ (Sconst.Node.Int n, Sconst.Type.int)
+ in
+ sel {length = n, elt = x}
+ end
| _ => Error.bug err
in val devector = make ("devector", #elt)
val vectorLength = make ("vectorLength", #length)
@@ -470,8 +496,8 @@
| Type.Vector t => Vector {length = loop Type.int,
elt = loop t}
| Type.Tuple ts => Tuple (Vector.map (ts, loop))
- | _ => Const (const ()),
- t)
+ | _ => Const (const ()),
+ t)
in loop
end
in
@@ -603,25 +629,55 @@
if equals (from, to)
then ()
else
- case (value from, value to) of
- (Const from, Const to) => Const.coerce {from = from, to = to}
- | (Datatype from, Datatype to) =>
- coerceData {from = from, to = to}
- | (Ref {birth, arg}, Ref {birth = b', arg = a'}) =>
- (Birth.coerce {from = birth, to = b'}
- ; unify (arg, a'))
- | (Array {birth = b, length = n, elt = x},
- Array {birth = b', length = n', elt = x'}) =>
- (Birth.coerce {from = b, to = b'}
- ; coerce {from = n, to = n'}
- ; unify (x, x'))
- | (Vector {length = n, elt = x},
- Vector {length = n', elt = x'}) =>
- (coerce {from = n, to = n'}
- ; coerce {from = x, to = x'})
- | (Tuple vs, Tuple vs') => coerces {froms = vs, tos = vs'}
- | _ => Error.bug "strange coerce") arg
-
+ let
+ fun error () =
+ Error.bug ("strange coerce:" ^
+ " from: " ^ (Layout.toString (Value.layout from)) ^
+ " to: " ^ (Layout.toString (Value.layout to)))
+ in
+ case (value from, value to) of
+ (Const from, Const to) => Const.coerce {from = from, to = to}
+ | (Datatype from, Datatype to) =>
+ coerceData {from = from, to = to}
+ | (Ref {birth, arg}, Ref {birth = b', arg = a'}) =>
+ (Birth.coerce {from = birth, to = b'}
+ ; unify (arg, a'))
+ | (Array {birth = b, length = n, elt = x},
+ Array {birth = b', length = n', elt = x'}) =>
+ (Birth.coerce {from = b, to = b'}
+ ; coerce {from = n, to = n'}
+ ; unify (x, x'))
+ | (Vector {length = n, elt = x},
+ Vector {length = n', elt = x'}) =>
+ (coerce {from = n, to = n'}
+ ; coerce {from = x, to = x'})
+ | (Tuple vs, Tuple vs') => coerces {froms = vs, tos = vs'}
+ | (Const (Const.T {const = ref (Const.Const c), coercedTo}),
+ Vector {length, elt}) =>
+ let
+ val s = case Sconst.node c of
+ Sconst.Node.String s => s
+ | _ => error ()
+ val n = String.length s
+ val x = if n = 0
+ then const' (Const.unknown(), Type.char)
+ else let
+ val c = String.sub (s, 0)
+ in
+ if String.forall (s, fn c' => c = c')
+ then (const o Sconst.make)
+ (Sconst.Node.Char c,
+ Sconst.Type.char)
+ else const' (Const.unknown(), Type.char)
+ end
+ val n = (const o Sconst.make)
+ (Sconst.Node.Int n, Sconst.Type.int)
+ in
+ coerce {from = x, to = elt}
+ ; coerce {from = n, to = length}
+ end
+ | (_, _) => error ()
+ end) arg
and unify (T s: t, T s': t): unit =
if Set.equals (s, s')
then ()
1.11 +1 -3 mlton/mlton/ssa/poly-equal.fun
Index: poly-equal.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/poly-equal.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- poly-equal.fun 5 Nov 2002 19:08:07 -0000 1.10
+++ poly-equal.fun 24 Nov 2002 01:19:44 -0000 1.11
@@ -284,8 +284,7 @@
args = Vector.new2 (dx1, dx2),
ty = Type.bool}
fun eq () = prim (Prim.eq, Vector.new1 ty)
- fun hasConstArg () =
- #isConst (varInfo x1) orelse #isConst (varInfo x2)
+ fun hasConstArg () = #isConst (varInfo x1) orelse #isConst (varInfo x2)
in
case Type.dest ty of
Type.Array _ => eq ()
@@ -301,7 +300,6 @@
then eq ()
else prim (Prim.intInfEqual, Vector.new0 ())
| Type.Ref _ => eq ()
- | Type.String => prim (Prim.stringEqual, Vector.new0 ())
| Type.Tuple tys =>
let
val max = Vector.length tys - 1
1.45 +1 -4 mlton/mlton/ssa/ssa-tree.fun
Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -r1.44 -r1.45
--- ssa-tree.fun 22 Nov 2002 19:58:13 -0000 1.44
+++ ssa-tree.fun 24 Nov 2002 01:19:44 -0000 1.45
@@ -22,7 +22,7 @@
| _ => Error.bug "FirstOrderType.tyconArgs"
datatype dest =
- Array of t
+ Array of t
| Char
| Datatype of Tycon.t
| Int
@@ -31,7 +31,6 @@
| PreThread
| Real
| Ref of t
- | String
| Thread
| Tuple of t vector
| Vector of t
@@ -60,7 +59,6 @@
(Tycon.pointer, nullary Pointer),
(Tycon.preThread, nullary PreThread),
(Tycon.real, nullary Real),
- (Tycon.string, nullary String),
(Tycon.thread, nullary Thread),
(Tycon.word8, nullary Word8),
(Tycon.word, nullary Word),
@@ -97,7 +95,6 @@
| PreThread => str "preThread"
| Real => str "real"
| Ref t => seq [layout t, str " ref"]
- | String => str "string"
| Thread => str "thread"
| Tuple ts =>
if Vector.isEmpty ts
1.38 +0 -1 mlton/mlton/ssa/ssa-tree.sig
Index: ssa-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.sig,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -r1.37 -r1.38
--- ssa-tree.sig 22 Nov 2002 19:58:13 -0000 1.37
+++ ssa-tree.sig 24 Nov 2002 01:19:44 -0000 1.38
@@ -31,7 +31,6 @@
| PreThread
| Real
| Ref of t
- | String
| Thread
| Tuple of t vector
| Vector of t
1.15 +8 -8 mlton/mlton/type-inference/infer.fun
Index: infer.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/infer.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- infer.fun 10 Apr 2002 07:02:21 -0000 1.14
+++ infer.fun 24 Nov 2002 01:19:44 -0000 1.15
@@ -170,7 +170,7 @@
fun makeXconst (c: Aconst.t, ty: Type.t): Xconst.t =
let
- val tycon = Xtype.detycon (Type.toXml (ty, Aconst.region c))
+ val ty = Xconst.Type.make (Xtype.deconConst (Type.toXml (ty, Aconst.region c)))
datatype z = datatype Xconst.Node.t
fun error m =
Control.error (Aconst.region c,
@@ -181,7 +181,7 @@
(case Aconst.node c of
Aconst.Char c => Char c
| Aconst.Int s =>
- if Tycon.equals (tycon, Tycon.intInf)
+ if Xconst.Type.equals (ty, Xconst.Type.intInf)
then
IntInf (stringToIntInf s)
handle _ => (error "invalid IntInf";
@@ -198,10 +198,10 @@
case StringCvt.scanString (Pervasive.Int32.scan radix) s of
NONE => (error "invalid int constant"; ~1)
| SOME n =>
- if Tycon.equals (tycon, Tycon.int)
+ if Xconst.Type.equals (ty, Xconst.Type.int)
then n
else (error (concat ["int can't be of type ",
- Tycon.toString tycon])
+ Xconst.Type.toString ty])
; ~1)
end
handle Overflow =>
@@ -209,15 +209,15 @@
| Aconst.Real r => Real r
| Aconst.String s => String s
| Aconst.Word w =>
- Word (if Tycon.equals (tycon, Tycon.word)
+ Word (if Xconst.Type.equals (ty, Xconst.Type.word)
then w
- else if Tycon.equals (tycon, Tycon.word8)
+ else if Xconst.Type.equals (ty, Xconst.Type.word8)
then if w = Word.andb (w, 0wxFF)
then w
else (error "word8 too big"; 0w0)
- else (error ("strange word " ^ Tycon.toString tycon)
+ else (error ("strange word " ^ (Xconst.Type.toString ty))
; 0w0)),
- tycon)
+ ty)
end
fun 'a sortByField (v: (Field.t * 'a) vector): 'a vector =
1.21 +3 -2 mlton/mlyacc/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/mlyacc/Makefile,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- Makefile 21 Nov 2002 02:49:21 -0000 1.20
+++ Makefile 24 Nov 2002 01:19:44 -0000 1.21
@@ -25,8 +25,9 @@
.PHONY: $(NAME)-stubs_cm
$(NAME)-stubs_cm: src/yacc.lex.sml src/yacc.grm.sig src/yacc.grm.sml
( \
- echo 'Group is'&& \
- cmcat sources.cm | grep -v 'mlton-stubs-in-smlnj' && \
+ echo 'Group is' && \
+ cmcat sources.cm | grep -v 'basis-stubs' | \
+ grep -v 'mlton-stubs-in-smlnj' && \
echo 'call-main.sml'; \
) >$(NAME)-stubs.cm
1.3 +1 -0 mlton/mlyacc/mlyacc-stubs.cm
Index: mlyacc-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlyacc/mlyacc-stubs.cm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- mlyacc-stubs.cm 2 Nov 2002 03:37:40 -0000 1.2
+++ mlyacc-stubs.cm 24 Nov 2002 01:19:44 -0000 1.3
@@ -26,6 +26,7 @@
src/yacc.sml
src/absyn.sml
src/link.sml
+../lib/mlton-stubs/int-inf.sml
../lib/mlton-stubs/real.sml
../lib/mlton/pervasive/pervasive.sml
../lib/mlton/basic/dynamic-wind.sig
1.2 +3 -0 mlton/regression/array.ok
Index: array.ok
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/array.ok,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- array.ok 18 Jul 2001 05:51:06 -0000 1.1
+++ array.ok 24 Nov 2002 01:19:44 -0000 1.2
@@ -40,6 +40,7 @@
test11k OK
test12a OK
test12b OK
+test12c OK
test12d OK
test12e OK
test13a OK
@@ -56,6 +57,8 @@
test13l OK
test13m OK
test13n OK
+test14a OK
+test14b OK
test15a OK
test15b OK
test15c OK
1.3 +18 -4 mlton/regression/array.sml
Index: array.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/array.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- array.sml 10 Feb 2002 19:46:58 -0000 1.2
+++ array.sml 24 Nov 2002 01:19:44 -0000 1.3
@@ -28,6 +28,20 @@
open Array
infix 9 sub
val array0 : int array = fromList []
+ fun extract (arr, s, l) = ArraySlice.vector (ArraySlice.slice (arr, s, l))
+ val copy = fn {src, si, len, dst, di} =>
+ ArraySlice.copy {src = ArraySlice.slice (src, si, len),
+ dst = dst, di = di}
+ fun foldli f b (arr, s, l) =
+ ArraySlice.foldli (fn (i,x,y) => f (i+s,x,y)) b (ArraySlice.slice (arr, s, l))
+ fun foldri f b (arr, s, l) =
+ ArraySlice.foldri (fn (i,x,y) => f (i+s,x,y)) b (ArraySlice.slice (arr, s, l))
+ fun appi f (arr, s, l) =
+ ArraySlice.appi (fn (i,x) => f (i+s,x)) (ArraySlice.slice (arr, s, l))
+ fun modifyi f (arr, s, l) =
+ ArraySlice.modifyi (fn (i,x) => f (i+s,x)) (ArraySlice.slice (arr, s, l))
+ fun findi f (arr, s, l) =
+ ArraySlice.findi (fn (i,x) => f (i+s,x)) (ArraySlice.slice (arr, s, l))
in
val a = fromList [1,11,21,31,41,51,61];
@@ -197,7 +211,6 @@
andalso foldr cons [1,2] inp = [7,9,13,1,2]
andalso (foldr (fn (x, _) => setv x) () inp; !v = 7));
-(*
val test12c =
tst' "test12c" (fn _ =>
find (fn _ => true) array0 = NONE
@@ -205,7 +218,7 @@
andalso find (fn x => x=7) inp = SOME 7
andalso find (fn x => x=9) inp = SOME 9
andalso (setv 0; find (fn x => (addv x; x=9)) inp; !v = 7+9));
-*)
+
val test12d =
tst' "test12d" (fn _ =>
(setv 117; app setv array0; !v = 117)
@@ -227,6 +240,7 @@
andalso foldri consi [] (array0, 0, NONE) = []
andalso foldli consi [] (inp, 0, NONE) = [(2,13),(1,9),(0,7)]
andalso foldri consi [] (inp, 0, NONE) = [(0,7),(1,9),(2,13)])
+
val test13b =
tst' "test13b" (fn _ =>
foldli consi [] (array0, 0, SOME 0) = []
@@ -269,7 +283,7 @@
handle Subscript => "OK" | _ => "WRONG");
val test13n = tst0 "test13n" ((foldri consi [] (inp, 2, SOME ~1) seq "WRONG")
handle Subscript => "OK" | _ => "WRONG");
-(*
+
val test14a =
tst' "test14a" (fn _ =>
findi (fn _ => true) (array0, 0, NONE) = NONE
@@ -296,7 +310,7 @@
handle Subscript => "OK" | _ => "WRONG";
val test14h = (findi (fn _ => true) (inp, 2, SOME ~1) seq "WRONG")
handle Subscript => "OK" | _ => "WRONG";
-*)
+
val test15a =
tst' "test15a" (fn _ =>
(setvi (0,117); appi setvi (array0, 0, NONE); !v = 117)
1.2 +6 -0 mlton/regression/array6.sml
Index: array6.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/array6.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- array6.sml 2 Oct 2001 21:13:37 -0000 1.1
+++ array6.sml 24 Nov 2002 01:19:44 -0000 1.2
@@ -18,6 +18,12 @@
local
open Array
+ fun extract (arr, s, l) = ArraySlice.vector (ArraySlice.slice (arr, s, l))
+ val copy = fn {src, si, len, dst, di} =>
+ ArraySlice.copy {src = ArraySlice.slice (src, si, len),
+ dst = dst, di = di}
+ fun appi f (arr, s, l) =
+ ArraySlice.appi (fn (i,x) => f (i+s,x)) (ArraySlice.slice (arr, s, l))
val a0 = array (0,())
1.2 +4 -6 mlton/regression/bytechar.sml
Index: bytechar.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/bytechar.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- bytechar.sml 18 Jul 2001 05:51:06 -0000 1.1
+++ bytechar.sml 24 Nov 2002 01:19:44 -0000 1.2
@@ -3,7 +3,7 @@
infix 1 seq
fun e1 seq e2 = e2;
fun check b = if b then "OK" else "WRONG";
-fun check' f = (if f () then "OK" else "WRONG") handle _ => "EXN";
+fun check' f = (if f () then "OK" else "WRONG") (* handle _ => "EXN" *);
fun range (from, to) p =
let open Int
@@ -31,6 +31,7 @@
local
in
+
val test1 = tstrange "test1" (0,255) (fn i =>
(Word8.toInt o Byte.charToByte o Byte.byteToChar o Word8.fromInt) i = i);
@@ -370,7 +371,8 @@
("\\x0000000A2", "\162"),
("\\x0000000Ag", "\010"),
("\\x00000000000000000000000000000000000000000000000000000000000000011+",
- "\017")]
+ "\017")
+ ]
in
tst' "test42" (fn _ => List.all checkFromCStringSucc argResList)
end;
@@ -393,7 +395,3 @@
"\\xG"])
end;
end
-
-
-
-
1.3 +2 -2 mlton/regression/filesys.sml
Index: filesys.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/filesys.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- filesys.sml 18 Jul 2001 22:41:25 -0000 1.2
+++ filesys.sml 24 Nov 2002 01:19:44 -0000 1.3
@@ -96,10 +96,10 @@
val dstr = openDir "testdir";
in
val test7a =
- tst' "test7a" (fn _ => "" = readDir dstr);
+ tst' "test7a" (fn _ => NONE = readDir dstr);
val _ = rewindDir dstr;
val test7b =
- tst' "test7b" (fn _ => "" = readDir dstr);
+ tst' "test7b" (fn _ => NONE = readDir dstr);
val _ = closeDir dstr;
val test7c = tst0 "test7c" ((readDir dstr seq "WRONG")
handle OS.SysErr _ => "OK" | _ => "WRONG")
1.2 +13 -0 mlton/regression/parse.sml
Index: parse.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/parse.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- parse.sml 3 Apr 2002 19:15:12 -0000 1.1
+++ parse.sml 24 Nov 2002 01:19:44 -0000 1.2
@@ -278,6 +278,19 @@
(impOpenIn fileName)))
end
+structure Word8Vector =
+ struct
+ open Word8Vector
+ fun extract (arr, s, l) =
+ Word8VectorSlice.vector (Word8VectorSlice.slice (arr, s, l))
+ end
+structure CharVector =
+ struct
+ open CharVector
+ fun extract (arr, s, l) =
+ CharVectorSlice.vector (CharVectorSlice.slice (arr, s, l))
+ end
+
structure FuncBinIO =
FFunctionalIO(type vec = Word8Vector.vector
type element = Word8.word
1.5 +2 -10 mlton/regression/prodcons.sml
Index: prodcons.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/prodcons.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- prodcons.sml 20 Jul 2002 00:07:47 -0000 1.4
+++ prodcons.sml 24 Nov 2002 01:19:44 -0000 1.5
@@ -1,13 +1,6 @@
(* Translated from prodcons.ocaml. *)
functor Z (S: sig
- structure Primitive:
- sig
- structure Stdio:
- sig
- val print: string -> unit
- end
- end
structure MLton:
sig
structure Itimer:
@@ -54,7 +47,7 @@
loop start
end
-fun print s = () (* Primitive.Stdio.print s *)
+fun print s = ()
structure Queue:
sig
@@ -277,7 +270,6 @@
end
-structure Z = Z (structure MLton = MLton
- structure Primitive = Primitive)
+structure Z = Z (structure MLton = MLton)
val _ = Z.main ( "prodcons", ["100000"] )
1.4 +1 -1 mlton/regression/real6.ok
Index: real6.ok
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/real6.ok,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- real6.ok 20 Jul 2002 23:14:01 -0000 1.3
+++ real6.ok 24 Nov 2002 01:19:44 -0000 1.4
@@ -64,7 +64,7 @@
NORMAL
SUBNORMAL
NORMAL
-NAN QUIET
+NAN
INF
INF
INF
1.4 +2 -3 mlton/regression/real6.sml
Index: real6.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/real6.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- real6.sml 20 Jul 2002 23:14:01 -0000 1.3
+++ real6.sml 24 Nov 2002 01:19:44 -0000 1.4
@@ -13,8 +13,7 @@
infix 4 == != ?=
val classToString =
- fn NAN QUIET => "NAN QUIET"
- | NAN SIGNALLING => "NAN SIGNALLING"
+ fn NAN => "NAN"
| INF => "INF"
| ZERO => "ZERO"
| NORMAL => "NORMAL"
@@ -40,7 +39,7 @@
[(maxFinite, NORMAL),
(minPos, SUBNORMAL),
(minNormalPos, NORMAL),
- (nan, NAN QUIET),
+ (nan, NAN),
(posInf, INF),
(negInf, INF),
(1.0 / 0.0, INF),
1.3 +1 -1 mlton/regression/size.ok
Index: size.ok
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/size.ok,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- size.ok 6 Jul 2002 16:28:31 -0000 1.2
+++ size.ok 24 Nov 2002 01:19:44 -0000 1.3
@@ -5,6 +5,6 @@
The size of a double array of length 10 is 92 bytes.
The size of an array of length 10 of 2-ples of ints is 172 bytes.
The size of a useless function is 0 bytes.
-The size of a continuation option ref is 4296 bytes.
+The size of a continuation option ref is 4280 bytes.
13
The size of a continuation option ref is 8 bytes.
1.3 +3 -0 mlton/regression/vector.sml
Index: vector.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/vector.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- vector.sml 10 Feb 2002 19:46:58 -0000 1.2
+++ vector.sml 24 Nov 2002 01:19:44 -0000 1.3
@@ -31,6 +31,9 @@
local
open Vector;
infix 9 sub;
+ fun extract (vec, s, l) = VectorSlice.vector (VectorSlice.slice (vec, s, l))
+ fun mapi f (vec, s, l) =
+ VectorSlice.mapi (fn (i,x) => f (i+s,x)) (VectorSlice.slice (vec, s, l))
in
val a = fromList [0,1,2,3,4,5,6];
1.4 +1 -1 mlton/regression/word.sml
Index: word.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/word.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- word.sml 20 Jul 2002 23:14:02 -0000 1.3
+++ word.sml 24 Nov 2002 01:19:44 -0000 1.4
@@ -77,7 +77,7 @@
val test8b = check (0 = w2i (notb (i2w ~1)));
val _ = pr_ln "test8b" test8b
val maxposint = valOf Int.maxInt;
-val maxnegint = ~maxposint-1;
+val maxnegint = (Int.~ maxposint)-1;
fun pwr2 0 = 1
| pwr2 n = 2 * pwr2 (n-1);
fun rwp i 0 = i
1.3 +5 -0 mlton/regression/word8array.sml
Index: word8array.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/word8array.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- word8array.sml 10 Feb 2002 19:46:58 -0000 1.2
+++ word8array.sml 24 Nov 2002 01:19:44 -0000 1.3
@@ -32,6 +32,11 @@
open Word8Array
infix 9 sub;
val array0 = fromList [];
+ val copy = fn {src, si, len, dst, di} =>
+ Word8ArraySlice.copy {src = Word8ArraySlice.slice (src, si, len),
+ dst = dst, di = di}
+ val extract = fn (a, i, sz) =>
+ Word8ArraySlice.vector (Word8ArraySlice.slice (a, i, sz))
in
val i2w = Word8.fromInt;
1.3 +4 -0 mlton/regression/word8vector.sml
Index: word8vector.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/word8vector.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- word8vector.sml 10 Feb 2002 19:46:58 -0000 1.2
+++ word8vector.sml 24 Nov 2002 01:19:44 -0000 1.3
@@ -30,6 +30,10 @@
local
open Word8Vector;
+ fun extract (vec, s, l) =
+ Word8VectorSlice.vector (Word8VectorSlice.slice (vec, s, l))
+ fun mapi f (vec, s, l) =
+ Word8VectorSlice.mapi (fn (i,x) => f (i+s,x)) (Word8VectorSlice.slice (vec, s, l))
val i2w = Word8.fromInt;
infix 9 sub;
in
1.2 +2 -0 mlton/regression/1.ok
1.2 +2 -0 mlton/regression/2.ok
1.2 +1 -0 mlton/regression/command-line.ok
1.2 +1 -0 mlton/regression/conv.ok
1.2 +1 -0 mlton/regression/conv2.ok
1.2 +1 -0 mlton/regression/fast.ok
1.2 +1 -0 mlton/regression/fast2.ok
1.2 +1 -0 mlton/regression/hello-world.ok
1.2 +8448 -0 mlton/regression/int-inf.bitops.ok
1.2 +110 -0 mlton/regression/int-inf.bitops.sml
1.2 +1 -0 mlton/regression/slow.ok
1.2 +1 -0 mlton/regression/slow2.ok
1.2 +1 -0 mlton/regression/slower.ok
1.2 +68 -0 mlton/regression/substring.ok
1.2 +3 -0 mlton/regression/testdyn2.ok
1.2 +1 -0 mlton/regression/thread-switch.ok
1.9 +43 -26 mlton/runtime/IntInf.h
Index: IntInf.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/IntInf.h,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- IntInf.h 2 Nov 2002 03:37:41 -0000 1.8
+++ IntInf.h 24 Nov 2002 01:19:45 -0000 1.9
@@ -55,33 +55,50 @@
* into the array used for allocation profiling, and the appropriate element
* is incremented by the amount that the function moves the frontier.
*/
-extern pointer IntInf_do_add (pointer lhs,
- pointer rhs,
- uint bytes),
- IntInf_do_sub (pointer lhs,
- pointer rhs,
- uint bytes),
- IntInf_do_mul (pointer lhs,
- pointer rhs,
- uint bytes),
- IntInf_do_toString (pointer arg,
- int base,
- uint bytes),
- IntInf_do_neg (pointer arg,
- uint bytes),
- IntInf_do_quot (pointer num,
- pointer den,
- uint bytes),
- IntInf_do_rem (pointer num,
- pointer den,
- uint bytes),
- IntInf_do_gcd (pointer lhs,
- pointer rhs,
- uint bytes);
+extern pointer IntInf_do_add(pointer lhs,
+ pointer rhs,
+ uint bytes),
+ IntInf_do_sub(pointer lhs,
+ pointer rhs,
+ uint bytes),
+ IntInf_do_mul(pointer lhs,
+ pointer rhs,
+ uint bytes),
+ IntInf_do_neg(pointer arg,
+ uint bytes),
+ IntInf_do_quot(pointer num,
+ pointer den,
+ uint bytes),
+ IntInf_do_rem(pointer num,
+ pointer den,
+ uint bytes),
+ IntInf_do_andb(pointer lhs,
+ pointer rhs,
+ uint bytes),
+ IntInf_do_orb(pointer lhs,
+ pointer rhs,
+ uint bytes),
+ IntInf_do_xorb(pointer lhs,
+ pointer rhs,
+ uint bytes),
+ IntInf_do_notb(pointer arg,
+ uint bytes),
+ IntInf_do_arshift(pointer arg,
+ uint shift,
+ uint bytes),
+ IntInf_do_lshift(pointer arg,
+ uint shift,
+ uint bytes),
+ IntInf_do_toString(pointer arg,
+ int base,
+ uint bytes),
+ IntInf_do_gcd(pointer lhs,
+ pointer rhs,
+ uint bytes);
-extern Word IntInf_smallMul (Word lhs, Word rhs, pointer carry);
-extern int IntInf_compare (pointer lhs, pointer rhs),
- IntInf_equal (pointer lhs, pointer rhs);
+extern Word IntInf_smallMul(Word lhs, Word rhs, pointer carry);
+extern int IntInf_compare(pointer lhs, pointer rhs),
+ IntInf_equal(pointer lhs, pointer rhs);
#endif /* #ifndef _MLTON_INT_INF_H */
1.41 +2 -2 mlton/runtime/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Makefile,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -r1.40 -r1.41
--- Makefile 13 Nov 2002 06:11:54 -0000 1.40
+++ Makefile 24 Nov 2002 01:19:45 -0000 1.41
@@ -41,6 +41,7 @@
basis/MLton/size.o \
basis/MLton/world.o \
basis/OS/FileSys/tmpnam.o \
+ basis/OS/IO/poll.o \
basis/PackReal/subVec.o \
basis/PackReal/update.o \
basis/Ptrace/ptrace2.o \
@@ -53,7 +54,6 @@
basis/Socket/listen.o \
basis/Socket/shutdown.o \
basis/Stdio.o \
- basis/String/equal.o \
basis/Thread.o \
basis/Time.o \
basis/Word32/addOverflow.o \
@@ -188,6 +188,7 @@
basis/MLton/size-gdb.o \
basis/MLton/world-gdb.o \
basis/OS/FileSys/tmpnam-gdb.o \
+ basis/OS/IO/poll-gdb.o \
basis/PackReal/subVec-gdb.o \
basis/PackReal/update-gdb.o \
basis/Ptrace/ptrace2-gdb.o \
@@ -200,7 +201,6 @@
basis/Socket/listen-gdb.o \
basis/Socket/shutdown-gdb.o \
basis/Stdio-gdb.o \
- basis/String/equal-gdb.o \
basis/Thread-gdb.o \
basis/Time-gdb.o \
basis/Word32/addOverflow-gdb.o \
1.8 +6 -2 mlton/runtime/posix-constants.h
Index: posix-constants.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/posix-constants.h,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- posix-constants.h 29 Sep 2002 02:23:59 -0000 1.7
+++ posix-constants.h 24 Nov 2002 01:19:45 -0000 1.8
@@ -118,15 +118,18 @@
#define Posix_FileSys_F_OK F_OK
/* used by pathconf and fpathconf */
+#define Posix_FileSys_CHOWN_RESTRICTED _PC_CHOWN_RESTRICTED
#define Posix_FileSys_LINK_MAX _PC_LINK_MAX
#define Posix_FileSys_MAX_CANON _PC_MAX_CANON
#define Posix_FileSys_MAX_INPUT _PC_MAX_INPUT
#define Posix_FileSys_NAME_MAX _PC_NAME_MAX
+#define Posix_FileSys_NO_TRUNC _PC_NO_TRUNC
#define Posix_FileSys_PATH_MAX _PC_PATH_MAX
#define Posix_FileSys_PIPE_BUF _PC_PIPE_BUF
-#define Posix_FileSys_CHOWN_RESTRICTED _PC_CHOWN_RESTRICTED
-#define Posix_FileSys_NO_TRUNC _PC_NO_TRUNC
#define Posix_FileSys_VDISABLE _PC_VDISABLE
+#define Posix_FileSys_ASYNC_IO _PC_ASYNC_IO
+#define Posix_FileSys_SYNC_IO _PC_SYNC_IO
+#define Posix_FileSys_PRIO_IO _PC_PRIO_IO
#define Posix_IO_F_DUPFD F_DUPFD
#define Posix_IO_F_GETFD F_GETFD
@@ -180,6 +183,7 @@
#define Posix_ProcEnv_EXPR_NEST_MAX _SC_EXPR_NEST_MAX
#define Posix_ProcEnv_JOB_CONTROL _SC_JOB_CONTROL
#define Posix_ProcEnv_LINE_MAX _SC_LINE_MAX
+#define Posix_ProcEnv_NGROUPS_MAX _SC_NGROUPS_MAX
#define Posix_ProcEnv_OPEN_MAX _SC_OPEN_MAX
#define Posix_ProcEnv_RE_DUP_MAX _SC_RE_DUP_MAX
#define Posix_ProcEnv_SAVED_IDS _SC_SAVED_IDS
1.11 +77 -12 mlton/runtime/basis/IntInf.c
Index: IntInf.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/IntInf.c,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- IntInf.c 5 Nov 2002 19:08:07 -0000 1.10
+++ IntInf.c 24 Nov 2002 01:19:45 -0000 1.11
@@ -200,7 +200,75 @@
return binary (lhs, rhs, bytes, &mpz_sub);
}
-Word IntInf_smallMul (Word lhs, Word rhs, pointer carry) {
+pointer IntInf_do_andb(pointer lhs, pointer rhs, uint bytes)
+{
+ return binary(lhs, rhs, bytes, &mpz_and);
+}
+
+pointer IntInf_do_orb(pointer lhs, pointer rhs, uint bytes)
+{
+ return binary(lhs, rhs, bytes, &mpz_ior);
+}
+
+pointer IntInf_do_xorb(pointer lhs, pointer rhs, uint bytes)
+{
+ return binary(lhs, rhs, bytes, &mpz_xor);
+}
+
+static pointer
+unary(pointer arg, uint bytes,
+ void(*unop)(__mpz_struct *resmpz,
+ __gmp_const __mpz_struct *argspace))
+{
+ __mpz_struct argmpz,
+ resmpz;
+ mp_limb_t argspace[2];
+
+ initRes(&resmpz, bytes);
+ fill(arg, &argmpz, argspace);
+ unop(&resmpz, &argmpz);
+ return answer(&resmpz);
+}
+
+pointer IntInf_do_neg(pointer arg, uint bytes)
+{
+ return unary(arg, bytes, &mpz_neg);
+}
+
+pointer IntInf_do_notb(pointer arg, uint bytes)
+{
+ return unary(arg, bytes, &mpz_com);
+}
+
+static pointer
+shary(pointer arg, uint shift, uint bytes,
+ void(*shop)(__mpz_struct *resmpz,
+ __gmp_const __mpz_struct *argspace,
+ ulong shift))
+{
+ __mpz_struct argmpz,
+ resmpz;
+ mp_limb_t argspace[2];
+
+ initRes(&resmpz, bytes);
+ fill(arg, &argmpz, argspace);
+ shop(&resmpz, &argmpz, (ulong)shift);
+ return answer(&resmpz);
+}
+
+pointer IntInf_do_arshift(pointer arg, uint shift, uint bytes)
+{
+ return shary(arg, shift, bytes, &mpz_fdiv_q_2exp);
+}
+
+pointer IntInf_do_lshift(pointer arg, uint shift, uint bytes)
+{
+ return shary(arg, shift, bytes, &mpz_mul_2exp);
+}
+
+Word
+IntInf_smallMul(Word lhs, Word rhs, pointer carry)
+{
llong prod;
prod = (llong)(int)lhs * (int)rhs;
@@ -246,6 +314,8 @@
mp_limb_t argspace[2];
char *str;
uint size;
+ int i;
+ char c;
assert (base == 2 || base == 8 || base == 10 || base == 16);
fill (arg, &argmpz, argspace);
@@ -255,22 +325,17 @@
size = strlen(str);
if (*sp->chars == '-')
*sp->chars = '~';
+ if (base > 0)
+ for (i = 0; i < size; i++) {
+ c = sp->chars[i];
+ if (('a' <= c) && (c <= 'z'))
+ sp->chars[i] = c + ('A' - 'a');
+ }
sp->counter = 0;
sp->card = size;
sp->magic = STRMAGIC;
setFrontier (&sp->chars[wordAlign(size)]);
return (pointer)str;
-}
-
-pointer IntInf_do_neg (pointer arg, uint bytes) {
- __mpz_struct argmpz,
- resmpz;
- mp_limb_t argspace[2];
-
- initRes (&resmpz, bytes);
- fill (arg, &argmpz, argspace);
- mpz_neg (&resmpz, &argmpz);
- return answer (&resmpz);
}
/*
1.2 +18 -0 mlton/runtime/basis/OS/IO/poll.c
-------------------------------------------------------
This sf.net email is sponsored by:ThinkGeek
Welcome to geek heaven.
http://thinkgeek.com/sf
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel